diff --git a/.gitignore b/.gitignore index 4f2d16b..da51fad 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,22 @@ +# base directory structure +/exe/ +/lib/ +/obj/ /bin/ -/build/ +/doxygen/ +/regtesting/ +/install/ + +# ignore local arch files not meant to be shared +/arch/local* + +# ensure people are not accidentally committing an old .svnignore when copying their stuff +.svnignore + +# allow folks to create a .clang-format to hide their personal style settings +.clang-format + +# Created by https://www.gitignore.io/api/python,fortran,c,c++,cuda,emacs,vim ### C ### # Prerequisites @@ -11,6 +28,15 @@ *.obj *.elf +# Linker output +*.ilk +*.map +*.exp + +# Precompiled Headers +*.gch +*.pch + # Libraries *.lib *.a @@ -22,6 +48,262 @@ *.so *.so.* *.dylib -.vscode -.DS_Store \ No newline at end of file +# Executables +*.exe +*.out +*.app +*.i*86 +*.x86_64 +*.hex + +# Debug files +*.dSYM/ +*.su +*.idb +*.pdb + +# Kernel Module Compile Results +*.mod* +*.cmd +.tmp_versions/ +modules.order +Module.symvers +Mkfile.old +dkms.conf + +### C++ ### +# Prerequisites + +# Compiled Object files +*.slo + +# Precompiled Headers + +# Compiled Dynamic libraries + +# Fortran module files +*.mod +*.smod + +# Compiled Static libraries +*.lai + +# Executables + +### CUDA ### +*.i +*.ii +*.gpu +*.ptx +*.cubin +*.fatbin + +### Emacs ### +# -*- mode: gitignore; -*- +*~ +\#*\# +/.emacs.desktop +/.emacs.desktop.lock +*.elc +auto-save-list +tramp +.\#* + +# Org-mode +.org-id-locations +*_archive + +# flymake-mode +*_flymake.* + +# eshell files +/eshell/history +/eshell/lastdir + +# elpa packages +/elpa/ + +# reftex files +*.rel + +# AUCTeX auto folder +/auto/ + +# cask packages +.cask/ +dist/ + +# Flycheck +flycheck_*.el + +# server auth directory +/server/ + +# projectiles files +.projectile + +# directory configuration +.dir-locals.el + +### Fortran ### +# Prerequisites + +# Compiled Object files + +# Precompiled Headers + +# Compiled Dynamic libraries + +# Fortran module files + +# Compiled Static libraries + +# Executables + +### Python ### +# Byte-compiled / optimized / DLL files +__pycache__/ +*.py[cod] +*$py.class + +# C extensions + +# Distribution / packaging +.Python +build/ +develop-eggs/ +downloads/ +eggs/ +.eggs/ +lib/ +lib64/ +parts/ +sdist/ +var/ +wheels/ +*.egg-info/ +.installed.cfg +*.egg +MANIFEST + +# PyInstaller +# Usually these files are written by a python script from a template +# before PyInstaller builds the exe, so as to inject date/other infos into it. +*.manifest +*.spec + +# Installer logs +pip-log.txt +pip-delete-this-directory.txt + +# Unit test / coverage reports +htmlcov/ +.tox/ +.nox/ +.coverage +.coverage.* +.cache +nosetests.xml +coverage.xml +*.cover +.hypothesis/ +.pytest_cache/ + +# Translations +*.mo +*.pot + +# Django stuff: +*.log +local_settings.py +db.sqlite3 + +# Flask stuff: +instance/ +.webassets-cache + +# Scrapy stuff: +.scrapy + +# Sphinx documentation +docs/_build/ + +# PyBuilder +target/ + +# Jupyter Notebook +.ipynb_checkpoints + +# IPython +profile_default/ +ipython_config.py + +# pyenv +.python-version + +# celery beat schedule file +celerybeat-schedule + +# SageMath parsed files +*.sage.py + +# Environments +.env +.venv +env/ +venv/ +ENV/ +env.bak/ +venv.bak/ + +# Spyder project settings +.spyderproject +.spyproject + +# Rope project settings +.ropeproject + +# mkdocs documentation +/site + +# mypy +.mypy_cache/ +.dmypy.json +dmypy.json + +### Python Patch ### +.venv/ + +### Python.VirtualEnv Stack ### +# Virtualenv +# http://iamzed.com/2009/05/07/a-primer-on-virtualenv/ +[Bb]in +[Ii]nclude +[Ll]ib +[Ll]ib64 +[Ll]ocal +[Ss]cripts +pyvenv.cfg +pip-selfcheck.json + +### Vim ### +# Swap +[._]*.s[a-v][a-z] +[._]*.sw[a-p] +[._]s[a-rt-v][a-z] +[._]ss[a-gi-z] +[._]sw[a-p] + +# Session +Session.vim + +# Temporary +.netrwhist +# Auto-generated tag files +tags +# Persistent undo +[._]*.un~ + + +# End of https://www.gitignore.io/api/python,fortran,c,c++,cuda,emacs,vim diff --git a/COPYRIGHT b/COPYRIGHT deleted file mode 100644 index 355cea6..0000000 --- a/COPYRIGHT +++ /dev/null @@ -1,24 +0,0 @@ -!-----------------------------------------------------------------------------! -! ! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2024 CP2K developers group ! -! ! -! This program is free software; you can redistribute it and/or modify ! -! it under the terms of the GNU General Public License as published by ! -! the Free Software Foundation; either version 2 of the License, or ! -! (at your option) any later version. ! -! ! -! This program is distributed in the hope that it will be useful, ! -! but WITHOUT ANY WARRANTY; without even the implied warranty of ! -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! -! GNU General Public License for more details. ! -! ! -! You should have received a copy of the GNU General Public License ! -! along with this program; if not, write to the Free Software ! -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! -! ! -!-----------------------------------------------------------------------------! - --- -cp2k@prr.mpi-stuttgart.mpg.de -15. X AD 2024 \ No newline at end of file diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 653a95b..0000000 --- a/INSTALL +++ /dev/null @@ -1,86 +0,0 @@ - -How to compile CP2K code -======================== - - 1) Extract the archive file: - -# tar xzvf cp2k.tar.gz - -or if you do not have GNU tar - -# unzip -cd cp2k.tar.gz - -This extracts the contents of the archive into the directory ./CP2K; please be -careful not to overwrite things in there if it already exists - - 2) Go to 'CP2K/tools' and do a 'make' (or 'gmake'); this compiles you an -executable which will be used when compiling the main source of CP2K - - 3) Go to '../src'; see if there is a suitable file with definitions of the -architecture: - -# machine (~/CP2K/src) : ls -lF ../arch/AIX-POWER2.popt -# -rw-r--r-- 1 aps users 464 Mar 9 15:08 ../arch/AIX-POWER2.popt - -If your architecture is not present you might have to make a small effort; -please contact us in you need help. A rather generic FFT, 'FFTW' -(http://www.fftw.org/) has been interfaced already to the present version - - Define the CP2KHOME in Makefile to be the path to the directory of CP2K - - 4) You most likely need GNU make: - -# gmake - -If you do not have 'gmake' some tricks have to be made; please contact us in -you need help - - We have seen problems in SGI with the MIPSpro 7.2.1 compiler; the -pre-processor does not work as expected. Please contact us for help, or you -could try by inter-changing the lines of the compilation and pre-processing -and changing *.F to *.f for the compilation - - You can compile different version by typing e.g. - -# gmake popt - -"p" stands for parallel (alternatively "s" = serial) -"opt" means to buil an optimised version (alternatively "dbg" = debugging) - - We have seen some problems in the compilation with PGI on a linux machine: -In some machines it works, in some not - - In Cray T3E there are some missing routines. Please contact us if you want -to try out CP2K on a T3E - - On DEC alpha's the pre-processors works somewhat differently than in the -other architectures; please contact us for help if you want to compile on a -DEC alpha/OSF1 - - 5) The compilation hopefully finishes and you can try it: - -# ../AIX-POWER2/cp2k.popt -# **** **** ****** ** PROGRAM STARTED AT Tue Mar 20 18:50:45 2024 - ... - -# No input section &CP2K found - ... - -Congratulations, the binary is running!!! - - 6) You can go into one of the test cases and try out the executable - -# cd ../tests/Argon -# ln -s ../../src/cp2k.x . -# ./cp2k.x input - -It hopefully runs now - - 7) In any case please tell us your comments, praise, criticism, thanks, ... -You can join our mailing lists by sending e-mail to the address below - - 8) Happy computing! - --- -adamparler@gmail.com -(c) 2024 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1e79309 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + cp2k-c + Copyright (C) 2022 Adam Parler + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Makefile b/Makefile deleted file mode 100644 index 031266f..0000000 --- a/Makefile +++ /dev/null @@ -1,106 +0,0 @@ -.SUFFIXES: .c .cpp .d .o - -CP2KHOME = $(HOME)/CP2K -ARCH = $(shell $(CP2KHOME)/tools/get_arch_code) -VERSION = sopt -SMAKE = gmake -r -PMAKE = $(SMAKE) -j 1 -LIB1 = fftsg - -### Dependent variables ### - -ARCHDIR = $(CP2KHOME)/arch -MAINEXEDIR = $(CP2KHOME)/exe -MAINLIBDIR = $(CP2KHOME)/lib -MAINOBJDIR = $(CP2KHOME)/obj -SRCDIR = $(CP2KHOME)/src -FORPAR = $(CP2KHOME)/tools/forpar.x -chkint -SFMAKEDEPEND = $(CP2KHOME)/tools/sfmakedepend -m int -s -f -MACHINEDEFS = $(ARCHDIR)/$(ARCH).$(VERSION) -PROG = $(EXEDIR)/cp2k.$(VERSION) -EXEDIR = $(MAINEXEDIR)/$(ARCH) -LIBDIR = $(MAINLIBDIR)/$(ARCH) -OBJDIR = $(MAINOBJDIR)/$(ARCH) -VPATH = $(SRCDIR) -MAKEFILE = $(SRCDIR)/Makefile -OBJECTDEFS = $(SRCDIR)/OBJECTDEFS -LIB1_ARCHIVE = $(LIBDIR)/$(VERSION)/lib$(LIB1).a - -### Definition of the multiple targets ### - -VERSION_TARGETS = sopt sdbg popt pdbg -CLEAN_TARGETS = sopt/clean sdbg/clean popt/clean pdbg/clean\ - sopt/realclean sdbg/realclean popt/realclean pdbg/realclean - -### Master rules ### - -$(VERSION_TARGETS): - cd $(EXEDIR) || mkdir -p $(EXEDIR) - cd $(OBJDIR)/$@ || mkdir -p $(OBJDIR)/$@ - $(SMAKE) -C $(OBJDIR)/$@ -f $(MAKEFILE) VERSION=$@ dependencies - $(PMAKE) -C $(OBJDIR)/$@ -f $(MAKEFILE) VERSION=$@ all - -$(LIB1_ARCHIVE): - cd $(LIBDIR)/$(VERSION) || mkdir -p $(LIBDIR)/$(VERSION) - $(PMAKE) -C $(SRCDIR)/lib -f $(MAKEFILE) VERSION=$(VERSION) $(LIB1) - $(SMAKE) -C $(SRCDIR)/lib -f $(MAKEFILE) clean - -$(CLEAN_TARGETS): - $(SMAKE) -C $(OBJDIR)/$(@D) -f $(MAKEFILE) VERSION=$(@D) $(@F) - -include $(OBJECTDEFS) - -include $(MACHINEDEFS) - -OBJECTS = $(OBJECTS_GENERIC) $(OBJECTS_ARCHITECTURE) - -LIB1_OBJECTS = ctrig.o fftpre.o fftrot.o fftstp.o mltfftsg.o - -DEPENDENCIES = $(OBJECTS:.o=.d) - -LIBRARIES = $(LIBS) -L$(LIBDIR)/$(VERSION) -l$(LIB1) - -### Slave rules ### - -dependencies: $(DEPENDENCIES) - -all: lib$(LIB1) $(PROG) - -lib$(LIB1): $(LIB1_ARCHIVE) - -$(LIB1): $(LIB1_OBJECTS) - $(AR) $(LIB1_ARCHIVE) $(LIB1_OBJECTS) - -$(PROG): $(OBJECTS) - $(LD) $(LDFLAGS) -o $(PROG) $(OBJECTS) $(LIBRARIES) - -%.o: %.cpp - $(FC) -c $(FCFLAGS) $< - -%.d: %.cpp - $(CPP) $(CPPFLAGS) $< $*.cpp - $(FORPAR) $*.cpp - $(PERL) $(SFMAKEDEPEND) $*.d $*.cpp - @rm -f $*.cpp $*.d.old - -parallel_include.o: parallel_include.cpp - $(FC_fixed) -c $(FCFLAGS) $< - -parallel_include.d: parallel_include.cpp - $(CPP) $(CPPFLAGS) $< $*.cpp - $(FORPAR) -fix $*.cpp - $(PERL) $(SFMAKEDEPEND) $*.d $*.cpp - @rm -f $*.cpp $*.d.old - -clean: - rm -f *.o *.mod F*.cpp - -realclean: clean - rm -f $(PROG) *.d *.int *~ *.lst - -distclean: - rm -rf $(MAINEXEDIR) $(MAINLIBDIR) $(MAINOBJDIR) - -### Load the automatically generated rules of sfmakedepend ### - -include $(wildcard *.d) diff --git a/README b/README deleted file mode 100644 index 6787e35..0000000 --- a/README +++ /dev/null @@ -1,19 +0,0 @@ - -This is the CP2K software & test suite - - * COPYRIGHT: Where you can send money :*) - * INSTALL: How to set up the program (mainly how to compile it) - * Makefile: A security copy (is the same as in ./src) - * README: This file - * arch: Definitions for different architectures/compilers - * doc: Documentation - * exe: where the executables will be located - * lib: library built during compilation - * obj: Where the object and other compilation-time files - * src: The source code; please see also the file 'INSTALL' - * tests: Test inputs and reference outputs - * tools: Some small programs/scripts needed to compile the program - --- -adamparler@gmail.com -(c) 2024 diff --git a/README.md b/README.md new file mode 100644 index 0000000..af8aaff --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# cp2k_to_c + +Converting CP2K from fortran to C/C++ diff --git a/arch/AIX-POWER2.pdbg b/arch/AIX-POWER2.pdbg deleted file mode 100644 index 17ced63..0000000 --- a/arch/AIX-POWER2.pdbg +++ /dev/null @@ -1,17 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = mpxlf90 -FC_fixed = mpxlf90 -qfixed -LD = mpxlf90 -AR = ar -r -CPPFLAGS = -C -D__parallel -D__AIX -D__ESSL -D__FFTSG -D__FFTW -D__FFTESSL -P -FCFLAGS = -C -WF,-C,-D__parallel,-D__AIX,-D__ESSL,-D__FFTSG,-D__FFTW,-D__FFTESSL,-P\ - -d -g -qarch=pwr2 -qfullpath\ - -qflttrap=overflow:zerodivide:enable -qinitauto=FF\ - -qlanglvl=90pure -qnointlog -qnosave -qsigtrap -LDFLAGS = $(FCFLAGS) -L/home/pool30/qs/lib -L/home/users/aps/lib/fftw/lib\ - -bmaxdata:0x40000000 -bnoquiet -LIBS = -lmass -llapack -lesslp2 -lfftw-double -lhmd - -OBJECTS_ARCHITECTURE = machine_aix.o diff --git a/arch/AIX-POWER2.popt b/arch/AIX-POWER2.popt deleted file mode 100644 index 0a3141b..0000000 --- a/arch/AIX-POWER2.popt +++ /dev/null @@ -1,15 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = mpxlf90 -FC_fixed = mpxlf90 -qfixed -LD = mpxlf90 -AR = ar -r -CPPFLAGS = -C -D__parallel -D__AIX -D__ESSL -D__FFTSG -D__FFTW -D__FFTESSL -P -FCFLAGS = -O2 -WF,-C,-D__parallel,-D__AIX,-D__ESSL,-D__FFTSG,-D__FFTW,-D__FFTESSL,-P\ - -qarch=auto -qmaxmem=-1 -LDFLAGS = $(FCFLAGS) -L/home/pool30/qs/lib -L/home/users/aps/lib/fftw/lib\ - -bmaxdata:0x80000000 -bnoquiet -LIBS = -lmass -llapack -lesslp2 -lfftw-double -lhm - -OBJECTS_ARCHITECTURE = machine_aix.o diff --git a/arch/AIX-POWER2.sdbg b/arch/AIX-POWER2.sdbg deleted file mode 100644 index 153281a..0000000 --- a/arch/AIX-POWER2.sdbg +++ /dev/null @@ -1,17 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = xlf90 -FC_fixed = xlf90 -qfixed -LD = xlf90 -AR = ar -r -CPPFLAGS = -C -D__AIX -D__ESSL -D__FFTSG -D__FFTW -D__FFTESSL -P -FCFLAGS = -C -WF,-C,-D__AIX,-D__ESSL,-D__FFTSG,-D__FFTW,-D__FFTESSL,-P\ - -d -g -qarch=pwr2 -qfullpath\ - -qflttrap=overflow:zerodivide:enable -qinitauto=FF\ - -qlanglvl=90pure -qnointlog -qnosave -qsigtrap -LDFLAGS = $(FCFLAGS) -L/home/pool30/qs/lib -L/home/users/aps/lib/fftw/lib\ - -bmaxdata:0x40000000 -bnoquiet -LIBS = -lmass -llapack -lesslp2 -lfftw-double -lhmd - -OBJECTS_ARCHITECTURE = machine_aix.o diff --git a/arch/AIX-POWER2.sopt b/arch/AIX-POWER2.sopt deleted file mode 100644 index b454a1c..0000000 --- a/arch/AIX-POWER2.sopt +++ /dev/null @@ -1,15 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = xlf90 -FC_fixed = xlf90 -qfixed -LD = xlf90 -AR = ar -r -CPPFLAGS = -C -D__AIX -D__ESSL -D__FFTSG -D__FFTW -D__FFTESSL -P -FCFLAGS = -O2 -WF,-C,-D__AIX,-D__ESSL,-D__FFTSG,-D__FFTW,-D__FFTESSL,-P\ - -qarch=auto -qmaxmem=-1 -LDFLAGS = $(FCFLAGS) -L/home/pool30/qs/lib -L/home/users/aps/lib/fftw/lib\ - -bmaxdata:0x80000000 -bnoquiet -LIBS = -lmass -llapack -lesslp2 -lfftw-double -lhm - -OBJECTS_ARCHITECTURE = machine_aix.o diff --git a/arch/CRAY-T3E.pdbg b/arch/CRAY-T3E.pdbg deleted file mode 100644 index 41eb2fb..0000000 --- a/arch/CRAY-T3E.pdbg +++ /dev/null @@ -1,30 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f90 -f free -FC_fixed = f90 -f fixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__T3E -D__FFTSG -D__parallel -P\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk -FCFLAGS = -D__T3E -D__FFTSG -D__parallel\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk\ - -F -Racps -Xm -eIin -g -m2 -LDFLAGS = $(FCFLAGS) -L/u/krack/lib -LIBS = -llapack-dbg - -OBJECTS_ARCHITECTURE = machine_t3e.o diff --git a/arch/CRAY-T3E.popt b/arch/CRAY-T3E.popt deleted file mode 100644 index 6289542..0000000 --- a/arch/CRAY-T3E.popt +++ /dev/null @@ -1,30 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f90 -f free -FC_fixed = f90 -f fixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__T3E -D__FFTSG -D__parallel -P\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk -FCFLAGS = -D__T3E -D__FFTSG -D__parallel\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk\ - -F -O3 -Xm -LDFLAGS = $(FCFLAGS) -L/u/krack/lib -LIBS = -llapack-opt - -OBJECTS_ARCHITECTURE = machine_t3e.o diff --git a/arch/CRAY-T3E.sdbg b/arch/CRAY-T3E.sdbg deleted file mode 100644 index a08b7c7..0000000 --- a/arch/CRAY-T3E.sdbg +++ /dev/null @@ -1,30 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f90 -f free -FC_fixed = f90 -f fixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__T3E -D__FFTSG -P\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk -FCFLAGS = -D__T3E -D__FFTSG\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk\ - -F -Racps -eIin -g -m2 -LDFLAGS = $(FCFLAGS) -L/u/krack/lib -LIBS = -llapack-dbg - -OBJECTS_ARCHITECTURE = machine_t3e.o diff --git a/arch/CRAY-T3E.sopt b/arch/CRAY-T3E.sopt deleted file mode 100644 index b6c2c1b..0000000 --- a/arch/CRAY-T3E.sopt +++ /dev/null @@ -1,30 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f90 -f free -FC_fixed = f90 -f fixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__T3E -D__FFTSG -P\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk -FCFLAGS = -D__T3E -D__FFTSG\ - -Ddcopy=scopy -Ddgbsv=sgbsv -Ddgecon=sgecon -Ddgemm=sgemm\ - -Ddgemv=sgemv -Ddger=sger -Ddgerfs=sgerfs -Ddgetrf=sgetrf\ - -Ddgetri=sgetri -Ddgetrs=sgetrs -Ddlamch=slamch\ - -Ddlange=slange -Ddscal=sscal -Ddsyev=ssyev\ - -Ddsyevd=ssyevd -Ddsyevx=ssyevx -Ddsymm=ssymm\ - -Ddsymv=ssymv -Ddsyr=ssyr -Ddsyrk=ssyrk -Dzcopy=ccopy\ - -Dzgemm=cgemm -Dzgemv=cgemv -Dzgerc=cgerc\ - -Dzgeru=cgeru -Dzscal=cscal -Dzsymm=csymm -Dzsyrk=csyrk\ - -F -O3 -LDFLAGS = $(FCFLAGS) -L/u/krack/lib -LIBS = -llapack-opt - -OBJECTS_ARCHITECTURE = machine_t3e.o diff --git a/arch/DEC.sdbg b/arch/DEC.sdbg deleted file mode 100644 index 0f649a9..0000000 --- a/arch/DEC.sdbg +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f95 -free -FC_fixed = f95 -fixed -LD = f95 -AR = ar -r -CPPFLAGS = -C -D__DEC -D__FFTSG -D__FFTW -P -FCFLAGS = -C -D__DEC -D__FFTSG -D__FFTW -automatic -g -u -LDFLAGS = $(FCFLAGS) -L$(HOME)/lib -LIBS = -ldxml -lfftw-double - -OBJECTS_ARCHITECTURE = machine_dec.o diff --git a/arch/DEC.sopt b/arch/DEC.sopt deleted file mode 100644 index eafb288..0000000 --- a/arch/DEC.sopt +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = f95 -free -FC_fixed = f95 -fixed -LD = f95 -AR = ar -r -CPPFLAGS = -C -D__DEC -D__FFTSG -D__FFTW -P -FCFLAGS = -D__DEC -D__FFTSG -D__FFTW -O5 -ansi_alias -ansi_args\ - -automatic -fast -fp_reorder -std1 -tune host -u -w0 -LDFLAGS = $(FCFLAGS) -L$(HOME)/lib -LIBS = -ldxml -lfftw-double - -OBJECTS_ARCHITECTURE = machine_dec.o diff --git a/arch/IRIX.pdbg b/arch/IRIX.pdbg deleted file mode 100644 index 9b5d345..0000000 --- a/arch/IRIX.pdbg +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = /usr/lib/cpp -FC = f90 -freeform -FC_fixed = f90 -fixedform -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__IRIX -D__parallel -D__FFTSG -D__FFTW -D__FFTSGI -P -FCFLAGS = -C -D__IRIX -D__parallel -D__FFTSG -D__FFTW -D__FFTSGI -automatic -g\ - -macro_expand -u -LDFLAGS = $(FCFLAGS) -L/usr/local/lib -LIBS = -lfftw -lcomplib.sgimath -lmpi - -OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/arch/IRIX.popt b/arch/IRIX.popt deleted file mode 100644 index 1f8bb99..0000000 --- a/arch/IRIX.popt +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = /usr/lib/cpp -FC = f90 -freeform -FC_fixed = f90 -fixedform -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__IRIX -D__parallel -D__FFTSG -D__FFTW -D__FFTSGI -P -FCFLAGS = -D__IRIX -D__parallel -D__FFTSG -D__FFTW -D__FFTSGI -O3 -automatic\ - -macro_expand -u -LDFLAGS = $(FCFLAGS) -L/usr/local/lib -LIBS = -lfftw -lcomplib.sgimath -lmpi - -OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/arch/IRIX.sdbg b/arch/IRIX.sdbg deleted file mode 100644 index deed62f..0000000 --- a/arch/IRIX.sdbg +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = /usr/lib/cpp -FC = f90 -freeform -FC_fixed = f90 -fixedform -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__IRIX -D__FFTSG -D__FFTW -D__FFTSGI -P -FCFLAGS = -C -D__IRIX -D__FFTSG -D__FFTW -D__FFTSGI -automatic -g\ - -macro_expand -u -LDFLAGS = $(FCFLAGS) -L/usr/local/lib -LIBS = -lfftw -lcomplib.sgimath - -OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/arch/IRIX.sopt b/arch/IRIX.sopt deleted file mode 100644 index 84e6e7f..0000000 --- a/arch/IRIX.sopt +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = /usr/lib/cpp -FC = f90 -freeform -FC_fixed = f90 -fixedform -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__IRIX -D__FFTSG -D__FFTW -D__FFTSGI -P -FCFLAGS = -D__IRIX -D__FFTSG -D__FFTW -D__FFTSGI -O3 -automatic\ - -macro_expand -u -ansi -LDFLAGS = $(FCFLAGS) -L/usr/local/lib -LIBS = -lfftw -lcomplib.sgimath - -OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/arch/Linux-i686-absoft.sdbg b/arch/Linux-i686-absoft.sdbg deleted file mode 100644 index bdf4d61..0000000 --- a/arch/Linux-i686-absoft.sdbg +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -traditional -FC = f90 -ffree -FC_fixed = f90 -ffixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__ABSOFT -D__FFTSG -P -FCFLAGS = -g -LDFLAGS = $(FCFLAGS) -L/usr/absoft/lib -LIBS = -llapack -lblas -lU77 - -OBJECTS_ARCHITECTURE = machine_absoft.o diff --git a/arch/Linux-i686-absoft.sopt b/arch/Linux-i686-absoft.sopt deleted file mode 100644 index dfb30d4..0000000 --- a/arch/Linux-i686-absoft.sopt +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -traditional -FC = f90 -ffree -FC_fixed = f90 -ffixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__ABSOFT -D__FFTSG -P -FCFLAGS = -O -LDFLAGS = $(FCFLAGS) -L/usr/absoft/lib -LIBS = -llapack -lblas -lU77 - -OBJECTS_ARCHITECTURE = machine_absoft.o diff --git a/arch/Linux-i686-pgi.sdbg b/arch/Linux-i686-pgi.sdbg deleted file mode 100644 index 06811ab..0000000 --- a/arch/Linux-i686-pgi.sdbg +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = pgf90 -Mfree -FC_fixed = pgf90 -Mfixed -LD = pgf90 -AR = ar -r -CPPFLAGS = -C -D__PGI -D__FFTSG -P -FCFLAGS = -Mbounds -g -D__PGI -D__FFTSG -LDFLAGS = $(FCFLAGS) -LIBS = -llapack -lblas - -OBJECTS_ARCHITECTURE = machine_pgi.o diff --git a/arch/Linux-i686-pgi.sopt b/arch/Linux-i686-pgi.sopt deleted file mode 100644 index 9ea85f9..0000000 --- a/arch/Linux-i686-pgi.sopt +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -FC = pgf90 -Mfree -FC_fixed = pgf90 -Mfixed -LD = pgf90 -AR = ar -r -CPPFLAGS = -C -D__PGI -D__FFTSG -P -FCFLAGS = -fast -D__PGI -D__FFTSG -LDFLAGS = $(FCFLAGS) -LIBS = -llapack -lblas - -OBJECTS_ARCHITECTURE = machine_pgi.o diff --git a/arch/Linux-ppc-absoft.sdbg b/arch/Linux-ppc-absoft.sdbg deleted file mode 100644 index 01bb7e8..0000000 --- a/arch/Linux-ppc-absoft.sdbg +++ /dev/null @@ -1,13 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -traditional -FC = f90 -ffree -FC_fixed = f90 -ffixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__ABSOFT -D__FFTSG -P -FCFLAGS = -g -en -LDFLAGS = $(FCFLAGS) -L/usr/absoft/lib -LIBS = -llapack -lblas -lU77 - -OBJECTS_ARCHITECTURE = machine_absoft.o diff --git a/arch/Linux-ppc-absoft.sopt b/arch/Linux-ppc-absoft.sopt deleted file mode 100644 index d2626de..0000000 --- a/arch/Linux-ppc-absoft.sopt +++ /dev/null @@ -1,14 +0,0 @@ -PERL = perl -CC = cc -CPP = cpp -traditional -FC = f90 -ffree -FC_fixed = f90 -ffixed -LD = f90 -AR = ar -r -CPPFLAGS = -C -D__ABSOFT -D__FFTSG -P -FCFLAGS = -O -en -FCSPEZ = -O -B18 -en -LDFLAGS = $(FCFLAGS) -L/usr/absoft/lib -LIBS = -llapack -lblas -lU77 - -OBJECTS_ARCHITECTURE = machine_absoft.o diff --git a/doc/Makefile b/doc/Makefile deleted file mode 100644 index 433b50f..0000000 --- a/doc/Makefile +++ /dev/null @@ -1,124 +0,0 @@ -SHELL = /bin/sh -.SUFFIXES: - -ROBODOC=/usr/local/bin/robodoc -ROBOOPTS=SORT - -# -# -CP2KHOME=$(HOME)/CP2K/ -VPATH=$(CP2KHOME)/src - -# Your source files. -# -include $(CP2KHOME)/src/OBJECTDEFS -SOURCES=$(OBJECTS_GENERIC:.o=.cpp) - -# The name of your Project -# -PROJECT=cp2k - -# The various documentation files, derived from the source files. -# HTML -# -HTMLDOCS=$(SOURCES:=.html) -HTMLXREFS=$(HTMLDOCS:.html=.html.xref) -HTMLXREFSFILE=$(PROJECT)_html.xrefs -# LATEX -# -LATEXDOCS=$(SOURCES:=.tex) -LATEXXREFS=$(LATEXDOCS:.tex=.tex.xref) -LATEXXREFSFILE=$(PROJECT)_tex.xrefs -# ASCII -# -ASCIIDOCS=$(SOURCES:=.txt) -# RTF -# -RTFDOCS=$(SOURCES:=.rtf) -RTFXREFS=$(RTFDOCS:.rtf=.rtf.xref) -RTFXREFSFILE=$(PROJECT)_rtf.xrefs - -# Some common targets -xrefall: xhtml xtex xrtf -docall: html tex ascii rtf - -# Create the xref files for the various formats. -xhtml: $(HTMLXREFSFILE) -xtex: $(LATEXXREFSFILE) -xrtf: $(RTFXREFSFILE) - -# Create the documentation files for the various formats. -html: $(HTMLDOCS) $(PROJECT)_mi.html -tex: $(LATEXDOCS) $(PROJECT)_mi.tex -rtf: $(RTFDOCS) -ascii: $(ASCIIDOCS) - -# master index file, currently works only for html and latex documentation. -# Note that you can define the title of the document. -$(PROJECT)_mi.html: $(HTMLXREFSFILE) - $(ROBODOC) $< $@ INDEX HTML TITLE "$(PROJECT) Master Index" - -$(PROJECT)_mi.tex: $(LATEXXREFSFILE) - $(ROBODOC) $< $@ INDEX LATEX TITLE "$(PROJECT) API Reference" - -# create xrefs file (file with the names of all .xref files). -$(HTMLXREFSFILE) : $(HTMLXREFS) - /bin/ls $(HTMLXREFS) > $@ -$(LATEXXREFSFILE) : $(LATEXXREFS) - /bin/ls $(LATEXXREFS) > $@ -$(RTFXREFSFILE) : $(RTFXREFS) - /bin/ls $(RTFXREFS) > $@ - -# Rule to create an .xref file from a source file for the various formats. -%.html.xref : % - $(ROBODOC) $< $(@:.xref=) $(ROBOOPTS) INTERNAL GENXREF $@ -%.tex.xref : % - $(ROBODOC) $< $(@:.xref=) $(ROBOOPTS) INTERNAL GENXREF $@ -%.rtf.xref : % - $(ROBODOC) $< $(@:.xref=) $(ROBOOPTS) INTERNAL GENXREF $@ - -# Rule to create html documentation from a source file. -%.html : % - $(ROBODOC) $< $@ HTML $(ROBOOPTS) XREF $(HTMLXREFSFILE) - -# Rule to create latex documentation from a source file. -# We do not include source items, and generate laxtex documents -# than can be included in a master document. -%.tex : % - $(ROBODOC) $< $@ LATEX $(ROBOOPTS) NOSOURCE SINGLEDOC XREF $(LATEXXREFSFILE) - -# Rule to create ascii documentation from a source file. -%.txt : % - $(ROBODOC) $< $@ ASCII - -# Rule to create rtf documentation from a source file. -%.rtf : % - $(ROBODOC) $< $@ RTF $(ROBOOPTS) XREF $(RTFXREFSFILE) - -# Use netscape to view the master index file for our project. -htmlview: html - netscape $(PROJECT)_mi.html - -# Use the latex programs to generate a .dvi from the master index file -# for our prokect. View this .dvi file with xdvi -texview: tex - latex $(PROJECT)_mi - makeindex $(PROJECT)_mi - latex $(PROJECT)_mi - latex $(PROJECT)_mi - xdvi $(PROJECT)_mi.dvi - -# Clean-up the mess we made -# -clean: - rm -f $(HTMLXREFS) - rm -f $(HTMLDOCS) - rm -f $(LATEXXREFS) - rm -f $(LATEXDOCS) - rm -f $(PROJECT)_mi.* *.aux - rm -f $(RTFXREFS) - rm -f $(RTFDOCS) - rm -f $(ASCIIDOCS) - rm -f $(HTMLXREFSFILE) - rm -f $(LATEXXREFSFILE) - rm -f $(RTFXREFSFILE) diff --git a/src/MACHINEDEFS.DEC b/src/MACHINEDEFS.DEC deleted file mode 100644 index 2700a26..0000000 --- a/src/MACHINEDEFS.DEC +++ /dev/null @@ -1,21 +0,0 @@ -### Machine dependent ### - -PERL = perl -CC = cc -CPP = cpp -FC = f95 -free -FCfixed = f95 -fixed -LDR = f95 - -CDEFS = -D__DEC -D__FFTW - -DEBUG = -g -C -#OPT = -w0 -O5 -fast -ansi_alias -ansi_args -fp_reorder -tune host -std1 -OPT = -g -C -BFLAGS = -u $(CDEFS) -automatic -FFLAGS = $(BFLAGS) $(OPT) -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -ldxml -L${HOME}/lib -lfftw-double - -OBJECTS_ARCHITECTURE = machine_dec.o \ No newline at end of file diff --git a/src/MACHINEDEFS.IBM b/src/MACHINEDEFS.IBM deleted file mode 100644 index 028e3a4..0000000 --- a/src/MACHINEDEFS.IBM +++ /dev/null @@ -1,27 +0,0 @@ -### Machine dependent ### - -PERL = perl -CC = cc -CPP = cpp -FC = xlf90 -FCfixed = xlf90 -qfixed -LDR = xlf90 - -CDEFS = -D__AIX -D__FFTW - -DEBUG = -g -C -d -qextchk -qinitauto=AA -qlanglvl=90pure \ - -qflttrap=overflow:zerodivide:invalid:enable \ - -qsigtrap -qnointlog -OPT = $(DEBUG) # -O -#OPT = -O4 -qarch=auto -qtune=auto -qmaxmem=-1 -qfloat=rsqrt:hssngl:fltint -qhot -OPT = -O3 -qarch=auto -qtune=auto -qmaxmem=-1 # -pg -OPT = -g -O -qarch=auto -qtune=auto -qmaxmem=-1 # -pg -OPT = -g -C # -O -qarch=auto -qtune=auto -qmaxmem=-1 # -pg -BFLAGS = -u -WF,"$(CDEFS)" -qnosave -qlanglvl=95pure -FFLAGS = $(BFLAGS) $(OPT) -qsuppress=1518-061:1518-132 -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -L/home/pool30/qs/MASS/2.6 -lmass -lhm -bmaxdata:0x40000000 \ - -llapack -lesslp2 -L/home/users/aps/lib/fftw/lib -lfftw-double - -OBJECTS_ARCHITECTURE = machine_aix.o \ No newline at end of file diff --git a/src/MACHINEDEFS.PGI b/src/MACHINEDEFS.PGI deleted file mode 100644 index ec7472b..0000000 --- a/src/MACHINEDEFS.PGI +++ /dev/null @@ -1,21 +0,0 @@ -### Machine dependent ### - -PERL = perl -CC = cc -CPP = cpp -FC = pgf90 -Mfree -FCfixed = pgf90 -Mfixed -LDR = pgf90 - -CDEFS = -D__PGI -D__FFTW - -DEBUG = -g -C -OPT = $(DEBUG) -O -#OPT = -O2 -Mvect -fast -BFLAGS = $(CDEFS) -FFLAGS = $(BFLAGS) $(OPT) -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -llapack -lblas -L${HOME}/lib -lfftw-double - -OBJECTS_ARCHITECTURE = machine_pgi.o diff --git a/src/MACHINEDEFS.SGI b/src/MACHINEDEFS.SGI deleted file mode 100644 index b87804e..0000000 --- a/src/MACHINEDEFS.SGI +++ /dev/null @@ -1,22 +0,0 @@ -### Machine dependent ### - -PERL = perl -CC = cc -CPP = /usr/lib/cpp -FC = f90 -freeform -FCfixed = f90 -fixedform -LDR = f90 - -CDEFS = -D__IRIX -D__FFTW - -DEBUG = -g -C -#OPT = -O3 -Ofast -64 -#OPT = -g -O -64 -OPT = -C -g -64 -BFLAGS = -u $(CDEFS) -automatic -FFLAGS = $(BFLAGS) $(OPT) -macro_expand -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -L${HOME}/lib -lfftw -lcomplib.sgimath - -OBJECTS_ARCHITECTURE = machine_irix.o diff --git a/src/MACHINEDEFS.T3E b/src/MACHINEDEFS.T3E deleted file mode 100644 index 3503140..0000000 --- a/src/MACHINEDEFS.T3E +++ /dev/null @@ -1,21 +0,0 @@ -### Machine dependent ### - -PERL = perl -CC = cc -CPP = cpp -FC = f90 -f free -FCfixed = f90 -f fixed -LDR = f90 - -CDEFS = -D__T3E -D__FFTW - -DEBUG = -g -R abcps -ei -m 0 -OPT = -O3 -eIn -m 1 -#OPT = $(DEBUG) -BFLAGS = $(CDEFS) -F -FFLAGS = $(BFLAGS) $(OPT) -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -L${HOME}/lib -lfftw-double -L${HOME}/cplv/lapack -llapack - -OBJECTS_ARCHITECTURE = machine_t3e.o diff --git a/src/Makefile b/src/Makefile deleted file mode 100644 index db5fb3f..0000000 --- a/src/Makefile +++ /dev/null @@ -1,55 +0,0 @@ -.SUFFIXES: .o .c .cpp .d - -CP2KHOME= ${HOME}/CP2K -FORPAR = $(CP2KHOME)/tools/forpar.x -chkint - -include OBJECTDEFS - -include MACHINEDEFS - -OBJECTS = $(OBJECTS_GENERIC) $(OBJECTS_ARCHITECTURE) - -################################# - -PROG = cp2k.x - -all: $(PROG) - -$(PROG): $(OBJECTS) - $(LDR) $(LFLAGS) -o $(PROG) $(OBJECTS) $(LIBS) - -%.o : %.cpp - $(CXX) -c $(CXXFLAGS) $*.cpp - $(CPP) -P $(CDEFS) $*.cpp - -$(FORPAR) $*.cpp - rm -f $*.cpp - -%.o : %.c - $(CC) -c $(CFLAGS) $*.c - $(CC) -P $(CDEFS) $*.c - -$(FORPAR) $*.c - rm -f $*.c - -parallel_include.o : parallel_include.cpp - $(CXXfixed) -c $(CXXFLAGS) $*.cpp - $(CPP) -P $(CDEFS) $*.cpp $*.cpp - -$(FORPAR) -fix $*.cpp - rm -f $*.cpp - -%.d : %.cpp - $(CPP) -P $(CDEFS) $*.cpp - $(PERL) $(CP2KHOME)/tools/sfmakedepend -m int -s -f $*.d $*.cpp - rm -f $*.cpp $*.d.old - -depend: - ../tools/deps - -clean: - rm -f *.o *.mod - -realclean: - rm -f $(PROG) *.o *.mod *.d *.int *~ F*.cpp F*.c *.lst - -#################### - -include $(OBJECTS:.o=.d) diff --git a/src/OBJECTDEFS b/src/OBJECTDEFS deleted file mode 100644 index 1a2eb40..0000000 --- a/src/OBJECTDEFS +++ /dev/null @@ -1,27 +0,0 @@ -OBJECTS_GENERIC = \ -atoms_input.o coefficients.o coefficient_types.o \ -constraint.o convert_units.o dgs.o dg_rho0s.o dg_types.o \ -dump.o cp2k.o cp2k_input.o environment.o \ -eigenvalueproblems.o global_types.o header.o kinds.o \ -ewalds.o ewald_parameters_types.o \ -fft_tools.o fist.o fist_debug.o fist_global.o fist_input.o \ -fist_force.o fist_force_numer.o \ -fist_intra_force.o fist_nonbond_force.o force_control.o \ -force_fields.o integrator.o input_types.o \ -initialize_particle_types.o initialize_molecule_types.o \ -initialize_extended_types.o io_parameters.o lapack.o \ -linklists.o linklist_control.o linklist_cell_types.o \ -linklist_cell_list.o linklist_utilities.o \ -linklist_verlet_list.o machine.o mathconstants.o \ -mol_force.o molecule_types.o molecule_input.o md.o \ -mp.o nhc.o nose.o pair_potential.o particle_lists.o \ -particle_types.o periodic_table.o parallel.o \ -parallel_include.o parser.o physcon.o pme.o \ -pws.o pw_types.o pw_grids.o pw_grid_types.o \ -simulation_cell.o splines.o stop_program.o \ -string_utilities.o \ -structure_factors.o structure_factor_types.o \ -structure_types.o timesl.o \ -tbmd.o tbmd_debug.o tbmd_force.o tbmd_global.o tbmd_input.o \ -tbmd_types.o \ -timings.o unit.o util.o erf_fn.o diff --git a/src/TODO b/src/TODO deleted file mode 100644 index 6c91931..0000000 --- a/src/TODO +++ /dev/null @@ -1,4 +0,0 @@ -### I'm in the middle of editing nrutil.cpp - - - * "Funny" messages away - they are not funny! diff --git a/src/amoeba.cpp b/src/amoeba.cpp deleted file mode 100644 index 488124b..0000000 --- a/src/amoeba.cpp +++ /dev/null @@ -1,98 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 MPI fuer Festkoerperforschung, Stuttgart */ -/*---------------------------------------------------------------------------*/ - -#include -#include -#include -#include - -#include "amoeba.h" - -namespace amoeba { - -/*----------------------------------------------------------------------------| -| NUMERICAL RECIPIES SUBROUTINE AMOEBA ADAPTED FOR USE IN CP2K | -|----------------------------------------------------------------------------*/ - - template - void amoeba_evaluate(std::vector>& p, std::vector& y, - double ftol, double& rtol, Func func, int itmax) { - int ndim = p[0].size(); - std::vector psum(ndim); - - amoeba_private(); - - //----------------------------------------------------------------------- - - void amoeba_private() { - int i, ilo, inhi; - int iter = 0; - double ysave, ytry, ytmp; - - ndim = p[0].size(); - psum.resize(ndim); - std::fill(psum.begin(), psum.end(), 0.0); - - do { - ilo = std::min_element(y.begin(), y.end()) - y.begin(); - ihi = std::max_element(y.begin(), y.end()) - y.begin(); - ytmp = y[ihi]; - y[ihi] = y[ilo]; - inhi = std::max_element(y.begin(), y.end()) - y.begin(); - y[ihi] = ytmp; - rtol = 2.0 * std::abs(y[ihi] - y[ilo]) / (std::abs(y[ihi]) + std::abs(y[ilo])); - if (rtol < ftol) { - std::swap(y[0], y[ilo]); - std::swap(p[0], p[ilo]); - return; - } - if (iter >= itmax) - return; - ytry = amotry(-1.0); - iter++; - if (ytry <= y[ilo]) { - ytry = amotry(2.0); - iter++; - } else if (ytry >= y[inhi]) { - ysave = y[ihi]; - ytry = amotry(0.5); - iter++; - if (ytry >= ysave) { - for (int i = 0; i < ndim + 1; i++) { - if (i != ilo) - y[i] = func(p[i]); - } - iter += ndim; - for (int j = 0; j < ndim; j++) { - psum[j] = 0.0; - for (int i = 0; i < ndim + 1; i++) { - psum[j] += p[i][j]; - } - } - } - } - } while (true); - } - - double amotry(double fac) { - double fac1 = (1.0 - fac) / ndim; - double fac2 = fac1 - fac; - std::vector ptry(ndim); - for (int j = 0; j < ndim; j++) { - ptry[j] = psum[j] * fac1 - p[ihi][j] * fac2; - } - double ytry = func(ptry); - if (ytry < y[ihi]) { - y[ihi] = ytry; - for (int j = 0; j < ndim; j++) { - psum[j] = psum[j] - p[ihi][j] + ptry[j]; - p[ihi][j] = ptry[j]; - } - } - return ytry; - } - } - -} // namespace amoeba diff --git a/src/amoeba.h b/src/amoeba.h deleted file mode 100644 index 9a33cfc..0000000 --- a/src/amoeba.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef _AMOEBA_H -#define _AMOEBA_H - -#include - -template -void amoeba_evaluate(std::vector>&, std::vector&, - double, double&, Func, int); - -#endif \ No newline at end of file diff --git a/src/atoms_input.cpp b/src/atoms_input.cpp deleted file mode 100644 index 18a8f82..0000000 --- a/src/atoms_input.cpp +++ /dev/null @@ -1,181 +0,0 @@ -#include -#include - -#include "atoms_input.h" -#include "global_types.h" - -/*----------------------------------------------------------------------------| -| CP2K: A general program to perform molecular dynamics simulations | -| Copyright (C) 2024 CP2K developers group | -|----------------------------------------------------------------------------*/ - -/*>---------------------------------------------------------------------------| -| | -| OPTIONS: either read the section &atoms in the input file or | -| read the coordinates from the file project_name.dat | -| SECTION: &atoms ... &end | -| file: file_name | -| cell: b11 b12 b13 & | -| b21 b22 b23 & | -| b31 b32 b33 | -| | -| | -| | -|<---------------------------------------------------------------------------*/ - -void read_coord_vel(system_type *atype, char *filen) { - - int ierror, ilen, iw, source, allgrp, ia, ie, i, ios; - char string[7]; - char label[6]; - - iw = globenv.scr; - - //..defaults - //..parse the input section - strncpy(label, "&ATOMS", 10); - parser_init(globenv.input_file_name, label, &ierror, globenv); - if (ierror != 0) { - if (globenv.ionode) { - printf("ATOM| No input section &ATOMS found\n"); - if (strcmp(filen, " ") == 0) { - ia = strlen(globenv.project_name); - ie = ia; - } else { - ia = strlen(filen); - ie = ia; - } - strcat(filen, ".dat"); - printf("ATOM| Try to read default file %s\n", filen); - read_file(filen, atype); - } - //..broadcast the input data to all nodes - #if defined(__parallel) - source = globenv.source; - allgrp = globenv.group; - mp_bcast(atype->box, source, allgrp); - mp_bcast(atype->ptype, source, allgrp); - mp_bcast(atype->rtype, source, allgrp); - mp_bcast(&atype->n, source, allgrp); - if (!globenv.ionode) { - atype->c = (double **)malloc(3 * sizeof(double *)); - for (i = 0; i < 3; i++) { - atype->c[i] = (double *)malloc(atype->n * sizeof(double)); - } - if (atype->c == NULL) { - stop_memory("ATOM", "atype%c", 3 * atype->n); - } - } - mp_bcast(atype->c, source, allgrp); - if (strcmp(atype->rtype, "POSVEL") == 0) { - if (!globenv.ionode) { - atype->v = (double **)malloc(3 * sizeof(double *)); - for (i = 0; i < 3; i++) { - atype->v[i] = (double *)malloc(atype->n * sizeof(double)); - } - if (atype->v == NULL) { - stop_memory("ATOM", "atype%v", 3 * atype->n); - } - } - mp_bcast(atype->v, source, allgrp); - } - #endif - } else { - stop_prg("atom", "this part of the code not yet written"); - } - parser_end(); - //..end of parsing the input section - - //..write some information to output - if (globenv.ionode && globenv.print_level > 0) { - fprintf(iw, "ATOM| Box parameters [Angstrom]\n"); - fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[0][0], atype->box[0][1], - atype->box[0][2]); - fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[1][0], atype->box[1][1], - atype->box[1][2]); - fprintf(iw, "ATOM| %15.5f %15.5f %15.5f\n", atype->box[2][0], atype->box[2][1], - atype->box[2][2]); - fprintf(iw, "ATOM| Number of atoms read %d\n", atype->n); - if (globenv.print_level > 4) { - if (strcmp(atype->rtype, "POS") == 0) { - print_c(iw, atype->c); - } else if (strcmp(atype->rtype, "POSVEL") == 0) { - print_cv(iw, atype->c, atype->v); - } - } - printf("\n"); - } -} - -void read_file(char *filen, system_type *atype) { - int iunit, i, j, ios; - int exists; - - exists = access(filen, F_OK) != -1; - if (exists) { - iunit = get_unit(); - FILE *file = fopen(filen, "r"); - fscanf(file, "%d", &atype->n); - - atype->c = (double **)malloc(3 * sizeof(double *)); - for (i = 0; i < 3; i++) { - atype->c[i] = (double *)malloc(atype->n * sizeof(double)); - } - if (atype->c == NULL) { - stop_memory("ATOM", "atype%c", 3 * atype->n); - } - atype->v = NULL; - - if (strcmp(atype->rtype, "POS") == 0) { - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); - } - fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); - fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); - fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); - } else if (strcmp(atype->rtype, "POSVEL") == 0) { - atype->v = (double **)malloc(3 * sizeof(double *)); - for (i = 0; i < 3; i++) { - atype->v[i] = (double *)malloc(atype->n * sizeof(double)); - } - if (atype->v == NULL) { - stop_memory("ATOM", "atype%v", 3 * atype->n); - } - - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->c[0][i], &atype->c[1][i], &atype->c[2][i]); - } - fscanf(file, "%lf %lf %lf", &atype->box[0][0], &atype->box[0][1], &atype->box[0][2]); - fscanf(file, "%lf %lf %lf", &atype->box[1][0], &atype->box[1][1], &atype->box[1][2]); - fscanf(file, "%lf %lf %lf", &atype->box[2][0], &atype->box[2][1], &atype->box[2][2]); - for (i = 0; i < atype->n; i++) { - fscanf(file, "%lf %lf %lf", &atype->v[0][i], &atype->v[1][i], &atype->v[2][i]); - } - } else { - stop_prg("ATOM", "this rtype not programmed"); - } - - fclose(file); - } else { - stop_prg("ATOM", "No information on atoms found"); - } -} - -void print_c(int iw, double **c, int n) { - int i; - - printf("ATOM| Atom coordinates [Angstrom]\n"); - for (i = 0; i < n; i++) { - printf("ATOM| %d %15.5f %15.5f %15.5f\n", i, c[0][i], c[1][i], c[2][i]); - } -} - -void print_cv(int iw, double **c, double **v, int n) { - int i; - - printf("ATOM| Atom coordinates [Angstrom]\n"); - for (i = 0; i < n; i++) { - printf("ATOM| %d %10.4f %10.4f %10.4f %10.4f %10.4f %10.4f\n", i, c[0][i], c[1][i], - c[2][i], v[0][i], v[1][i], v[2][i]); - } -} diff --git a/src/atoms_input.h b/src/atoms_input.h deleted file mode 100644 index 799a584..0000000 --- a/src/atoms_input.h +++ /dev/null @@ -1,33 +0,0 @@ -#ifndef _ATOMS_INPUT_H -#define _ATOMS_INPUT_H - -#ifdef __cplusplus -namespace CP2K_NS { -#include -#include -#else -#include -#include -#endif - -typedef struct system_type { - double box[3][3]; - char ptype[4]; - char rtype[21]; - int n; - double** c; - double** v; -} system_type; - -void read_coord_vel(system_type, char*, global_environment_type); - -void read_file(FILE); -void read_file(FILE, bool); -void print_c(int, std::vector>); -void print_cv(int, std::vector>, std::vector>); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/coefficient_types.cpp b/src/coefficient_types.cpp deleted file mode 100644 index ae31e90..0000000 --- a/src/coefficient_types.cpp +++ /dev/null @@ -1,60 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include "coefficients.h" - -using namespace CP2K_NS; - -void coeff_allocate_from_coeff(coeff_type c_out, coeff_type c_model, int use_basis) { - - int use_data; - - if (use_basis > 0) { - if (use_basis == PLANEWAVES) { - c_out.in_use = PLANEWAVES; - pw_allocate(c_out.pw, c_model.pw.pw_grid, c_model.pw.in_use); - } else if (use_basis == PW_REALDATA1D || use_basis == PW_COMPLEXDATA1D || - use_basis == PW_REALDATA3D || use_basis == PW_COMPLEXDATA3D) { - c_out.in_use = PLANEWAVES; - pw_allocate(c_out.pw, c_model.pw.pw_grid, use_basis); - } else { - stop_prg ("coeff_allocate_from_coeff", "no suitable data with use_basis"); - } - } else { - use_data = c_model.pw.in_use; - if ( use_data == PW_REALDATA1D || use_data == PW_COMPLEXDATA1D || - use_data == PW_REALDATA3D || use_data == PW_COMPLEXDATA3D ) { - c_out.in_use = PLANEWAVES; - pw_allocate(c_out.pw, c_model.pw.pw_grid, c_model.pw.in_use); - } else { - stop_prg("coeff_allocate_from_coeff", "no suitable data without use_basis"); - } - } -} - -void coeff_allocate_from_grid(coeff_type c_out, pw_grid_type pw_grid, int use_data) { - if (pw_grid) { - c_out.in_use = PLANEWAVES; - pw_allocate(c_out.pw, pw_grid, use_data); - } else { - stop_prg("coeff_allocate_from_grid", "no suitable grid"); - } -} - -void coeff_deallocate(coeff_type coeff) { - if (coeff.in_use == PLANEWAVES) { - pw_deallocate(coeff.pw); - } else { - stop_prg("coeff_deallocate", "no valid data type"); - } -} - -void coeff_zero(coeff_type coeff) { - if (coeff.in_use == PLANEWAVES) { - pw_zero(coeff.pw); - } else { - stop_prg("coeff_zero", "no valid data type"); - } -} diff --git a/src/coefficients.cpp b/src/coefficients.cpp deleted file mode 100644 index 7efaece..0000000 --- a/src/coefficients.cpp +++ /dev/null @@ -1,28 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include "coefficients.h" - -double integral_a(coeff_type *coeff, int flag) { - if (strncpy(coeff->in_use, PLANEWAVES, 256)) { - integral_value = pw_integral_a(coeff->pw, flag); - } else { - printf("integral_a, not defined"); - exit(1); - } - - return integral_value; -} - -double integral_ab(coeff_type *coeff1, coeff_type *coeff2, int flag) { - if (strncpy(coeff1->in_use, PLANEWAVES, 256) && strncpy(coeff2->in_use, PLANEWAVES, 256)) { - integral_value = pw_integral_ab(coeff1->pw, coeff2->pw, flag); - } else { - printf("integral_ab, not defined"); - exit(1); - } - - return integral_value; -} diff --git a/src/coefficients.h b/src/coefficients.h deleted file mode 100644 index 34fb29e..0000000 --- a/src/coefficients.h +++ /dev/null @@ -1,36 +0,0 @@ -#ifndef _COEFF_H -#define _COEFF_H - -#include "pw.h" -#include "stop.h" - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - -const int PLANEWAVES = 401; -const int GAUSSIAN = 402; - -const int SQUARE = 391; -const int SQUAREROOT = 392; - -const int PW_REALDATA1D = REALDATA1D; -const int PW_COMPLEXDATA1D = COMPLEXDATA1D; -const int PW_REALDATA3D = REALDATA3D; -const int PW_COMPLEXDATA3D = COMPLEXDATA3D; - -typedef struct coeff_type { - struct pw_type pw; - int in_use; -} coeff_type; - -void coeff_allocate_from_coeff(coeff_type, coeff_type, int); -void coeff_allocate_from_grid(coeff_type, pw_grid_type, int); -void coeff_deallocate(coeff_type); -void coeff_zero(coeff_type); - -#ifdef __cplusplus -} -#endif - -#endif diff --git a/src/complex.h b/src/complex.h deleted file mode 100644 index 5940c86..0000000 --- a/src/complex.h +++ /dev/null @@ -1,9 +0,0 @@ -#ifndef _COMPLEX_H -#define _COMPLEX_H - -typedef struct complex { - double real; - double imag; -} complex; - -#endif \ No newline at end of file diff --git a/src/constraint.c b/src/constraint.c deleted file mode 100644 index cc0fe6b..0000000 --- a/src/constraint.c +++ /dev/null @@ -1,1475 +0,0 @@ -/*-----------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*-----------------------------------------------------------------------------*/ - -#include "md.h" -#include "molecule.h" - -double scale; -double r_rattle[3][3]; - -void shake_control(molecule_structure_type *molecule, simulation_parameters_type simpar) { - int nmol = sizeof(molecule) / sizeof(molecule[0]); - for (int imol = 0; imol < nmol; imol++) { - if (molecule[imol].ng3x3const_mol != 0) { - shake_3x3(&molecule[imol], simpar); - } - int ishake = 0; - if (molecule[imol].ndistconst_mol != 0) { - double max_sigma = -1.0E+10; - while (fabs(max_sigma) >= simpar.shake_tol) { - max_sigma = 0.0; - ishake++; - shake(&molecule[imol], simpar, &max_sigma, ishake); - } - } - } -} - -void rattle_control(molecule_structure_type *molecule, simulation_parameters_type simpar) { - int nmol = sizeof(molecule) / sizeof(molecule[0]); - for (int imol = 0; imol < nmol; imol++) { - if (molecule[imol].ng3x3const_mol != 0) { - rattle_3x3(&molecule[imol], simpar); - } - int irattle = 0; - if (molecule[imol].ndistconst_mol != 0) { - double max_sigma = -1.0E+10; - while (fabs(max_sigma) >= simpar.shake_tol) { - max_sigma = 0.0; - irattle++; - rattle(&molecule[imol], simpar, &max_sigma, irattle); - } - } - } -} - -void shake_roll_control(molecule_structure_type *molecule, simulation_parameters_type simpar, thermodynamic_type *thermo, double *vector, double *roll_tol, int *iroll, int group, double **u) { - - double max_sigma; - int imol, iconst, ishake, nmol, handle; - double r_shake[3][3]; - - nmol = sizeof(molecule) / sizeof(molecule[0]); - - // setting up for roll - if (strcmp(simpar.ensemble, "NPT_I") == 0) { - get_r_shake(r_shake, vector); - } else if (strcmp(simpar.ensemble, "NPT_F") == 0) { - get_r_shake(r_shake, vector, u); - } - - // initialize locals - for (int imol = 0; imol < nmol; imol++) { - // 3x3 - if (molecule[imol].ng3x3const_mol != 0) { - shake_roll_3x3(&molecule[imol], simpar, r_shake, ishake); - } - ishake = 0; - - // dist - if (molecule[imol].ndistconst_mol != 0) { - double max_sigma = -1.0E+10; - while (fabs(max_sigma) >= simpar.shake_tol) { - ishake++; - max_sigma = 0.0; - shake_roll(&molecule[imol], simpar, r_shake, &max_sigma, &ishake); - } - } - } - - if (strcmp(simpar.ensemble, "NPT_I") == 0) { - check_tol(roll_tol, iroll, "SHAKE", vector); - } - pv_constraint(molecule, thermo, "FULL", group); -} - -!****************************************************************************** - -SUBROUTINE rattle_roll_control ( molecule, simpar, thermo, veps, & - roll_tol, iroll, group ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & - molecule - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: veps - REAL ( dbl ), INTENT ( OUT ) :: roll_tol - INTEGER, INTENT ( INOUT ) :: iroll - INTEGER, INTENT ( IN ) :: group - -! Locals - REAL ( dbl ) :: max_sigma, feps - INTEGER :: imol, iconst, irattle, nmol, handle - -!------------------------------------------------------------------------------ - - CALL timeset( 'RATTLE_ROLL','I',' ',handle) - -! initialize locals - irattle = 0 - nmol = SIZE ( molecule ) - max_sigma = -1.0E+10 - -! Initialize scale and r_rattle - CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - irattle = irattle + 1 - max_sigma = 0. - MOL: DO imol = 1, nmol - IF (molecule(imol)%ndistconst_mol /= 0 ) THEN - -! dist - CALL rattle_roll(molecule(imol),simpar,veps,max_sigma,irattle) - ELSE IF (molecule(imol)%ng3x3const_mol /= 0 ) THEN - -! 3x3 - CALL rattle_roll_3x3(molecule(imol),simpar,veps,max_sigma,irattle) - END IF - END DO MOL - -! update veps - IF ( irattle /= 1 ) CALL update_veps ( molecule, & - veps, thermo, simpar % ensemble, group ) - END DO CONS - - CALL check_tol ( roll_tol, iroll, 'RATTLE', molecule = molecule ) - CALL pv_constraint ( molecule, thermo, 'FULL', group ) - - CALL timestop ( 0.0, handle ) - -END SUBROUTINE rattle_roll_control - -!****************************************************************************** - -SUBROUTINE shake_3x3 ( molecule, simpar, ishake ) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - INTEGER, INTENT ( OUT ) :: ishake - -! Locals - REAL ( dbl ) :: idtsq, dtsqby2, dtby2, imass1, imass2, imass3 - REAL ( dbl ) :: sigma, max_sigma - REAL ( dbl ), DIMENSION(3) :: r12, r23, r13, vec, bvec - REAL ( dbl ), DIMENSION(3) :: r0_12, r0_23, r0_13 - REAL ( dbl ), DIMENSION(3) :: r1, r2, r3, v1, v2, v3, fc1, fc2, fc3 - REAL ( dbl ), DIMENSION(3,3) :: amat, ainv - TYPE (linklist_g3x3_constraints), POINTER :: llconst - INTEGER :: info, iconst - -!------------------------------------------------------------------------------ - -! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5 - idtsq = 1./simpar%dt/simpar%dt - dtby2 = simpar%dt*.5 - llconst => molecule%ll_g3x3_const - DO iconst = 1, molecule%ng3x3const_mol - ishake=0 - r0_12=llconst%p1%r-llconst%p2%r - r0_13=llconst%p1%r-llconst%p3%r - r0_23=llconst%p2%r-llconst%p3%r - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - imass3 = 1./llconst%p3%prop%mass - llconst%fc1 = -2.*(llconst%rold1-llconst%rold2) - llconst%fc2 = -2.*(llconst%rold1-llconst%rold3) - llconst%fc3 = -2.*(llconst%rold2-llconst%rold3) - -! construct matrix - amat(1,1)=(imass1+imass2)*DOTPROD_3D(r0_12,llconst%fc1) - amat(1,2)=imass1*DOTPROD_3D(r0_12,llconst%fc2) - amat(1,3)=-imass2*DOTPROD_3D(r0_12,llconst%fc3) - amat(2,1)=imass1*DOTPROD_3D(r0_13,llconst%fc1) - amat(2,2)=(imass1+imass3)*DOTPROD_3D(r0_13,llconst%fc2) - amat(2,3)=imass3*DOTPROD_3D(r0_13,llconst%fc3) - amat(3,1)=-imass2*DOTPROD_3D(r0_23,llconst%fc1) - amat(3,2)=imass3*DOTPROD_3D(r0_23,llconst%fc2) - amat(3,3)=(imass3+imass2)*DOTPROD_3D(r0_23,llconst%fc3) - -! Iterate until convergence: - max_sigma = -1.0E+10 - CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - max_sigma=0. - ishake=ishake+1 - vec= llconst%lambda(1)*llconst%fc1*(imass1+imass2) + & - llconst%lambda(2)*imass1*llconst%fc2 - & - llconst%lambda(3)*imass2*llconst%fc3 - bvec(1)=llconst%d12*llconst%d12-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_12,r0_12) - vec= llconst%lambda(1)*llconst%fc1*imass1 + & - llconst%lambda(2)*(imass1+imass3)*llconst%fc2 + & - llconst%lambda(3)*imass3*llconst%fc3 - bvec(2)=llconst%d13*llconst%d13-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_13,r0_13) - vec= -llconst%lambda(1)*llconst%fc1*imass2 + & - llconst%lambda(2)*imass3*llconst%fc2 + & - llconst%lambda(3)*(imass2+imass3)*llconst%fc3 - bvec(3)=llconst%d23*llconst%d23-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_23,r0_23) - bvec = bvec * idtsq - -! find inverse of amat - CALL getinv3x3 ( amat, ainv ) - -! get lambda - llconst%lambda ( : )=MATVEC_3x3(ainv,bvec) - fc1=llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(2)*llconst%fc2 - fc2=-llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(3)*llconst%fc3 - fc3=-llconst%lambda(2)*llconst%fc2- & - llconst%lambda(3)*llconst%fc3 - r1 = llconst%p1%r + imass1*dtsqby2*fc1 - r2 = llconst%p2%r + imass2*dtsqby2*fc2 - r3 = llconst%p3%r + imass3*dtsqby2*fc3 - v1 = llconst%p1%v + imass1*dtby2*fc1 - v2 = llconst%p2%v + imass2*dtby2*fc2 - v3 = llconst%p3%v + imass3*dtby2*fc3 - r12=r1-r2 - r13=r1-r3 - r23=r2-r3 - -! compute the tolerance: - sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 - max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 - max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 - max_sigma=MAX(max_sigma,ABS(sigma)) - END DO CONS - -! update positions with full multiplier - llconst%p1%r = r1 - llconst%p2%r = r2 - llconst%p3%r = r3 - -! update velocites with full multiplier - llconst%p1%v = v1 - llconst%p2%v = v2 - llconst%p3%v = v3 - llconst => llconst%next - - END DO - -END SUBROUTINE shake_3x3 - -!****************************************************************************** - -SUBROUTINE shake_roll_3x3(molecule,simpar,r_shake,ishake) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: r_shake - INTEGER, INTENT ( OUT ) :: ishake - -! Locals - REAL ( dbl ) :: idtsq, dtsqby2, dtby2, imass1, imass2, imass3 - REAL ( dbl ) :: sigma, max_sigma - REAL ( dbl ), DIMENSION(3) :: r12, r23, r13, vec, bvec - REAL ( dbl ), DIMENSION(3) :: r0_12, r0_23, r0_13 - REAL ( dbl ), DIMENSION(3) :: r1, r2, r3, v1, v2, v3, fc1, fc2, fc3, f_roll1, & - f_roll2, f_roll3 - REAL ( dbl ), DIMENSION(3,3) :: amat, ainv - TYPE (linklist_g3x3_constraints), POINTER :: llconst - INTEGER :: info, iconst - -!------------------------------------------------------------------------------ - -! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5 - idtsq = 1./simpar%dt/simpar%dt - dtby2 = simpar%dt*.5 - llconst => molecule%ll_g3x3_const - - DO iconst = 1, molecule%ng3x3const_mol - ishake=0 - r0_12=llconst%p1%r-llconst%p2%r - r0_13=llconst%p1%r-llconst%p3%r - r0_23=llconst%p2%r-llconst%p3%r - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - imass3 = 1./llconst%p3%prop%mass - llconst%fc1 = -2.*(llconst%rold1-llconst%rold2) - llconst%fc2 = -2.*(llconst%rold1-llconst%rold3) - llconst%fc3 = -2.*(llconst%rold2-llconst%rold3) - -! rotate fconst: - f_roll1 = matvec_3x3(r_shake,llconst%fc1) - f_roll2 = matvec_3x3(r_shake,llconst%fc2) - f_roll3 = matvec_3x3(r_shake,llconst%fc3) - -! construct matrix - amat(1,1)=(imass1+imass2)*DOTPROD_3D(r0_12,f_roll1) - amat(1,2)=imass1*DOTPROD_3D(r0_12,f_roll2) - amat(1,3)=-imass2*DOTPROD_3D(r0_12,f_roll3) - amat(2,1)=imass1*DOTPROD_3D(r0_13,f_roll1) - amat(2,2)=(imass1+imass3)*DOTPROD_3D(r0_13,f_roll2) - amat(2,3)=imass3*DOTPROD_3D(r0_13,f_roll3) - amat(3,1)=-imass2*DOTPROD_3D(r0_23,f_roll1) - amat(3,2)=imass3*DOTPROD_3D(r0_23,f_roll2) - amat(3,3)=(imass3+imass2)*DOTPROD_3D(r0_23,f_roll3) - -! Iterate until convergence: - max_sigma = -1.0E+10 - CONS: DO WHILE (abs(max_sigma)>=simpar%shake_tol) - max_sigma=0. - ishake=ishake+1 - vec= llconst%lambda(1)*f_roll1*(imass1+imass2) + & - llconst%lambda(2)*imass1*f_roll2 - & - llconst%lambda(3)*imass2*f_roll3 - bvec(1)=llconst%d12*llconst%d12-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_12,r0_12) - vec= llconst%lambda(1)*f_roll1*imass1 + & - llconst%lambda(2)*(imass1+imass3)*f_roll2 + & - llconst%lambda(3)*imass3*f_roll3 - bvec(2)=llconst%d13*llconst%d13-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_13,r0_13) - vec= -llconst%lambda(1)*f_roll1*imass2 + & - llconst%lambda(2)*imass3*f_roll2 + & - llconst%lambda(3)*(imass2+imass3)*f_roll3 - bvec(3)=llconst%d23*llconst%d23-dtsqby2*dtsqby2*DOTPROD_3D(vec,vec) & - -DOTPROD_3D(r0_23,r0_23) - bvec=bvec*idtsq - -! find inverse of amat - CALL getinv3x3 ( amat, ainv ) - -! get lambda - llconst%lambda ( : )=MATVEC_3x3(ainv,bvec) - fc1=llconst%lambda(1)*f_roll1+ & - llconst%lambda(2)*f_roll2 - fc2=-llconst%lambda(1)*f_roll1+ & - llconst%lambda(3)*f_roll3 - fc3=-llconst%lambda(2)*f_roll2- & - llconst%lambda(3)*f_roll3 - r1 = llconst%p1%r + imass1*dtsqby2*fc1 - r2 = llconst%p2%r + imass2*dtsqby2*fc2 - r3 = llconst%p3%r + imass3*dtsqby2*fc3 - v1 = llconst%p1%v + imass1*dtby2*fc1 - v2 = llconst%p2%v + imass2*dtby2*fc2 - v3 = llconst%p3%v + imass3*dtby2*fc3 - r12=r1-r2 - r13=r1-r3 - r23=r2-r3 - -! compute the tolerance: - sigma = dot_product(r12,r12) - llconst%d12*llconst%d12 - max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r13,r13) - llconst%d13*llconst%d13 - max_sigma=MAX(max_sigma,ABS(sigma)) - sigma = dot_product(r23,r23) - llconst%d23*llconst%d23 - max_sigma=MAX(max_sigma,ABS(sigma)) - END DO CONS - -! update positions with full multiplier - llconst%p1%r = r1 - llconst%p2%r = r2 - llconst%p3%r = r3 - -! update velocites with full multiplier - llconst%p1%v = v1 - llconst%p2%v = v2 - llconst%p3%v = v3 - llconst => llconst%next - - END DO - -END SUBROUTINE shake_roll_3x3 - -!****************************************************************************** - -SUBROUTINE rattle_roll_3x3(molecule,simpar,veps,max_sigma,irattle) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), INTENT ( INOUT ) :: max_sigma - INTEGER, INTENT ( IN ) :: irattle - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: veps - -! Locals - INTEGER :: iconst, info - REAL ( dbl ) :: idt, dtby2, imass1, imass2, imass3, sigma_dot - REAL ( dbl ), DIMENSION(3) :: r12, r23, r13, vec, bvec - REAL ( dbl ), DIMENSION(3) :: f_roll1, f_roll2, f_roll3 - REAL ( dbl ), DIMENSION(3) :: v12_0, v23_0, v13_0 - REAL ( dbl ), DIMENSION(3) :: v12, v23, v13 - REAL ( dbl ), DIMENSION(3) :: v1, v2, v3 - REAL ( dbl ), DIMENSION(3) :: v1_0, v2_0, v3_0 - REAL ( dbl ), DIMENSION(3) :: fc1, fc2, fc3, lambda - REAL ( dbl ), DIMENSION(3,3) :: amat, ainv - TYPE (linklist_g3x3_constraints), POINTER :: llconst - -!------------------------------------------------------------------------------ - -! define local variables - idt = 1./simpar%dt - dtby2 = simpar%dt*.5 - IF (irattle==1) THEN - llconst => molecule%ll_g3x3_const - DO iconst = 1, molecule%ng3x3const_mol - llconst%vold1=llconst%p1%v - llconst%vold2=llconst%p2%v - llconst%vold3=llconst%p3%v - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - imass3 = 1./llconst%p3%prop%mass - fc1=llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(2)*llconst%fc2 - fc2=-llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(3)*llconst%fc3 - fc3=-llconst%lambda(2)*llconst%fc2- & - llconst%lambda(3)*llconst%fc3 - llconst%p1%v=llconst%p1%v+imass1*dtby2*fc1 - llconst%p2%v=llconst%p2%v+imass2*dtby2*fc2 - llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 - llconst => llconst%next - END DO - max_sigma = -1.0E+10 - - ELSE - - llconst => molecule%ll_g3x3_const - DO iconst = 1, molecule%ng3x3const_mol - v12_0=llconst%vold1-llconst%vold2 - v13_0=llconst%vold1-llconst%vold3 - v23_0=llconst%vold2-llconst%vold3 - r12=llconst%p1%r-llconst%p2%r - r13=llconst%p1%r-llconst%p3%r - r23=llconst%p2%r-llconst%p3%r - -! roll the local velocities - v12_0=matvec_3x3(r_rattle,v12_0)*llconst%scale - v13_0=matvec_3x3(r_rattle,v13_0)*llconst%scale - v23_0=matvec_3x3(r_rattle,v23_0)*llconst%scale - v1_0=matvec_3x3(r_rattle,llconst%vold1)*llconst%scale - v2_0=matvec_3x3(r_rattle,llconst%vold2)*llconst%scale - v3_0=matvec_3x3(r_rattle,llconst%vold3)*llconst%scale - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - imass3 = 1./llconst%p3%prop%mass - llconst%fc1 = -2.*(llconst%p1%r-llconst%p2%r) - llconst%fc2 = -2.*(llconst%p1%r-llconst%p3%r) - llconst%fc3 = -2.*(llconst%p2%r-llconst%p3%r) - -! roll the fc - f_roll1=matvec_3x3(r_rattle,llconst%fc1)*llconst%scale - f_roll2=matvec_3x3(r_rattle,llconst%fc2)*llconst%scale - f_roll3=matvec_3x3(r_rattle,llconst%fc3)*llconst%scale - -! construct matrix - amat(1,1)=(imass1+imass2)*DOTPROD_3D(r12,f_roll1) - amat(1,2)=imass1*DOTPROD_3D(r12,f_roll2) - amat(1,3)=-imass2*DOTPROD_3D(r12,f_roll3) - amat(2,1)=imass1*DOTPROD_3D(r13,f_roll1) - amat(2,2)=(imass1+imass3)*DOTPROD_3D(r13,f_roll2) - amat(2,3)=imass3*DOTPROD_3D(r13,f_roll3) - amat(3,1)=-imass2*DOTPROD_3D(r23,f_roll1) - amat(3,2)=imass3*DOTPROD_3D(r23,f_roll2) - amat(3,3)=(imass2+imass3)*DOTPROD_3D(r23,f_roll3) - -! construct solution vector - bvec(1)=DOTPROD_3D(r12,v12_0+MATVEC_3X3(veps,r12)) - bvec(2)=DOTPROD_3D(r13,v13_0+MATVEC_3X3(veps,r13)) - bvec(3)=DOTPROD_3D(r23,v23_0+MATVEC_3X3(veps,r23)) - bvec = -bvec * 2.0 * idt - -! find inverse of amat - CALL getinv3x3 ( amat, ainv ) - -! get lambda - lambda ( : )=MATVEC_3X3(ainv,bvec) - llconst%del_lam=lambda-llconst%lambda - -! update local velocities for calculation of sigma_dot -! NOTE: use full multiplier because always starting -! from reference velocity, v1_0, v2_0, v3_0. - fc1=llconst%lambda(1)*f_roll1+ & - llconst%lambda(2)*f_roll2 - fc2=-llconst%lambda(1)*f_roll1+ & - llconst%lambda(3)*f_roll3 - fc3=-llconst%lambda(2)*f_roll2- & - llconst%lambda(3)*f_roll3 - v1=v1_0+imass1*dtby2*fc1 - v2=v2_0+imass2*dtby2*fc2 - v3=v3_0+imass3*dtby2*fc3 - -! update true velocities - fc1=llconst%del_lam(1)*llconst%fc1+ & - llconst%del_lam(2)*llconst%fc2 - fc2=-llconst%del_lam(1)*llconst%fc1+ & - llconst%del_lam(3)*llconst%fc3 - fc3=-llconst%del_lam(2)*llconst%fc2- & - llconst%del_lam(3)*llconst%fc3 - llconst%p1%v=llconst%p1%v+imass1*dtby2*fc1 - llconst%p2%v=llconst%p2%v+imass2*dtby2*fc2 - llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 - -! computing the convergence of the sigma_dot - v12=v1-v2 - sigma_dot=2.*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) - max_sigma = MAX(abs(sigma_dot),max_sigma) - v13=v1-v3 - sigma_dot=2.*DOTPROD_3D(r13,v13+MATVEC_3X3(veps,r13)) - max_sigma = MAX(abs(sigma_dot),max_sigma) - v23=v2-v3 - sigma_dot=2.*DOTPROD_3D(r23,v23+MATVEC_3X3(veps,r23)) - max_sigma = MAX(abs(sigma_dot),max_sigma) - llconst%lambda=lambda - llconst => llconst%next - END DO - - END IF - -END SUBROUTINE rattle_roll_3x3 - -!****************************************************************************** - -SUBROUTINE rattle_3x3(molecule,simpar) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - -! Locals - INTEGER :: iconst, info - REAL ( dbl ) :: idt, dtby2, imass1, imass2, imass3 - REAL ( dbl ), DIMENSION(3) :: r12, r23, r13, vec, bvec - REAL ( dbl ), DIMENSION(3) :: v12, v23, v13 - REAL ( dbl ), DIMENSION(3) :: fc1, fc2, fc3 - REAL ( dbl ), DIMENSION(3,3) :: amat, ainv - TYPE (linklist_g3x3_constraints), POINTER :: llconst - -!------------------------------------------------------------------------------ - -! define local variables - idt = 1./simpar%dt - dtby2 = simpar%dt*.5 - llconst => molecule%ll_g3x3_const - DO iconst = 1, molecule%ng3x3const_mol - v12=llconst%p1%v-llconst%p2%v - v13=llconst%p1%v-llconst%p3%v - v23=llconst%p2%v-llconst%p3%v - r12=llconst%p1%r-llconst%p2%r - r13=llconst%p1%r-llconst%p3%r - r23=llconst%p2%r-llconst%p3%r - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - imass3 = 1./llconst%p3%prop%mass - llconst%fc1 = -2.*(llconst%p1%r-llconst%p2%r) - llconst%fc2 = -2.*(llconst%p1%r-llconst%p3%r) - llconst%fc3 = -2.*(llconst%p2%r-llconst%p3%r) - -! construct matrix - amat(1,1)=(imass1+imass2)*DOTPROD_3D(r12,llconst%fc1) - amat(1,2)=imass1*DOTPROD_3D(r12,llconst%fc2) - amat(1,3)=-imass2*DOTPROD_3D(r12,llconst%fc3) - amat(2,1)=imass1*DOTPROD_3D(r13,llconst%fc1) - amat(2,2)=(imass1+imass3)*DOTPROD_3D(r13,llconst%fc2) - amat(2,3)=imass3*DOTPROD_3D(r13,llconst%fc3) - amat(3,1)=-imass2*DOTPROD_3D(r23,llconst%fc1) - amat(3,2)=imass3*DOTPROD_3D(r23,llconst%fc2) - amat(3,3)=(imass2+imass3)*DOTPROD_3D(r23,llconst%fc3) - -! construct solution vector - bvec(1)=DOTPROD_3D(r12,v12) - bvec(2)=DOTPROD_3D(r13,v13) - bvec(3)=DOTPROD_3D(r23,v23) - bvec=-bvec*2.*idt - -! find inverse of amat - CALL getinv3x3(amat,ainv) - -! get lambda - llconst%lambda ( : )=MATVEC_3X3(ainv,bvec) - fc1=llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(2)*llconst%fc2 - fc2=-llconst%lambda(1)*llconst%fc1+ & - llconst%lambda(3)*llconst%fc3 - fc3=-llconst%lambda(2)*llconst%fc2- & - llconst%lambda(3)*llconst%fc3 - llconst%p1%v=llconst%p1%v+imass1*dtby2*fc1 - llconst%p2%v=llconst%p2%v+imass2*dtby2*fc2 - llconst%p3%v=llconst%p3%v+imass3*dtby2*fc3 - llconst => llconst%next - END DO - -END SUBROUTINE rattle_3x3 - -!****************************************************************************** - -SUBROUTINE shake(molecule,simpar,max_sigma,ishake) - -! updates the multiplier one molecule type at a time - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), INTENT ( INOUT ) :: max_sigma - INTEGER, INTENT ( IN ) :: ishake - REAL ( dbl ) :: dtsqby2, dtby2, imass1, imass2, fdotf, fdotf_sum, del_lam - REAL ( dbl ), DIMENSION (3) :: fc_t, r12 - TYPE (linklist_dist_constraints), POINTER :: llconst - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - -! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5 - dtby2 = simpar%dt*.5 - IF (ishake==1) THEN - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - llconst%fc = -2.*(llconst%rold1-llconst%rold2) - -! update positions with full multiplier - llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%lambda* & - llconst%fc - llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%lambda* & - llconst%fc - -! update velocites with full multiplier - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & - fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%lambda*llconst% & - fc - llconst => llconst%next - END DO - - ELSE - - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - -! computing the constraint - r12 = llconst%p1%r - llconst%p2%r - llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & - distance - -! computing fc(dt) - fc_t = -2.*(llconst%p1%r-llconst%p2%r) - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - fdotf = dot_product(llconst%fc,fc_t) - fdotf_sum = fdotf*imass1 + fdotf*imass2 - del_lam = 2.*llconst%sigma/(simpar%dt*simpar%dt*fdotf_sum) - llconst%lambda = llconst%lambda + del_lam - -! update positions by delta_lam - llconst%p1%r = llconst%p1%r + imass1*dtsqby2*del_lam*llconst%fc - llconst%p2%r = llconst%p2%r - imass2*dtsqby2*del_lam*llconst%fc - -! update velocites by delta_lam - llconst%p1%v = llconst%p1%v + imass1*dtby2*del_lam*llconst%fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*del_lam*llconst%fc - llconst => llconst%next - END DO - END IF - -! computing the constraint and value of tolerance - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - r12 = llconst%p1%r - llconst%p2%r - llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & - distance - max_sigma = max(abs(llconst%sigma),max_sigma) - llconst => llconst%next - END DO - -END SUBROUTINE shake - -!****************************************************************************** - -SUBROUTINE rattle ( molecule, simpar, max_sigma, irattle ) - -! updates the multiplier one molecule type at a time - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), INTENT ( INOUT ) :: max_sigma - INTEGER, INTENT ( IN ) :: irattle - -! Locals - REAL ( dbl ) :: dtby2, imass1, imass2, fdotf, fdotf_sum, del_lam - REAL ( dbl ), DIMENSION (3) :: r12, v12 - TYPE (linklist_dist_constraints), POINTER :: llconst - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - -! define local variables - dtby2 = simpar%dt*.5 - IF (irattle==1) THEN - llconst => molecule%ll_dist_const -! if statement to catch molecule types with no constraints.: - DO iconst = 1, molecule%ndistconst_mol - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) - -! update velocites with full multiplier - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & - fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%lambda*llconst% & - fc - llconst => llconst%next - END DO - - ELSE - - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - -! computing sigma - r12 = llconst%p1%r - llconst%p2%r - v12 = llconst%p1%v - llconst%p2%v - llconst%sigma = 2.*dot_product(r12,v12) - -! computing f(dt) - llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - fdotf = dot_product(llconst%fc,llconst%fc) - fdotf_sum = fdotf*imass1 + fdotf*imass2 - del_lam = 2.*llconst%sigma/(simpar%dt*fdotf_sum) - llconst%lambda = llconst%lambda + del_lam - -!update velocites with del_lam - llconst%p1%v = llconst%p1%v + imass1*dtby2*del_lam*llconst%fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*del_lam*llconst%fc - llconst => llconst%next - END DO - END IF - -! computing the constraint and value of the tolerance - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - -! computing the updated constraint - r12 = llconst%p1%r - llconst%p2%r - v12 = llconst%p1%v - llconst%p2%v - llconst%sigma = 2.*dot_product(r12,v12) - max_sigma = max(abs(llconst%sigma),max_sigma) - llconst => llconst%next - END DO - -END SUBROUTINE rattle - -!****************************************************************************** - -SUBROUTINE rattle_roll(molecule,simpar,veps,max_sigma,irattle) - -! updates the multiplier one molecule type at a time - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), INTENT ( INOUT ) :: max_sigma - INTEGER, INTENT ( IN ) :: irattle - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: veps - -! Locals - REAL ( dbl ) :: dtby2, imass1, imass2, fdotf, fdotf_sum, del_lam - REAL ( dbl ), DIMENSION (3) :: r12, v12, f_roll - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: v1, v2 - TYPE (linklist_dist_constraints), POINTER :: llconst - INTEGER :: imol, iconst, isos - -!------------------------------------------------------------------------------ - -! define local variables - dtby2 = simpar%dt*.5 - IF (irattle==1) THEN - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - llconst%fc = -2.*(llconst%p1%r-llconst%p2%r) - -! update velocites with full multiplier - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & - fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%lambda*llconst% & - fc - llconst => llconst%next - END DO - max_sigma = -1.E+10 - - ELSE - llconst => molecule%ll_dist_const - -! allocating local vs - ALLOCATE (v1(3,molecule%ndistconst_mol),STAT=isos) - IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to allocate v1') - ALLOCATE (v2(3,molecule%ndistconst_mol),STAT=isos) - IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to allocate v2') - - DO iconst = 1, molecule%ndistconst_mol - -! assign local variable - v1(:,iconst) = llconst%p1%v - v2(:,iconst) = llconst%p2%v - r12 = llconst%p1%r - llconst%p2%r - -! Roll the local vs and fc - v1(:,iconst) = matvec_3x3(r_rattle ( :, : ),v1(:,iconst)) - v2(:,iconst) = matvec_3x3(r_rattle ( :, : ),v2(:,iconst)) - v1(:,iconst) = v1(:,iconst)*llconst%scale - v2(:,iconst) = v2(:,iconst)*llconst%scale - llconst%fc = -2.*r12 - f_roll = matvec_3x3(r_rattle,llconst%fc) - f_roll = f_roll*llconst%scale - -! computing sigma - v12 ( : ) = v1(:,iconst) + matvec_3x3(veps,llconst%p1%r) & - - v2(:,iconst) - matvec_3x3(veps,llconst%p2%r) - llconst%sigma = 2.*dot_product(r12,v12) - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - fdotf = dot_product(f_roll,llconst%fc) - fdotf_sum = fdotf*imass1 + fdotf*imass2 - llconst%del_lam = 2.*llconst%sigma/(simpar%dt*fdotf_sum) - llconst%lambda = llconst%lambda + llconst%del_lam - -!update local velocities with del_lam - v1(:,iconst) = v1(:,iconst) & - + imass1*dtby2*llconst%del_lam*f_roll ( : ) - v2(:,iconst) = v2(:,iconst) & - - imass2*dtby2*llconst%del_lam*f_roll ( : ) - -!update true velocites with del_lam - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%del_lam*llconst & - %fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%del_lam*llconst & - %fc - llconst => llconst%next - END DO - -! computing the constraint and value of the tolerance with local vs - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - -! computing the updated constraint - r12 = llconst%p1%r - llconst%p2%r - v12 ( : ) = v1(:,iconst)-v2(:,iconst) - llconst%sigma = 2.*DOTPROD_3D(r12,v12+MATVEC_3X3(veps,r12)) - max_sigma = max(abs(llconst%sigma),max_sigma) - llconst => llconst%next - END DO - - DEALLOCATE (v1,STAT=isos) - IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to deallocate v1') - DEALLOCATE (v2,STAT=isos) - IF ( isos /= 0 ) CALL stop_prg( 'rattle_roll','failed to deallocate v2') - - END IF - -END SUBROUTINE rattle_roll - -!****************************************************************************** - -SUBROUTINE getold(molecule) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: molecule - -! Locals - INTEGER :: imol, iconst - TYPE (linklist_dist_constraints), POINTER :: ll_dist - TYPE (linklist_g3x3_constraints), POINTER :: ll_g3x3 - -!------------------------------------------------------------------------------ - -! saves all of the old variables - DO imol = 1, size(molecule) - ll_dist => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - ll_dist%rold1(1) = ll_dist%p1%r(1) - ll_dist%rold1(2) = ll_dist%p1%r(2) - ll_dist%rold1(3) = ll_dist%p1%r(3) - ll_dist%rold2(1) = ll_dist%p2%r(1) - ll_dist%rold2(2) = ll_dist%p2%r(2) - ll_dist%rold2(3) = ll_dist%p2%r(3) - ll_dist => ll_dist%next - END DO - - ll_g3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - ll_g3x3%rold1(1) = ll_g3x3%p1%r(1) - ll_g3x3%rold1(2) = ll_g3x3%p1%r(2) - ll_g3x3%rold1(3) = ll_g3x3%p1%r(3) - ll_g3x3%rold2(1) = ll_g3x3%p2%r(1) - ll_g3x3%rold2(2) = ll_g3x3%p2%r(2) - ll_g3x3%rold2(3) = ll_g3x3%p2%r(3) - ll_g3x3%rold3(1) = ll_g3x3%p3%r(1) - ll_g3x3%rold3(2) = ll_g3x3%p3%r(2) - ll_g3x3%rold3(3) = ll_g3x3%p3%r(3) - ll_g3x3 => ll_g3x3%next - END DO - - END DO - -END SUBROUTINE getold - -!****************************************************************************** - -SUBROUTINE pv_constraint ( molecule, thermo, char, group ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - CHARACTER ( LEN = * ), INTENT ( IN ) :: char - INTEGER, INTENT ( IN ) :: group - -! Locals - REAL ( dbl ) :: lambda, pv ( 3, 3 ), lambda_3x3 ( 3 ) - REAL ( dbl ) :: fc1 ( 3 ), fc2 ( 3 ), fc3 ( 3 ) - TYPE ( linklist_dist_constraints ), POINTER :: llconst - TYPE ( linklist_g3x3_constraints ), POINTER :: ll3x3 - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - - pv = 0.0 - DO imol = 1, size(molecule) - -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - - SELECT CASE (char) - CASE ( 'FULL') -! pv gets updated with FULL multiplier - lambda = llconst%lambda - - CASE ( 'DEL') -! pv gets updated with del_lam - lambda = llconst%del_lam - END SELECT - -!pv(1,1) - pv(1,1) = pv(1,1) + lambda*llconst%fc(1)*llconst%p1%r(1) - pv(1,1) = pv(1,1) - lambda*llconst%fc(1)*llconst%p2%r(1) -!pv(1,2) - pv(1,2) = pv(1,2) + lambda*llconst%fc(1)*llconst%p1%r(2) - pv(1,2) = pv(1,2) - lambda*llconst%fc(1)*llconst%p2%r(2) -!pv(1,3) - pv(1,3) = pv(1,3) + lambda*llconst%fc(1)*llconst%p1%r(3) - pv(1,3) = pv(1,3) - lambda*llconst%fc(1)*llconst%p2%r(3) -!pv(2,1) - pv(2,1) = pv(2,1) + lambda*llconst%fc(2)*llconst%p1%r(1) - pv(2,1) = pv(2,1) - lambda*llconst%fc(2)*llconst%p2%r(1) -!pv(2,2) - pv(2,2) = pv(2,2) + lambda*llconst%fc(2)*llconst%p1%r(2) - pv(2,2) = pv(2,2) - lambda*llconst%fc(2)*llconst%p2%r(2) -!pv(2,3) - pv(2,3) = pv(2,3) + lambda*llconst%fc(2)*llconst%p1%r(3) - pv(2,3) = pv(2,3) - lambda*llconst%fc(2)*llconst%p2%r(3) -!pv(3,1) - pv(3,1) = pv(3,1) + lambda*llconst%fc(3)*llconst%p1%r(1) - pv(3,1) = pv(3,1) - lambda*llconst%fc(3)*llconst%p2%r(1) -!pv(3,2) - pv(3,2) = pv(3,2) + lambda*llconst%fc(3)*llconst%p1%r(2) - pv(3,2) = pv(3,2) - lambda*llconst%fc(3)*llconst%p2%r(2) -!pv(3,3) - pv(3,3) = pv(3,3) + lambda*llconst%fc(3)*llconst%p1%r(3) - pv(3,3) = pv(3,3) - lambda*llconst%fc(3)*llconst%p2%r(3) - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol)%ll_g3x3_const - DO iconst = 1, molecule(imol)%ng3x3const_mol - - SELECT CASE (char) - CASE ( 'FULL') -! pv gets updated with FULL multiplier - lambda_3x3 = ll3x3%lambda - - CASE ( 'DEL') -! pv gets updated with del_lam - lambda_3x3 = ll3x3%del_lam - END SELECT - - fc1=lambda_3x3(1)*ll3x3%fc1+ & - lambda_3x3(2)*ll3x3%fc2 - fc2=-lambda_3x3(1)*ll3x3%fc1+ & - lambda_3x3(3)*ll3x3%fc3 - fc3=-lambda_3x3(2)*ll3x3%fc2- & - lambda_3x3(3)*ll3x3%fc3 - -!pv(1,1) - pv(1,1) = pv(1,1) + fc1(1)*ll3x3%p1%r(1) - pv(1,1) = pv(1,1) + fc2(1)*ll3x3%p2%r(1) - pv(1,1) = pv(1,1) + fc3(1)*ll3x3%p3%r(1) -!pv(1,2) - pv(1,2) = pv(1,2) + fc1(1)*ll3x3%p1%r(2) - pv(1,2) = pv(1,2) + fc2(1)*ll3x3%p2%r(2) - pv(1,2) = pv(1,2) + fc3(1)*ll3x3%p3%r(2) -!pv(1,3) - pv(1,3) = pv(1,3) + fc1(1)*ll3x3%p1%r(3) - pv(1,3) = pv(1,3) + fc2(1)*ll3x3%p2%r(3) - pv(1,3) = pv(1,3) + fc3(1)*ll3x3%p3%r(3) -!pv(2,1) - pv(2,1) = pv(2,1) + fc1(2)*ll3x3%p1%r(1) - pv(2,1) = pv(2,1) + fc2(2)*ll3x3%p2%r(1) - pv(2,1) = pv(2,1) + fc3(2)*ll3x3%p3%r(1) -!pv(2,2) - pv(2,2) = pv(2,2) + fc1(2)*ll3x3%p1%r(2) - pv(2,2) = pv(2,2) + fc2(2)*ll3x3%p2%r(2) - pv(2,2) = pv(2,2) + fc3(2)*ll3x3%p3%r(2) -!pv(2,3) - pv(2,3) = pv(2,3) + fc1(2)*ll3x3%p1%r(3) - pv(2,3) = pv(2,3) + fc2(2)*ll3x3%p2%r(3) - pv(2,3) = pv(2,3) + fc3(2)*ll3x3%p3%r(3) -!pv(3,1) - pv(3,1) = pv(3,1) + fc1(3)*ll3x3%p1%r(1) - pv(3,1) = pv(3,1) + fc2(3)*ll3x3%p2%r(1) - pv(3,1) = pv(3,1) + fc3(3)*ll3x3%p3%r(1) -!pv(3,2) - pv(3,2) = pv(3,2) + fc1(3)*ll3x3%p1%r(2) - pv(3,2) = pv(3,2) + fc2(3)*ll3x3%p2%r(2) - pv(3,2) = pv(3,2) + fc3(3)*ll3x3%p3%r(2) -!pv(3,3) - pv(3,3) = pv(3,3) + fc1(3)*ll3x3%p1%r(3) - pv(3,3) = pv(3,3) + fc2(3)*ll3x3%p2%r(3) - pv(3,3) = pv(3,3) + fc3(3)*ll3x3%p3%r(3) - - ll3x3 => ll3x3%next - END DO - - END DO - -#if defined(__parallel) - CALL mp_sum ( pv, group ) -#endif - - thermo % pv_const = pv - -END SUBROUTINE pv_constraint - -!****************************************************************************** - -SUBROUTINE shake_roll(molecule,simpar,r_shake,max_sigma,ishake) - -! updates the multiplier one molecule type at a time - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ) :: molecule - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - REAL ( dbl ), INTENT ( INOUT ) :: max_sigma - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: r_shake - INTEGER, INTENT ( IN ) :: ishake - -! Locals - REAL ( dbl ) :: dtsqby2, dtby2, imass1, imass2, fdotf, fdotf_sum - REAL ( dbl ), DIMENSION (3) :: fc_t, r12, f_roll - TYPE (linklist_dist_constraints), POINTER :: llconst - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - -! define local variables - dtsqby2 = simpar%dt*simpar%dt*.5 - dtby2 = simpar%dt*.5 - IF (ishake==1) THEN - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - llconst%fc = -2.*(llconst%rold1-llconst%rold2) - -! rotate fconst: - f_roll = matvec_3x3(r_shake,llconst%fc) - -! update positions with full multiplier - llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%lambda*f_roll - llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%lambda*f_roll - -! update velocites with full multiplier - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%lambda*llconst% & - fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%lambda*llconst% & - fc - llconst => llconst%next - END DO - - ELSE - - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - -! computing the constraint - r12 = llconst%p1%r - llconst%p2%r - llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & - distance - -! computing fc(dt) - fc_t = -2.*(llconst%p1%r-llconst%p2%r) - imass1 = 1./llconst%p1%prop%mass - imass2 = 1./llconst%p2%prop%mass - -! rotate fc: - f_roll = matvec_3x3(r_shake,llconst%fc) - fdotf = dot_product(f_roll,fc_t) - fdotf_sum = fdotf*imass1 + fdotf*imass2 - llconst%del_lam = 2.*llconst%sigma/(simpar%dt*simpar%dt* & - fdotf_sum) - llconst%lambda = llconst%lambda + llconst%del_lam - -! update positions by delta_lam - llconst%p1%r = llconst%p1%r + imass1*dtsqby2*llconst%del_lam* & - f_roll - llconst%p2%r = llconst%p2%r - imass2*dtsqby2*llconst%del_lam* & - f_roll - -! update velocites by delta_lam - llconst%p1%v = llconst%p1%v + imass1*dtby2*llconst%del_lam*llconst & - %fc - llconst%p2%v = llconst%p2%v - imass2*dtby2*llconst%del_lam*llconst & - %fc - - llconst => llconst%next - END DO - - END IF - -! computing the constraint and value of tolerance - llconst => molecule%ll_dist_const - DO iconst = 1, molecule%ndistconst_mol - r12 = llconst%p1%r - llconst%p2%r - llconst%sigma = dot_product(r12,r12) - llconst%distance*llconst% & - distance - max_sigma = max(abs(llconst%sigma),max_sigma) - llconst => llconst%next - END DO -END SUBROUTINE shake_roll - -!****************************************************************************** - -SUBROUTINE roll(molecule,veps,veta,wb,dt,nnhc,nfree,eval,u) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: molecule - REAL ( dbl ), INTENT ( INOUT ), DIMENSION ( :, : ) :: veta, veps, wb - REAL ( dbl ), INTENT ( IN ) :: dt - INTEGER, INTENT ( IN ) :: nfree, nnhc - REAL ( dbl ), INTENT ( IN ), OPTIONAL, DIMENSION ( :, : ) :: u - REAL ( dbl ), INTENT ( IN ), OPTIONAL, DIMENSION ( : ) :: eval - -! Locals - REAL ( dbl ) :: aa, bb, infree, trvg - REAL ( dbl ), DIMENSION (3,3) :: roll_local, diag - TYPE (linklist_dist_constraints), POINTER :: llconst - TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - - infree = 1.0 / REAL ( nfree, dbl ) - -! updating the scale factor for barostat velocity - aa = exp(-.125*dt*veta(1,nnhc)) - bb = exp(-3.*.125*dt*veta(1,nnhc)) - scale = scale*aa*aa*aa*aa + (aa+bb)*.25*dt/wb(1,1) - -! updating the roll matrix for the velocities - IF ( PRESENT ( u)) THEN - diag = 0. - diag(1,1) = eval(1) - diag(2,2) = eval(2) - diag(3,3) = eval(3) - trvg = infree*(veps(1,1)+veps(2,2)+veps(3,3)) - roll_local = matmul_3x3(matmul_3x3(u,diag),transpose_3d(u)) - r_rattle = matmul_3x3(roll_local,r_rattle) - - DO imol = 1, size(molecule) - -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - llconst%scale = llconst%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+trvg)) - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - ll3x3%scale = ll3x3%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+trvg)) - ll3x3 => ll3x3%next - END DO - END DO - - ELSE - - DO imol = 1, size(molecule) -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - llconst%scale = llconst%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+(1.+3.*infree)*veps(1,1))) - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - ll3x3%scale = ll3x3%scale*exp(-dt*(veta(1, & - molecule(imol)%nvt_num)+(1.+3.*infree)*veps(1,1))) - ll3x3 => ll3x3%next - END DO - END DO - - END IF - -END SUBROUTINE roll - -!****************************************************************************** - -SUBROUTINE check_tol(roll_tol,iroll,char,vector,molecule) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( OUT ) :: roll_tol - INTEGER, INTENT ( INOUT ) :: iroll - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ), OPTIONAL :: vector - TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ), & - OPTIONAL :: molecule - CHARACTER ( LEN = * ), INTENT ( IN ) :: char - -! Locals - REAL ( dbl ), SAVE :: scale_old - REAL ( dbl ), DIMENSION (3), SAVE :: vector_old - REAL ( dbl ), DIMENSION (3,3), SAVE :: r_rattle_old - REAL ( dbl ), DIMENSION (3,3) :: diff_rattle - REAL ( dbl ), DIMENSION (3) :: diff_shake - REAL ( dbl ) :: local_tol - TYPE (linklist_dist_constraints), POINTER :: llconst - TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 - INTEGER :: imol, iconst - -!------------------------------------------------------------------------------ - - SELECT CASE (char) - CASE ( 'SHAKE') - IF (iroll==1) THEN - vector_old = vector - roll_tol = -1.E10 - ELSE - roll_tol = 0. - diff_shake = abs(vector_old-vector) - local_tol = maxval(diff_shake) - roll_tol = max(roll_tol,local_tol) - vector_old = vector - END IF - iroll = iroll + 1 - - CASE ( 'RATTLE') - IF (iroll==1) THEN - scale_old = scale - r_rattle_old = r_rattle - DO imol = 1, size(molecule) - -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - llconst%scale_old = llconst%scale - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - ll3x3%scale_old = ll3x3%scale - ll3x3 => ll3x3%next - END DO - END DO - roll_tol = -1.E+10 - - ELSE - - roll_tol = 0. - -! compute tolerance on - DO imol = 1, size(molecule) - -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - local_tol = abs(llconst%scale-llconst%scale_old) - roll_tol = max(roll_tol,local_tol) - llconst%scale_old = llconst%scale - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - local_tol = abs(ll3x3%scale-ll3x3%scale_old) - roll_tol = max(roll_tol,local_tol) - ll3x3%scale_old = ll3x3%scale - ll3x3 => ll3x3%next - END DO - - END DO - - diff_rattle = abs(r_rattle-r_rattle_old) - local_tol = maxval(diff_rattle) - roll_tol = max(roll_tol,local_tol) - local_tol = abs(scale-scale_old) - roll_tol = max(roll_tol,local_tol) - END IF - - iroll = iroll + 1 - END SELECT - -END SUBROUTINE check_tol - -!****************************************************************************** - -SUBROUTINE initialize_roll(molecule) - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: molecule - -! Locals - INTEGER :: imol, iconst - REAL ( dbl ), DIMENSION (3,3) :: unit - TYPE (linklist_dist_constraints), POINTER :: llconst - TYPE (linklist_g3x3_constraints), POINTER :: ll3x3 - -!------------------------------------------------------------------------------ - -! initialize unit matrix - unit = 0. - unit(1,1) = 1. - unit(2,2) = 1. - unit(3,3) = 1. - -! initialize scale variable for veps - scale = 0. - r_rattle = unit - -! initialize r_rattle - DO imol = 1, SIZE ( molecule ) - -! dist - llconst => molecule(imol) %ll_dist_const - DO iconst = 1, molecule(imol) %ndistconst_mol - llconst%scale = 1. - llconst => llconst%next - END DO - -! 3x3 - ll3x3 => molecule(imol) %ll_g3x3_const - DO iconst = 1, molecule(imol) %ng3x3const_mol - ll3x3%scale = 1. - ll3x3 => ll3x3%next - END DO - END DO - -END SUBROUTINE initialize_roll - -!****************************************************************************** - -SUBROUTINE update_veps ( molecule, veps, thermo, ensemble, group ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: veps - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble - INTEGER, INTENT ( IN ) :: group - -! Locals - REAL ( dbl ) :: feps - -!------------------------------------------------------------------------------ - -! increment pressure pv_const - CALL pv_constraint ( molecule, thermo, 'DEL', group ) - IF ( ensemble == 'NPT_I' ) THEN - feps = thermo%pv_const(1,1) & - + thermo%pv_const(2,2) & - + thermo%pv_const(3,3) - veps(1,1) = veps(1,1) + scale * feps - veps(2,2) = veps(1,1) - veps(3,3) = veps(1,1) - ELSE IF ( ensemble == 'NPT_F' ) THEN - veps ( :, : ) = veps ( :, : ) + scale * thermo % pv_const ( :, : ) - END IF - -END SUBROUTINE update_veps - -!****************************************************************************** - -SUBROUTINE get_r_shake(r_shake,vector,u) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: r_shake - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: vector - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ), OPTIONAL :: u - -! Locals - INTEGER :: i - REAL ( dbl ), DIMENSION (3,3) :: diag - -!------------------------------------------------------------------------------ - - r_shake = 0.0 - diag = 0.0 - - IF ( PRESENT ( u ) ) THEN - diag(1,1) = vector(1) - diag(2,2) = vector(2) - diag(3,3) = vector(3) - r_shake = matmul_3x3(matmul_3x3(u,diag),transpose_3d(u)) - ELSE - DO i = 1, 3 - r_shake(i,i) = vector(i) - END DO - END IF - -END SUBROUTINE get_r_shake - -!****************************************************************************** - -END MODULE constraint diff --git a/src/convert_units.c b/src/convert_units.c deleted file mode 100644 index cdd9c3d..0000000 --- a/src/convert_units.c +++ /dev/null @@ -1,160 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2024 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE convert_units - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type - USE molecule_types, ONLY : intra_parameters_type - USE pair_potential, ONLY : potentialparm_type - USE particle_types, ONLY : particle_type, particle_prop_type - USE physcon, ONLY : joule, evolt, boltzmann - USE simulation_cell, ONLY : cell_type - USE unit, ONLY : unit_convert_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: convert - -CONTAINS - -!-----------------------------------------------------------------------------! -! -! routine to convert input variables from external units to internal units -SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, & - intra_param, ewald_param ) - - IMPLICIT NONE - -! Arguments - TYPE (unit_convert_type ), INTENT ( IN ) :: units - TYPE (simulation_parameters_type ), INTENT ( INOUT ), OPTIONAL :: simpar - TYPE (particle_type ), INTENT ( INOUT ), OPTIONAL :: part ( : ) - TYPE (cell_type ), INTENT ( INOUT ), OPTIONAL :: box - TYPE (intra_parameters_type ), INTENT ( INOUT ), OPTIONAL :: intra_param - TYPE (ewald_parameters_type ), INTENT ( INOUT ), OPTIONAL :: ewald_param - TYPE (potentialparm_type ), INTENT ( INOUT ), OPTIONAL :: potparm ( :, : ) - TYPE (particle_prop_type ), INTENT ( INOUT ), OPTIONAL :: pstat ( : ) - -! Locals - REAL ( dbl ), PARAMETER :: permittivity = 8.854187817E-12 - REAL ( dbl ) :: conv2k - INTEGER :: i - -!------------------------------------------------------------------------------ - -! convert hmat - IF ( PRESENT ( box)) box%hmat = box%hmat*units%lconv - - IF ( PRESENT ( simpar)) THEN -! convert time - simpar%dt = simpar%dt*units%tconv -! convert temperature - simpar%temp_ext = simpar%temp_ext*units%econv -! convert pressure - simpar%p_ext = simpar%p_ext/units%pconv -! convert verlet skin - simpar%verlet_skin = simpar%verlet_skin*units%lconv - -! converting extended system time constants - SELECT CASE (simpar%ensemble) - CASE ( 'NVT') - simpar%tau_nhc = simpar%tau_nhc*units%tconv - CASE ( 'NPT_I') - simpar%tau_cell = simpar%tau_cell*units%tconv - simpar%tau_nhc = simpar%tau_nhc*units%tconv - CASE ( 'NPT_F') - simpar%tau_cell = simpar%tau_cell*units%tconv - simpar%tau_nhc = simpar%tau_nhc*units%tconv - END SELECT - END IF - - IF ( PRESENT ( pstat)) THEN -! convert mass - DO i = 1, size(pstat) - pstat(i) %mass = pstat(i) %mass*units%mconv - END DO - END IF - - IF ( PRESENT ( part)) THEN -! convert position - DO i = 1, size(part) - part(i) %r(1) = part(i) %r(1)*units%lconv - part(i) %r(2) = part(i) %r(2)*units%lconv - part(i) %r(3) = part(i) %r(3)*units%lconv - END DO - END IF - - IF ( PRESENT ( potparm)) THEN -! convert LJ parameters - potparm ( :, : ) %lj%epsilon = potparm ( :, : ) %lj%epsilon*units%econv - potparm ( :, : ) %lj%sigma6 = potparm ( :, : ) %lj%sigma6*(units%lconv)**6 - potparm ( :, : ) %lj%sigma12 = potparm ( :, : ) %lj%sigma12*(units%lconv)**12 -! convert Williams parameters - potparm ( :, : ) %willis%a = potparm ( :, : ) %willis%a*units%econv - potparm ( :, : ) %willis%b = potparm ( :, : ) %willis%b/units%lconv - potparm ( :, : ) %willis%c = potparm ( :, : ) %willis%c*units%econv* & - units%lconv**6 -! convert Goodwin parameters ( ev -> K has to be included ) - conv2k = joule/(evolt*boltzmann) - potparm(:,:) %goodwin%vr0 = potparm(:,:) %goodwin%vr0*units%econv* & - conv2k - potparm(:,:) %goodwin%d = potparm(:,:) %goodwin%d*units%lconv - potparm(:,:) %goodwin%dc = potparm(:,:) %goodwin%dc*units%lconv -! convert Cutoff distances - potparm ( :, : ) %rcutsq = potparm ( :, : ) %rcutsq*(units%lconv)**2 - END IF -! convert hopping matrix elements -! orbital energies -! DO i = 1, size(tbatom(:)) -! tbatom(i) %orbital_energy(:,:) = tbatom(i) %orbital_energy(:,:)* & -! units%econv*conv_2k -! END DO -! convert Goodwin parameters -! tbhop(:,:) %rcutsq = tbhop(:,:) %rcutsq*(units%lconv)**2 -! DO i = 1, size(tbhop(:,1)) -! DO j = 1, size(tbhop(1,:)) -! tbhop(i,j) %gsp(:) %er0 = tbhop(i,j) %gsp(:) %er0*units%econv* & -! conv_2k -! tbhop(i,j) %gsp(:) %r0 = tbhop(i,j) %gsp(:) %r0*units%lconv -! tbhop(i,j) %gsp(:) %rt = tbhop(i,j) %gsp(:) %rt*units%lconv -! END DO -! END DO -! -! note: e_cutoff_coul and energy_cutoff do not need to be converted -! because ewald_correction and the initialization of the energy_cutoff -! are called later and the cut-off will be computed in the appropriate units -! -! convert electrostatic parameters - IF ( PRESENT ( ewald_param)) THEN - ewald_param % eps0 = permittivity*units%eps0 - ewald_param % alpha = ewald_param % alpha/units % lconv - END IF - - IF ( PRESENT ( intra_param)) THEN -! converting bond, bends and torsion and constraint parameters - intra_param % bond_param ( :, : ) % r0 = intra_param % bond_param ( :, : ) % r0 & - *units%lconv - intra_param % bond_param ( :, : ) % k = intra_param % bond_param ( :, : ) % k & - * units%econv/units%lconv/units%lconv - - intra_param % bend_param(:,:,:) % k & - = intra_param % bend_param(:,:,:) % k * units%econv - - DO i = 1, 6 - intra_param % torsion_param(:,:,:,:) % parm(i) = & - intra_param % torsion_param(:,:,:,:) % parm(i)*units%econv - END DO - intra_param % constraint_distance ( :, : ) & - = intra_param % constraint_distance ( :, : ) * units%lconv - END IF - -END SUBROUTINE convert - -!****************************************************************************** - -END MODULE convert_units diff --git a/src/cp2k.cpp b/src/cp2k.cpp deleted file mode 100644 index 5d0ae20..0000000 --- a/src/cp2k.cpp +++ /dev/null @@ -1,65 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* */ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/* */ -/* This program is free software; you can redistribute it and/or modify */ -/* it under the terms of the GNU General Public License as published by */ -/* the Free Software Foundation; either version 2 of the License, or */ -/* (at your option) any later version. */ -/* */ -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ -/* */ -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ -/* */ -/*---------------------------------------------------------------------------*/ - -#include "global_types.h" - -// Main Program -// - performs only basic initialisations -// - calls major modules - -using namespace CP2K_NS; - -class cp2k_input; -class environment; -class fist; -class fist_global; -class parallel; -class physcon; -class tbmd; -class tbmd_global; - - - -int cp2k(int argc, char **argv) { - - global_environment_type globenv; - - start_parallel(globenv); - - initialisation(globenv); - - read_cp2k_section(globenv); - - if (globenv.ionode && globenv.print_level > 9) print_kind_info(globenv.scr); - if (globenv.ionode && globenv.print_level > 4) print_physcon(globenv.scr); - - if (globenv.program_name == "FIST") { - set_fist_global(globenv); - fist_main(); - } else if (globenv.program_name == "TBMD") { - set_tbmd_global(globenv); - tbmd_main(); - } - - trailer(globenv); - - end_parallel(); -} \ No newline at end of file diff --git a/src/cp2k.h b/src/cp2k.h deleted file mode 100644 index 6824c3a..0000000 --- a/src/cp2k.h +++ /dev/null @@ -1,14 +0,0 @@ -#ifndef _LAMMPS_H -#define _LAMMPS_H - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - -int cp2k(int, char **); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/cp2k_input.cpp b/src/cp2k_input.cpp deleted file mode 100644 index 26ba387..0000000 --- a/src/cp2k_input.cpp +++ /dev/null @@ -1,89 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include -#include -#include - -#include "global_types.h" - -using namespace CP2K_NS; - -void read_cp2k_section(global_environment_type *globenv) { - - // Locals - int ierror, ilen, iw, source, allgrp; - std::string string; - std::string label; - - // defaults - globenv->program_name = "None"; - globenv->project_name = "project"; - globenv->print_level = 0; - - iw = globenv->scr; - // parse the input section - label = "&CP2K"; - ierror = 0; - parser_init(globenv->input_file_name, label, &ierror, globenv); - if (ierror != 0 ) { - if (globenv->ionode) std::cout << " No input section &CP2K found " << std::endl; - } else { - read_line() - while (test_next() != "X") { - ilen = 6; - cfield(string, ilen); - string.upper() - - switch (string) { - case "PROGRA": - ilen = 0 - cfield(globenv->program_name, ilen); - globenv->program_name.upper(); - break; - case "PROJEC": - ilen = 0 - cfield(globenv->project_name, ilen); - break; - case "IOLEVE": - globenv->print_level = get_int(); - break; - default: - p_error(); - stop_prg("input_cntl", "unknown option"); - } - - read_line(); - } - } - - parser_end(); - // end of parsing the input section - - if (globenv->program_name == "QUICKSTEP") globenv->program_name = "QS"; - - if (globenv->ionode) { - // write some information to output - std::cout << std::left << std::setw(40) << " CP2K| Program name "; - std::cout << std::right << std::setw(40) << globenv->program_name << std::endl; - - std::cout << std::left << std::setw(40) << " CP2K| Input file name "; - std::cout << std::right << std::setw(40) << globenv->input_file_name << std::endl; - - std::cout << std::left << std::setw(40) << " CP2K| Project name "; - std::cout << std::right << std::setw(40) << globenv->project_name << std::endl; - - std::cout << std::left << std::setw(76) << " CP2K| Global print level "; - std::cout << globenv->print_level << std::endl; - - std::cout << std::left << std::setw(74) << " CP2K| Total number of processors "; - std::cout << globenv->num_pe << std::endl; - - std::cout << std::left << std::setw(74) << " CP2K| This output from processor "; - std::cout << globenv->mepos << "\n" << std::endl; - - } - -} \ No newline at end of file diff --git a/src/dg.h b/src/dg.h deleted file mode 100644 index 24d7113..0000000 --- a/src/dg.h +++ /dev/null @@ -1,30 +0,0 @@ -#ifndef _DG_H -#define _DG_H - -#include "coefficients.h" -#include "particle.h" - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct dg_rho0_type { - char type[13]; - int grid; - double *gcc; - double *zet; - coeff_type density; - } dg_rho0_type; - - typedef struct dg_type { - int grid_index; - int nparts; - dg_rho0_type dg_rho0; - particle_list_type *plist; - } dg_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/dg_rho0s.c b/src/dg_rho0s.c deleted file mode 100644 index d382835..0000000 --- a/src/dg_rho0s.c +++ /dev/null @@ -1,148 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE dg_rho0s - - USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_zero, & - PW_REALDATA3D - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi - USE pw_grid_types, ONLY : pw_grid_type - USE stop_program, ONLY : stop_prg - - IMPLICIT NONE - - PRIVATE - PUBLIC:: dg_rho0_type, dg_rho0_setup - - ! type = type of gaussian (PME_GAUSS) - ! grid = grid number - ! gcc = Gaussian contraction coefficient - ! zet = Gaussian exponent - TYPE dg_rho0_type - CHARACTER ( LEN = 12 ) :: type - INTEGER :: grid - REAL ( dbl ), DIMENSION ( : ), POINTER :: gcc - REAL ( dbl ), DIMENSION ( : ), POINTER :: zet - TYPE ( coeff_type ) :: density - END TYPE dg_rho0_type - -CONTAINS - -!****************************************************************************** - -#if defined ( __PGI ) -#define mp mpp -#endif - -!****************************************************************************** - -SUBROUTINE dg_rho0_setup ( dg_rho0, pw_grid ) - - IMPLICIT NONE - -! Arguments - TYPE ( dg_rho0_type ), INTENT ( INOUT ) :: dg_rho0 - TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid - -! Locals - -!------------------------------------------------------------------------------ - - SELECT CASE ( dg_rho0 % type ) - CASE ( "PME_GAUSS", "EWALD_GAUSS" ) - CALL coeff_allocate ( dg_rho0 % density, pw_grid, PW_REALDATA3D ) - CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 ) ) - - CASE DEFAULT - CALL stop_prg ( 'dg_rho0_setup', 'type not implemented' ) - END SELECT - -END SUBROUTINE dg_rho0_setup - -!****************************************************************************** - -SUBROUTINE dg_rho0_pme_gauss ( dg_rho0, alpha ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: dg_rho0 - REAL ( dbl ), INTENT ( IN ) :: alpha - -! Locals - TYPE ( pw_grid_type ), POINTER :: pw_grid - INTEGER :: l0, m0, n0 - INTEGER, PARAMETER :: IMPOSSIBLE = 10000 - REAL ( dbl ) :: const, e_gsq - INTEGER :: lp, mp, np, ln, mn, nn, gpt - INTEGER, DIMENSION ( :, : ), POINTER :: bds - INTEGER, DIMENSION ( : ), POINTER :: ghat - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho0 - -!------------------------------------------------------------------------------ - - const = 1.0_dbl / ( 8.0_dbl * alpha ** 2 ) - - pw_grid => dg_rho0 % pw % pw_grid - bds => pw_grid % bounds - - IF ( -bds ( 1, 1 ) == bds ( 2, 1 ) ) THEN - l0 = IMPOSSIBLE - ELSE - l0 = bds ( 1, 1 ) - END IF - - IF ( -bds ( 1, 2 ) == bds ( 2, 2 ) ) THEN - m0 = IMPOSSIBLE - ELSE - m0 = bds ( 1, 2 ) - END IF - - IF ( -bds ( 1, 3 ) == bds ( 2, 3 ) ) THEN - n0 = IMPOSSIBLE - ELSE - n0 = bds ( 1, 3 ) - END IF - - CALL coeff_zero ( dg_rho0 ) - - rho0 => dg_rho0 % pw % cr3d - - DO gpt = 1, pw_grid % ngpts_cut - ghat => pw_grid % g_hat ( :, gpt ) - - lp = pw_grid % mapl % pos ( ghat ( 1 ) ) - ln = pw_grid % mapl % neg ( ghat ( 1 ) ) - mp = pw_grid % mapm % pos ( ghat ( 2 ) ) - mn = pw_grid % mapm % neg ( ghat ( 2 ) ) - np = pw_grid % mapn % pos ( ghat ( 3 ) ) - nn = pw_grid % mapn % neg ( ghat ( 3 ) ) - - e_gsq = EXP ( -const * pw_grid % gsq ( gpt ) ) / pw_grid % vol - - !*apsi - lp = lp + bds ( 1, 1 ) - mp = mp + bds ( 1, 2 ) - np = np + bds ( 1, 3 ) - ln = ln + bds ( 1, 1 ) - mn = mn + bds ( 1, 2 ) - nn = nn + bds ( 1, 3 ) - - rho0 ( lp, mp, np ) = e_gsq - rho0 ( ln, mn, nn ) = e_gsq - - IF ( ghat ( 1 ) == l0 .OR. ghat ( 2 ) == m0 .OR. ghat ( 3 ) == n0 ) THEN - rho0 ( lp, mp, np ) = 0.0_dbl - rho0 ( ln, mn, nn ) = 0.0_dbl - END IF - - END DO - -END SUBROUTINE dg_rho0_pme_gauss - -!****************************************************************************** - -END MODULE dg_rho0s diff --git a/src/dg_types.c b/src/dg_types.c deleted file mode 100644 index a6bd16c..0000000 --- a/src/dg_types.c +++ /dev/null @@ -1,25 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -MODULE dg_types - - USE dg_rho0s, ONLY : dg_rho0_type - USE particle_lists, ONLY : particle_list_type - - IMPLICIT NONE - -! Information on the assignment function for Ewald - TYPE dg_type - INTEGER :: grid_index - INTEGER :: nparts - TYPE ( dg_rho0_type ) :: dg_rho0 - TYPE ( particle_list_type ), POINTER :: plist - END TYPE dg_type - - PRIVATE - PUBLIC :: dg_type - -!-----------------------------------------------------------------------------! -END MODULE dg_types -!-----------------------------------------------------------------------------! diff --git a/src/dgs.c b/src/dgs.c deleted file mode 100644 index 7c579d8..0000000 --- a/src/dgs.c +++ /dev/null @@ -1,730 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE dgs - - USE coefficient_types, ONLY : coeff_type - USE fft_tools, ONLY : fft_radix_operations, & - FFT_RADIX_ALLOWED, FFT_RADIX_DISALLOWED, BWFFT, FWFFT, & - fft3d => fft_wrap - USE kinds, ONLY : dbl, sgl - USE mathconstants, ONLY : twopi, pi - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup, pw_find_cutoff - USE pw_types, ONLY : COMPLEXDATA3D - USE pws, ONLY : fft_wrap - USE simulation_cell, ONLY : cell_type, get_hinv, get_cell_param - USE stop_program, ONLY : stop_prg - USE structure_factors, ONLY : structure_factor_evaluate - USE util, ONLY : dotprod_3d - - IMPLICIT NONE - - PRIVATE - PUBLIC :: dg_grid_setup, dg_find_max_cutoff, dg_sum_patch, & - dg_sum_patch_force, dg_get_1x_patch, dg_get_2x_patch, & - dg_get_strucfac, dg_get_rho_tot - -CONTAINS - -!****************************************************************************** - -SUBROUTINE dg_grid_setup ( box_b, npts_s, epsilon, alpha, grid_s, grid_b, & - dg_gaussian_type ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts_s - REAL ( dbl ), INTENT ( IN ) :: epsilon, alpha - TYPE ( cell_type ), INTENT ( IN ) :: box_b - CHARACTER( LEN = * ), INTENT ( IN ) :: dg_gaussian_type - - TYPE ( pw_grid_type ), INTENT ( INOUT ) :: grid_s, grid_b - -! Locals - INTEGER :: check - REAL ( dbl ) :: dr ( 3 ), cutoff - REAL ( dbl ) :: cell_lengths ( 3 ) - TYPE ( cell_type ) :: unit_box, box_s - - INTEGER :: foo ( 3 ) !*apsi -!------------------------------------------------------------------------------ - - CALL fft_radix_operations ( npts_s ( 1 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #1" ) - END IF - CALL fft_radix_operations ( npts_s ( 2 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #2" ) - END IF - CALL fft_radix_operations ( npts_s ( 3 ), check, & - operation = FFT_RADIX_ALLOWED ) - IF ( check /= FFT_RADIX_ALLOWED ) THEN - CALL stop_prg ( "dg_grid_setup", "disallowed small FFT length #3" ) - END IF - - CALL get_cell_param ( box_b, cell_lengths ) - - CALL dg_get_spacing ( npts_s, epsilon, alpha, dg_gaussian_type, dr ) - - CALL dg_find_radix ( dr, cell_lengths, grid_b % npts ) - - grid_b % bounds ( 1, : ) = - grid_b % npts / 2 - grid_b % bounds ( 2, : ) = + ( grid_b % npts - 1 ) / 2 - grid_s % npts ( : ) = grid_s % bounds ( 2, : ) - grid_s % bounds ( 1, : ) + 1 - - CALL pw_find_cutoff ( grid_b % npts, box_b, cutoff ) - - CALL pw_grid_setup ( box_b, grid_b, cutoff ) - - CALL dg_find_basis ( grid_b % npts, box_b, unit_box ) - - CALL dg_set_cell ( grid_s % npts, unit_box, box_s ) - - CALL pw_grid_setup ( box_s, grid_s ) - -END SUBROUTINE dg_grid_setup - -!****************************************************************************** - -SUBROUTINE dg_get_spacing ( npts, epsilon, alpha, dg_gaussian_type, dr ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: epsilon, alpha - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - CHARACTER ( LEN = * ), INTENT ( IN ) :: dg_gaussian_type - - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: dr - -! Locals - REAL ( dbl ) :: alphasq, norm - -!------------------------------------------------------------------------------ - - write(6,*) "dg_get_spacing, please check n/2 vs REAL(n)/2.0 !!!" - - SELECT CASE ( dg_gaussian_type ) - - CASE ( "PME_GAUSS" ) ! use a Gaussian of form N exp(-2*alpha^2*r^2) - alphasq = alpha ** 2 - norm = ( 2.0_dbl * alphasq / pi ) ** ( 1.5_dbl ) - dr ( : ) = SQRT ( -LOG ( epsilon / norm ) / alphasq / 2.0_dbl ) & - / ( REAL ( npts ( : ), dbl ) / 2.0_dbl ) - - CASE ( "S" ) ! use a Gaussian of form N exp(-2*alpha^2*r^2) - alphasq = alpha ** 2 - norm = ( 2.0_dbl * alphasq / pi ) ** ( 1.5_dbl ) - dr ( : ) = SQRT ( -LOG ( epsilon / norm ) / alphasq / 2.0_dbl ) & - / ( REAL ( npts ( : ), dbl ) / 2.0_dbl ) - - CASE ( "P" ) - CALL stop_prg ( "dg_get_spacing", "'P; gaussian type not defined" ) - - CASE DEFAULT - CALL stop_prg ( "dg_get_spacing", "no suitable gaussian type specified" ) - - END SELECT - -END SUBROUTINE dg_get_spacing - -!****************************************************************************** - -SUBROUTINE dg_find_radix ( dr, cell_lengths, npts ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: dr ( 3 ) - REAL ( dbl ), INTENT ( IN ) :: cell_lengths ( 3 ) - INTEGER, DIMENSION ( : ), INTENT ( OUT ) :: npts - -!------------------------------------------------------------------------------ - - npts ( : ) = NINT ( cell_lengths ( : ) / dr ( : ) ) - -END SUBROUTINE dg_find_radix - -!****************************************************************************** - -SUBROUTINE dg_find_basis( npts, box, unit_box ) - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( cell_type ), INTENT ( OUT ) :: unit_box - -! Locals - INTEGER :: i -!------------------------------------------------------------------------------ - - DO i = 1, 3 - unit_box % hmat ( :, i ) = box % hmat ( :, i ) / REAL ( npts ( : ), dbl ) - END DO - - CALL get_hinv ( unit_box ) - -END SUBROUTINE dg_find_basis - -!****************************************************************************** - -!! Calculation of the basis on the mesh 'box' - -SUBROUTINE dg_set_cell (npts, unit_box, box ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - TYPE ( cell_type ), INTENT ( OUT ) :: box - TYPE ( cell_type ), INTENT ( IN ) :: unit_box - -!------------------------------------------------------------------------------ -! computing the unit vector along a, b, c and scaling it to length dr: - - - box % hmat ( :, 1 ) = unit_box % hmat ( :, 1 ) * npts ( 1 ) - box % hmat ( :, 2 ) = unit_box % hmat ( :, 2 ) * npts ( 2 ) - box % hmat ( :, 3 ) = unit_box % hmat ( :, 3 ) * npts ( 3 ) - - CALL get_hinv ( box ) - -END SUBROUTINE dg_set_cell - -!****************************************************************************** - -SUBROUTINE dg_find_max_cutoff ( npts, grid_b ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - TYPE ( pw_grid_type ), DIMENSION ( : ), INTENT ( IN ) :: grid_b - -!------------------------------------------------------------------------------ - - CALL stop_prg ( "dg_find_max_cutoff", "not yet implemented" ) - -END SUBROUTINE dg_find_max_cutoff - -!****************************************************************************** - -SUBROUTINE dg_get_strucfac ( box, r, npts_s, npts_b, centre, lb, ex, ey, ez ) - IMPLICIT NONE - -! Arguments - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: r - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts_s, npts_b - INTEGER, INTENT ( IN ) :: lb ( 3 ) - - INTEGER, INTENT ( OUT ) :: centre ( 3 ) - COMPLEX ( dbl ), DIMENSION ( lb ( 1 ): ), INTENT ( OUT ) :: ex - COMPLEX ( dbl ), DIMENSION ( lb ( 2 ): ), INTENT ( OUT ) :: ey - COMPLEX ( dbl ), DIMENSION ( lb ( 3 ): ), INTENT ( OUT ) :: ez - -! Locals - REAL ( dbl ) :: delta ( 3 ) - -!------------------------------------------------------------------------------ - - CALL get_delta ( box, r, npts_s, npts_b, centre, delta) - - CALL structure_factor_evaluate ( delta, npts_s, lb, ex, ey, ez ) - -END SUBROUTINE dg_get_strucfac - -!****************************************************************************** - -SUBROUTINE get_delta ( box, r, npts_s, npts_b, centre, delta ) - IMPLICIT NONE - -! Arguments - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: r - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts_s, npts_b - - INTEGER, DIMENSION ( : ), INTENT ( OUT ) :: centre - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: delta - -! Locals - REAL ( dbl ), DIMENSION ( 3 ) :: s, grid_i - -!------------------------------------------------------------------------------ - -! compute the scaled coordinate of atomi - s = MATMUL ( box % h_inv, r ) - s = s - NINT ( s ) - -! find the continuous ``grid'' point (on big grid) - grid_i ( 1:3 ) = REAL ( npts_b ( 1:3 ), dbl ) * s ( 1:3 ) - -! find the closest grid point (on big grid) - centre ( : ) = NINT ( grid_i ( : ) ) - -! find the distance vector - delta ( : ) = ( grid_i ( : ) - centre ( : ) ) / REAL ( npts_s ( : ), dbl ) - -END SUBROUTINE get_delta - -!****************************************************************************** - -SUBROUTINE dg_get_1x_patch ( rho0, rhos_r, charge1, & - lb, ex1, ey1, ez1 ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: charge1 - TYPE ( coeff_type ), INTENT ( IN ) :: rho0 - INTEGER, INTENT ( IN ) :: lb ( 3 ) - COMPLEX ( dbl ), DIMENSION ( lb(1): ), INTENT ( IN ) :: ex1 - COMPLEX ( dbl ), DIMENSION ( lb(2): ), INTENT ( IN ) :: ey1 - COMPLEX ( dbl ), DIMENSION ( lb(3): ), INTENT ( IN ) :: ez1 - - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos_r - -! Locals - INTEGER :: i1, i2, i3 - COMPLEX ( dbl ) :: temp1a, temp2a, temp3a - INTEGER, DIMENSION ( :, : ), POINTER :: bds - INTEGER, DIMENSION ( : ), POINTER :: npts - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos - -!------------------------------------------------------------------------------ - - rhos => rhos_r % pw % cc3d - rho => rho0 % pw % cr3d - bds => rhos_r % pw % pw_grid % bounds - npts => rhos_r % pw % pw_grid % npts - - DO i3 = bds ( 1, 3 ), bds ( 2, 3 ) - temp3a = ez1 ( i3 ) * charge1 - - DO i2 = bds ( 1, 2 ), bds ( 2, 2 ) - temp2a = temp3a * ey1 ( i2 ) - - DO i1 = bds ( 1, 1 ), bds ( 2, 1 ) - temp1a = temp2a * ex1 ( i1 ) - - rhos ( i1, i2, i3 ) = temp1a * rho ( i1, i2, i3 ) - END DO - END DO - END DO - -! compute rho_s(r) for the current atoms - CALL fft3d ( BWFFT, npts, rhos ) - -END SUBROUTINE dg_get_1x_patch - -!****************************************************************************** - -!! The output comes in the real and imag parts of 'rhos_r' - -SUBROUTINE dg_get_2x_patch ( rho0, rhos_r, charge1, charge2, & - lb, ex1, ey1, ez1, ex2, ey2, ez2 ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: charge1, charge2 - TYPE ( coeff_type ), INTENT ( IN ), TARGET :: rho0 - INTEGER, INTENT ( IN ) :: lb ( 3 ) - COMPLEX ( dbl ), DIMENSION ( lb(1): ), INTENT ( IN ) :: ex1, ex2 - COMPLEX ( dbl ), DIMENSION ( lb(2): ), INTENT ( IN ) :: ey1, ey2 - COMPLEX ( dbl ), DIMENSION ( lb(3): ), INTENT ( IN ) :: ez1, ez2 - - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos_r - -! Locals - INTEGER :: i1, i2, i3 - COMPLEX ( dbl ) :: temp1a, temp2a, temp3a, temp1b, temp2b, temp3b - COMPLEX ( dbl ) :: ci - INTEGER, DIMENSION ( :, : ), POINTER :: bds_s - INTEGER, DIMENSION ( : ), POINTER :: npts_s - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos - -!------------------------------------------------------------------------------ - - rhos => rhos_r % pw % cc3d - rho => rho0 % pw % cr3d - bds_s => rhos_r % pw % pw_grid % bounds - npts_s => rhos_r % pw % pw_grid % npts - - ci = CMPLX ( 0.0_dbl, 1.0_dbl ) - - DO i3 = bds_s ( 1, 3 ), bds_s ( 2, 3 ) - temp3a = ez1 ( i3 ) * charge1 - temp3b = ez2 ( i3 ) * charge2 - - DO i2 = bds_s ( 1, 2 ), bds_s ( 2, 2 ) - temp2a = temp3a * ey1 ( i2 ) - temp2b = temp3b * ey2 ( i2 ) - - DO i1 = bds_s ( 1, 1 ), bds_s ( 2, 1 ) - temp1a = temp2a * ex1 ( i1 ) - temp1b = temp2b * ex2 ( i1 ) - - rhos ( i1, i2, i3 ) = ( temp1a + ci * temp1b ) * rho ( i1, i2, i3 ) - END DO - END DO - END DO - -! compute rho_s(r) for the current atoms - CALL fft3d ( BWFFT, npts_s, rhos ) - -END SUBROUTINE dg_get_2x_patch - -!****************************************************************************** - -SUBROUTINE dg_sum_patch ( rhos, rhob, bounds_s, centre, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( 2, 3 ), INTENT ( IN ) :: bounds_s - REAL ( dbl ), DIMENSION ( bounds_s(1,1):bounds_s(2,1), & - bounds_s(1,2):bounds_s(2,2), bounds_s(1,3):bounds_s(2,3) ), & - INTENT ( IN ) :: rhos - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: centre - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_pbc, lb_rhob - INTEGER, DIMENSION ( lb_pbc ( 1 ) : ), INTENT ( IN ) :: pbc1_b - INTEGER, DIMENSION ( lb_pbc ( 2 ) : ), INTENT ( IN ) :: pbc2_b - INTEGER, DIMENSION ( lb_pbc ( 3 ) : ), INTENT ( IN ) :: pbc3_b - - REAL ( dbl ), DIMENSION ( lb_rhob(1):, lb_rhob(2):, lb_rhob(3): ), & - INTENT ( INOUT ) :: rhob - -! Locals - INTEGER :: i1, i2, i3, ii1, ii2, ii3 - INTEGER :: lb1, lb2, lb3, ub1, ub2, ub3 - -!------------------------------------------------------------------------------ - - lb1 = pbc1_b ( bounds_s ( 1, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - lb2 = pbc2_b ( bounds_s ( 1, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - lb3 = pbc3_b ( bounds_s ( 1, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - ub1 = pbc1_b ( bounds_s ( 2, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - ub2 = pbc2_b ( bounds_s ( 2, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - ub3 = pbc3_b ( bounds_s ( 2, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - - IF ( lb3 < ub3 .AND. lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, lb2+i2, lb3+i3 ) & - = rhob ( lb1+i1, lb2+i2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, lb2+i2, ii3 ) = rhob ( lb1+i1, lb2+i2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, ii2, lb3+i3 ) = rhob ( lb1+i1, ii2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, lb2+i2, lb3+i3 ) = rhob ( ii1, lb2+i2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, ii2, ii3 ) = rhob ( lb1+i1, ii2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, lb2+i2, ii3 ) = rhob ( ii1, lb2+i2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, ii2, lb3+i3 ) = rhob ( ii1, ii2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, ii2, ii3 ) = rhob ( ii1, ii2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END IF - -END SUBROUTINE dg_sum_patch - -!****************************************************************************** - -SUBROUTINE dg_sum_patch_force ( rhos, rhob, f_xyz, bounds_s, centre, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( 2, 3 ), INTENT ( IN ) :: bounds_s - REAL ( dbl ), DIMENSION ( bounds_s(1,1):bounds_s(2,1), & - bounds_s(1,2):bounds_s(2,2), bounds_s(1,3):bounds_s(2,3) ), & - INTENT ( IN ) :: rhos - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_rhob - REAL ( dbl ), & - DIMENSION ( 1:, lb_rhob ( 1 ) :, lb_rhob ( 2 ) :, lb_rhob ( 3 ) : ), & - INTENT ( IN ) :: rhob - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: centre - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_pbc - INTEGER, DIMENSION ( lb_pbc ( 1 ) : ), INTENT ( IN ) :: pbc1_b - INTEGER, DIMENSION ( lb_pbc ( 2 ) : ), INTENT ( IN ) :: pbc2_b - INTEGER, DIMENSION ( lb_pbc ( 3 ) : ), INTENT ( IN ) :: pbc3_b - - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: f_xyz - -! Locals - INTEGER :: i1, i2, i3, ii1, ii2, ii3, ic - INTEGER :: lb1, lb2, lb3, ub1, ub2, ub3 - -!------------------------------------------------------------------------------ - - f_xyz ( : ) = 0.0_dbl - - lb1 = pbc1_b ( bounds_s ( 1, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - lb2 = pbc2_b ( bounds_s ( 1, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - lb3 = pbc3_b ( bounds_s ( 1, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - ub1 = pbc1_b ( bounds_s ( 2, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - ub2 = pbc2_b ( bounds_s ( 2, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - ub3 = pbc3_b ( bounds_s ( 2, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - - IF ( lb3 < ub3 .AND. lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, lb2+i2, lb3+i3 ) & - * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, lb2+i2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, ii2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, lb2+i2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, ii2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, lb2+i2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, ii2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, ii2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - END IF - -END SUBROUTINE dg_sum_patch_force - -!****************************************************************************** - -SUBROUTINE dg_get_rho_tot ( rho_r, rhob_r ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhob_r - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rho_r - -! Locals - INTEGER :: lp1,mp1,np1,ln1,mn1,nn1 - INTEGER :: lp2,mp2,np2,ln2,mn2,nn2 - INTEGER :: gpt - INTEGER, DIMENSION ( :, : ), POINTER :: bds1, bds2 - INTEGER, DIMENSION ( : ), POINTER :: ghat - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho, rhob - TYPE ( pw_grid_type ), POINTER :: grid1, grid2 - -!------------------------------------------------------------------------------ - - grid1 => rhob_r % pw % pw_grid - grid2 => rho_r % pw % pw_grid - bds1 => grid1 % bounds - bds2 => grid2 % bounds - rhob => rhob_r % pw % cc3d - rho => rho_r % pw % cc3d - - CALL fft_wrap ( rhob_r, dir = FWFFT, scale = grid1 % dvol ) - - rho = 0.0_dbl - - DO gpt = 1, grid1 % ngpts_cut - ghat => grid1 % g_hat ( :, gpt ) - - lp1 = grid1 % mapl % pos ( ghat ( 1 ) ) - ln1 = grid1 % mapl % neg ( ghat ( 1 ) ) - mp1 = grid1 % mapm % pos ( ghat ( 2 ) ) - mn1 = grid1 % mapm % neg ( ghat ( 2 ) ) - np1 = grid1 % mapn % pos ( ghat ( 3 ) ) - nn1 = grid1 % mapn % neg ( ghat ( 3 ) ) - - lp2 = grid2 % mapl % pos ( ghat ( 1 ) ) - ln2 = grid2 % mapl % neg ( ghat ( 1 ) ) - mp2 = grid2 % mapm % pos ( ghat ( 2 ) ) - mn2 = grid2 % mapm % neg ( ghat ( 2 ) ) - np2 = grid2 % mapn % pos ( ghat ( 3 ) ) - nn2 = grid2 % mapn % neg ( ghat ( 3 ) ) - - !*apsi - lp1 = lp1 + bds1 ( 1, 1 ) - mp1 = mp1 + bds1 ( 1, 2 ) - np1 = np1 + bds1 ( 1, 3 ) - ln1 = ln1 + bds1 ( 1, 1 ) - mn1 = mn1 + bds1 ( 1, 2 ) - nn1 = nn1 + bds1 ( 1, 3 ) - !*apsi - lp2 = lp2 + bds1 ( 1, 1 ) - mp2 = mp2 + bds1 ( 1, 2 ) - np2 = np2 + bds1 ( 1, 3 ) - ln2 = ln2 + bds1 ( 1, 1 ) - mn2 = mn2 + bds1 ( 1, 2 ) - nn2 = nn2 + bds1 ( 1, 3 ) - - rho ( lp2, mp2, np2 ) = rho ( lp2, mp2, np2 ) + rhob ( lp1, mp1, np1 ) - rho ( ln2, mn2, nn2 ) = rho ( ln2, mn2, nn2 ) + rhob ( ln1, mn1, nn1 ) - - END DO - - CALL fft_wrap ( rho_r, dir = BWFFT ) - -END SUBROUTINE dg_get_rho_tot - -!****************************************************************************** - -END MODULE dgs diff --git a/src/dump.c b/src/dump.c deleted file mode 100644 index 014dd5e..0000000 --- a/src/dump.c +++ /dev/null @@ -1,62 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE dump - - USE kinds, ONLY : dbl - USE global_types, ONLY : global_environment_type - USE stop_program, ONLY : stop_prg - USE structure_types, ONLY : structure_type - USE util, ONLY : get_unit - - PRIVATE - PUBLIC :: dump_variables - -CONTAINS - -!****************************************************************************** - -SUBROUTINE dump_variables ( struc, dump_file_name, globenv ) - -! routine to dump all simulation variables periodically and at the last step. - - IMPLICIT NONE - -! Arguments - TYPE ( structure_type ), INTENT ( IN ) :: struc - CHARACTER ( LEN = * ), INTENT ( IN ) :: dump_file_name - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - INTEGER :: i, natoms, dmp - -!------------------------------------------------------------------------------ - - IF ( globenv % ionode ) THEN - dmp = get_unit() - OPEN ( UNIT = dmp, FILE = dump_file_name, STATUS = 'unknown', & - POSITION = 'rewind' ) - END IF - - IF (globenv % ionode) THEN - natoms = size(struc % part) - WRITE (dmp,*) natoms - DO i = 1, natoms - WRITE (dmp,*) struc % part(i) %r - END DO - DO i = 1, 3 - WRITE (dmp,*) struc % box % hmat(i,:) - END DO - DO i = 1, natoms - WRITE (dmp,*) struc % part(i) % v - END DO - CLOSE (dmp) - END IF - -END SUBROUTINE dump_variables - -!****************************************************************************** - -END MODULE dump diff --git a/src/eigenvalueproblems.c b/src/eigenvalueproblems.c deleted file mode 100644 index 26bb03c..0000000 --- a/src/eigenvalueproblems.c +++ /dev/null @@ -1,303 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -!! We are using LAPACK interfaces, so please make sure in IBM/AIX you have -!! the lapack library before essl: "xlf90 ... -llapack -lessl" !!! - -MODULE eigenvalueproblems - - USE kinds, ONLY : dbl - USE lapack, ONLY : lapack_ssyev, lapack_chpev, lapack_chpgv - USE stop_program, ONLY : stop_prg - - IMPLICIT NONE - - PRIVATE - PUBLIC :: diagonalise, diagonalise_overlap - - INTERFACE diagonalise - MODULE PROCEDURE diagonalise_ssyev - MODULE PROCEDURE diagonalise_dsyev - MODULE PROCEDURE diagonalise_chpev - MODULE PROCEDURE diagonalise_zhpev - END INTERFACE - - INTERFACE diagonalise_overlap - MODULE PROCEDURE diagonalise_chpgv - MODULE PROCEDURE diagonalise_zhpgv - END INTERFACE - -CONTAINS - -!****************************************************************************** - -SUBROUTINE diagonalise_ssyev ( matrix, mysize, storageform, eigenvalues, & - eigenvectors ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: mysize - REAL ( KIND = 4 ), INTENT ( IN ) :: matrix ( :, : ) - REAL ( KIND = 4 ), INTENT ( OUT ) :: eigenvalues ( : ) - REAL ( KIND = 4 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - -! Local - CHARACTER :: jobz = "V", uplo - INTEGER :: info, itype - - INTEGER :: lwork, lda - REAL ( KIND = 4 ) :: work ( 3 * mysize - 1 ) - -!------------------------------------------------------------------------------ - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - CALL stop_prg ( "diagonalise_ssyev", "unknown form of storage" ) - END IF - - lda = SIZE ( matrix, 1 ) - lwork = 3 * mysize - 1 - -!*apsi* Because 'ssyev' is in-place... - eigenvectors = matrix - - CALL lapack_ssyev ( jobz, uplo, mysize, eigenvectors, lda, eigenvalues, & - work, lwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_ssyev", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_ssyev - -!****************************************************************************** - -SUBROUTINE diagonalise_dsyev ( matrix, mysize, storageform, eigenvalues, & - eigenvectors ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: mysize - REAL ( KIND = 8 ), INTENT ( IN ) :: matrix ( :, : ) - REAL ( KIND = 8 ), INTENT ( OUT ) :: eigenvalues ( : ) - REAL ( KIND = 8 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - -! Local - CHARACTER :: jobz = "V", uplo - INTEGER :: info, itype - - INTEGER :: lwork, lda - REAL ( KIND = 8 ) :: work ( 3 * mysize - 1 ) - -!------------------------------------------------------------------------------ - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - CALL stop_prg ( "diagonalise_dsyev", "unknown form of storage" ) - END IF - - lda = SIZE ( matrix, 1 ) - lwork = 3 * mysize - 1 - -!*apsi* Because 'dsyev' is in-place... - eigenvectors = matrix - - CALL lapack_ssyev ( jobz, uplo, mysize, eigenvectors, lda, eigenvalues, & - work, lwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_dsyev", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_dsyev - -!****************************************************************************** - -SUBROUTINE diagonalise_chpev ( matrix, mysize, storageform, eigenvalues, & - eigenvectors ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: mysize - REAL ( KIND = 4 ), INTENT ( OUT ) :: eigenvalues ( : ) - COMPLEX ( KIND = 4 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - COMPLEX ( KIND = 4 ), INTENT ( INOUT ) :: matrix ( : ) - -! Local - CHARACTER :: jobz = "V", uplo - INTEGER :: info, itype - - REAL ( KIND = 4 ) :: rwork ( 3 * mysize - 2 ) - COMPLEX ( KIND = 4 ) :: work ( 2 * mysize - 1 ) - -!------------------------------------------------------------------------------ - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - CALL stop_prg ( "diagonalise_chpev", "unknown form of storage" ) - END IF - - CALL lapack_chpev ( jobz, uplo, mysize, matrix, eigenvalues, & - eigenvectors, mysize, work, rwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_chpev", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_chpev - -!****************************************************************************** - -SUBROUTINE diagonalise_zhpev ( matrix, mysize, storageform, eigenvalues, & - eigenvectors ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: mysize - REAL ( KIND = 8 ), INTENT ( OUT ) :: eigenvalues ( : ) - COMPLEX ( KIND = 8 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - COMPLEX ( KIND = 8 ), INTENT ( INOUT ) :: matrix ( : ) - -! Local - CHARACTER :: jobz = "V", uplo - INTEGER :: info, itype - - REAL ( KIND = 8 ) :: rwork ( 3 * mysize - 2 ) - COMPLEX ( KIND = 8 ) :: work ( 2 * mysize - 1 ) - -!------------------------------------------------------------------------------ - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - CALL stop_prg ( "diagonalise_chpev", "unknown form of storage" ) - END IF - - CALL lapack_chpev ( jobz, uplo, mysize, matrix, eigenvalues, & - eigenvectors, mysize, work, rwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_zhpev", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_zhpev - -!********************************************************************** - -SUBROUTINE diagonalise_chpgv ( matrix, overlap, mysize, type, storageform, & - eigenvalues, eigenvectors ) - - implicit none - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: type, mysize - REAL ( KIND = 4 ), INTENT ( OUT ) :: eigenvalues ( : ) - COMPLEX ( KIND = 4 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - COMPLEX ( KIND = 4 ), INTENT ( INOUT ) :: matrix ( : ), overlap ( : ) - -! Local - CHARACTER :: jobz = "V", uplo - integer :: info - real ( kind = 4 ) :: rwork ( 3 * mysize - 2 ) - COMPLEX ( kind = 4 ) :: work ( 2 * mysize - 1 ) - -!---------------------------------------------------------------------- - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - stop "diagonalise_chpev, unknown form of storage" - END IF - - CALL lapack_chpgv ( type, jobz, uplo, mysize, matrix, overlap, eigenvalues, & - eigenvectors, mysize, work, rwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_chpgv", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_chpgv - -!****************************************************************************** - -SUBROUTINE diagonalise_zhpgv ( matrix, overlap, mysize, type, storageform, & - eigenvalues, eigenvectors ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform - INTEGER, INTENT ( IN ) :: type, mysize - REAL ( KIND = 8 ), INTENT ( OUT ) :: eigenvalues ( : ) - COMPLEX ( KIND = 8 ), INTENT ( OUT ) :: eigenvectors ( :, : ) - COMPLEX ( KIND = 8 ), INTENT ( INOUT ) :: matrix ( : ) - COMPLEX ( KIND = 8 ), INTENT ( INOUT ) :: overlap ( : ) - -! Local - CHARACTER :: jobz = "V", uplo - INTEGER :: info - REAL ( KIND = 8 ) :: rwork ( 3 * mysize - 2 ) - COMPLEX ( KIND = 8 ) :: work ( 2 * mysize - 1 ) - -!------------------------------------------------------------------------------ - - IF ( storageform ( 1:5 ) == "Lower" .OR. & - storageform ( 1:5 ) == "LOWER" .OR. & - storageform ( 1:5 ) == "lower" ) THEN - uplo = "L" - ELSE IF ( storageform ( 1:5 ) == "Upper" .OR. & - storageform ( 1:5 ) == "upper" .OR. & - storageform ( 1:5 ) == "UPPER" ) then - uplo = "U" - ELSE - stop "diagonalise_chpev, unknown form of storage" - END IF - - CALL lapack_chpgv ( type, jobz, uplo, mysize, matrix, overlap, eigenvalues, & - eigenvectors, mysize, work, rwork, info ) - IF ( info /= 0 ) THEN - CALL stop_prg ( "diagonalise_zhpgv", "error in diagonalisation" ) - END IF - -END SUBROUTINE diagonalise_zhpgv - -END MODULE eigenvalueproblems diff --git a/src/environment.cpp b/src/environment.cpp deleted file mode 100644 index dce720e..0000000 --- a/src/environment.cpp +++ /dev/null @@ -1,120 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include "global_types.h" - -#ifdef __cplusplus -#include -#include -using namespace CP2K_NS; -#endif - -void initialisation(global_environment_type *globenv) { - - std::string datx; - int iw, l, initial_random; - - //----------------------------------------------------------------------------- - - globenv->scr = 6; - - set_stop(globenv.scr); - - if (globenv->ionode) { - iw = globenv.scr; - - set_environment(globenv); - - datum(datx); - - std::cout << std::left << std::setw(54) << " **** **** ****** ** PROGRAM STARTED AT "; - std::cout << std::right << std::setw(26) << datx << std::endl; - - std::cout << std::left << std::setw(48) << " ***** ** *** *** ** PROGRAM STARTED ON "; - std::cout << std::right << std::setw(32) << hname << std::endl; - - std::cout << std::left << std::setw(70) << " ** **** ****** PROGRAM STARTED BY "; - std::cout << std::right << std::setw(10) << user << std::endl; - - std::cout << std::left << std::setw(70) << " ***** ** ** ** ** PROGRAM PROCESS ID "; - std::cout << std::right << std::setw(10) << my_pid << std::endl; - - std::cout << std::left << std::setw(42) << " **** ** ******* ** PROGRAM STARTED IN "; - std::cout << std::right << std::setw(38) << curdir << "\n" << std::endl; - - } - - // initialize timing - timeset("CP2K", "I", " ", handle); - - // initialize random number generator - globenv.idum = -1; - initial_random = ran2(globenv.idum); - - init_physcon(); -} - -void trailer(global_environment_type *globenv) { - - std::string datx; - int iw, l; - - timestop(zero, handle); - - if (globenv.ionode) { - iw = globenv.scr; - - timeprint(iw, globenv.print_level); - - std::cout << "\n" << std::endl; - - datum(datx); - - std::cout << std::left << std::setw(54) << " **** **** ****** ** PROGRAM ENDED AT "; - std::cout << std::right << std::setw(26) << datx << std::endl; - - std::cout << std::left << std::setw(48) << " ***** ** *** *** ** PROGRAM RAN ON "; - std::cout << std::right << std::setw(32) << hname << std::endl; - - std::cout << std::left << std::setw(70) << " ** **** ****** PROGRAM RAN BY "; - std::cout << std::right << std::setw(10) << user << std::endl; - - std::cout << std::left << std::setw(70) << " ***** ** ** ** ** PROGRAM PROCESS ID "; - std::cout << std::right << std::setw(10) << my_pid << std::endl; - - std::cout << std::left << std::setw(70) << " **** ** ******* ** PROGRAM RAN IN "; - std::cout << std::right << std::setw(10) << curdir << std::endl; - } - -} - -/*****************************************************************************/ - -void set_environment(global_environment_type *globenv) { - - // Locals - int narg, iargc; - - //----------------------------------------------------------------------------- - - m_hostnm(hname); - m_getcwd(curdir); - m_getlog(user); - m_getuid(my_uid); - m_getpid(my_pid); - - narg = iargc(); - - switch (narg) { - case 0: - globenv.input_file_name = "input"; - break; - case 1: - m_getarg(1, globenv.input_file_name); - break; - default: - stop_prg("set_environment", "illegal number of command line arguments passed") - } -} \ No newline at end of file diff --git a/src/erf.c b/src/erf.c deleted file mode 100644 index 2350fcc..0000000 --- a/src/erf.c +++ /dev/null @@ -1,319 +0,0 @@ - -SUBROUTINE CALERF(ARG,RESULT,JINT) -!------------------------------------------------------------------ -! -! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) -! for a real argument x. It contains three FUNCTION type -! subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX), -! and one SUBROUTINE type subprogram, CALERF. The calling -! statements for the primary entries are: -! -! Y=ERF(X) (or Y=DERF(X)), -! -! Y=ERFC(X) (or Y=DERFC(X)), -! and -! Y=ERFCX(X) (or Y=DERFCX(X)). -! -! The routine CALERF is intended for internal packet use only, -! all computations within the packet being concentrated in this -! routine. The function subprograms invoke CALERF with the -! statement -! -! CALL CALERF(ARG,RESULT,JINT) -! -! where the parameter usage is as follows -! -! Function Parameters for CALERF -! call ARG Result JINT -! -! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 -! ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 -! ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 -! -! The main computation evaluates near-minimax approximations -! from "Rational Chebyshev approximations for the error function" -! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This -! transportable program uses rational functions that theoretically -! approximate erf(x) and erfc(x) to at least 18 significant -! decimal digits. The accuracy achieved depends on the arithmetic -! system, the compiler, the intrinsic functions, and proper -! selection of the machine-dependent constants. -! -!******************************************************************* -!******************************************************************* -! -! Explanation of machine-dependent constants -! -! XMIN = the smallest positive floating-point number. -! XINF = the largest positive finite floating-point number. -! XNEG = the largest negative argument acceptable to ERFCX; -! the negative of the solution to the equation -! 2*exp(x*x) = XINF. -! XSMALL = argument below which erf(x) may be represented by -! 2*x/sqrt(pi) and above which x*x will not underflow. -! A conservative value is the largest machine number X -! such that 1.0 + X = 1.0 to machine precision. -! XBIG = largest argument acceptable to ERFC; solution to -! the equation: W(x) * (1-0.5/x**2) = XMIN, where -! W(x) = exp(-x*x)/[x*sqrt(pi)]. -! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to -! machine precision. A conservative value is -! 1/[2*sqrt(XSMALL)] -! XMAX = largest acceptable argument to ERFCX; the minimum -! of XINF and 1/[sqrt(pi)*XMIN]. -! -! Approximate values for some important machines are: -! -! XMIN XINF XNEG XSMALL -! -! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 -! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 -! IEEE (IBM/XT, -! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 -! IEEE (IBM/XT, -! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 -! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 -! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 -! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 -! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 -! -! -! XBIG XHUGE XMAX -! -! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 -! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 -! IEEE (IBM/XT, -! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 -! IEEE (IBM/XT, -! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 -! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 -! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 -! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 -! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 -! -!******************************************************************* -!******************************************************************* -! -! Error returns -! -! The program returns ERFC = 0 for ARG .GE. XBIG; -! -! ERFCX = XINF for ARG .LT. XNEG; -! and -! ERFCX = 0 for ARG .GE. XMAX. -! -! -! Intrinsic functions required are: -! -! ABS, AINT, EXP -! -! -! Author: W. J. Cody -! Mathematics and Computer Science Division -! Argonne National Laboratory -! Argonne, IL 60439 -! -! Latest modification: March 19, 1990 -! -!------------------------------------------------------------------ - USE KINDS, ONLY : dbl - IMLICIT NONE - INTEGER I,JINT - REAL(dbl), DIMENSION(5) :: A - REAL(dbl), DIMENSION(4) :: B - REAL(dbl), DIMENSION(9) :: C - REAL(dbl), DIMENSION(8) :: D - REAL(dbl), DIMENSION(6) :: P - REAL(dbl), DIMENSION(5) :: Q - REAL(dbl) :: ARG,DEL,FOUR,HALF,ONE,RESULT,SIXTEN,SQRPI, & - TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, & - Y,YSQ,ZERO -!------------------------------------------------------------------ -! Mathematical constants -!------------------------------------------------------------------ - REAL(dbl), PARAMETER :: FOUR=4._dbl - REAL(dbl), PARAMETER :: ONE=4._dbl - REAL(dbl), PARAMETER :: HALF=4._dbl - REAL(dbl), PARAMETER :: TWO=4._dbl - REAL(dbl), PARAMETER :: ZERO=4._dbl - REAL(dbl), PARAMETER :: SQRPI=5.6418958354775628695E-1_dbl - REAL(dbl), PARAMETER :: THRESH=0.46875_dbl - REAL(dbl), PARAMETER :: SIXTEN=16._dbl -!------------------------------------------------------------------ -! Machine-dependent constants -!------------------------------------------------------------------ - REAL(dbl), PARAMETER :: XINF=1.79E308_dbl - REAL(dbl), PARAMETER :: XNEG=-26.628_dbl - REAL(dbl), PARAMETER :: XSMALL=1.11E-16_dbl - REAL(dbl), PARAMETER :: XBIG=25.543_dbl - REAL(dbl), PARAMETER :: XHUGE=6.71E7_dbl - REAL(dbl), PARAMETER :: XMAX=2.53E307_dbl -!------------------------------------------------------------------ -! Coefficients for approximation to erf in first interval -!------------------------------------------------------------------ - DATA A/3.16112374387056560D00,1.13864154151050156D02, - 1 3.77485237685302021D02,3.20937758913846947D03, - 2 1.85777706184603153D-1/ - DATA B/2.36012909523441209D01,2.44024637934444173D02, - 1 1.28261652607737228D03,2.84423683343917062D03/ -!------------------------------------------------------------------ -! Coefficients for approximation to erfc in second interval -!------------------------------------------------------------------ - DATA C/5.64188496988670089D-1,8.88314979438837594D0, - 1 6.61191906371416295D01,2.98635138197400131D02, - 2 8.81952221241769090D02,1.71204761263407058D03, - 3 2.05107837782607147D03,1.23033935479799725D03, - 4 2.15311535474403846D-8/ - DATA D/1.57449261107098347D01,1.17693950891312499D02, - 1 5.37181101862009858D02,1.62138957456669019D03, - 2 3.29079923573345963D03,4.36261909014324716D03, - 3 3.43936767414372164D03,1.23033935480374942D03/ -!------------------------------------------------------------------ -! Coefficients for approximation to erfc in third interval -!------------------------------------------------------------------ - DATA P/3.05326634961232344D-1,3.60344899949804439D-1, - 1 1.25781726111229246D-1,1.60837851487422766D-2, - 2 6.58749161529837803D-4,1.63153871373020978D-2/ - DATA Q/2.56852019228982242D00,1.87295284992346047D00, - 1 5.27905102951428412D-1,6.05183413124413191D-2, - 2 2.33520497626869185D-3/ -!------------------------------------------------------------------ - X = ARG - Y = ABS(X) - IF (Y <= THRESH) THEN -!------------------------------------------------------------------ -! Evaluate erf for |X| <= 0.46875 -!------------------------------------------------------------------ - YSQ = ZERO - IF (Y > XSMALL) YSQ = Y * Y - XNUM = A(5)*YSQ - XDEN = YSQ - DO I = 1, 3 - XNUM = (XNUM + A(I)) * YSQ - XDEN = (XDEN + B(I)) * YSQ - END DO - RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) - IF (JINT .NE. 0) RESULT = ONE - RESULT - IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT - GO TO 800 -!------------------------------------------------------------------ -! Evaluate erfc for 0.46875 <= |X| <= 4.0 -!------------------------------------------------------------------ - ELSE IF (Y <= FOUR) THEN - XNUM = C(9)*Y - XDEN = Y - DO I = 1, 7 - XNUM = (XNUM + C(I)) * Y - XDEN = (XDEN + D(I)) * Y - END DO - RESULT = (XNUM + C(8)) / (XDEN + D(8)) - IF (JINT /= 2) THEN - YSQ = AINT(Y*SIXTEN)/SIXTEN - DEL = (Y-YSQ)*(Y+YSQ) - RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT - END IF -!------------------------------------------------------------------ -! Evaluate erfc for |X| > 4.0 -!------------------------------------------------------------------ - ELSE - RESULT = ZERO - IF (Y >= XBIG) THEN - IF ((JINT /= 2) .OR. (Y >= XMAX)) GO TO 300 - IF (Y >= XHUGE) THEN - RESULT = SQRPI / Y - GO TO 300 - END IF - END IF - YSQ = ONE / (Y * Y) - XNUM = P(6)*YSQ - XDEN = YSQ - DO I = 1, 4 - XNUM = (XNUM + P(I)) * YSQ - XDEN = (XDEN + Q(I)) * YSQ - END DO - RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) - RESULT = (SQRPI - RESULT) / Y - IF (JINT /= 2) THEN - YSQ = AINT(Y*SIXTEN)/SIXTEN - DEL = (Y-YSQ)*(Y+YSQ) - RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT - END IF - END IF -!------------------------------------------------------------------ -! Fix up for negative argument, erf, etc. -!------------------------------------------------------------------ - 300 IF (JINT == 0) THEN - RESULT = (HALF - RESULT) + HALF - IF (X < ZERO) RESULT = -RESULT - ELSE IF (JINT .EQ. 1) THEN - IF (X < ZERO) RESULT = TWO - RESULT - ELSE - IF (X < ZERO) THEN - IF (X < XNEG) THEN - RESULT = XINF - ELSE - YSQ = AINT(X*SIXTEN)/SIXTEN - DEL = (X-YSQ)*(X+YSQ) - Y = EXP(YSQ*YSQ) * EXP(DEL) - RESULT = (Y+Y) - RESULT - END IF - END IF - END IF - 800 RETURN -!---------- Last card of CALERF ---------- - END - - FUNCTION ERF(X) -!-------------------------------------------------------------------- -! -! This subprogram computes approximate values for erf(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, January 8, 1985 -! -!-------------------------------------------------------------------- - INTEGER JINT - REAL(dbl) :: ERF, X, RESULT -!------------------------------------------------------------------ - JINT = 0 - CALL CALERF(X,RESULT,JINT) - ERF = RESULT -!---------- Last card of ERF ---------- - END FUNCTION ERF - - FUNCTION ERFC(X) -!-------------------------------------------------------------------- -! -! This subprogram computes approximate values for erfc(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, January 8, 1985 -! -!-------------------------------------------------------------------- - INTEGER JINT - REAL(dbl) :: ERFC, X, RESULT -!------------------------------------------------------------------ - JINT = 1 - CALL CALERF(X,RESULT,JINT) - ERFC = RESULT -C---------- Last card of DERFC ---------- - END FUNCTION ERFC - - FUNCTION ERFCX(X) -!------------------------------------------------------------------ -! -! This subprogram computes approximate values for exp(x*x) * erfc(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, March 30, 1987 -! -!------------------------------------------------------------------ - INTEGER JINT - REAL(dbl) :: ERFCX, X, RESULT -!------------------------------------------------------------------ - JINT = 2 - CALL CALERF(X,RESULT,JINT) - DERFCX = RESULT -!---------- Last card of DERFCX ---------- - END FUNCTION ERFCX - diff --git a/src/erf_fn.c b/src/erf_fn.c deleted file mode 100644 index bb70632..0000000 --- a/src/erf_fn.c +++ /dev/null @@ -1,348 +0,0 @@ - -SUBROUTINE CALERF(ARG,RESULT,JINT) - -!------------------------------------------------------------------ -! -! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) -! for a real argument x. It contains three FUNCTION type -! subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX), -! and one SUBROUTINE type subprogram, CALERF. The calling -! statements for the primary entries are: -! -! Y=ERF(X) (or Y=DERF(X)), -! -! Y=ERFC(X) (or Y=DERFC(X)), -! and -! Y=ERFCX(X) (or Y=DERFCX(X)). -! -! The routine CALERF is intended for internal packet use only, -! all computations within the packet being concentrated in this -! routine. The function subprograms invoke CALERF with the -! statement -! -! CALL CALERF(ARG,RESULT,JINT) -! -! where the parameter usage is as follows -! -! Function Parameters for CALERF -! call ARG Result JINT -! -! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 -! ERFC(ARG) ABS(ARG) < XBIG ERFC(ARG) 1 -! ERFCX(ARG) XNEG < ARG < XMAX ERFCX(ARG) 2 -! -! The main computation evaluates near-minimax approximations -! from "Rational Chebyshev approximations for the error function" -! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This -! transportable program uses rational functions that theoretically -! approximate erf(x) and erfc(x) to at least 18 significant -! decimal digits. The accuracy achieved depends on the arithmetic -! system, the compiler, the intrinsic functions, and proper -! selection of the machine-dependent constants. -! -!******************************************************************* -!******************************************************************* -! -! Explanation of machine-dependent constants -! -! XMIN = the smallest positive floating-point number. -! XINF = the largest positive finite floating-point number. -! XNEG = the largest negative argument acceptable to ERFCX; -! the negative of the solution to the equation -! 2*exp(x*x) = XINF. -! XSMALL = argument below which erf(x) may be represented by -! 2*x/sqrt(pi) and above which x*x will not underflow. -! A conservative value is the largest machine number X -! such that 1.0 + X = 1.0 to machine precision. -! XBIG = largest argument acceptable to ERFC; solution to -! the equation: W(x) * (1-0.5/x**2) = XMIN, where -! W(x) = exp(-x*x)/[x*sqrt(pi)]. -! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to -! machine precision. A conservative value is -! 1/[2*sqrt(XSMALL)] -! XMAX = largest acceptable argument to ERFCX; the minimum -! of XINF and 1/[sqrt(pi)*XMIN]. -! -! Approximate values for some important machines are: -! -! XMIN XINF XNEG XSMALL -! -! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 -! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 -! IEEE (IBM/XT, -! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 -! IEEE (IBM/XT, -! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 -! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 -! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 -! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 -! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 -! -! -! XBIG XHUGE XMAX -! -! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 -! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 -! IEEE (IBM/XT, -! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 -! IEEE (IBM/XT, -! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 -! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 -! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 -! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 -! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 -! -!******************************************************************* -!******************************************************************* -! -! Error returns -! -! The program returns ERFC = 0 for ARG >= XBIG; -! -! ERFCX = XINF for ARG < XNEG; -! and -! ERFCX = 0 for ARG >= XMAX. -! -! -! Intrinsic functions required are: -! -! ABS, AINT, EXP -! -! -! Author: W. J. Cody -! Mathematics and Computer Science Division -! Argonne National Laboratory -! Argonne, IL 60439 -! -! Latest modification: March 19, 1990 -! -!------------------------------------------------------------------ - - USE KINDS, ONLY : dbl - IMPLICIT NONE - INTEGER I,JINT - REAL ( dbl ) :: & - A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI, & - TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, & - Y,YSQ,ZERO - DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5) -!------------------------------------------------------------------ -! Mathematical constants -!------------------------------------------------------------------ -!S DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/, -!S 1 SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/, -!S 2 SIXTEN/16.0E0/ - DATA FOUR,ONE,HALF,TWO,ZERO/4.0_dbl,1.0_dbl,0.5_dbl,2.0_dbl,0.0_dbl/, & - SQRPI/5.6418958354775628695E-1_dbl/,THRESH/0.46875_dbl/, & - SIXTEN/16.0_dbl/ -!------------------------------------------------------------------ -! Machine-dependent constants -!------------------------------------------------------------------ -!S DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/, -!S 1 XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/ - DATA XINF,XNEG,XSMALL/1.79E+308_dbl,-26.628_dbl,1.11E-16_dbl/, & - XBIG,XHUGE,XMAX/26.543_dbl,6.71E+7_dbl,2.53E+307_dbl/ -!------------------------------------------------------------------ -! Coefficients for approximation to erf in first interval -!------------------------------------------------------------------ -!S DATA A/3.16112374387056560E00,1.13864154151050156E02, -!S 1 3.77485237685302021E02,3.20937758913846947E03, -!S 2 1.85777706184603153E-1/ -!S DATA B/2.36012909523441209E01,2.44024637934444173E02, -!S 1 1.28261652607737228E03,2.84423683343917062E03/ - DATA A/3.16112374387056560E+00_dbl,1.13864154151050156E+02_dbl, & - 3.77485237685302021E+02_dbl,3.20937758913846947E+03_dbl, & - 1.85777706184603153E-1_dbl/ - DATA B/2.36012909523441209E+01_dbl,2.44024637934444173E+02_dbl, & - 1.28261652607737228E+03_dbl,2.84423683343917062E+03_dbl/ -!------------------------------------------------------------------ -! Coefficients for approximation to erfc in second interval -!------------------------------------------------------------------ -!S DATA C/5.64188496988670089E-1,8.88314979438837594E0, -!S 1 6.61191906371416295E01,2.98635138197400131E02, -!S 2 8.81952221241769090E02,1.71204761263407058E03, -!S 3 2.05107837782607147E03,1.23033935479799725E03, -!S 4 2.15311535474403846E-8/ -!S DATA D/1.57449261107098347E01,1.17693950891312499E02, -!S 1 5.37181101862009858E02,1.62138957456669019E03, -!S 2 3.29079923573345963E03,4.36261909014324716E03, -!S 3 3.43936767414372164E03,1.23033935480374942E03/ - DATA C/5.64188496988670089E-1_dbl,8.88314979438837594E+0_dbl, & - 6.61191906371416295E+01_dbl,2.98635138197400131E+02_dbl, & - 8.81952221241769090E+02_dbl,1.71204761263407058E+03_dbl, & - 2.05107837782607147E+03_dbl,1.23033935479799725E+03_dbl, & - 2.15311535474403846E-8_dbl/ - DATA D/1.57449261107098347E+01_dbl,1.17693950891312499E+02_dbl, & - 5.37181101862009858E+02_dbl,1.62138957456669019E+03_dbl, & - 3.29079923573345963E+03_dbl,4.36261909014324716E+03_dbl, & - 3.43936767414372164E+03_dbl,1.23033935480374942E+03_dbl/ -!------------------------------------------------------------------ -! Coefficients for approximation to erfc in third interval -!------------------------------------------------------------------ -!S DATA P/3.05326634961232344E-1,3.60344899949804439E-1, -!S 1 1.25781726111229246E-1,1.60837851487422766E-2, -!S 2 6.58749161529837803E-4,1.63153871373020978E-2/ -!S DATA Q/2.56852019228982242E00,1.87295284992346047E00, -!S 1 5.27905102951428412E-1,6.05183413124413191E-2, -!S 2 2.33520497626869185E-3/ - DATA P /3.05326634961232344E-1_dbl,3.60344899949804439E-1_dbl, & - 1.25781726111229246E-1_dbl,1.60837851487422766E-2_dbl, & - 6.58749161529837803E-4_dbl,1.63153871373020978E-2_dbl/ - DATA Q /2.56852019228982242E+00_dbl,1.87295284992346047E+00_dbl, & - 5.27905102951428412E-1_dbl,6.05183413124413191E-2_dbl, & - 2.33520497626869185E-3_dbl/ - -!------------------------------------------------------------------ - - X = ARG - Y = ABS(X) - IF (Y <= THRESH) THEN -!------------------------------------------------------------------ -! Evaluate erf for |X| <= 0.46875 -!------------------------------------------------------------------ - YSQ = ZERO - IF (Y > XSMALL) YSQ = Y * Y - XNUM = A(5)*YSQ - XDEN = YSQ - DO I = 1, 3 - XNUM = (XNUM + A(I)) * YSQ - XDEN = (XDEN + B(I)) * YSQ - END DO - RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) - IF (JINT /= 0) RESULT = ONE - RESULT - IF (JINT == 2) RESULT = EXP(YSQ) * RESULT - GO TO 800 -!------------------------------------------------------------------ -! Evaluate erfc for 0.46875 <= |X| <= 4.0 -!------------------------------------------------------------------ - ELSE IF (Y <= FOUR) THEN - XNUM = C(9)*Y - XDEN = Y - DO I = 1, 7 - XNUM = (XNUM + C(I)) * Y - XDEN = (XDEN + D(I)) * Y - END DO - RESULT = (XNUM + C(8)) / (XDEN + D(8)) - IF (JINT /= 2) THEN - YSQ = AINT(Y*SIXTEN)/SIXTEN - DEL = (Y-YSQ)*(Y+YSQ) - RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT - END IF -!------------------------------------------------------------------ -! Evaluate erfc for |X| > 4.0 -!------------------------------------------------------------------ - ELSE - RESULT = ZERO - IF (Y >= XBIG) THEN - IF ((JINT /= 2) .OR. (Y >= XMAX)) GO TO 300 - IF (Y >= XHUGE) THEN - RESULT = SQRPI / Y - GO TO 300 - END IF - END IF - YSQ = ONE / (Y * Y) - XNUM = P(6)*YSQ - XDEN = YSQ - DO I = 1, 4 - XNUM = (XNUM + P(I)) * YSQ - XDEN = (XDEN + Q(I)) * YSQ - END DO - RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) - RESULT = (SQRPI - RESULT) / Y - IF (JINT /= 2) THEN - YSQ = AINT(Y*SIXTEN)/SIXTEN - DEL = (Y-YSQ)*(Y+YSQ) - RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT - END IF - END IF -!------------------------------------------------------------------ -! Fix up for negative argument, erf, etc. -!------------------------------------------------------------------ -300 IF (JINT == 0) THEN - RESULT = (HALF - RESULT) + HALF - IF (X < ZERO) RESULT = -RESULT - ELSE IF (JINT == 1) THEN - IF (X < ZERO) RESULT = TWO - RESULT - ELSE - IF (X < ZERO) THEN - IF (X < XNEG) THEN - RESULT = XINF - ELSE - YSQ = AINT(X*SIXTEN)/SIXTEN - DEL = (X-YSQ)*(X+YSQ) - Y = EXP(YSQ*YSQ) * EXP(DEL) - RESULT = (Y+Y) - RESULT - END IF - END IF - END IF -800 RETURN -!---------- Last card of CALERF ---------- -END SUBROUTINE CALERF - -FUNCTION ERF(X) -!-------------------------------------------------------------------- -! -! This subprogram computes approximate values for erf(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, January 8, 1985 -! -!-------------------------------------------------------------------- - USE kinds, ONLY : dbl - IMPLICIT NONE - REAL ( dbl ) :: ERF - INTEGER JINT - REAL ( dbl ) :: X, RESULT - -!------------------------------------------------------------------ - - JINT = 0 - CALL CALERF(X,RESULT,JINT) - ERF = RESULT - RETURN -!---------- Last card of DERF ---------- -END - -FUNCTION ERFC(X) -!-------------------------------------------------------------------- -! -! This subprogram computes approximate values for erfc(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, January 8, 1985 -! -!-------------------------------------------------------------------- - USE kinds, ONLY : dbl - IMPLICIT NONE - REAL ( dbl ) :: ERFC - INTEGER JINT - REAL ( dbl ) :: X, RESULT -!------------------------------------------------------------------ - JINT = 1 - CALL CALERF(X,RESULT,JINT) - ERFC = RESULT - RETURN -!---------- Last card of DERFC ---------- -END - -FUNCTION ERFCX(X) -!------------------------------------------------------------------ -! -! This subprogram computes approximate values for exp(x*x) * erfc(x). -! (see comments heading CALERF). -! -! Author/date: W. J. Cody, March 30, 1987 -! -!------------------------------------------------------------------ - USE kinds, ONLY : dbl - IMPLICIT NONE - REAL ( dbl ) :: ERFCX - INTEGER JINT - REAL ( dbl ) :: X, RESULT -!------------------------------------------------------------------ - JINT = 2 - CALL CALERF(X,RESULT,JINT) - ERFCX = RESULT - RETURN -!---------- Last card of DERFCX ---------- -END diff --git a/src/ewald.h b/src/ewald.h deleted file mode 100644 index 323510e..0000000 --- a/src/ewald.h +++ /dev/null @@ -1,23 +0,0 @@ -#ifndef _EWALD_H -#define _EWALD_H - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct ewald_parameters_type { - char ewald_type[13]; - double alpha; - double eps0; - double epsilon; - int gmax; - int ns_max; - int gtot; - int ewald_grp; - } ewald_parameters_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/ewald_parameters_types.c b/src/ewald_parameters_types.c deleted file mode 100644 index 1f0f3b7..0000000 --- a/src/ewald_parameters_types.c +++ /dev/null @@ -1,26 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE ewald_parameters_types - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - TYPE ewald_parameters_type - CHARACTER( LEN = 12 ) :: ewald_type ! type of ewald - REAL ( dbl ) :: alpha ! ewald alpha - REAL ( dbl ) :: eps0 ! permittivity constant - REAL ( dbl ) :: epsilon ! tolerance for small grid (PME) - INTEGER :: gmax ! max Miller index - INTEGER :: ns_max ! # grid points for small grid (PME) - INTEGER :: gtot ! total number of g-vectors - INTEGER :: ewald_grp ! parallel group - END TYPE ewald_parameters_type - - PRIVATE - PUBLIC :: ewald_parameters_type - -END MODULE ewald_parameters_types diff --git a/src/ewalds.c b/src/ewalds.c deleted file mode 100644 index d2be584..0000000 --- a/src/ewalds.c +++ /dev/null @@ -1,330 +0,0 @@ -#include -#include -#include -#include - -#include "coefficients.h" -// #include "complex.h" -#include "dg.h" -#include "ewald.h" -#include "md.h" -#include "molecule.h" -#include "pw.h" -#include "simulation.h" -#include "structure.h" -#include "timings.h" -#include "util.h" - -#if defined ( __PGI ) -#define mp mpp -#endif - -int ewald_grp; - -void ewald_gaussian(dg_type dg, ewald_parameters_type ewald_param, double **fg_coulomb, - double vg_coulomb, double **pv_g, particle_node_type pnode[], cell_type box) { - - // - int node, gpt, nnodes, handle, isos, gptl, gptm, gptn, lp, mp, np; - int *bds; - // - double gdotr, gsq, four_alpha_sq, common, pref, denom, charge, e_igdotr; - double flops, gauss; - - size_t i, j; - double vec[3]; - double ***rho0; - double complex *summe; - coeff_type *dg_rho0; - pw_grid_type *pw_grid; - structure_factor_type exp_igr; - - timeset("EWALD", 'E', "Mflops", handle); - flops = 0.0; - - // pointing - dg_rho0 = dg.dg_rho0->density; - rho0 = dg.dg_rho0->density->pw->cr3d; - pw_grid = dg.dg_rho0->density->pw->pw_grid; - bds = dg.dg_rho0.density.pw.pw_grid.bounds; - - // allocating - nnodes = sizeof(pnode); - - structure_factor_allocate(&pw_grid->bounds, nnodes, exp_igr); - summe = malloc(pw_grid->ngpts_cut*sizeof(double complex)); - - vg_coulomb = 0.0; - for (i = 0; i < node; i++) { - fg_coulomg[0][i] = 0.0; - fg_coulomg[1][i] = 0.0; - fg_coulomg[2][i] = 0.0; - } - - for (i = 0; i < 3; i++) { - for (j = 0; j < 3; j++) { - pv_g[i][j] = 0.0; - } - } - - // define four alpha_sq - four_alpha_sq = 4.0 * ewald_param.alpha * ewald_param.alpha; - - for (node = 0; node < nnodes; node++) { - vec = matvec_3x3(box.h_inv, pnode[node].p->r); - - structure_factor_evaluate(vec, pw_grid->npts, exp_igr.lb, - exp_igr.ex, exp_igr.ey, exp_igr.ez); - } - - // looping over the positive g-vectors - for (gpt = 0; gpt < pw_grid->ngpts_cut; gpt++) { - lp = pw_grid->mapl->pos[pw_grid->g_hat[0][gpt]]; - mp = pw_grid->mapm->pos[pw_grid->g_hat[1][gpt]]; - np = pw_grid->mapn->pos[pw_grid->g_hat[2][gpt]]; - - lp += bds[0][0]; - mp += bds[0][1]; - np += bds[0][2]; - - for (node = 0; node < nnodes; node++) { - charge = pnode[node]->p->prop->charge; - summe[gpt] += charge * - ( exp_igr.ex[lp][node] - * exp_igr.ey[mp][node] - * exp_igr.ez[np][node] ); - } - } - - flops += pw_grid->ngpts_cut * 10.0 + pw_grid->ngpts_cut * nnodes * 20.0; - #if defined (__parallel) - mp_sum(summe, ewald_grp); - #endif - - // looping over the positive g-vectors - for (gpt = 0; gpt < pw_grid -> ngpts_cut; gpt++) { - // compute the potential energy - lp = pw_grid->mapl->pos[pw_grid->g_hat[0][gpt]]; - mp = pw_grid->mapm->pos[pw_grid->g_hat[1][gpt]]; - np = pw_grid->mapn->pos[pw_grid->g_hat[2][gpt]]; - - lp += bds[0][0]; - mp += bds[0][1]; - np += bds[0][2]; - - if (pw_grid->gsq[gpt] < 1.0E-10) break; - - double tmp = rho0[lp][mp][np] * pw_grid->vol; - - gauss = tmp * tmp / pw_grid->gsq[gpt]; - common = gauss * (double)(summe[gpt] * conj(summe[gpt])); - vg_coulomb += common; - - // computing the forces - for (node = 0; node < nnodes; node++) { - e_igdotr = cimag(summe[gpt] * conj - ( exp_igr.ex[lp][node] - * exp_igr.ey[mp][node] - * exp_igr.ez[np][node])); - charge = pnode[node].p->prop->charge * gauss * e_igdotr; - fg_coulomb[0][node] += charge * pw_grid->g[0][gpt]; - fg_coulomb[1][node] += charge * pw_grid->g[1][gpt]; - fg_coulomb[2][node] += charge * pw_grid->g[2][gpt]; - } - - // computing the virial P*V - - denom = 1.0 / four_alpha_sq + 1.0 / pw_grid->gsq[gpt]; - pv_g[0][0] += common * (1.0 - 2.0 * pw_grid->g[0][gpt] * pw_grid->g[0][gpt] * denom); - - pv_g[0][1] -= common * (2.0 * pw_grid->g[0][gpt] * pw_grid->g[1][gpt] * denom); - - pv_g[0][2] -= common * (2.0 * pw_grid->g[0][gpt] * pw_grid->g[2][gpt] * denom); - - pv_g[1][0] -= common * (2.0 * pw_grid->g[1][gpt] * pw_grid->g[0][gpt] * denom); - - pv_g[1][1] += common * (1.0 - 2.0 * pw_grid->g[1][gpt] * pw_grid->g[1][gpt] * denom); - - pv_g[1][2] -= common * (2.0 * pw_grid->g[1][gpt] * pw_grid->g[2][gpt] * denom); - - pv_g[2][0] -= common * (2.0 * pw_grid->g[2][gpt] * pw_grid->g[0][gpt] * denom); - - pv_g[2][1] -= common * (2.0 * pw_grid->g[2][gpt] * pw_grid->g[1][gpt] * denom); - - pv_g[2][2] += common * (1.0 - 2.0 * pw_grid->g[2][gpt] * pw_grid->g[2][gpt] * denom); - } - - flops += pw_grid->ngpts_cut * 55.0 + pw_grid->ngpts_cut * nnodes * 23.0; - - pref = 1.0 / (ewald_param.eps0 * box.deth); - vg_coulomb *= pref; - - for (i = 0; i < 3; i++) { - for (j = 0; j < 3; j++) { - pv_g[i][j] *= pref; - } - } - - pref *= 2.0; - - for (j = 0; j < 3; j++) { - for (i = 0; i < nnodes; i++) { - fg_coulomb[j][i] *= pref; - } - } - - for (size_t i = 0; i < nnodes; i++) { - fg_coulomb[0][i] *= pref; - fg_coulomb[1][i] *= pref; - fg_coulomb[2][i] *= pref; - } - - structure_factor_deallocate(exp_igr); - - free(summe); - - flops *= 1.0E-6; - timestop(flops, handle); - -} - -void ewald_self(ewald_parameters_type ewald_param, thermodynamic_type *thermo, partilce_node_type pnode[], int nnodes) { - - size_t i; - double q_self, q_sum, q; - - q_self = 0.0; - q_sum = 0.0; - - for (i = 0; i < nnodes; i++) { - q = pnode[i].p->prop->charge; - q_self += q * q; - q_sum += q; - } - - #if defined (__parallel) - mp_sum(q_self, ewald_grp); - mp_sum(q_sum, ewald_grp); - #endif - - if (strncmp(ewald_param.ewald_type, "EWALD_GAUSS", 20) || - strncmp(ewald_param.ewald_type, "PME_GAUSS", 20)) { - - thermo->e_self = -q_self * ewald_param.alpha - / (4.0 * ewald_param.eps0 * sqrt(M_PI) * M_PI); - - thermo->e_neut = -q_sum * q_sum / (8.0 * ewald_param.eps0 - * ewald_param.alpha * ewald_param.alpha); - } - -} - -double ewald_correction(ewald_parameters_type ewald_param, double qi, double qj, double rcutsq) { - - double e_cutoff_coul, inv_fourpiesp0; - double tc, arg, e_arg_arg, erfcf, erfc_over_rij; - - double ac1 = 0.254829592; - double ac2 = -0.284496736; - double ac3 = 1.421413741; - double ac4 = -1.453152027; - double ac5 = 1.061405429; - double pc = 0.3275911; - - // compute the value of the real-space coulomb at the cut-off - inv_fourpiesp0 = 1.0 / (4.0 * M_PI * ewald_param.eps0); - arg = ewald_param.alpha * sqrt(rcutsq); - e_arg_arg = exp(-arg * arg); - tc = 1.0 / (1.0 + pc * arg); - erfcf = ((((ac5 * tc + ac4) * tc + ac3) * tc + ac2) * tc + ac1) * tc * e_arg_arg; - erfc_over_rij = erfcf / sqrt(rcutsq); - e_cutoff_coul = inv_fourpiesp0 * qi * qj * erfc_over_rij; - - return e_cutoff_coul; -} - -void ewald_print(FILE *iw, thermodynamic_type thermo, cell_type box, char *e_label) { - fprintf(iw, "( %s, %s )", " *********************************", - "**********************************************"); - fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " INITIAL GSPACE ENERGY", - e_label, "= ", thermo.gspace); - fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " SELF ENERGY CORRECTION", - e_label, "= ", thermo.e_self); - fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " NEUT. BACKGROUND", e_label, - "= ", thermo.e_neut / box.deth); - fprintf(iw, "( %s, %s, %35s, %s, %66s, %15.7E )", " BONDED CORRECTION", e_label, - "= ", thermo.e_bonded); - fprintf(iw, "( %s, %s )", " *********************************", - "**********************************************"); -} - -void ewald_initialize(dg_type *dg, particle_type *part, particle_node_type *pnode, - int pnode_grp, ewald_parameters_type *ewald_param, cell_type *box, - thermodynamic_type *thermo, int iounit, pw_grid_type *ewald_grid, - pw_grid_type *pme_small_grid, pw_grid_type *pme_big_grid) { - - int natoms, iat, jat, gmax, npts_s[3], iw; - double qi, qj, i, cutoff; - - // parallelisation is over atoms (pnodes), so the group of processors - // has to be the same as the group for the pnodes - ewald_grp = pnode_grp; - - // writing output to unit iounit - iw = iounit; - - natoms = sizeof(part) / sizeof(part[0]); - - if (strcmp(ewald_param.ewald_type, "NONE") != 0) { - printf("Ewald summation is done by: %s\n", ewald_param.ewald_type); - printf("Ewald alpha parameter [A]: %f\n", ewald_param.alpha); - - if (strncmp(ewald_param.ewald_type, "EWALD", 5) == 0) { - printf("Ewald G-space max. Miller index: %d\n", ewald_param.gmax); - } else if (strncmp(ewald_param.ewald_type, "PME", 3) == 0) { - printf("PME max small-grid points: %d\n", ewald_param.ns_max); - } - } else { - printf("No Ewald summation is performed\n"); - } - - // fire up the reciprocal space and compute self interaction and - // term from the neutralizing background. - if (strcmp(ewald_param.ewald_type, "NONE") != 0) { - ewald_self(ewald_param, thermo, pnode); - // set up EWALD_GAUSS - if (ewald_grid != NULL) { - gmax = ewald_param.gmax; - if (gmax % 2 == 0) { - stop_prg("initialize_ewalds", "gmax has to be odd"); - } - ewald_grid->bounds[0][:] = -gmax / 2; - ewald_grid->bounds[1][:] = +gmax / 2; - npts_s[0] = gmax; - npts_s[1] = gmax; - npts_s[2] = gmax; - ewald_grid->grid_span = HALFSPACE; - - pw_find_cutoff(npts_s, box, cutoff); - - pw_grid_setup(box, ewald_grid, cutoff); - - pme_setup(pnode, ewald_grid, ewald_param, dg); - } - - // set up PME_GAUSS - if (pme_small_grid != NULL and pme_big_grid != NULL) { - npts_s[:] = ewald_param.ns_max; - pme_small_grid->bounds[0][:] = -npts_s[:]/2; - pme_small_grid->bounds[1][:] = (+npts_s[:] - 1) / 2; - pme_small_grid->grid_span = HALFSPACE; - pme_big_grid->grid_span = HALFSPACE; - - dg_grid_setup(box, npts_s, ewald_param.epsilon, ewald_param.alpha, - pme_small_grid, pme_big_grid, ewald_param.ewald_type); - - pme_setup(pnode, pme_small_grid, ewald_param, dg); - - } - -} diff --git a/src/fft_tools.c b/src/fft_tools.c deleted file mode 100644 index 4758052..0000000 --- a/src/fft_tools.c +++ /dev/null @@ -1,989 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fft_tools - - USE kinds, ONLY: dbl, sgl -!TMPTMPTMP USE timings, ONLY: timeset, timestop - USE stop_program, ONLY : stop_prg - USE util, ONLY: sort - - IMPLICIT NONE - - PRIVATE - PUBLIC :: fft_wrap, FWFFT, BWFFT - PUBLIC :: FFT_RADIX_CLOSEST, FFT_RADIX_NEXT, FFT_RADIX_ALLOWED - PUBLIC :: FFT_RADIX_DISALLOWED - PUBLIC :: fft_radix_operations - - INTEGER, PARAMETER :: FWFFT = +1, BWFFT = -1 - INTEGER, PARAMETER :: FFT_RADIX_CLOSEST = 493, FFT_RADIX_NEXT = 494 - INTEGER, PARAMETER :: FFT_RADIX_ALLOWED = 495, FFT_RADIX_DISALLOWED = 496 - - INTERFACE fft_wrap - MODULE PROCEDURE fft_wrap_dbl, fft_wrap_sgl - END INTERFACE - -#if defined ( __FFTW ) -!*apsi 220500 This is actually the file fftw_f77.i ... -! This file contains PARAMETER statements for various constants -! that can be passed to FFTW routines. You should include -! this file in any FORTRAN program that calls the fftw_f77 -! routines (either directly or with an #include statement -! if you use the C preprocessor). - - integer FFTW_FORWARD,FFTW_BACKWARD - parameter (FFTW_FORWARD=-1,FFTW_BACKWARD=1) - - integer FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL - parameter (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1) - - integer FFTW_ESTIMATE,FFTW_MEASURE - parameter (FFTW_ESTIMATE=0,FFTW_MEASURE=1) - - integer FFTW_OUT_OF_PLACE,FFTW_IN_PLACE,FFTW_USE_WISDOM - parameter (FFTW_OUT_OF_PLACE=0) - parameter (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16) - - integer FFTW_THREADSAFE - parameter (FFTW_THREADSAFE=128) - -! Constants for the MPI wrappers: - integer FFTW_TRANSPOSED_ORDER, FFTW_NORMAL_ORDER - integer FFTW_SCRAMBLED_INPUT, FFTW_SCRAMBLED_OUTPUT - parameter(FFTW_TRANSPOSED_ORDER=1, FFTW_NORMAL_ORDER=0) - parameter(FFTW_SCRAMBLED_INPUT=8192) - parameter(FFTW_SCRAMBLED_OUTPUT=16384) -#endif - -CONTAINS - -!****************************************************************************** - -!! Give the allowed lengths of FFT's ''' - -SUBROUTINE fft_get_lengths ( data, max_length ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: max_length - INTEGER, DIMENSION ( : ), POINTER :: data - -! Locals - INTEGER :: iloc - INTEGER, DIMENSION ( : ), ALLOCATABLE :: idx - INTEGER :: h, i, j, k, m, number, ndata, nmax, allocstat, maxn - INTEGER :: maxn_twos, maxn_threes, maxn_fives - INTEGER :: maxn_sevens, maxn_elevens, maxn_thirteens - -!------------------------------------------------------------------------------ - -! compute ndata -!! FFTW can do arbitrary(?) lenghts, maybe you want to limit them to some -!! powers of small prime numbers though... - -#if defined ( __FFTW ) - maxn_twos = 15 - maxn_threes = 3 - maxn_fives = 2 - maxn_sevens = 1 - maxn_elevens = 1 - maxn_thirteens = 0 - maxn = MIN ( max_length, 37748736 ) - -#elif defined ( __AIX ) - maxn_twos = 15 - maxn_threes = 2 - maxn_fives = 1 - maxn_sevens = 1 - maxn_elevens = 1 - maxn_thirteens = 0 - maxn = MIN ( max_length, 37748736 ) - -#else - CALL stop_prg ( "fft_get_lengths", "no fft basis defined" ) -#endif - - ndata = 0 - DO h = 0, maxn_twos - nmax = HUGE(0) / 2**h - DO i = 0, maxn_threes - DO j = 0, maxn_fives - DO k = 0, maxn_sevens - DO m = 0, maxn_elevens - number = (3**i) * (5**j) * (7**k) * (11**m) - - IF ( number > nmax ) CYCLE - - number = number * 2 ** h - IF ( number >= maxn ) CYCLE - - ndata = ndata + 1 - END DO - END DO - END DO - END DO - END DO - - ALLOCATE ( data ( ndata ), idx ( ndata ), STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_prg ( "fft_get_lengths", "error allocating data, idx" ) - END IF - - ndata = 0 - data ( : ) = 0 - DO h = 0, maxn_twos - nmax = HUGE(0) / 2**h - DO i = 0, maxn_threes - DO j = 0, maxn_fives - DO k = 0, maxn_sevens - DO m = 0, maxn_elevens - number = (3**i) * (5**j) * (7**k) * (11**m) - - IF ( number > nmax ) CYCLE - - number = number * 2 ** h - IF ( number >= maxn ) CYCLE - - ndata = ndata + 1 - data ( ndata ) = number - END DO - END DO - END DO - END DO - END DO - - CALL sort ( data, ndata, idx ) - - DEALLOCATE ( idx, STAT = allocstat ) - IF ( allocstat /= 0 ) THEN - CALL stop_prg ( "fft_get_lengths", "error deallocating idx" ) - END IF - -END SUBROUTINE fft_get_lengths - -!****************************************************************************** - -SUBROUTINE fft_radix_operations ( radix_in, radix_out, operation ) -!! Determine the allowed lengths of FFT's ''' - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: radix_in, operation - INTEGER, INTENT ( OUT ) :: radix_out - -! Locals - INTEGER :: i, iloc - INTEGER, DIMENSION ( : ), POINTER :: data - -!------------------------------------------------------------------------------ - - CALL fft_get_lengths ( data, max_length = 1024 ) - - iloc = 0 - DO i = 1, SIZE ( data ) - IF ( data ( i ) == radix_in ) THEN - iloc = i - EXIT - ELSE - IF ( OPERATION == FFT_RADIX_ALLOWED ) THEN - CYCLE - ELSE IF ( data ( i ) > radix_in ) THEN - iloc = i - EXIT - END IF - END IF - END DO - - IF ( iloc == 0 ) THEN - CALL stop_prg ( "fft_radix_operations", "index to radix array not found" ) - END IF - - IF ( OPERATION == FFT_RADIX_ALLOWED ) THEN - IF ( data ( iloc ) == radix_in ) THEN - radix_out = FFT_RADIX_ALLOWED - ELSE - radix_out = FFT_RADIX_DISALLOWED - END IF - - ELSE IF ( OPERATION == FFT_RADIX_CLOSEST ) THEN - IF ( data ( iloc ) == radix_in ) THEN - radix_out = data ( iloc ) - ELSE - IF ( ABS ( data ( iloc - 1 ) - radix_in ) <= & - ABS ( data ( iloc ) - radix_in ) ) THEN - radix_out = data ( iloc - 1 ) - ELSE - radix_out = data ( iloc ) - END IF - END IF - - ELSE IF ( OPERATION == FFT_RADIX_NEXT ) THEN - radix_out = data ( iloc ) - - ELSE - CALL stop_prg ( "fft_radix_operations", "disallowed radix operation" ) - END IF - -END SUBROUTINE fft_radix_operations - -!****************************************************************************** - -#if defined ( __FFTSG ) - -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals - - stop "SG sFFT not implemented" - -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -SUBROUTINE fft_wrap_dbl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER :: ldx, ldy, ldz, nx, ny, nz, isign, norm - COMPLEX ( dbl ), DIMENSION(SIZE(zg)) :: xf, yf - - ldx = n(1) - ldy = n(2) - ldz = n(3) - nx = n(1) - ny = n(1) - nz = n(1) - norm = 1._dbl - -! CALL mltfft( 'N','T',zg,ldx,ldy*ldz,xf,ldy*ldz,ldx,nx, & -! ldy*ldz,isign,1.d0) -! CALL mltfft( 'N','T',xf,ldy,ldx*ldz,yf,ldx*ldz,ldy,ny, & -! ldx*ldz,isign,1.d0) -! IF ( PRESENT ( zgout ) ) THEN -! CALL mltfft( 'N','T',yf,ldz,ldy*ldx,zgout,ldy*ldx,ldz,nz, & -! ldy*ldx,isign,scale) -! ELSE -! CALL mltfft( 'N','T',yf,ldz,ldy*ldx,zg,ldy*ldx,ldz,nz, & -! ldy*ldx,isign,scale) -! END IF - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -#elif defined ( __FFTW ) && defined ( __AIX ) && defined ( __SPRECFFT ) - -!*** Single precision from FFTW ... - -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1a_save = -1, n2a_save = -1, n3a_save = -1 - INTEGER, SAVE :: n1b_save = -1, n2b_save = -1, n3b_save = -1 - LOGICAL, SAVE :: ffta_in_place = .true., fftb_in_place = .true. - LOGICAL :: fft_in_place - INTEGER :: sign_fft, n1, n2, n3 - INTEGER ( KIND = 4 ), SAVE :: plan_a_fw, plan_a_bw - INTEGER ( KIND = 4 ), SAVE :: plan_b_fw, plan_b_bw - REAL(sgl) :: norm - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - - IF ( PRESENT ( zgout ) ) THEN - fft_in_place = .false. - ELSE - fft_in_place = .true. - END IF - - sign_fft = fsign - - IF ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .eqv. ffta_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE IF ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .eqv. fftb_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - ELSE IF ( n1a_save == -1 .OR. & - ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .neqv. ffta_in_place ) .AND. & - n1b_save /= -1 ) ) THEN ! Initialise 'a' - write(6,*) "Init a" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1a_save = n1 - n2a_save = n2 - n3a_save = n3 - ffta_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE ! Initialise 'b' - write(6,*) "Init b" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1b_save = n1 - n2b_save = n2 - n3b_save = n3 - fftb_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - END IF - - IF ( norm /= 1._dbl ) THEN - IF ( fft_in_place ) THEN - zg = zg * norm - ELSE - zgout = zgout * norm - END IF - END IF - -END SUBROUTINE fft_wrap_sgl - -!*** ... and double precision from ESSL - -SUBROUTINE fft_wrap_dbl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL ( dbl ):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -#elif defined ( __FFTW ) && ! defined ( __SPRECFFT ) - -SUBROUTINE fft_wrap_sgl ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale - - stop "fftw cannot be used in both single and double precision..." -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - -SUBROUTINE fft_wrap_dbl ( fsign, n, zg, zg_out, scale ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: fsign - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n - COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ) :: zg - COMPLEX ( dbl ), DIMENSION(:,:,:), INTENT ( INOUT ), OPTIONAL, TARGET :: zg_out - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER, SAVE :: n1a_save = -1, n2a_save = -1, n3a_save = -1 - INTEGER, SAVE :: n1b_save = -1, n2b_save = -1, n3b_save = -1 - INTEGER, SAVE :: n1c_save = -1, n2c_save = -1, n3c_save = -1 - LOGICAL, SAVE :: ffta_in_place = .TRUE., fftb_in_place = .TRUE. - LOGICAL, SAVE :: fftc_in_place = .TRUE. - LOGICAL :: fft_in_place - INTEGER :: sign_fft, n1, n2, n3 - INTEGER ( KIND = 8 ), SAVE :: plan_a_fw, plan_a_bw - INTEGER ( KIND = 8 ), SAVE :: plan_b_fw, plan_b_bw - INTEGER ( KIND = 8 ), SAVE :: plan_c_fw, plan_c_bw - REAL ( dbl ) :: norm - - ! Just due to DEC... apsi - COMPLEX ( dbl ), DIMENSION(:,:,:), POINTER :: zgout - COMPLEX ( dbl ), DIMENSION(1,1,1), TARGET :: zgout_tmp - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( scale ) ) THEN - norm = scale - ELSE - norm = 1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - - IF ( PRESENT ( zg_out ) ) THEN - fft_in_place = .false. - zgout => zg_out - ELSE - fft_in_place = .true. - zgout => zgout_tmp - END IF - - sign_fft = fsign - - IF ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .eqv. ffta_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - ELSE IF ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .eqv. fftb_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - ELSE IF ( n1c_save == n1 .AND. n2c_save == n2 .AND. n3c_save == n3 & - .AND. ( fft_in_place .eqv. fftc_in_place ) ) THEN - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) - END IF - ELSE IF ( n1a_save == -1 .OR. & - ( n1a_save == n1 .AND. n2a_save == n2 .AND. n3a_save == n3 & - .AND. ( fft_in_place .neqv. ffta_in_place ) .AND. & - ( n1b_save /= -1 .AND. n1c_save /= -1 ) ) ) THEN ! Initialise 'a' - write(6,*) "Init a" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_a_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_a_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1a_save = n1 - n2a_save = n2 - n3a_save = n3 - ffta_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_a_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_a_bw, zg, zgout ) - END IF - - ELSE IF ( n1b_save == -1 .OR. & - ( n1b_save == n1 .AND. n2b_save == n2 .AND. n3b_save == n3 & - .AND. ( fft_in_place .neqv. fftb_in_place ) .AND. & - n1c_save /= -1 ) ) THEN ! Initialise 'a' - write(6,*) "Init b" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_b_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_b_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1b_save = n1 - n2b_save = n2 - n3b_save = n3 - fftb_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_b_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_b_bw, zg, zgout ) - END IF - - ELSE ! Initialise 'c' - write(6,*) "Init c" - IF ( fft_in_place ) THEN - CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_IN_PLACE ) - ELSE - CALL fftw3d_f77_create_plan ( plan_c_fw, n1, n2, n3, FFTW_FORWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - CALL fftw3d_f77_create_plan ( plan_c_bw, n1, n2, n3, FFTW_BACKWARD, & - FFTW_ESTIMATE + FFTW_OUT_OF_PLACE ) - END IF - n1c_save = n1 - n2c_save = n2 - n3c_save = n3 - fftc_in_place = fft_in_place - - IF ( sign_fft == +1 ) THEN - CALL fftwnd_f77_one ( plan_c_fw, zg, zgout ) - ELSE - CALL fftwnd_f77_one ( plan_c_bw, zg, zgout ) - END IF - END IF - - IF ( norm /= 1._dbl ) THEN - IF ( fft_in_place ) THEN - zg = zg * norm - ELSE - zgout = zgout * norm - END IF - END IF - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -#elif defined ( __AIX ) - -SUBROUTINE fft_wrap_dbl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL ( dbl ):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL dcft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_dbl - -!****************************************************************************** - -SUBROUTINE fft_wrap_sgl(fsign,n,zg,zgout,scale) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX(sgl), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - COMPLEX(sgl), DIMENSION(0:,0:,0:), OPTIONAL, INTENT ( INOUT ):: zgout - REAL(sgl), OPTIONAL, INTENT ( IN ):: scale -! locals -! REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE:: aux - REAL(sgl):: norm - INTEGER:: la1,la2,la3,sign_fft,na1,na2,naux,isos - INTEGER :: n1,n2,n3 - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF -! IBM FFT CALL - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n1*n2 - IF( MAX(n2,n3)<252 ) THEN - IF( n1<=2048 ) THEN - naux=60000 - ELSE - naux=60000+4.56*n1 - END IF - ELSE - IF( n1<=2048 ) THEN - na1=60000+(2*n2+256)*(MIN(64,n1)+4.56) - na2=60000+(2*n3+256)*(MIN(64,n1*n2)+4.56) - ELSE - na1=60000+4.56*n1+(2*n2+256)*(MIN(64,n1)+4.56) - naux=60000+4.56*n1+(2*n3+256)*(MIN(64,n1*n2)+4.56) - END IF - IF( n2>=252 .AND. n3<252 ) THEN - naux=na1 - ELSE IF( n2<252 .AND. n3>=252 ) THEN - naux=na2 - ELSE - naux=MAX(na1,na2) - END IF - END IF - -! ALLOCATE(aux(naux),STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate aux') - -! sign_fft = fsign -! CALL dcft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - IF ( PRESENT ( zgout ) ) THEN - CALL do_ibm_fft_ab ( naux ) - ELSE - CALL do_ibm_fft_aa ( naux ) - END IF - -! DEALLOCATE(aux,STAT=isos) -! IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate aux') - -CONTAINS - - SUBROUTINE do_ibm_fft_ab ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL scft3(zg,la1,la2,zgout,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_ab - - SUBROUTINE do_ibm_fft_aa ( naux ) - - INTEGER, INTENT ( IN ) :: naux - - REAL(kind=dbl), DIMENSION ( naux ) :: aux - - sign_fft = fsign - CALL scft3(zg,la1,la2,zg,la1,la2,n1,n2,n3,sign_fft,norm,aux,naux) - - END SUBROUTINE do_ibm_fft_aa - -END SUBROUTINE fft_wrap_sgl - -!****************************************************************************** - -#elif defined ( __T3E ) - -SUBROUTINE fft_wrap_ab ( fsign, n, zg, zgout, scale ) -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( IN ):: zg - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zgout - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1save = -1, n2save = -1, n3save = -1 - INTEGER:: la1,la2,la3,sign_fft,na1,na2,isos, isys ( 4 ) - INTEGER :: n1,n2,n3 - REAL ( dbl ):: norm - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE :: work - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE, SAVE :: table - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n2 - isys ( 1 ) = 3 - isys ( 2 ) = 0 - isys ( 3 ) = 0 - isys ( 4 ) = 0 - - ALLOCATE ( work ( 2 * n1 * n2 * n3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate work') - sign_fft = fsign - - IF ( n1save /= n1 .OR. n2save /= n2 .OR. n3save /= n3 ) THEN - IF ( ALLOCATED ( table ) ) DEALLOCATE ( table ) - ALLOCATE ( table ( 2 * ( n1 + n2 + n3 ) ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate table') - CALL ccfft3d ( 0, n1, n2, n3, norm, zg, la1, la2, & - zgout, la1, la2, table, work, isys ) - n1save = n1 - n2save = n2 - n3save = n3 - END IF - - CALL ccfft3d ( sign_fft, n1, n2, n3, norm, zg, la1, la2, & - zgout, la1, la2, table, work, isys ) - - DEALLOCATE ( work, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate work') - -END SUBROUTINE fft_wrap_ab - -!****************************************************************************** - -SUBROUTINE fft_wrap_aa ( fsign, n, zg, scale ) - -! routine with wrapper for all fft calls: -! Does transform with exp(+ig.r*sign): - - IMPLICIT NONE - INTEGER, INTENT ( IN ):: fsign - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n - COMPLEX ( dbl ), DIMENSION(0:,0:,0:), INTENT ( INOUT ):: zg - REAL ( dbl ), OPTIONAL, INTENT ( IN ):: scale -! locals - INTEGER, SAVE :: n1save = -1, n2save = -1, n3save = -1 - INTEGER:: la1,la2,la3,sign_fft,na1,na2,isos, isys ( 4 ) - INTEGER :: n1,n2,n3 - REAL ( dbl ):: norm - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE :: work - REAL(kind=dbl), DIMENSION ( : ), ALLOCATABLE, SAVE :: table - - IF( PRESENT ( scale) ) THEN - norm=scale - ELSE - norm=1._dbl - END IF - - n1 = n(1) - n2 = n(2) - n3 = n(3) - la1 = n1 - la2 = n2 - isys ( 1 ) = 3 - isys ( 2 ) = 0 - isys ( 3 ) = 0 - isys ( 4 ) = 0 - - ALLOCATE ( work ( 2 * n1 * n2 * n3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate work') - sign_fft = fsign - - IF ( n1save /= n1 .OR. n2save /= n2 .OR. n3save /= n3 ) THEN - IF ( ALLOCATED ( table ) ) DEALLOCATE ( table ) - ALLOCATE ( table ( 2 * ( n1 + n2 + n3 ) ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to allocate table') - CALL ccfft3d ( 0, n1, n2, n3, norm, zg, la1, la2, & - zg, la1, la2, table, work, isys ) - n1save = n1 - n2save = n2 - n3save = n3 - END IF - - CALL ccfft3d ( sign_fft, n1, n2, n3, norm, zg, la1, la2, & - zg, la1, la2, table, work, isys ) - - DEALLOCATE ( work, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg( 'fft_wrap','failed to deallocate work') - -END SUBROUTINE fft_wrap_aa - -#endif - -END MODULE fft_tools diff --git a/src/fist.cpp b/src/fist.cpp deleted file mode 100644 index 8b53ccd..0000000 --- a/src/fist.cpp +++ /dev/null @@ -1,241 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include - -#include "atoms_input.h" -#include "convert_units.h" -#include "dump.h" -#include "ewalds.h" -#include "ewald_parameters_types.h" -#include "header.h" -#include "kinds.h" -#include "fist_debug.h" -#include "fist_input.h" -#include "fist_global.h" -#include "force_fields.h" -#include "initialize_extended_types.h" -#include "initialize_molecule_types.h" -#include "initialize_particle_types.h" -#include "integrator.h" -#include "input_types.h" -#include "linklist_control.h" -#include "mathconstants.h" -#include "md.h" -#include "molecule_input.h" -#include "molecule_types.h" -#include "nose.h" -#include "pair_potential.h" -#include "particle_types.h" -#include "simulation_cell.h" -#include "stop_program.h" -#include "structure_types.h" -#include "timings.h" -#include "unit.h" -#include "util.h" - -using namespace CP2K_NS; - -class fist { - -public: - void fist_main(); - -private: - void allocmem(system_type ainp, std::vector mol_setup, structure_type *struc); - void deallocmem(structure_type struc); - -}; - -/*----------------------------------------------------------------------------*/ -/* FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST */ -/*----------------------------------------------------------------------------*/ - -void fist::fist_main() { - - double cons, ecut, qi, qj; - std::vector> rcut; - int handle, itimes, isos, para_comm_cart; - int iat, jat; - std::vector atom_names; - std::string set_fn; - - potentialparm_type potparm; - particle_prop_type pstat; - molecule_type mol_setup; - unit_convert_type units; - simulation_parameters_type simpar; - structure_type struc; - extended_parameters_type nhcp; - thermodynamic_type thermo; - system_type ainp; - ewald_parameters_type ewald_param; - setup_parameters_type setup; - intra_parameters_type intra_param; - - timeset("FIST", "I", " ", handle); - - if (fistpar.ionone) fist_header(fistpar.scr); - - // read fist section - - read_fist_section(setup, ewald_param, fistpar); - - // read from the setup and molecule section of *.set - - set_fn = setup.set_file_name; - - read_setup_section(mol_setup, set_fn, fistpar); - - read_molecule_section(mol_setup, set_fn, fistpar); - - // read force_field information for classical MD - - read_force_field_section(setup, mol_setup, set_fn, - intra_param, potparm, atom_names, pstat, fistpar); - - // read the input of the molecular dynamics section - - read_md_section(simpar, fistpar, mdio); - simpar.program = "FIST"; - - // read atomic coordinates, velocities (optional) and the simulation box - ainp.rtype = simpar.read_type; - atoms_input.read_coord_vel(ainp, setup.input_file_name, fistpar); - - // initialize box, perd - struc.box.hmat = ainp.box; - struc.box.perd = setup.perd; - - get_hinv(struc.box); - - // initialize working units - set_units ( setup.unit_type, units ); - - set_energy_parm ( units.pconv, units.econv, units.l_label, - units.vol_label, units.e_label, units.pres_label, - units.temp_label, units.angl_label ); - - // allocate memory for atoms and molecules - allocmem ( ainp, mol_setup, struc ); - - // initialize particle_type - initialize_particle_type ( atom_names, simpar, mol_setup, - ainp, pstat, struc.part ); - - // convert the units - convert ( units = units, simpar = simpar, - part = struc.part, pstat = pstat, box = struc.box, - potparm = potparm, intra_param = intra_param, - ewald_param = ewald_param ); - - // initialize molecule_type - initialize_molecule_type ( mol_setup, intra_param, struc.pnode, - struc.part, struc.molecule, fistpar ); - - // initialize extended_parameters_type and get number of degrees of freedom - initialize_extended_type ( struc.box, simpar, - struc.molecule, mol_setup, nhcp, fistpar ); - - // initialize velocities if needed - if ( simpar.read_type == "POS" ) { - initialize_velocities ( simpar, struc.part, fistpar ); - } - - // initialize splines - - potparm ( :, : ).energy_cutoff = 0.0; - potparm ( :, : ).e_cutoff_coul = 0.0; - spline_nonbond_control ( potparm, pstat, 5000, ewald_param ); - - // set linklist control parameters - allocate ( rcut ( setup.natom_type, setup.natom_type ), STAT = isos ); - if ( isos !=0 ) stop_memory ( "fist", "rcut", 0 ); - - rcut ( :, : ) = potparm ( :, : ).rcutsq; - - set_ll_parm ( fistpar, simpar.verlet_skin, - setup.natom_type, rcut, simpar.n_cell ); - - set_ll_parm ( fistpar, printlevel = fistpar.print_level, - ltype = "NONBOND" ); - - deallocate ( rcut, STAT = isos ); - if ( isos != 0 ) stop_memory ( "fist", "rcut" ); - - // deallocate arrays needed for atom input - if (associated(ainp.c)) { - deallocate(ainp.c, STAT=isos); - if (isos != 0) stop_memory("fist", "ainp.c"); - } - - if (associated(ainp.v)) { - deallocate(ainp.v, STAT=isos); - if (isos != 0) stop_memory("fist", "ainp.v"); - } - - // initialize integrator - set_integrator(fistpar.ionode, fistpar.group, fistpar.scr, mdio); - - if (setup.run_type == "DEBUG") { - // debug the forces - debug_control( fistpar, ewald_param, struc.part, struc.pnode, - struc.molecule, struc.box, thermo, potparm, simpar.ensemble ); - } else { - // MD - itimes = 0; - force(struc, potparm, thermo, simpar, ewald_param); - if (fistpar.ionode && ewald_param.ewald_type != "None") { - ewald_print(fistpar.scr, thermo, struc.box, units.e_label); - } - energy(itimes, cons, simpar, struc, thermo, nhcp); - - for (itimes = 0; itimes < simpar.nsteps; itimes++) { - velocity_verlet(itimes, cons, simpar, potparm, thermo, - struc, ewald_param, nhcp); - if (itimes % mdio.idump == 0) dump_variables(struc, mdio.dump_file_name, fistpar); - } - - dump_variables(struc, mdio.dump_file_name, fistpar); - - if (fistpar.ionode) close_unit(10,99); - } - - // deallocate memory for atoms and molecules - deallocmem(struc); - - timestop(zero, handle); -} - -fist::~fist() { - deallocmem(struc); -} - -/*----------------------------------------------------------------------------*/ -/* FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST FIST */ -/*----------------------------------------------------------------------------*/ - -void fist::allocmem(system_type ainp, std::vector mol_setup, structure_type *struc) { - - // Locals - int iw, natoms, nnodes, nmol, nmoltype, ios, iat, i; - - //----------------------------------------------------------------------------- - - struc.name = "FIST MOLECULAR SYSTEM" - if (fistpar.num_pe == 1) { - natoms = ainp.c.length(); - allocate(struc.part, STAT = ios); - - } -} - -void fist::deallocmem(structure_type *struc) { - - free(struc->part); - free(struc->pnode); - free(struc->molecule); - -} diff --git a/src/fist_debug.c b/src/fist_debug.c deleted file mode 100644 index ab86f4a..0000000 --- a/src/fist_debug.c +++ /dev/null @@ -1,452 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist_debug - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type - USE particle_types, ONLY : particle_type - USE pair_potential, ONLY : potentialparm_type, ener_coul - USE fist_force, ONLY : force_control, debug_variables_type - USE fist_force_numer, ONLY : force_bond_numer, force_bend_numer, & - force_nonbond_numer, force_recip_numer, pvbond_numer, pvbend_numer, & - ptens_numer, pvg_numer, potential_g_numer, de_g_numer, & - energy_recip_numer - USE linklists, ONLY : bonds, bends, torsions, dist_constraints, & - g3x3_constraints - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup - USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: debug_control - -CONTAINS - -!****************************************************************************** - -! Routine to execute numerical tests for debugging - -SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & - thermo, potparm, ensemble ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( particle_type ), INTENT ( INOUT ), DIMENSION ( : ) :: part - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ) :: pnode - TYPE ( potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule - TYPE ( cell_type ), INTENT ( INOUT ) :: box - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble - -! Locals - TYPE ( debug_variables_type ) :: dbg - TYPE ( pw_grid_type ) :: pw_grid - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff - INTEGER :: iflag, i, natoms, isos, iatom, iw, ir - INTEGER, DIMENSION ( 2 ) :: dum - REAL ( dbl ) :: delta, energy_numer - REAL ( dbl ) :: e_numer, pv_test ( 3, 3 ) - REAL ( dbl ) :: err1, numer, denom1, vec ( 3 ), e_bc, e_real, energy_tot - REAL ( dbl ) :: denom2, err2 - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_bc, f_real - -!------------------------------------------------------------------------------ - - iw = globenv % scr - ir = 5 - WRITE ( iw, '( 16x,A )' ) & - '***************************************************' - WRITE ( iw, '( 16x,A )' ) ' BEGIN DEBUG' - WRITE ( iw, '( 16x,A )' ) & - '***************************************************' - -! allocating all arrays involved with debug - natoms = SIZE ( pnode ) - IF ( .NOT. ALLOCATED ( diff ) ) ALLOCATE ( diff ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "diff", 3 * natoms ) - IF ( .NOT. ALLOCATED ( rel ) ) ALLOCATE ( rel ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "rel", 3 * natoms ) - IF ( .NOT. ALLOCATED ( f_numer ) ) & - ALLOCATE ( f_numer ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_numer", 3 * natoms ) - ALLOCATE ( dbg % f_nonbond ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( "debug_control", "f_nonbond", 3 * natoms ) - ALLOCATE ( dbg % f_g ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_g", 3 * natoms ) - ALLOCATE ( dbg % f_bond ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_bond", 3 * natoms ) - ALLOCATE ( dbg % f_bend ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_bend", 3 * natoms ) - -! call to analytical nonbond force routine: - CALL force_control ( molecule, pnode, part, box, thermo, & - potparm, ewald_param, ensemble, globenv, dbg ) - -! Debug real-space nonbond - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR REAL SPACE NON-BOND (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - -! get numerical force for the nonbond - WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL force_nonbond_numer ( pnode, box, potparm, delta, f_numer, & - energy_numer ) - WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND NUMER ENERGY = ', & - energy_numer - WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND ANAL ENERGY = ', & - dbg % pot_nonbond - -! computing the absolute value of the differences in the forces - diff = ABS ( dbg % f_nonbond - f_numer ) - rel = diff / dbg % f_nonbond - -! find the maximum difference and the relative and absolute errors. - WRITE ( iw, '( A, T61, E20.14 )' ) & - ' MAXIMUM ABSOLUTE ERROR = ', MAXVAL ( diff ) - WRITE ( iw, '( A, T61, E20.14 )' ) & - ' MAXIMUM RELATIVE ERROR = ', MAXVAL ( rel ) - -! write out the particle number and forces of -! the max absolute and relative error - dum = MAXLOC ( diff ) - WRITE ( iw, '( A, T71, I10 )' ) & - ' NON BOND PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) - WRITE ( iw, '( A, T21, 3G20.14 )' ) & - ' F ANAL NONBOND =', dbg % f_nonbond ( :, dum ( 2 ) ) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F NUMR NONBOND =', f_numer ( :, dum ( 2 ) ) - - dum = MAXLOC ( rel ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BOND PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F ANAL NONBOND =', dbg % f_nonbond ( :, dum ( 2 ) ) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F NUMR NONBOND =', f_numer ( :, dum ( 2 ) ) - END IF - -! Debug real-space intramolecular - IF ( bonds ) THEN - WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG BONDS (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL force_bond_numer ( molecule, f_numer, energy_numer, delta ) - WRITE ( iw, '( A, T61, G20.14 )' ) ' BOND NUMER ENERGY = ', & - energy_numer - WRITE ( iw, '( A, T61, G20.14 )' ) ' BOND ANAL ENERGY = ', & - dbg % pot_bond - -! computing the absolute value of the differences in the forces - diff = ABS ( dbg % f_bond - f_numer ) - rel = diff / dbg % f_bond - -! find the maximum difference and the relative and absolute errors. - WRITE ( iw, '( A,T61,G20.14 )' ) ' MAXIMUM ABSOLUTE ERROR = ', & - MAXVAL ( diff ) - WRITE ( iw, '( A,T61,G20.14 )' ) ' MAXIMUM RELATIVE ERROR = ', & - MAXVAL ( rel ) - -! write out the particle number and forces of -! the max absolute and relative error - dum = MAXLOC ( diff ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BOND PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) ' F ANAL BOND =', & - dbg % f_bond(:,dum(2)) - WRITE ( iw, '( A,T21,3G20.14 )' ) ' F NUMR BOND =', & - f_numer(:,dum(2)) - - dum = MAXLOC ( rel ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BOND PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F ANAL BOND =', & - dbg % f_bond(:,dum(2)) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F NUMR BOND =', & - f_numer(:,dum(2)) - END IF - -! Debug bond virial - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR BOND VIRIAL (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - -! get numerical virial - WRITE ( iw, * ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1 .OR. delta <= 0 ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL pvbond_numer ( molecule, pv_test, box, pnode, delta ) - -! writing out the virials - WRITE ( iw, '( A )' ) ' PV NUMERICAL' - DO i = 1, 3 - WRITE ( iw, '( T21, 3G20.14 )' ) pv_test ( i, : ) - END DO - WRITE ( iw, '( A )' ) ' PV BOND' - DO i = 1, 3 - WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_bond(i,:) - END DO - END IF - END IF - - IF ( bends ) THEN - WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG BENDS (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - IF ( delta >= 1 ) THEN - delta = 1.0E-5_dbl - END IF - - CALL force_bend_numer ( molecule, f_numer, energy_numer, delta ) - WRITE ( iw, '( A, T61, G20.14 )' ) ' BEND NUMER ENERGY = ', & - energy_numer - WRITE ( iw, '( A, T61, G20.14 )' ) ' BEND ANAL ENERGY = ', & - dbg % pot_bend - -! computing the absolute value of the differences in the forces - diff = ABS ( dbg % f_bend - f_numer ) - rel = diff / dbg % f_bend - -! find the maximum difference and the relative and absolute errors. - WRITE ( iw, '( A,T61,G20.14 )' ) ' MAXIMUM ABSOLUTE ERROR = ', & - MAXVAL ( diff ) - WRITE ( iw, '( A,T61,G20.14 )' ) ' MAXIMUM RELATIVE ERROR = ', & - MAXVAL ( rel ) - -! write out the particle number and forces of -! the max absolute and relative error - dum = MAXLOC ( diff ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BEND PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F ANAL BEND =', & - dbg % f_bend(:,dum(2)) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F NUMR BEND =', & - f_numer(:,dum(2)) - - dum = MAXLOC ( rel ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BEND PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F ANAL BEND =', & - dbg % f_bend(:,dum(2)) - WRITE ( iw, '( A,T21,3G20.14 )' ) 'F NUMR BEND =', & - f_numer(:,dum(2)) - END IF - -! Debug bond virial - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR BEND VIRIAL (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - -! get numerical virial - WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - IF ( delta >= 1.0_dbl ) THEN - delta = 1.0E-5_dbl - END IF - CALL pvbend_numer ( molecule, pv_test, box, pnode, delta ) - -! writing out the virials - WRITE ( iw, '( A )' ) ' PV NUMERICAL' - DO i = 1, 3 - WRITE ( iw, '( T21, 3G20.14 )' ) pv_test(i,:) - END DO - WRITE ( iw, '( A )' ) ' PV BEND' - DO i = 1, 3 - WRITE ( iw, '( T21, 3G20.14 )' ) dbg % pv_bend(i,:) - END DO - END IF - END IF - -! Debug g-space -! IF ( ewald_param % ewald_type /= 'NONE' ) THEN -! WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! CALL pw_grid_setup ( box, pw_grid, ewald_param % gmax ) -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & -! pw_grid % ngpts_cut -! WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & -! ewald_param % alpha -! CALL energy_recip_numer ( pnode, box, potparm, pw_grid, & -! energy_numer, pw_grid % ngpts_cut ) -! WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & -! dbg % pot_g -! WRITE ( iw, '( A, T61, G20.14 )' ) & -! 'G-SPACE NUMERICAL ENERGY = ', energy_numer -! END IF -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A, T71, F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta -! END IF -! -! CALL force_recip_numer ( pnode, box, potparm, gvec, delta, f_numer ) -! -! computing the absolute value of the differences in the forces -! diff = ABS ( dbg % f_g - f_numer ) -! rel = diff / dbg % f_g -! -! find the maximum difference and the relative and absolute errors. -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM RELATIVE ERROR = ', maxval(rel) -! -! write out the particle number and forces of -! the max absolute and relative error -! dum = MAXLOC ( diff ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! -! dum = MAXLOC ( rel ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! END IF -! -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! -! get numerical virial -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A,T71,F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta -! END IF -! CALL pvg_numer ( pnode, box, potparm, gvec, pv_test, delta ) -! -! writing out the virials -! WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) -! END DO -! WRITE ( iw, '( A )' ) ' PV G-SPACE' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) -! END DO -! END IF -! END IF -! END IF -! -! Debug real-space virial - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR NON BOND (REAL SPACE) VIRIAL (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN -! -! get numerical virial - WRITE ( iw, '( A )' ) 'ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL ptens_numer ( pnode, box, potparm, pv_test, delta ) -! -! writing out the virials - WRITE ( iw, '( A )' ) ' PV NUMERICAL' - DO i = 1, 3 - WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) - END DO - WRITE ( iw, '( A )' ) ' PV NONBOND' - DO i = 1, 3 - WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_nonbond(i,:) - END DO - END IF - - WRITE ( iw, '( )' ) - WRITE ( iw, '( 16x, A )' ) & - '***************************************************' - WRITE ( iw, '( 16x, A )' ) & - '* END DEBUG *' - WRITE ( iw, '( 16x, A )' ) & - '***************************************************' -END SUBROUTINE debug_control - -!****************************************************************************** - -END MODULE fist_debug diff --git a/src/fist_force.c b/src/fist_force.c deleted file mode 100644 index fd63f9e..0000000 --- a/src/fist_force.c +++ /dev/null @@ -1,279 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C ) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -MODULE fist_force - - USE dg_types, ONLY : dg_type - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE ewalds, ONLY : ewald_gaussian, ewald_initialize - USE fist_intra_force, ONLY : force_intra_control - USE fist_nonbond_force, ONLY : force_nonbond, bonded_correct_gaussian - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklist_control, ONLY : list_control - USE mathconstants, ONLY : pi, zero - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type, & - linklist_neighbor, linklist_exclusion, linklist_bonds, linklist_bends - USE mp, ONLY : mp_sum - USE pair_potential, ONLY : potentialparm_type - USE particle_types, ONLY : particle_type - USE pme, ONLY: pme_evaluate - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_change - USE simulation_cell, ONLY : cell_type, get_hinv - USE stop_program, ONLY : stop_prg, stop_memory - USE timings, ONLY : timeset, timestop - - PRIVATE - PUBLIC :: force_control, debug_variables_type - - TYPE debug_variables_type - REAL ( dbl ) :: pot_nonbond, pot_g, pot_bond, pot_bend - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: & - f_nonbond, f_g, f_bond, f_bend - REAL ( dbl ), DIMENSION ( 3, 3 ) :: pv_nonbond, pv_g, pv_bond, pv_bend - END TYPE debug_variables_type - -CONTAINS - -!****************************************************************************** - -!! Calculates the total potential energy, total force, and the -!! total pressure tensor from the potentials - -SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & - potparm, ewald_param, ensemble, fc_global, debug ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( INOUT ) :: part - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - TYPE ( cell_type ), INTENT ( INOUT ) :: box - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( potentialparm_type ), DIMENSION ( :,: ), INTENT ( IN ) :: potparm - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble - TYPE ( global_environment_type ), INTENT ( IN ) :: fc_global - TYPE ( debug_variables_type ), INTENT ( OUT ), OPTIONAL :: debug - -! Locals - INTEGER :: id, i, natoms, nnodes, handle, isos - REAL ( dbl ) :: pot_nonbond, pot_bond, pot_bend, vg_coulomb - REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE, SAVE :: f_nonbond - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_nonbond, pv_bond, pv_bend - REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE :: fg_coulomb - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_g, ident - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_bc - TYPE ( pw_grid_type ), SAVE :: grid_s, grid_b, grid_ewald - TYPE ( dg_type ), SAVE :: dg - LOGICAL :: first_time - -!------------------------------------------------------------------------------ - - CALL timeset ( 'FORCE','I',' ',handle ) - - nnodes = SIZE ( pnode ) - natoms = SIZE ( part ) - isos = 0 - first_time = .NOT. ALLOCATED ( f_nonbond ) - IF ( .NOT. ALLOCATED ( f_nonbond ) ) & - ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_control', 'f_nonbond', 3 * natoms ) - -! initialize ewalds - IF ( first_time ) THEN - SELECT CASE ( ewald_param % ewald_type ) - CASE ( 'EWALD_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - ewald_grid = grid_ewald ) - CASE ( 'PME_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - pme_small_grid = grid_s, pme_big_grid = grid_b ) - END SELECT - END IF - -! reinitialize the gspace for the new box - SELECT CASE ( ensemble ( 1:3 ) ) - CASE ( 'NPT' ) - CALL get_hinv ( box ) - - SELECT CASE ( ewald_param % ewald_type ) - CASE ( 'EWALD_GAUSS' ) - CALL pw_grid_change ( box, grid_s ) - CASE ( 'PME_GAUSS' ) - CALL stop_prg ( 'force_control', & - 'constant pressure with PME not implemented' ) - END SELECT - END SELECT - -! -! first check with list_control to update neighbor lists -! - CALL list_control ( pnode, part, box ) -! -! initial force, energy and pressure tensor arrays -! - DO i = 1, natoms - part ( i ) % f ( 1 ) = 0.0_dbl - part ( i ) % f ( 2 ) = 0.0_dbl - part ( i ) % f ( 3 ) = 0.0_dbl - END DO - pv_bond = 0.0_dbl - pv_bend = 0.0_dbl - thermo % pot = 0.0_dbl - thermo % pv = 0.0_dbl -! -! get real-space non-bonded forces: -! - f_nonbond = zero - CALL force_nonbond ( ewald_param,pnode,box,potparm, & - pot_nonbond,f_nonbond,pv_nonbond ) -! -! get g-space non-bonded forces: -! - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - IF ( .NOT. ALLOCATED ( fg_coulomb ) ) & - ALLOCATE ( fg_coulomb ( 3,nnodes ), STAT=isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_control', 'fg_coulomb', 3 * nnodes ) - -! compute g-space part of the ewald sum - SELECT CASE ( ewald_param % ewald_type ) - - CASE ( "EWALD_GAUSS" ) - CALL ewald_gaussian ( dg, ewald_param, fg_coulomb, vg_coulomb, & - pv_g, pnode, box ) - CALL bonded_correct_gaussian ( ewald_param, molecule, & - thermo % e_bonded, pv_bc ) - - CASE ( "PME_GAUSS" ) - CALL pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, & - grid_s, grid_b, ewald_param ) - CALL bonded_correct_gaussian ( ewald_param, molecule, & - thermo % e_bonded, pv_bc ) - - CASE DEFAULT - CALL stop_prg ( "force_control", "illegal value of ewald_type:", & - ewald_param % ewald_type ) - END SELECT - END IF - -! -! get intramolecular forces -! - IF ( PRESENT ( debug ) ) THEN - CALL force_intra_control ( molecule, pot_bond, pot_bend, & - pv_bond, pv_bend, debug % f_bond,debug % f_bend ) - ELSE - CALL force_intra_control ( molecule, pot_bond, pot_bend, & - pv_bond, pv_bend ) - END IF - -! -! add up all the potential energies -! - IF ( ewald_param % ewald_type == 'NONE' ) THEN - thermo % pot = pot_nonbond + pot_bond + pot_bend -#if defined ( __parallel ) - CALL mp_sum ( thermo % pot,fc_global % group ) -#endif - ELSE - thermo % pot = pot_nonbond + pot_bond + pot_bend + thermo % e_bonded - thermo % gspace = vg_coulomb -#if defined ( __parallel ) - CALL mp_sum ( thermo % pot,fc_global % group ) - CALL mp_sum ( thermo % e_bonded,fc_global % group ) -#endif -! e_self and e_neut are already summed over all processors -! vg_coulomb is not calculated in parallel - thermo % pot = thermo % pot + thermo % e_self + thermo % e_neut/box % deth - thermo % pot = thermo % pot + vg_coulomb - END IF - -! add up all the forces -! nonbonded forces might be claculated for atoms not on this node -! ewald forces are strictly local -> sum only over pnode - DO i = 1, natoms - part ( i ) % f ( 1 ) = part ( i ) % f ( 1 ) + f_nonbond ( 1, i ) - part ( i ) % f ( 2 ) = part ( i ) % f ( 2 ) + f_nonbond ( 2, i ) - part ( i ) % f ( 3 ) = part ( i ) % f ( 3 ) + f_nonbond ( 3, i ) - END DO - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - DO i = 1, nnodes - pnode ( i ) % p % f ( 1 ) = pnode ( i ) % p % f ( 1 ) & - + fg_coulomb ( 1, i ) - pnode ( i ) % p % f ( 2 ) = pnode ( i ) % p % f ( 2 ) & - + fg_coulomb ( 2, i ) - pnode ( i ) % p % f ( 3 ) = pnode ( i ) % p % f ( 3 ) & - + fg_coulomb ( 3, i ) - END DO - END IF - -! add up all the pressure tensors - IF ( ewald_param % ewald_type == 'NONE' ) THEN - thermo % pv = pv_nonbond + pv_bond + pv_bend -#if defined ( __parallel ) - CALL mp_sum ( thermo % pv, fc_global % group ) -#endif - ELSE - ident = 0.0_dbl - DO i = 1, 3 - ident ( i, i ) = 1.0_dbl - END DO - - thermo % pv = pv_nonbond + pv_bond + pv_bend + pv_bc -#if defined ( __parallel ) - CALL mp_sum ( thermo % pv,fc_global % group ) -#endif - - thermo % pv = thermo % pv + ident * thermo % e_neut / box % deth - thermo % pv = thermo % pv + pv_g - END IF - -! -! if we are doing debugging, check if variables are present and assign -! - IF ( PRESENT ( debug ) ) THEN - debug % pot_bond = pot_bond - debug % pot_bend = pot_bend - debug % pot_nonbond = pot_nonbond - debug % f_nonbond = f_nonbond - debug % pv_nonbond = pv_nonbond - debug % pv_bond = pv_bond - debug % pv_bend = pv_bend - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - debug % pot_g = vg_coulomb - debug % f_g = fg_coulomb - debug % pv_g = pv_g - ELSE - debug % pot_g = 0.0_dbl - debug % f_g = 0.0_dbl - debug % pv_g = 0.0_dbl - END IF - END IF - -! deallocating all local variables - isos = 0 - IF ( ALLOCATED ( fg_coulomb ) ) DEALLOCATE ( fg_coulomb, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'fg_coulomb' ) - -#if defined ( __parallel ) - DO i = 1, natoms - CALL mp_sum ( part ( i ) % f, fc_global % group ) - END DO -#endif - - CALL timestop ( zero, handle ) - -END SUBROUTINE force_control - -!****************************************************************************** - -END MODULE fist_force diff --git a/src/fist_force_numer.c b/src/fist_force_numer.c deleted file mode 100644 index a538cbb..0000000 --- a/src/fist_force_numer.c +++ /dev/null @@ -1,1322 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist_force_numer - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE fist_nonbond_force, ONLY : find_image - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi - USE molecule_types, ONLY : molecule_structure_type, linklist_bonds, & - linklist_bends, linklist_exclusion, particle_node_type - USE mol_force, ONLY : force_bonds, force_bends - USE pair_potential, ONLY : potential_f, potentialparm_type - USE pw_grid_types, ONLY : pw_grid_type - USE simulation_cell, ONLY : cell_type, pbc, get_hinv, get_cell_param - USE stop_program, ONLY : stop_memory - - PRIVATE - PUBLIC :: force_bend_numer, force_bond_numer, force_nonbond_numer - PUBLIC :: force_recip_numer, pvbond_numer, pvbend_numer, ptens_numer - PUBLIC :: pvg_numer, de_g_numer, potential_g_numer, energy_recip_numer - -CONTAINS - -!****************************************************************************** - -SUBROUTINE force_bond_numer ( molecule, f_bond_numer, v_bond_numer, & - numerical_shift ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: f_bond_numer - REAL ( dbl ), INTENT ( OUT ) :: v_bond_numer - REAL ( dbl ), INTENT ( IN ) :: numerical_shift - -! Locals - TYPE ( linklist_bonds ), POINTER :: llbond - INTEGER :: imol, ibond, idim, atom1, atom2 - REAL ( dbl ), DIMENSION (3) :: rij, rij_minus_delta, rij_plus_delta - REAL ( dbl ) :: e0, ep, em, fscalar - REAL ( dbl ), DIMENSION (3) :: delta - -!------------------------------------------------------------------------------ - -! initializing the forces - f_bond_numer = 0.0_dbl - v_bond_numer = 0.0_dbl - MOL: DO imol = 1, SIZE ( molecule ) - llbond => molecule(imol) % ll_bonds - - BOND: DO ibond = 1, molecule(imol) % nbonds_mol - atom1 = llbond % index(1) - atom2 = llbond % index(2) - rij = llbond % p1 % r - llbond % p2 % r - delta = 0.0_dbl - -! get the energy - CALL force_bonds ( rij, llbond % bond_param % r0, & - llbond % bond_param % k, e0, fscalar ) - v_bond_numer = v_bond_numer + e0 - -! get the forces - DO idim = 1, 3 - delta(idim) = numerical_shift - rij_minus_delta = rij - delta - CALL force_bonds ( rij_minus_delta, llbond % bond_param % r0, & - llbond % bond_param % k, em, fscalar ) - rij_plus_delta = rij + delta - CALL force_bonds ( rij_plus_delta, llbond % bond_param % r0, & - llbond % bond_param % k, ep, fscalar ) - f_bond_numer(idim,atom1) = f_bond_numer(idim,atom1) + (em-ep) - f_bond_numer(idim,atom2) = f_bond_numer(idim,atom2) - (em-ep) - delta = 0.0_dbl - END DO - - llbond => llbond % next - END DO BOND - END DO MOL - - f_bond_numer = f_bond_numer / ( 2.0_dbl * numerical_shift ) - -END SUBROUTINE force_bond_numer - -!****************************************************************************** - -SUBROUTINE force_bend_numer ( molecule, f_bend_numer, v_bend_numer, & - numerical_shift ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: f_bend_numer - REAL ( dbl ), INTENT ( OUT ) :: v_bend_numer - REAL ( dbl ), INTENT ( IN ) :: numerical_shift - -! Locals - TYPE ( linklist_bends ), POINTER :: llbend - INTEGER :: idim, imol, ibend, atom1, atom2, atom3 - REAL ( dbl ) :: d12, d12p, d12m, id12, id12p, id12m - REAL ( dbl ) :: d32, d32p, d32m, id32, id32p, id32m - REAL ( dbl ) :: dist, theta - REAL ( dbl ) :: em, ep, e0, fscalar - REAL ( dbl ), DIMENSION (3) :: g1, g2, g3 - REAL ( dbl ), DIMENSION (3) :: b12, b12_plus_delta, b12_minus_delta - REAL ( dbl ), DIMENSION (3) :: b32, b32_plus_delta, b32_minus_delta - REAL ( dbl ), DIMENSION (3) :: delta - -!------------------------------------------------------------------------------ - -! initializing the forces - f_bend_numer = 0.0_dbl - v_bend_numer = 0.0_dbl - MOL: DO imol = 1, SIZE ( molecule ) - llbend => molecule(imol) % ll_bends - - BEND: DO ibend = 1, molecule(imol) % nbends_mol - atom1 = llbend % index(1) - atom2 = llbend % index(2) - atom3 = llbend % index(3) - b12 = llbend % p1 % r - llbend % p2 % r - b32 = llbend % p3 % r - llbend % p2 % r - d12 = sqrt(dot_product(b12,b12)) - id12 = 1.0_dbl/d12 - d32 = sqrt(dot_product(b32,b32)) - id32 = 1.0_dbl/d32 - dist = dot_product(b12,b32) - theta = acos(dist*id12*id32) - -! get the energy - CALL force_bends ( b12, b32, d12, d32, id12, id32, dist, theta, & - llbend % bend_param % theta0, llbend % bend_param % k, & - g1, g2, g3, e0, fscalar ) - v_bend_numer = v_bend_numer + e0 - -! get the force on atom1 and atom2 - delta = 0.0_dbl - DO idim = 1, 3 - delta(idim) = numerical_shift - b12_minus_delta = b12 - delta - d12m = sqrt(dot_product(b12_minus_delta,b12_minus_delta)) - id12m = 1.0_dbl / d12m - dist = dot_product(b12_minus_delta,b32) - theta = acos(dist*id12m*id32) - CALL force_bends ( b12_minus_delta, b32, d12m, d32, id12m, id32, & - dist, theta, llbend % bend_param % theta0, & - llbend % bend_param % k, g1, g2, g3, em, fscalar ) - b12_plus_delta = b12 + delta - d12p = sqrt(dot_product(b12_plus_delta,b12_plus_delta)) - id12p = 1.0_dbl/d12p - dist = dot_product(b12_plus_delta,b32) - theta = acos(dist*id12p*id32) - CALL force_bends ( b12_plus_delta, b32, d12p, d32, id12p, id32, & - dist, theta, llbend % bend_param % theta0, & - llbend % bend_param % k, g1, g2, g3, ep, fscalar ) - f_bend_numer(idim,atom1) = f_bend_numer(idim,atom1) + (em-ep) - f_bend_numer(idim,atom2) = f_bend_numer(idim,atom2) - (em-ep) - delta = 0.0_dbl - END DO - -! get the force on atom3 and atom2 - delta = 0.0_dbl - DO idim = 1, 3 - delta(idim) = numerical_shift - b32_minus_delta = b32 - delta - d32m = sqrt(dot_product(b32_minus_delta,b12_minus_delta)) - id32m = 1.0_dbl/d32m - dist = dot_product(b32_minus_delta,b12) - theta = acos(dist*id32m*id12) - CALL force_bends(b12,b32_minus_delta,d12,d32m,id12,id32m,dist, & - theta, llbend % bend_param % theta0, & - llbend % bend_param % k, g1, g2, g3, em, fscalar ) - b32_plus_delta = b32 + delta - d32p = sqrt(dot_product(b32_plus_delta,b32_plus_delta)) - id32p = 1.0_dbl/d32p - dist = dot_product(b32_plus_delta,b12) - theta = acos(dist*id32p*id12) - CALL force_bends ( b12, b32_plus_delta, d12, d32p, id12, id32p, & - dist, theta, llbend % bend_param % theta0, & - llbend % bend_param % k, g1, g2, g3, ep, fscalar ) - f_bend_numer(idim,atom3) = f_bend_numer(idim,atom3) + (em-ep) - f_bend_numer(idim,atom2) = f_bend_numer(idim,atom2) - (em-ep) - delta = 0.0_dbl - END DO - - llbend => llbend % next - END DO BEND - END DO MOL - - f_bend_numer = f_bend_numer / ( 2.0_dbl * numerical_shift ) - -END SUBROUTINE force_bend_numer - -!****************************************************************************** - -SUBROUTINE force_nonbond_numer ( pnode, box, potparm, numerical_shift, & - f_numer, energy_numer ) - -! -! Calculates the force and the potential of the minimum image, and -! the pressure tensor -! - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( INOUT ) :: box - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: f_numer - REAL ( dbl ), INTENT ( OUT ) :: energy_numer - REAL ( dbl ), INTENT ( IN ) :: numerical_shift - -! Locals - INTEGER :: i, j, ii, jj, iatomtype, jatomtype - INTEGER :: icell,jcell,kcell,itype,jtype,id - INTEGER :: iexclude, natoms, n, isos - INTEGER :: xx, yy, zz - REAL ( dbl ), DIMENSION (3) ::vec, ri, rij, cell, ang, perd, dist - REAL ( dbl ) :: energy, fscalar, rijsq, rcut - REAL ( dbl ) :: rij_minus_delta_sq, rij_plus_delta_sq - REAL ( dbl ), DIMENSION (3) :: delta, s, quotient - REAL ( dbl ) :: energy_plus, energy_minus, qi, qj - INTEGER, DIMENSION ( :, :, : ), ALLOCATABLE :: n_images - TYPE ( linklist_exclusion ), POINTER :: ll_exclude - LOGICAL :: match - -!------------------------------------------------------------------------------ - - n = SIZE ( potparm ( :, 1 ) ) - IF ( .NOT. ALLOCATED ( n_images ) ) & - ALLOCATE ( n_images ( n, n, 3 ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_nonbond_numer', 'n_images', n * n * 3 ) - - CALL get_cell_param ( box, cell ) - - DO itype=1, n - DO jtype=1, n - rcut = SQRT ( potparm ( itype, jtype ) % rcutsq ) - quotient ( : ) = rcut / cell ( : ) - DO id=1,3 - IF ( quotient ( id ) <= 0.5_dbl ) THEN - n_images ( itype, jtype, id )=0 - ELSE - n_images ( itype, jtype, id ) = CEILING ( rcut / cell ( id ) ) - END IF - END DO - END DO - END DO - - energy_numer = 0.0_dbl - f_numer = 0.0_dbl - - delta = 0.0_dbl -! -! starting the force loop -! - CALL get_hinv ( box ) - CALL get_cell_param(box,cell,ang) - perd=box % perd - natoms = size(pnode) - ILOOP: DO i = 1, natoms - iatomtype = pnode(i) % p % prop % ptype - qi = pnode(i) % p % prop % charge - ri = pnode(i) % p % r - JLOOP: DO j = 1, natoms - IF (j>i) THEN - jatomtype = pnode(j) % p % prop % ptype - qj = pnode(j) % p % prop % charge - rij = pnode(j) % p % r - ri - -! -! imaging,transform back to unscaled distances and get potential and force -! - IF (MAXVAL(n_images(iatomtype,jatomtype,:))==0) THEN - rij = pbc(rij,box) - END IF - rijsq = dot_product(rij,rij) - - IF ( rijsq <= potparm ( iatomtype, jatomtype ) % rcutsq ) THEN -! pointing to the start of the exclusion list of particle i - ll_exclude => pnode(i) % ex - match = .FALSE. - EXCL: DO iexclude = 1, pnode(i) % nexcl - IF (ll_exclude % p % iatom==j) THEN - match = .TRUE. - EXIT EXCL - END IF - ll_exclude => ll_exclude % next - END DO EXCL - NOTMATCH: IF ( .NOT. match) THEN - delta = 0.0_dbl - DIM_LOOP: DO id = 1, 3 - delta(id) = numerical_shift - rij_minus_delta_sq = dot_product(rij-delta,rij-delta) - rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f ( rij_minus_delta_sq, potparm, qi, qj, & - iatomtype, jatomtype, energy_minus ) - CALL potential_f ( rij_plus_delta_sq, potparm, qi, qj, & - iatomtype, jatomtype, energy_plus ) - f_numer(id,i) = f_numer(id,i) + (energy_plus-energy_minus) - f_numer(id,j) = f_numer(id,j) - (energy_plus-energy_minus) - delta = 0.0_dbl - END DO DIM_LOOP - - CALL potential_f ( rijsq, potparm, qi, qj, & - iatomtype, jatomtype, energy ) - energy_numer = energy_numer + energy - END IF NOTMATCH - END IF - - zz = n_images ( iatomtype, jatomtype, 3 ) - yy = n_images ( iatomtype, jatomtype, 2 ) - xx = n_images ( iatomtype, jatomtype, 1 ) - s(1) = box % h_inv(1,1)*rij(1) & - + box % h_inv(1,2)*rij(2) & - + box % h_inv(1,3)*rij(3) - s(2) = box % h_inv(2,1)*rij(1) & - + box % h_inv(2,2)*rij(2) & - + box % h_inv(2,3)*rij(3) - s(3) = box % h_inv(3,1)*rij(1) & - + box % h_inv(3,2)*rij(2) & - + box % h_inv(3,3)*rij(3) - - DO kcell = -zz, zz - DO jcell = -yy, yy - DO icell = -xx, xx - IF ( icell == 0 .AND. jcell == 0 .AND. kcell == 0 ) CYCLE - - vec ( : ) = (/ icell, jcell, kcell /) - CALL find_image(s,perd,vec,box % hmat,rijsq,rij) - IF ( rijsq <= potparm(iatomtype,jatomtype ) % rcutsq ) THEN - delta = 0.0_dbl - DIM_LOOP2: DO id = 1, 3 - delta(id) = numerical_shift - rij_minus_delta_sq = dot_product(rij-delta,rij-delta) - rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f(rij_minus_delta_sq,potparm,qi,qj, & - iatomtype, jatomtype, energy_minus ) - CALL potential_f(rij_plus_delta_sq,potparm,qi,qj, & - iatomtype, jatomtype, energy_plus ) - f_numer(id,i) = f_numer(id,i) & - + (energy_plus-energy_minus) - f_numer(id,j) = f_numer(id,j) & - - (energy_plus-energy_minus) - delta = 0.0_dbl - END DO DIM_LOOP2 - - CALL potential_f ( rijsq, potparm, qi, qj, & - iatomtype, jatomtype, energy ) - energy_numer = energy_numer + energy - END IF - END DO - END DO - END DO - - ELSE IF (i==j) THEN -! search images if needed - zz=n_images(iatomtype,iatomtype,3) - yy=n_images(iatomtype,iatomtype,2) - xx=n_images(iatomtype,iatomtype,1) - s = 0.0_dbl - DO kcell=-zz,zz - DO jcell=-yy,yy - DO icell=-xx,xx - IF (icell==0.AND.jcell==0.AND.kcell==0) CYCLE - vec ( : )=(/icell,jcell,kcell/) - CALL find_image(s,perd,vec,box % hmat,rijsq,rij) - IF ( rijsq <= potparm ( iatomtype, iatomtype ) % rcutsq ) & - THEN - delta = 0.0_dbl - DIM_LOOP3: DO id = 1, 3 - delta(id) = numerical_shift - rij_minus_delta_sq = dot_product(rij-delta,rij-delta) - rij_plus_delta_sq = dot_product(rij+delta,rij+delta) - CALL potential_f(rij_minus_delta_sq,potparm,qi,qi, & - iatomtype,iatomtype,energy_minus) - CALL potential_f(rij_plus_delta_sq,potparm,qi,qi, & - iatomtype,iatomtype,energy_plus) - f_numer(id,i) = f_numer(id,i) & - + (energy_plus-energy_minus) - f_numer(id,i) = f_numer(id,i) & - - (energy_plus-energy_minus) - delta = 0.0_dbl - END DO DIM_LOOP3 - - CALL potential_f ( rijsq, potparm, qi, qi, & - iatomtype,iatomtype, energy ) - energy_numer = energy_numer + energy - END IF - END DO - END DO - END DO - END IF - - END DO JLOOP - END DO ILOOP - -! computing long range corrections to the potential -!when we get the system for handling multiple potentials -!we will add the long range correction -! energy_numer=energy_numer+lrc*(1./box % deth) - - f_numer = f_numer/(2.0_dbl*numerical_shift) - -END SUBROUTINE force_nonbond_numer - -!****************************************************************************** - -SUBROUTINE force_recip_numer ( ewald_param, pnode, box, potparm, & - pw_grid, numerical_shift, f_numer ) - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid - REAL ( dbl ), INTENT ( IN ) :: numerical_shift - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: f_numer - -! Locals - COMPLEX ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: sum_igr - REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: gauss - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: gdebug - REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: r_delta - INTEGER :: ig, i, idim, natoms, ngtot, isos, lp, mp, np - REAL ( dbl ) :: alpha, epsilon0, ep, em, charge - -!------------------------------------------------------------------------------ - -! allocating - ngtot = pw_grid % ngpts_cut - ALLOCATE (gdebug(3,ngtot),STAT=isos) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_recip_numer', 'gdebug', 3 * ngtot ) - ALLOCATE (sum_igr(ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'sum_igr', ngtot ) - ALLOCATE (gauss(ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'gauss', ngtot ) - ALLOCATE (r_delta(3),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'r_delta', 3 ) - -! computing the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - gdebug(1,ig) = 2.0_dbl*pi*(box % h_inv(1,1)*lp+box % h_inv(2,1)* mp & - +box % h_inv(3,1)*np) - gdebug(2,ig) = 2.0_dbl*pi*(box % h_inv(1,2)*lp+box % h_inv(2,2)* mp & - +box % h_inv(3,2)*np) - gdebug(3,ig) = 2.0_dbl*pi*(box % h_inv(1,3)*lp+box % h_inv(2,3)* mp & - +box % h_inv(3,3)*np) - END DO - -! defining alpha and epsilon0 (see ewald.f for details) - alpha = ewald_param % alpha - epsilon0 = ewald_param % eps0 - -! first initialize the arrays gauss and sum_igr - CALL potential_g_numer ( ep, pnode, sum_igr, gauss, alpha, gdebug, ngtot ) - -! initializing numerical force - f_numer = 0.0_dbl - -! computing the numerical force on each atom - natoms = size(pnode) - DO i = 1, natoms - charge = pnode(i) % p % prop % charge - r_delta ( : ) = pnode(i) % p % r ( : ) - DO idim = 1, 3 - r_delta(idim) = r_delta(idim) + numerical_shift - CALL de_g_numer(ep,sum_igr,gauss,pnode(i) % p % r,r_delta,charge, & - gdebug,ngtot) - r_delta(idim) = r_delta(idim) - 2.0_dbl*numerical_shift - CALL de_g_numer(em,sum_igr,gauss,pnode(i) % p % r,r_delta,charge, & - gdebug,ngtot) - f_numer(idim,i) = (em-ep)/epsilon0/box % deth - r_delta(idim) = r_delta(idim) + numerical_shift - END DO - END DO - f_numer = f_numer / ( 2.0_dbl * numerical_shift ) - - DEALLOCATE (r_delta,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','r_delta') - DEALLOCATE (gdebug,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','gdebug') - DEALLOCATE (sum_igr,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer','sum_igr') - DEALLOCATE (gauss,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'force_recip_numer', 'gauss' ) - -END SUBROUTINE force_recip_numer - -!****************************************************************************** - -SUBROUTINE pvbond_numer ( molecule, pv_test, box, pnode, delta ) - -! computes the numerical pressure tensor - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_test - REAL ( dbl ), INTENT ( IN ) :: delta - -! Locals - TYPE ( cell_type ) :: box_local - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: x, s - REAL ( dbl ), DIMENSION ( 3, 3 ) :: dvdh - REAL ( dbl ) :: idelta, vm, vp, vnb - INTEGER :: i, j, k, ii, jj, natoms, isos - -!------------------------------------------------------------------------------ - -! assigning the local variables - natoms = size(pnode) - ALLOCATE (x(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbond_numer', 'x', 3 * natoms ) - ALLOCATE (s(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbond_numer', 's', 3 * natoms ) - DO i = 1, natoms - x(:,i) = pnode(i) % p % r ( : ) - s(:,i) = matmul(box % h_inv,pnode(i) % p % r) - END DO - box_local = box - -! Initializing pv_test - pv_test = 0.0_dbl -! Defining the increments - idelta = 1.0_dbl/(2.0_dbl*delta) - LOOP1: DO ii = 1, 3 - LOOP2: DO jj = 1, 3 - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - -! get inverse - CALL get_hinv(box_local) - -! get coords from perturbed hmat - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL vnumer_bonds(molecule,x,vp) - -! tweak again - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) - 2.0_dbl*delta - -! get inverse - CALL get_hinv ( box_local ) - -! get coords from perturbed hmat - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL vnumer_bonds(molecule,x,vm) - -! calculate the derivative - dvdh(ii,jj) = (vm-vp)*idelta -! resetting the hmat - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - CALL get_hinv(box_local) - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - END DO LOOP2 - END DO LOOP1 - -! computing pv_test - DO i = 1, 3 - DO j = 1, 3 - DO k = 1, 3 - pv_test(i,j) = pv_test(i,j) + dvdh(i,k)*box_local % hmat(j,k) - END DO - END DO - END DO - - DEALLOCATE (x,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbond_numer', 'x' ) - DEALLOCATE (s,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbond_numer', 's' ) - -END SUBROUTINE pvbond_numer - -!****************************************************************************** - -SUBROUTINE pvbend_numer(molecule,pv_test,box,pnode,delta) - -! computes the numerical pressure tensor - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule - TYPE ( particle_node_type ), INTENT ( IN ), DIMENSION ( : ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: pv_test - REAL ( dbl ), INTENT ( IN ) :: delta - -! Locals - TYPE (cell_type) :: box_local - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: x, s - REAL ( dbl ), DIMENSION (3,3) :: dvdh - REAL ( dbl ) :: idelta, vm, vp, vnb - INTEGER :: i, j, k, ii, jj, natoms, isos - -!------------------------------------------------------------------------------ - -! assigning the local variables - natoms = size(pnode) - ALLOCATE (x(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbend_numer', 'x', 3 * natoms ) - ALLOCATE (s(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbend_numer', 's', 3 * natoms ) - DO i = 1, natoms - x(:,i) = pnode(i) % p % r ( : ) - s(:,i) = matmul(box % h_inv,pnode(i) % p % r) - END DO - box_local = box - -! Initializing pv_test - pv_test = 0.0_dbl - -! Defining the increments - idelta = 1.0_dbl/(2.0_dbl*delta) - LOOP1: DO ii = 1, 3 - LOOP2: DO jj = 1, 3 - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta -! get inverse - CALL get_hinv(box_local) -! get coords from perturbed hmat - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL vnumer_bends(molecule,x,vp) -! tweak again - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) - 2.0_dbl*delta -! get inverse - CALL get_hinv(box_local) -! get coords from perturbed hmat - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL vnumer_bends(molecule,x,vm) -! calculate the derivative - dvdh(ii,jj) = (vm-vp)*idelta -! resetting the hmat - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - CALL get_hinv(box_local) - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - END DO LOOP2 - END DO LOOP1 - -! computing pv_test - DO i = 1, 3 - DO j = 1, 3 - DO k = 1, 3 - pv_test(i,j) = pv_test(i,j) + dvdh(i,k)*box_local % hmat(j,k) - END DO - END DO - END DO - - DEALLOCATE (x,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbend_numer', 'x' ) - DEALLOCATE (s,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvbend_numer', 's' ) - -END SUBROUTINE pvbend_numer - -!****************************************************************************** - -SUBROUTINE ptens_numer(pnode,box,potparm,pv_test,delta) - -! computes the numerical pressure tensor - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( IN ) :: delta - REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( OUT ) :: pv_test - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -! Locals - TYPE ( cell_type ) :: box_local - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: x, s - REAL ( dbl ), DIMENSION (3,3) :: dvdh - REAL ( dbl ) :: idelta, vm, vp, vnb - INTEGER :: i, j, k, ii, jj, natoms, isos - -!------------------------------------------------------------------------------ - -! assigning the local variables - natoms = size(pnode) - ALLOCATE (x(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'ptens_numer', 'x', 3 * natoms ) - ALLOCATE (s(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'ptens_numer', 's', 3 * natoms ) - - DO i = 1, natoms - x(:,i) = pnode(i) % p % r ( : ) - s(:,i) = matmul(box % h_inv,pnode(i) % p % r) - END DO - box_local = box - -! Initializing pv_test - pv_test = 0.0_dbl - -! Defining the increments - idelta = 1.0_dbl / (2.0_dbl * delta ) - LOOP1: DO ii = 1, 3 - LOOP2: DO jj = 1, 3 - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - -! get inverse - CALL get_hinv(box_local) - -! get coords from perturbed hmat - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL getv_ptens(pnode,x,vnb,box_local,potparm) - vp = vnb - -! tweak again - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) - 2.0_dbl*delta - CALL get_hinv(box_local) - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - CALL getv_ptens(pnode,x,vnb,box_local,potparm) - vm = vnb - -! calculate the derivative - dvdh(ii,jj) = (vm-vp)*idelta - -! resetting the hmat - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - CALL get_hinv(box_local) - DO i = 1, natoms - x(:,i) = matmul(box_local % hmat,s(:,i)) - END DO - END DO LOOP2 - END DO LOOP1 - -! computing pv_test - DO i = 1, 3 - DO j = 1, 3 - DO k = 1, 3 - pv_test(i,j) = pv_test(i,j) + dvdh(i,k)*box_local % hmat(j,k) - END DO - END DO - END DO - - DEALLOCATE (x,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'ptens_numer', 'x' ) - DEALLOCATE (s,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'ptens_numer', 's' ) - -END SUBROUTINE ptens_numer - -!****************************************************************************** - -SUBROUTINE pvg_numer(ewald_param,pnode,box,potparm,pw_grid,pv_test,delta) - -! computes the numerical pressure tensor - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( IN ) :: delta - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_test - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -! Locals - TYPE ( cell_type ) :: box_local - REAL ( dbl ), DIMENSION (3,3) :: dvdh - REAL ( dbl ) :: idelta, vm, vp - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: glocal - TYPE ( particle_node_type ), DIMENSION ( : ), ALLOCATABLE :: pnode_local - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: s - REAL ( dbl ) :: alpha, epsilon0 - COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: sum_igr - REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: gauss - INTEGER :: i, j, k, ii, jj, ig, ngtot, natoms, isos, lp, mp, np - -!------------------------------------------------------------------------------ - -! allocating - natoms = SIZE ( pnode ) - ALLOCATE ( s ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 's', 3 * natoms ) - ngtot = pw_grid % ngpts_cut - ALLOCATE (sum_igr(ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'sum_igr', ngtot ) - ALLOCATE (gauss(ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'gauss', ngtot ) - ALLOCATE (glocal(3,ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'glocal', 3 * ngtot ) - ALLOCATE (pnode_local(natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'pvg_numer', 'pnode_local', natoms ) - -! assigning the local variables - box_local = box - pnode_local = pnode - DO i = 1, natoms - s(:,i) = matmul(box % h_inv,pnode(i) % p % r) - END DO - -! defining alpha and epsilon0 (see ewald.f for details) - alpha = ewald_param % alpha - epsilon0 = ewald_param % eps0 - -! Initializing pv_test - pv_test = 0.0_dbl - -! Defining the increments - idelta = 1.0_dbl/(2.0_dbl*delta) - LOOP1: DO ii = 1, 3 - LOOP2: DO jj = 1, 3 - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - -! get inverse - CALL get_hinv(box_local) - -! recompute new partical postions from old scaled coords. - DO i = 1, natoms - pnode_local(i) % p % r = matmul(box_local % hmat,s(:,i)) - END DO - -! compute the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - glocal(1,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,1) * lp & - + box % h_inv(2,1) * mp & - + box % h_inv(3,1) * np ) - glocal(2,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,2) * lp & - + box % h_inv(2,2) * mp & - + box % h_inv(3,2) * np ) - glocal(3,ig) = 2.0_dbl * pi * & - ( box % h_inv(1,3) * lp & - + box % h_inv(2,3) * mp & - + box % h_inv(3,3) * np ) - END DO - - CALL potential_g_numer ( vp, pnode_local, sum_igr, gauss, alpha, & - glocal, ngtot ) - vp = vp / ( epsilon0 * box_local % deth ) - -! tweak again - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) - 2.0_dbl * delta - -! get inverse - CALL get_hinv ( box_local ) - -! recompute new partical postions from old scaled coords. - DO i = 1, natoms - pnode_local(i) % p % r = matmul(box_local % hmat,s(:,i)) - END DO - -! compute the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - - glocal ( 1, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 1 ) * lp & - + box % h_inv ( 2, 1 ) * mp & - + box % h_inv ( 3, 1 ) * np ) - glocal ( 2, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 2 ) * lp & - + box % h_inv ( 2, 2 ) * mp & - + box % h_inv ( 3, 2 ) * np ) - glocal ( 3, ig ) = 2.0_dbl * pi * & - ( box % h_inv ( 1, 3 ) * lp & - + box % h_inv ( 2, 3 ) * mp & - + box % h_inv ( 3, 3 ) * np ) - END DO - CALL potential_g_numer ( vm, pnode_local, sum_igr, gauss, alpha, & - glocal, ngtot ) - vm = vm / epsilon0 / box_local % deth - -! calculate the derivative - dvdh ( ii, jj ) = ( vm - vp ) * idelta - -! resetting the hmat - box_local % hmat(ii,jj) = box_local % hmat(ii,jj) + delta - END DO LOOP2 - END DO LOOP1 - -! computing pv_test - DO i = 1, 3 - DO j = 1, 3 - DO k = 1, 3 - pv_test(i,j) = pv_test(i,j) + dvdh(i,k)*box_local % hmat(j,k) - END DO - END DO - END DO - - DEALLOCATE (s,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 's' ) - DEALLOCATE (sum_igr,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'sum_igr' ) - DEALLOCATE (gauss,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'gauss' ) - DEALLOCATE (glocal,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'glocal' ) - DEALLOCATE (pnode_local,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'pvg_numer', 'pnode_local' ) - -END SUBROUTINE pvg_numer - -!****************************************************************************** - -SUBROUTINE potential_g_numer(energy,pnode,sum_igr,gauss,alpha, & - glocal,ngtot) - - IMPLICIT NONE - -! Arguments - TYPE (particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - REAL ( dbl ), INTENT ( OUT ) :: energy - REAL ( dbl ), INTENT ( IN ) :: alpha - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: glocal - COMPLEX ( dbl ), INTENT ( OUT ), DIMENSION ( : ) :: sum_igr - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( : ) :: gauss - INTEGER, INTENT ( IN ) :: ngtot - -! Locals - REAL ( dbl ) :: gdotr, gsq, charge - INTEGER :: iatom, ig, natoms - -!------------------------------------------------------------------------------ - -! numerical energy - natoms = SIZE ( pnode ) - energy = 0.0_dbl - sum_igr = 0.0_dbl - DO ig = 1, ngtot - gsq = dot_product(glocal(:,ig),glocal(:,ig)) - gauss(ig) = exp(-gsq*.25_dbl/alpha/alpha)/gsq - DO iatom = 1, natoms - gdotr = dot_product(pnode(iatom) % p % r ( : ),glocal(:,ig)) - charge = pnode(iatom) % p % prop % charge - sum_igr(ig) = sum_igr(ig) + charge*cmplx(cos(gdotr),sin(gdotr)) - END DO - -! computing the potential energy - energy = energy + gauss(ig)*sum_igr(ig)*conjg(sum_igr(ig)) - END DO - -END SUBROUTINE potential_g_numer - -!****************************************************************************** - -SUBROUTINE de_g_numer(energy,sum_igr,gauss,r,r_delta,charge,glocal, & - igtot) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: charge - COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: sum_igr - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: gauss - REAL ( dbl ), INTENT ( OUT ) :: energy - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: glocal - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: r, r_delta - INTEGER, INTENT ( IN ) :: igtot - -! Locals - INTEGER :: ig - REAL ( dbl ) :: gdotr, gdotr_delta - COMPLEX ( dbl ) :: sum - -!------------------------------------------------------------------------------ - -! initialize energy - energy = 0._dbl - DO ig = 1, igtot -! compute g.r and g.(r+delta) - gdotr = dot_product(r ( : ),glocal(:,ig)) - gdotr_delta = dot_product(r_delta ( : ),glocal(:,ig)) -! subtract off exp(ig.r) and add exp(ig.(r+delta)) - sum = sum_igr(ig) - charge*cmplx(cos(gdotr),sin(gdotr)) + & - charge*cmplx(cos(gdotr_delta),sin(gdotr_delta)) -! recompute energy - energy = energy + gauss(ig)*sum*conjg(sum) - END DO - -END SUBROUTINE de_g_numer - -!****************************************************************************** - -SUBROUTINE energy_recip_numer ( ewald_param, pnode, box, potparm, pw_grid, & - energy_numer, ngtot ) - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - REAL ( dbl ), INTENT ( OUT ) :: energy_numer - INTEGER, INTENT ( IN ) :: ngtot - -! Locals - COMPLEX ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: sum_igr - REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: gauss - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: gdebug - INTEGER :: ig, i, idim, isos, lp, mp, np - REAL ( dbl ) :: alpha, epsilon0, ep, em, charge - -!------------------------------------------------------------------------------ - -! allocating - ALLOCATE (gdebug(3,ngtot),STAT=isos) - IF ( isos /= 0 ) & - CALL stop_memory ( 'energy_recip_numer', 'gdebug', 3 * ngtot ) - ALLOCATE ( sum_igr ( ngtot ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'sum_igr', ngtot ) - ALLOCATE (gauss(ngtot),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'gauss', ngtot ) - -! computing the g-vectors - DO ig = 1, ngtot - lp = pw_grid % mapl % pos ( pw_grid % g_hat(1,ig) ) - mp = pw_grid % mapm % pos ( pw_grid % g_hat(2,ig) ) - np = pw_grid % mapn % pos ( pw_grid % g_hat(3,ig) ) - gdebug(1,ig) = 2.0_dbl*pi*(box % h_inv(1,1)*lp+box % h_inv(2,1)*mp & - +box % h_inv(3,1)*np) - gdebug(2,ig) = 2.0_dbl*pi*(box % h_inv(1,2)*lp+box % h_inv(2,2)*mp & - +box % h_inv(3,2)*np) - gdebug(3,ig) = 2.0_dbl*pi*(box % h_inv(1,3)*lp+box % h_inv(2,3)*mp & - +box % h_inv(3,3)*np) - END DO - -! defining alpha and epsilon0 (see ewald.f for details) - alpha = ewald_param % alpha - epsilon0 = ewald_param % eps0 - -! initializing numerical energy - energy_numer = 0.0_dbl - -! computing the energy - CALL potential_g_numer(energy_numer,pnode,sum_igr,gauss,alpha, & - gdebug,ngtot) - energy_numer = energy_numer/epsilon0/box % deth - - DEALLOCATE (gdebug,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'gdebug' ) - DEALLOCATE (sum_igr,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'sum_igr' ) - DEALLOCATE (gauss,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'energy_recip_numer', 'gauss' ) - -END SUBROUTINE energy_recip_numer - -!****************************************************************************** - -SUBROUTINE vnumer_bonds ( molecule, x, energy ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( OUT ) :: energy - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: x - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - -! Locals - REAL ( dbl ), DIMENSION ( 3 ) :: rij - REAL ( dbl ) :: e0, fscalar - INTEGER :: imol, ibond - TYPE ( linklist_bonds ), POINTER :: llbond - -!------------------------------------------------------------------------------ - -! initializing - energy = 0.0_dbl - MOL: DO imol = 1, SIZE ( molecule ) - llbond => molecule ( imol ) % ll_bonds - BOND: DO ibond = 1, molecule ( imol ) % nbonds_mol - rij = x ( :, llbond % index ( 1 ) ) - x ( :, llbond % index ( 2 ) ) - CALL force_bonds ( rij, llbond % bond_param % r0, & - llbond % bond_param % k, e0, fscalar ) - energy = energy + e0 - llbond => llbond % next - END DO BOND - END DO MOL - -END SUBROUTINE vnumer_bonds - -!****************************************************************************** - -SUBROUTINE vnumer_bends ( molecule, x, energy ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( OUT ) :: energy - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: x - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - -! Locals - REAL ( dbl ), DIMENSION (3) :: b12, b32, g1, g2, g3 - REAL ( dbl ) :: d12, d32, id12, id32, dist, theta, e0, fscalar - INTEGER :: imol, ibend - TYPE ( linklist_bends ), POINTER :: llbend - -!------------------------------------------------------------------------------ - -! initializing - energy = 0.0_dbl - MOL: DO imol = 1, SIZE ( molecule ) - llbend => molecule ( imol ) % ll_bends - BEND: DO ibend = 1, molecule ( imol ) % nbends_mol - b12 = x(:,llbend % index(1)) - x(:,llbend % index(2)) - b32 = x(:,llbend % index(3)) - x(:,llbend % index(2)) - d12 = SQRT ( DOT_PRODUCT ( b12, b12 ) ) - d32 = SQRT ( DOT_PRODUCT ( b32, b32 ) ) - id12 = 1.0_dbl / d12 - id32 = 1.0_dbl / d32 - dist = DOT_PRODUCT ( b12, b32 ) - theta = ACOS ( dist * id12 * id32 ) - CALL force_bends ( b12, b32, d12, d32, id12, id32, dist, theta, & - llbend % bend_param % theta0, llbend % bend_param % k, & - g1, g2, g3, e0, fscalar ) - energy = energy + e0 - llbend => llbend % next - END DO BEND - END DO MOL - -END SUBROUTINE vnumer_bends - -!****************************************************************************** - -SUBROUTINE getv_ptens ( pnode, x, vnb, box, potparm ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: x - REAL ( dbl ), INTENT ( INOUT ) :: vnb - TYPE (cell_type), INTENT ( INOUT ) :: box - TYPE (particle_node_type ), INTENT ( IN ), DIMENSION ( : ) :: pnode - TYPE (potentialparm_type), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - -! Locals - INTEGER :: i, j, ii, jj, iatomtype, jatomtype, iexclude, natoms, id - INTEGER :: zz,yy,xx - INTEGER :: icell, jcell, kcell, n, itype, jtype, isos - REAL ( dbl ), DIMENSION (3) :: vec,ri,rij,cell,s,perd,quotient - REAL ( dbl ) :: energy, fscalar, rijsq, qi, qj, rcut - TYPE (linklist_exclusion), POINTER :: ll_exclude - LOGICAL :: match - INTEGER, DIMENSION ( :, :, : ), ALLOCATABLE :: ncell - -!------------------------------------------------------------------------------ - - n = SIZE ( potparm ( :, 1 ) ) - - isos = 0 - IF ( .NOT. ALLOCATED ( ncell ) ) ALLOCATE ( ncell ( n, n, 3 ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_nonbond_numer', 'ncell', n * n * 3 ) - - CALL get_cell_param ( box, cell ) - DO itype = 1, n - DO jtype = 1, n - rcut = SQRT ( potparm ( itype, jtype ) % rcutsq ) - quotient ( : ) = rcut / cell ( : ) - DO id = 1, 3 - IF ( quotient ( id ) <= 0.5_dbl ) THEN - ncell ( itype, jtype, id ) = 0 - ELSE - ncell ( itype, jtype, id ) = CEILING ( rcut/ cell ( id ) ) - END IF - END DO - END DO - END DO - -! -! initializing the potential energy -! - vnb = 0.0_dbl - -! -! starting the loop -! - CALL get_hinv ( box ) - CALL get_cell_param ( box, cell ) - perd = box % perd - natoms = size(pnode) - ILOOP: DO i = 1, natoms - iatomtype = pnode(i) % p % prop % ptype - qi = pnode(i) % p % prop % charge - ri = x(:,i) - JLOOP: DO j = 1, natoms - IF (j>i) THEN - jatomtype = pnode(j) % p % prop % ptype - qj = pnode(j) % p % prop % charge - rij = x(:,j) - ri - -! -! imaging,transform back to unscaled distances and get potential -! - IF ( MAXVAL ( ncell ( iatomtype, jatomtype, : ) ) == 0 ) THEN - rij = pbc ( rij, box ) - END IF - - rijsq = DOT_PRODUCT ( rij, rij ) - - IF ( rijsq <= potparm ( iatomtype, jatomtype ) % rcutsq ) THEN - -! pointing to the start of the exclusion list of particle i - ll_exclude => pnode(i) % ex - match = .FALSE. - - EXCL: DO iexclude = 1, pnode(i) % nexcl - IF (ll_exclude % p % iatom==j) THEN - match = .TRUE. - EXIT EXCL - END IF - ll_exclude => ll_exclude % next - END DO EXCL - - NOTMATCH: IF ( .NOT. match) THEN - CALL potential_f ( rijsq, potparm, qi, qj, & - iatomtype, jatomtype, energy ) - -! -! summing up the potential energy -! - vnb = vnb + energy - END IF NOTMATCH - END IF - -! searching images if needed - zz = ncell(iatomtype,jatomtype,3) - yy = ncell(iatomtype,jatomtype,2) - xx = ncell(iatomtype,jatomtype,1) - s(1) = box % h_inv(1,1)*rij(1) & - + box % h_inv(1,2)*rij(2) & - + box % h_inv(1,3)*rij(3) - s(2) = box % h_inv(2,1)*rij(1) & - + box % h_inv(2,2)*rij(2) & - + box % h_inv(2,3)*rij(3) - s(3) = box % h_inv(3,1)*rij(1) & - + box % h_inv(3,2)*rij(2) & - + box % h_inv(3,3)*rij(3) - DO kcell = -zz,zz - DO jcell = -yy,yy - DO icell = -xx,xx - IF (icell==0.AND.jcell==0.AND.kcell==0) CYCLE - vec ( : ) = (/icell,jcell,kcell/) - CALL find_image(s,perd,vec,box % hmat,rijsq,rij) - IF ( rijsq <= potparm ( iatomtype, jatomtype ) % rcutsq ) & - THEN - CALL potential_f ( rijsq, potparm, qi, qj, & - iatomtype,jatomtype, energy ) - vnb = vnb + energy - END IF - END DO - END DO - END DO - - ELSE IF ( i == j ) THEN -! search images if needed - zz = ncell(iatomtype,iatomtype,3) - yy = ncell(iatomtype,iatomtype,2) - xx = ncell(iatomtype,iatomtype,1) - s = 0.0_dbl - DO kcell = -zz,zz - DO jcell = -yy,yy - DO icell = -xx,xx - IF ( icell == 0 .AND. jcell == 0 .AND. kcell == 0 ) CYCLE - - vec ( : ) = (/ icell, jcell, kcell /) - CALL find_image ( s, perd, vec, box % hmat, rijsq, rij ) - IF ( rijsq <= potparm ( iatomtype, iatomtype ) % rcutsq ) & - THEN - CALL potential_f ( rijsq, potparm, qi, qi, & - iatomtype, iatomtype, energy ) - vnb = vnb + energy - END IF - - END DO - END DO - END DO - END IF - - END DO JLOOP - END DO ILOOP - -END SUBROUTINE getv_ptens - -!****************************************************************************** - -END MODULE fist_force_numer diff --git a/src/fist_global.c b/src/fist_global.c deleted file mode 100644 index 560c6cb..0000000 --- a/src/fist_global.c +++ /dev/null @@ -1,39 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -!! Definition of some global variables for the FIST code - -MODULE fist_global - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: set_fist_global, fistpar - - TYPE ( global_environment_type ) :: fistpar - -CONTAINS - -!****************************************************************************** - -SUBROUTINE set_fist_global ( glopar ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( IN ) :: glopar - -!------------------------------------------------------------------------------ - - fistpar = glopar - -END SUBROUTINE set_fist_global - -!****************************************************************************** - -END MODULE fist_global diff --git a/src/fist_input.c b/src/fist_input.c deleted file mode 100644 index ff0327e..0000000 --- a/src/fist_input.c +++ /dev/null @@ -1,167 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist_input - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE global_types, ONLY : global_environment_type - USE input_types, ONLY : setup_parameters_type - USE kinds, ONLY : dbl - USE mp, ONLY : mp_bcast - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int, stop_parser - USE string_utilities, ONLY : uppercase, xstring - - PRIVATE - PUBLIC :: read_fist_section - -CONTAINS - -!!>---------------------------------------------------------------------------! -!! SECTION: &fist ... &end ! -!! ! -!! simulation [md,debug] ! -!! printlevel fistpar%print_level ! -!! units [kelvin,atomic] ! -!! periodic [0,1][0,1][0,1] ! -!! Ewald_type [pme_gauss,ewald_gauss] ! -!! Ewald_param alpha,[gmax,ns_max,epsilon] ! -!! set_file "filename" ! -!! input_file "filename" ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_fist_section ( setup, ewald_param, fistpar ) - - IMPLICIT NONE - -! Arguments - TYPE ( setup_parameters_type ), INTENT ( INOUT ) :: setup - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( global_environment_type ), INTENT ( INOUT ) :: fistpar - -! Locals - INTEGER :: ierror, ilen, ia, ie, i, j, n, iw, source, group - CHARACTER ( LEN = 20 ) :: string - CHARACTER ( LEN = 5 ) :: label - CHARACTER ( LEN = 3 ), PARAMETER :: yn ( 0:1 ) = (/ ' NO', 'YES' /) - -!------------------------------------------------------------------------------ - -!..defaults - setup % run_type = 'MD' - setup % unit_type = 'KELVIN' - setup % perd = 1 - ewald_param % alpha = 0.4_dbl - ewald_param % gmax = 10 - ewald_param % ns_max = 10 - ewald_param % epsilon = 1.e-6_dbl - ewald_param % ewald_type = 'NONE' - CALL xstring(fistpar % project_name,ia,ie) - setup % set_file_name = fistpar % project_name(ia:ie) // '.set' - setup % input_file_name = fistpar % project_name(ia:ie) // '.dat' - - iw = fistpar % scr - -!..parse the input section - label = '&FIST' - CALL parser_init(fistpar % input_file_name,label,ierror,fistpar) - IF (ierror /= 0 ) THEN - IF (fistpar % ionode) & - WRITE ( iw, '( a )' ) ' No input section &FIST found ' - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 8 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error() - CALL stop_parser( 'read_fist','unknown option') - CASE ( 'SIMULATI') - ilen = 20 - CALL cfield(setup % run_type,ilen) - CALL uppercase(setup % run_type ) - CASE ( 'PRINTLEV') - fistpar % print_level = get_int() - CASE ( 'UNITS') - ilen = 20 - CALL cfield(setup % unit_type,ilen) - CALL uppercase(setup % unit_type ) - CASE ( 'PERIODIC') - setup % perd(1) = get_int() - setup % perd(2) = get_int() - setup % perd(3) = get_int() - CASE ( 'EWALD_TY') - ilen=20 - CALL cfield(string,ILEN) - CALL uppercase ( string ) - SELECT CASE(string) - CASE( 'EWALD_GAUSS') - ewald_param % ewald_type = 'ewald_gauss' - CALL uppercase(ewald_param % ewald_type ) - CASE( 'PME_GAUSS') - ewald_param % ewald_type = 'pme_gauss' - CALL uppercase(ewald_param % ewald_type ) - END SELECT - -! if no type specified, assume ewald_gauss - CASE ( 'EWALD_PA') - ewald_param % alpha = get_real() - SELECT CASE (ewald_param % ewald_TYPE ( 1:3)) - CASE DEFAULT - ewald_param % gmax = get_int() - CASE ( 'PME') - ewald_param % ns_max = get_int() - IF ( test_next() == 'N' ) THEN - ewald_param % epsilon = get_real() - END IF - END SELECT - CASE ( 'SET_FILE') - ilen = 20 - CALL cfield(setup % set_file_name,ilen) - CASE ( 'INPUT_FI') - ilen = 20 - CALL cfield(setup % input_file_name,ilen) - END SELECT - -! check for trailing rubbish - CALL read_line - END DO - - END IF - CALL parser_end -!..end of parsing the input section - -!..write some information to output - IF (fistpar % ionode) THEN - IF ( fistpar % print_level >= 0 ) THEN - WRITE ( iw, '( A, T71, A )' ) & - ' FIST| Run type ', ADJUSTR ( setup % run_type ) - WRITE ( iw, '( A, T71, A )' ) & - ' FIST| Unit type ', ADJUSTR ( setup % unit_type ) - WRITE ( iw, '( A, T78, A )' ) ' FIST| Periodic in X direction ', & - yn(setup % perd(1)) - WRITE ( iw, '( A, T78, A )' ) ' FIST| Periodic in Y direction ', & - yn(setup % perd(2)) - WRITE ( iw, '( A, T78, A )' ) ' FIST| Periodic in Z direction ', & - yn(setup % perd(3)) - - WRITE ( iw, '( A, T61, A )' ) ' FIST| Set file name', & - ADJUSTR ( setup % set_file_name ) - WRITE ( iw, '( A, T61, A )' ) ' FIST| Input file name', & - ADJUSTR ( setup % input_file_name ) - WRITE ( iw, '( A, T76, I5 )' ) & - ' FIST| Print level ', fistpar % print_level - WRITE ( iw, '( )' ) - END IF - END IF - -END SUBROUTINE read_fist_section - -!****************************************************************************** - -END MODULE fist_input diff --git a/src/fist_intra_force.c b/src/fist_intra_force.c deleted file mode 100644 index ad7edfe..0000000 --- a/src/fist_intra_force.c +++ /dev/null @@ -1,118 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist_intra_force - - USE kinds, ONLY : dbl - USE mol_force, ONLY : force_bonds, force_bends, force_torsions, & - get_pv_bond, get_pv_bend, get_pv_torsion - USE molecule_types, ONLY : molecule_structure_type, linklist_bonds, & - linklist_bends - - IMPLICIT NONE - - PRIVATE - PUBLIC :: force_intra_control - -CONTAINS - -!****************************************************************************** - -SUBROUTINE force_intra_control ( molecule, v_bond, v_bend, pvbond, pvbend, & - f_bond, f_bend ) - -! parses up intramolecular properties - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - REAL ( dbl ), INTENT ( INOUT ) :: v_bond, v_bend - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: pvbond, pvbend - REAL ( dbl ), DIMENSION ( :, : ), OPTIONAL, INTENT ( OUT ) :: f_bond, f_bend - -! Locals - REAL ( dbl ) :: d12, d32, id12, id32, dist, theta - REAL ( dbl ) :: energy, fscalar - REAL ( dbl ), DIMENSION (3) :: rij, b12, b32, g1, g2, g3 - TYPE (linklist_bonds), POINTER :: llbond - TYPE (linklist_bends), POINTER :: llbend - INTEGER :: ibond, ibend, imol - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( f_bond)) f_bond = 0._dbl - IF ( PRESENT ( f_bend)) f_bend = 0._dbl - v_bond = 0._dbl - v_bend = 0._dbl - - MOL: DO imol = 1, size(molecule) - llbond => molecule(imol) %ll_bonds - llbend => molecule(imol) %ll_bends - - BOND: DO ibond = 1, molecule(imol) %nbonds_mol - rij = llbond%p1%r - llbond%p2%r - CALL force_bonds(rij,llbond%bond_param%r0,llbond%bond_param%k, & - energy,fscalar) - v_bond = v_bond + energy - llbond%p1%f = llbond%p1%f - rij*fscalar - llbond%p2%f = llbond%p2%f + rij*fscalar - -! computing the pressure tensor - CALL get_pv_bond ( -rij * fscalar, rij * fscalar, & - llbond%p1%r, llbond%p2%r, pvbond ) - -! the contribution from the bonds. ONLY FOR DEBUG - IF ( PRESENT ( f_bond)) THEN - f_bond(:,llbond%index(1)) = f_bond(:,llbond%index(1)) - & - rij*fscalar - f_bond(:,llbond%index(2)) = f_bond(:,llbond%index(2)) + & - rij*fscalar - END IF - - llbond => llbond%next - END DO BOND - - BEND: DO ibend = 1, molecule(imol) %nbends_mol - b12 = llbend%p1%r - llbend%p2%r - b32 = llbend%p3%r - llbend%p2%r - d12 = sqrt(dot_product(b12,b12)) - id12 = 1._dbl/d12 - d32 = sqrt(dot_product(b32,b32)) - id32 = 1._dbl/d32 - dist = dot_product(b12,b32) - theta = acos(dist*id12*id32) - CALL force_bends(b12,b32,d12,d32,id12,id32,dist,theta, & - llbend%bend_param%theta0,llbend%bend_param%k,g1,g2,g3,energy, & - fscalar) - v_bend = v_bend + energy - llbend%p1%f = llbend%p1%f + fscalar*g1 - llbend%p2%f = llbend%p2%f + fscalar*g2 - llbend%p3%f = llbend%p3%f + fscalar*g3 - -! computing the pressure tensor - CALL get_pv_bend(fscalar*g1,fscalar*g2,fscalar*g3,llbend%p1%r, & - llbend%p2%r,llbend%p3%r,pvbend) - -! the contribution from the bends. ONLY FOR DEBUG - IF ( PRESENT ( f_bend)) THEN - f_bend(:,llbend%index(1)) = f_bend(:,llbend%index(1)) + & - fscalar*g1 - f_bend(:,llbend%index(2)) = f_bend(:,llbend%index(2)) + & - fscalar*g2 - f_bend(:,llbend%index(3)) = f_bend(:,llbend%index(3)) + & - fscalar*g3 - END IF - - llbend => llbend%next - END DO BEND - - END DO MOL - -END SUBROUTINE force_intra_control - -!****************************************************************************** - -END MODULE fist_intra_force diff --git a/src/fist_nonbond_force.c b/src/fist_nonbond_force.c deleted file mode 100644 index 2215599..0000000 --- a/src/fist_nonbond_force.c +++ /dev/null @@ -1,381 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE fist_nonbond_force - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi, zero - USE molecule_types, ONLY : molecule_structure_type, particle_node_type, & - linklist_atoms, linklist_neighbor, linklist_exclusion, linklist_images - USE pair_potential, ONLY : potential_s, potentialparm_type - USE simulation_cell, ONLY : cell_type, pbc, get_cell_param - USE stop_program, ONLY : stop_memory - USE timings, ONLY : timeset, timestop - USE util, ONLY : include_list - - IMPLICIT NONE - - PRIVATE - PUBLIC :: force_nonbond, bonded_correct_gaussian, find_image - -CONTAINS - -!****************************************************************************** - -SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, & - f_nonbond, ptens_nonbond ) - -! Calculates the force and the potential of the minimum image, and -! the pressure tensor -! - IMPLICIT NONE - -! Arguments - TYPE (ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - TYPE (particle_node_type ), INTENT ( IN ), DIMENSION ( : ) :: pnode - TYPE (cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( OUT ) :: pot_nonbond - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: f_nonbond - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: ptens_nonbond - REAL ( dbl ), ALLOCATABLE, SAVE , DIMENSION ( :, : ) :: rtest - -! Locals - INTEGER :: i, j, ii, jj, iatomtype, jatomtype, imol, nmol, iat - INTEGER :: id,itype,jtype,isos,natom_types - INTEGER :: jatom, handle, ios, im - REAL ( dbl ), DIMENSION (3) :: ri, rij, s, perd, & - vec, quotient, cell_lengths - REAL ( dbl ), DIMENSION (3,3) :: hmat, h_inv - REAL ( dbl ) :: energy, fscalar, rijsq, flops, rcut - TYPE (linklist_neighbor), POINTER :: current_neighbor - TYPE (linklist_images), POINTER :: current_image - INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: n_images - LOGICAL :: first_time - -!------------------------------------------------------------------------------ - - CALL timeset ( 'NONBOND', 'E', 'Mflops', handle ) - flops = zero - -! initializing the potential energy, pressure tensor and force - pot_nonbond = zero - f_nonbond = zero - ptens_nonbond = zero - -! local copies of the box parameters - hmat = box % hmat - h_inv = box % h_inv - perd = box % perd - -! local copy of cutoffs - natom_types = SIZE ( potparm, 1 ) - IF ( .NOT. ALLOCATED ( rtest ) ) THEN - ALLOCATE ( rtest ( natom_types, natom_types ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'fist_nonbond_force', & - 'rtest', natom_types ** 2 ) - END IF - - DO i = 1, natom_types - DO j = 1, natom_types - rtest ( i, j ) = potparm ( i, j ) % rcutsq - END DO - END DO - - first_time = .NOT.ALLOCATED ( n_images ) - IF ( first_time ) THEN - IF ( .NOT. ALLOCATED ( n_images ) ) & - ALLOCATE ( n_images ( natom_types, natom_types, 3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'force_control', & - 'n_images', natom_types ** 2 * 3 ) - - CALL get_cell_param ( box, cell_lengths ) - - DO itype = 1, natom_types - DO jtype = 1, natom_types - rcut = SQRT ( potparm ( itype, jtype ) % rcutsq ) - quotient ( : ) = rcut / cell_lengths ( : ) - DO id=1,3 - IF ( quotient ( id ) <= 0.5_dbl ) THEN - n_images ( itype, jtype, id ) = 0 - ELSE - n_images ( itype, jtype, id ) & - = CEILING ( rcut / cell_lengths ( id ) ) - END IF - END DO - END DO - END DO - END IF - -! -! starting the force loop -! - DO iat = 1, SIZE ( pnode ) - iatomtype = pnode ( iat ) % p % prop % ptype - i = pnode ( iat ) % p % iatom - ri = pnode ( iat ) % p % r - -! now do neighbors - current_neighbor => pnode ( iat ) % nl - DO j = 1, pnode ( iat ) % nneighbor - jatom = current_neighbor % index - jatomtype = current_neighbor % p % prop % ptype - rij = current_neighbor % p % r - ri - -! -! apply periodic boundary conditions; the following code is the inline version -! of the general function pbc -! - s(1) = h_inv(1,1)*rij(1) + h_inv(1,2)*rij(2) + h_inv(1,3)*rij(3) - s(2) = h_inv(2,1)*rij(1) + h_inv(2,2)*rij(2) + h_inv(2,3)*rij(3) - s(3) = h_inv(3,1)*rij(1) + h_inv(3,2)*rij(2) + h_inv(3,3)*rij(3) - IF ( MAXVAL ( n_images ( iatomtype, jatomtype, : ) ) == 0 ) THEN - IF ( ABS ( s ( 1 ) ) > 0.5_dbl ) THEN - s(1) = s(1) - perd(1) * INT(s(1)+SIGN(0.5_dbl,s(1))) - END IF - IF ( ABS ( s ( 2 ) ) > 0.5_dbl ) THEN - s(2) = s(2) - perd(2) * INT(s(2)+SIGN(0.5_dbl,s(2))) - END IF - IF ( ABS ( s ( 3 ) ) > 0.5_dbl ) THEN - s(3) = s(3) - perd(3) * INT(s(3)+SIGN(0.5_dbl,s(3))) - END IF - rij(1) = hmat(1,1)*s(1) + hmat(1,2)*s(2) + hmat(1,3)*s(3) - rij(2) = hmat(2,1)*s(1) + hmat(2,2)*s(2) + hmat(2,3)*s(3) - rij(3) = hmat(3,1)*s(1) + hmat(3,2)*s(2) + hmat(3,3)*s(3) - END IF - - rijsq = rij ( 1 ) ** 2 + rij ( 2 ) ** 2 + rij ( 3 ) ** 2 - flops = flops + 41.0_dbl - IF ( iat /= jatom .AND. rijsq <= rtest ( iatomtype, jatomtype ) ) THEN - CALL potential_s ( rijsq, potparm, iatomtype, jatomtype, energy, & - fscalar ) - -! -! summing up the potential energy,the force and pressure tensor -! - CALL sum_ener_forces ( i, jatom, pot_nonbond, energy, & - fscalar, f_nonbond, rij, ptens_nonbond ) - flops = flops + 64.0_dbl - - END IF - -! -! now sum over lattice translations of neighbors -! - current_image => current_neighbor % image - DO im = 1, current_neighbor % nimages - - CALL find_image ( s, perd, current_image % vec, hmat, rijsq, rij ) - flops = flops + 41.0_dbl - - IF ( rijsq <= rtest ( iatomtype, jatomtype ) ) THEN - CALL potential_s ( rijsq, potparm, iatomtype, jatomtype, & - energy, fscalar ) -! -! summing up the potential energy,the force and pressure tensor -! - CALL sum_ener_forces ( i, jatom, pot_nonbond, energy, & - fscalar, f_nonbond, rij, ptens_nonbond ) - flops = flops + 64.0_dbl - END IF - - current_image => current_image % next - END DO - - current_neighbor => current_neighbor % next - END DO - - END DO - -! computing long range corrections to the potential -! -!when we get the system for handling multiple potentials -!we will add the long range correction -! -! pot_nonbond=pot_nonbond+lrc*(1./box % deth) -! - flops = flops * 1.E-6_dbl - CALL timestop ( flops, handle ) - -END SUBROUTINE force_nonbond - -!****************************************************************************** - -SUBROUTINE find_image ( s, perd, vec, hmat, rijsq, rij ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: s,perd - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: vec - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: hmat - REAL ( dbl ), INTENT ( OUT ) :: rijsq - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: rij - -! Locals - REAL ( dbl ) :: strans(3) - -!------------------------------------------------------------------------------ - - strans(1) = s(1) + perd(1)*vec(1) - strans(2) = s(2) + perd(2)*vec(2) - strans(3) = s(3) + perd(3)*vec(3) - rij(1) = hmat(1,1)*strans(1) + hmat(1,2)*strans(2) + hmat(1,3)*strans(3) - rij(2) = hmat(2,1)*strans(1) + hmat(2,2)*strans(2) + hmat(2,3)*strans(3) - rij(3) = hmat(3,1)*strans(1) + hmat(3,2)*strans(2) + hmat(3,3)*strans(3) - - rijsq = rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3) - -END SUBROUTINE find_image - -!****************************************************************************** - -SUBROUTINE sum_ener_forces ( i, j, pot, e, fs, f, rij, pv ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: i, j - REAL ( dbl ), INTENT ( INOUT ) :: pot - REAL ( dbl ), INTENT ( IN ) :: e, fs - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: f, pv - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: rij - -! Locals - REAL ( dbl ), DIMENSION(3) :: fr - -!------------------------------------------------------------------------------ - - pot = pot + e - f(1,i) = f(1,i) - fs*rij(1) - f(2,i) = f(2,i) - fs*rij(2) - f(3,i) = f(3,i) - fs*rij(3) - f(1,j) = f(1,j) + fs*rij(1) - f(2,j) = f(2,j) + fs*rij(2) - f(3,j) = f(3,j) + fs*rij(3) - fr(1) = rij(1)*fs - fr(2) = rij(2)*fs - fr(3) = rij(3)*fs - pv(1,1) = pv(1,1) + rij(1)*fr(1) - pv(1,2) = pv(1,2) + rij(1)*fr(2) - pv(1,3) = pv(1,3) + rij(1)*fr(3) - pv(2,1) = pv(2,1) + rij(2)*fr(1) - pv(2,2) = pv(2,2) + rij(2)*fr(2) - pv(2,3) = pv(2,3) + rij(2)*fr(3) - pv(3,1) = pv(3,1) + rij(3)*fr(1) - pv(3,2) = pv(3,2) + rij(3)*fr(2) - pv(3,3) = pv(3,3) + rij(3)*fr(3) - -END SUBROUTINE sum_ener_forces - -!****************************************************************************** - -SUBROUTINE bonded_correct_gaussian ( ewald_param, molecule, v_bonded_corr, & - pv_bc ) - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( molecule_structure_type ), INTENT ( IN ) :: molecule ( : ) - REAL ( dbl ), INTENT ( OUT ) :: v_bonded_corr - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( :, : ) :: pv_bc - -! Locals - TYPE ( linklist_exclusion ), POINTER :: llex - TYPE ( linklist_atoms ), POINTER :: llat -! parameters for the numerical erf in Abramowitz and Stegun Eq. 7.1.26 pg 299 - REAL ( dbl ), PARAMETER :: ac1 = 0.254829592_dbl, & - ac2 = -0.284496736_dbl, ac3 = 1.421413741_dbl, & - ac4 = -1.453152027_dbl, ac5 = 1.061405429_dbl, pc = 0.3275911_dbl - REAL ( dbl ) :: arg, e_arg_arg, tc, errf, alpha, fscalar, flops - REAL ( dbl ) :: const, ifourpieps0, dij, idij, rijsq, qi, qj - REAL ( dbl ), DIMENSION (3) :: rij - INTEGER :: i, j, nmol, imol, iat, handle - -!------------------------------------------------------------------------------ - - CALL timeset ( 'BOND_CORRECT_GAUSSIAN', 'E', 'Mflops', handle ) - flops = 0.0_dbl - -! defining the constants - pv_bc = 0.0_dbl - v_bonded_corr = 0.0_dbl - -! -! return !wdbg -! - alpha = ewald_param % alpha - const = 2.0_dbl * alpha / SQRT( pi ) - ifourpieps0 = 1.0_dbl / ( 4.0_dbl * pi * ewald_param % eps0 ) - - nmol = SIZE ( molecule ) - - DO imol = 1, nmol - llat => molecule ( imol ) % ll_atoms - - DO iat = 1, molecule ( imol ) % natoms_mol - qi = llat % part % p % prop % charge - llex => llat % part % ex - - DO j = 1, llat % part % nexcl -!defining the charge - qj = llex % p % prop % charge - rij(1) = llat % part % p % r(1) - llex % p % r(1) - rij(2) = llat % part % p % r(2) - llex % p % r(2) - rij(3) = llat % part % p % r(3) - llex % p % r(3) - rijsq = rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3) - dij = SQRT ( rijsq ) - idij = 1.0_dbl / dij - arg = alpha * dij - e_arg_arg = EXP ( -arg ** 2 ) - tc = 1.0_dbl / ( 1.0_dbl + pc * arg ) - -! defining errf=1-erfc - errf = 1.0_dbl & - - ((((ac5*tc+ac4)*tc+ac3)*tc+ac2)*tc+ac1) * tc * e_arg_arg - -! getting the potential - v_bonded_corr = v_bonded_corr - qi*qj*idij*errf - -! subtracting the force from the total force - fscalar = ifourpieps0 * qi * qj * idij ** 2 & - * ( idij * errf - const * EXP ( -alpha ** 2 * rijsq ) ) - - llat % part % p % f(1) = llat % part % p % f(1) - fscalar*rij(1) - llat % part % p % f(2) = llat % part % p % f(2) - fscalar*rij(2) - llat % part % p % f(3) = llat % part % p % f(3) - fscalar*rij(3) - -! computing the pressure tensor - pv_bc(1,1) = pv_bc(1,1) - fscalar * rij(1) * llat % part % p % r(1) - pv_bc(1,2) = pv_bc(1,2) - fscalar * rij(1) * llat % part % p % r(2) - pv_bc(1,3) = pv_bc(1,3) - fscalar * rij(1) * llat % part % p % r(3) - pv_bc(2,1) = pv_bc(2,1) - fscalar * rij(2) * llat % part % p % r(1) - pv_bc(2,2) = pv_bc(2,2) - fscalar * rij(2) * llat % part % p % r(2) - pv_bc(2,3) = pv_bc(2,3) - fscalar * rij(2) * llat % part % p % r(3) - pv_bc(3,1) = pv_bc(3,1) - fscalar * rij(3) * llat % part % p % r(1) - pv_bc(3,2) = pv_bc(3,2) - fscalar * rij(3) * llat % part % p % r(2) - pv_bc(3,3) = pv_bc(3,3) - fscalar * rij(3) * llat % part % p % r(3) - - flops = flops + 62.0_dbl - llex => llex % next - END DO - - llat => llat % next - END DO - END DO - -! the factor of 1/2 comes from double counting in the exclusion list - v_bonded_corr = v_bonded_corr * ifourpieps0 * 0.5_dbl - - flops = flops * 1.0E-6_dbl - CALL timestop ( flops, handle ) - -END SUBROUTINE bonded_correct_gaussian - -!****************************************************************************** - -END MODULE fist_nonbond_force diff --git a/src/force_control.c b/src/force_control.c deleted file mode 100644 index 5a96156..0000000 --- a/src/force_control.c +++ /dev/null @@ -1,61 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE force_control - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE fist_force, ONLY : fist_force_control => force_control - USE fist_global, ONLY : fistpar - USE tbmd_force, ONLY : tbmd_force_control => force_control - USE tbmd_global, ONLY : tbmdpar - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type, thermodynamic_type - USE pair_potential, ONLY : potentialparm_type - USE stop_program, ONLY : stop_prg - USE structure_types, ONLY : structure_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: force - -CONTAINS - -!****************************************************************************** - -SUBROUTINE force ( struc, potparm, thermo, simpar, ewald_param ) - - IMPLICIT NONE - -! Arguments - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -!------------------------------------------------------------------------------ - - SELECT CASE ( simpar % program ) - CASE DEFAULT - CALL stop_prg ( 'force', 'not implemented' ) - - CASE ( 'FIST' ) - CALL fist_force_control ( struc % molecule, struc % pnode, struc % part, & - struc % box, thermo, potparm, ewald_param, simpar % ensemble, & - fistpar ) - - CASE ( 'TBMD' ) - CALL tbmd_force_control ( struc % molecule, struc % pnode, struc % part, & - struc % box, thermo, potparm, ewald_param, simpar % ensemble, & - tbmdpar ) - - END SELECT - -END SUBROUTINE force - -!****************************************************************************** - -END MODULE force_control diff --git a/src/force_fields.c b/src/force_fields.c deleted file mode 100644 index 17c8739..0000000 --- a/src/force_fields.c +++ /dev/null @@ -1,846 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE force_fields - - USE kinds, ONLY : dbl - USE global_types, ONLY : global_environment_type - USE input_types, ONLY : setup_parameters_type - USE particle_types, ONLY : particle_prop_type - USE pair_potential, ONLY : potentialparm_type - USE mathconstants, ONLY : pi - USE molecule_types, ONLY : bond_parameters_type, bend_parameters_type, & - torsion_parameters_type, intra_parameters_type, & - molecule_type - USE mp, ONLY : mp_bcast - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int, stop_parser - USE string_utilities, ONLY : uppercase, xstring, str_search, & - str_comp, make_tuple - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: read_force_field_section - -!*apsi* Because of a feature(?) in DEC compiler - PUBLIC :: ATOMNAMESLENGTH - INTEGER, PARAMETER :: ATOMNAMESLENGTH = 20 - - INTEGER :: scr - TYPE ( global_environment_type ) :: globenv - -CONTAINS - -!****************************************************************************** - -SUBROUTINE read_force_field_section ( setup, mol_setup, set_fn, intra_param, & - potparm, atom_names, pstat, globenv_input ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - CHARACTER ( LEN = ATOMNAMESLENGTH ), DIMENSION ( : ), POINTER :: atom_names - TYPE (intra_parameters_type ), INTENT ( OUT ) :: intra_param - TYPE (potentialparm_type ), DIMENSION ( :, : ), POINTER :: potparm - TYPE (molecule_type ), DIMENSION ( : ), INTENT ( IN ) :: mol_setup - TYPE (particle_prop_type ), DIMENSION ( : ), POINTER :: pstat - TYPE (setup_parameters_type ), INTENT ( INOUT ) :: setup - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv_input - -! Locals - INTEGER :: i, j, n, natom_types, ios, nmol_type, iw - -!------------------------------------------------------------------------------ - - globenv = globenv_input - scr = globenv % scr - - iw = scr - -!..count total number of molecules and atoms - setup % nmol = 0 - setup % natoms = 0 - setup % natom_type = 0 - nmol_type = size(mol_setup) - DO i = 1, nmol_type - setup % nmol = setup % nmol + mol_setup(i) % num_mol - setup % natoms = setup % natoms + mol_setup(i) % num_mol * & - mol_setup(i) % molpar % natom - setup % natom_type = setup % natom_type + & - mol_setup(i) % molpar % natom_type - END DO - -!..generate unique atom list - ALLOCATE ( atom_names ( setup % natom_type ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'input_fist', & - 'atom_names', setup % natom_type ) - - n = 0 - DO i = 1, nmol_type - DO j = 1, mol_setup(i) % molpar % natom - IF (str_search(atom_names,n,mol_setup(i) % molpar%aname(j))==0) THEN - n = n + 1 - atom_names(n) = mol_setup(i) % molpar%aname(j) - END IF - END DO - END DO - - IF ( n /= setup % natom_type ) CALL stop_prg ( 'input_fist', & - 'natom_type mismatch' ) - -!..define pstat to hold all information (static) on different particle types - ALLOCATE ( pstat ( setup % natom_type ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'input_fist', & - 'pstat', setup % natom_type ) - natom_types = SIZE ( atom_names ) - - DO i = 1, nmol_type - DO j = 1, mol_setup(i) % molpar % natom - n = str_search(atom_names,natom_types,mol_setup(i) % molpar % aname(j)) - pstat(n) % charge = mol_setup(i) % molpar % acharge(j) - pstat(n) % mass = mol_setup(i) % molpar % aweight(j) - pstat(n) % ptype = n - END DO - END DO - -!..read in non-bonded interaction information - natom_types = size(atom_names) - ALLOCATE (potparm(natom_types,natom_types),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'fist_input', & - 'potparm', natom_types ** 2 ) - CALL input_nonbonded(potparm,atom_names,set_fn) - -!..read the bond parameters - CALL input_bonds(intra_param % bond_param,atom_names,set_fn) - -!..read the bend parameters - CALL input_bends(intra_param % bend_param,atom_names,set_fn) - -!..read the torsion parameters - CALL input_torsions(intra_param % torsion_param,atom_names,set_fn) - -!..read the distance constraint parameters - CALL input_distance_constraints ( intra_param % constraint_distance, & - atom_names, set_fn ) - -END SUBROUTINE read_force_field_section - -!!>---------------------------------------------------------------------------! -!! SECTION: &force_field ... &end ! -!! ! -!! nonbonded ! -!! lennard-jones atom1 atom2 epsilon sigma rcut ! -!! williams atom1 atom2 a b c rcut ! -!! goodwin atom1 atom2 vr0 d dc m mc rcut ! -!! end nonbonded ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE input_nonbonded ( potparm, atom_names, set_fn ) - - IMPLICIT NONE - -! Arguments - TYPE (potentialparm_type ), INTENT ( INOUT ) :: potparm ( :, : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: atom_names ( : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - -! Locals - INTEGER :: ios, i, i1, i2, msglen, np, iw, source, allgrp - INTEGER :: ierror, ilen, natom_types - LOGICAL :: exists - CHARACTER ( LEN = 10 ) :: at1, at2 - CHARACTER ( LEN = 40 ) :: string, string2 - CHARACTER ( LEN = 12 ) :: label - REAL ( dbl ) :: epsilon, sigma, rcut, a, b, c, c0, c1, c2, d - REAL ( dbl ) :: vr0, dc, m, mc - -!------------------------------------------------------------------------------ - - natom_types = SIZE ( atom_names ) - np = 0 - DO i1 = 1, natom_types - DO i2 = 1, natom_types - potparm(i1,i2) %type = 'NULL' - CALL uppercase(potparm(i1,i2) %type ) - END DO - END DO - -! initialize parameters in potparm - potparm ( :, : ) % lj % epsilon = 0._dbl - potparm ( :, : ) % lj % sigma6 = 0._dbl - potparm ( :, : ) % lj % sigma12 = 0._dbl - potparm ( :, : ) % willis % a = 0._dbl - potparm ( :, : ) % willis % b = 0._dbl - potparm ( :, : ) % willis % c = 0._dbl - potparm ( :, : ) % goodwin % vr0 = 0._dbl - potparm ( :, : ) % goodwin % d = 0._dbl - potparm ( :, : ) % goodwin % dc = 0._dbl - potparm ( :, : ) % goodwin % m = 0._dbl - potparm ( :, : ) % goodwin % mc = 0._dbl - iw = scr -!..parse the input section - label = '&FORCE_FIELD' - CALL parser_init(set_fn,label,ierror,globenv) - IF (ierror /= 0 ) THEN - IF (globenv%ionode) THEN - WRITE ( iw, '( a )' ) ' No input section &FORCE_FIELD found on file ' - WRITE ( iw, '( a )' ) set_fn - END IF - CALL stop_parser( 'input_nonbond','FORCE_FIELD') - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 9 - CALL cfield(string,ilen) - CALL uppercase(string) - IF (index(string,'NONBONDED') /= 0 ) THEN - DO - CALL read_line - ilen = 0 - CALL cfield(string2,ilen) - CALL uppercase(string2) - SELECT CASE (string2) - CASE DEFAULT - CALL p_error() - CALL stop_parser( 'input_nonbonded','unknown option') - CASE ( 'LENNARD-JONES') - np = np + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - epsilon = get_real() - sigma = get_real() - rcut = get_real() - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - potparm(i1,i2) %type = string2 - potparm(i1,i2) %lj%epsilon = epsilon - potparm(i1,i2) %lj%sigma6 = sigma**6 - potparm(i1,i2) %lj%sigma12 = sigma**12 - potparm(i1,i2) %rcutsq = rcut*rcut - potparm(i2,i1) = potparm(i1,i2) - CASE ( 'WILLIAMS') - np = np + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - a = get_real() - b = get_real() - c = get_real() - rcut = get_real() - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - potparm(i1,i2) %type = string2 - potparm(i1,i2) %willis%a = a - potparm(i1,i2) %willis%b = b - potparm(i1,i2) %willis%c = c - potparm(i1,i2) %rcutsq = rcut*rcut - potparm(i2,i1) = potparm(i1,i2) - CASE ( 'GOODWIN') - np = np + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - vr0 = get_real() - d = get_real() - dc = get_real() - m = get_real() - mc = get_real() - rcut = get_real() - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_nonbonded', & - 'atom not found') - potparm(i1,i2) %type = string2 - potparm(i1,i2) %goodwin%vr0 = vr0 - potparm(i1,i2) %goodwin%d = d - potparm(i1,i2) %goodwin%dc = dc - potparm(i1,i2) %goodwin%m = m - potparm(i1,i2) %goodwin%mc = mc - potparm(i1,i2) %rcutsq = rcut*rcut - potparm(i2,i1) = potparm(i1,i2) - CASE ( 'END') - ilen = 0 - CALL cfield(string2,ilen) - EXIT - END SELECT - END DO - END IF - CALL read_line - END DO - END IF - CALL parser_end - -!..write some information to output - IF (globenv%ionode) THEN - IF (globenv % print_level>=0 .AND. np>0) THEN - WRITE ( iw, '( A )' ) ' FORCE FIELD| Non-bonded interaction parameters' - DO i1 = 1, natom_types - DO i2 = i1, natom_types - IF (potparm(i1,i2)%type=='LENNARD-JONES') THEN - WRITE ( iw, '( A,A,T35,A,T45,A,T58,A,T71,F10.4 )' ) & - ' FORCE FIELD| ', 'Lennard-Jones(12-6)', & - adjustl(atom_names(i1)), adjustl(atom_names(i2)), & - ' epsilon [K]', potparm(i1,i2) %lj%epsilon - WRITE ( iw, '( A,T58,A,T71,F10.4 )' ) ' FORCE FIELD| ', & - ' sigma [A]', (potparm(i1,i2)%lj%sigma6)**(1./6.) - WRITE ( iw, '( A,T58,A,T71,F10.4 )' ) ' FORCE FIELD| ', & - ' rcut [A]', sqrt(potparm(i1,i2)%rcutsq) - ELSE IF (potparm(i1,i2)%type=='WILLIAMS') THEN - WRITE ( iw, '( A,A,T30,A,T40,A,T55,A,T68,E13.4 )' ) & - ' FORCE FIELD| ', 'Williams', adjustl(atom_names(i1)), & - adjustl(atom_names(i2)), 'A[K]', potparm(i1,i2) %willis%a - WRITE ( iw, '( A,T47,A,T71,F10.4 )' ) ' FORCE FIELD| ', & - ' B [A^-1]', potparm(i1,i2) %willis%b - WRITE ( iw, '( A,T47,A,T68,E13.4 )' ) ' FORCE FIELD| ', & - ' C [K A^6]', potparm(i1,i2) %willis%c - WRITE ( iw, '( A,T47,A,T71,F10.4 )' ) ' FORCE FIELD| ', & - ' rcut [A]', sqrt(potparm(i1,i2)%rcutsq) - ELSE IF (potparm(i1,i2)%type=='GOODWIN') THEN - WRITE ( iw, '( A,A,T30,A,T40,A,T55,A,T68,E13.4 )' ) & - ' FORCE FIELD| ', 'Goodwin', adjustl(atom_names(i1)), & - adjustl(atom_names(i2)), 'Ve0[eV]', & - potparm(i1,i2) %goodwin%vr0 - WRITE ( iw, '( A,T44,A,T61,2F10.4 )' ) ' FORCE FIELD| ', & - ' d,dc [A]', potparm(i1,i2) %goodwin%d, & - potparm(i1,i2) %goodwin%dc - WRITE ( iw, '( A,T44,A,T61,2F10.4 )' ) ' FORCE FIELD| ', & - ' m,mc ', potparm(i1,i2) %goodwin%m, & - potparm(i1,i2) %goodwin%mc - WRITE ( iw, '( A,T44,A,T71,F10.4 )' ) ' FORCE FIELD| ', & - ' rcut [A]', sqrt(potparm(i1,i2)%rcutsq) - END IF - END DO - END DO - WRITE ( iw, '( )' ) - END IF - END IF - -END SUBROUTINE input_nonbonded - -!------------------------------------------------------------------------------ -! -! read all the bond parameters. Put them in the -! bond_parm matrix. Symmetrize this matrix since a bond between atoms -! A and B is the same as between B and A. While we read the bond_pot_type, -! we (so far) will do nothing with this information. It appears that -! all major parameters sets, such as CHARMM or AMBER, all have only -! one type of bonded interaction (harmonic). -! -!!>---------------------------------------------------------------------------! -!! SECTION: &force_field ... &end ! -!! ! -!! bonds ! -!! harmonic atom1 atom2 bp1 bp2 ! -!! end bonds ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE input_bonds(bond_parm,atom_names,set_fn) - IMPLICIT NONE - -! Arguments - TYPE (bond_parameters_type ), POINTER :: bond_parm ( :, : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: atom_names ( : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - -! Locals - INTEGER :: i1, i2, ierror, ilen, ios - INTEGER :: nb, iw, allgrp, source, natom_types - LOGICAL :: exists - CHARACTER ( LEN = 20 ) :: type, at1, at2 - CHARACTER ( LEN = 40 ) :: string, string2 - CHARACTER ( LEN = 12 ) :: label - REAL ( dbl ) :: bp1, bp2 - -!------------------------------------------------------------------------------ - - natom_types=SIZE(atom_names) - nb = 0 - ALLOCATE (bond_parm(natom_types,natom_types),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'input_bonds', & - 'bond_parm', natom_types ** 2 ) - - bond_parm ( :, : ) %type = 'null' - bond_parm ( :, : ) %r0 = 0._dbl - bond_parm ( :, : ) %k = 0._dbl - iw = scr -!..parse the input section - label = '&FORCE_FIELD' - CALL parser_init(set_fn,label,ierror,globenv) - IF (ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( a )' ) ' No input section &FORCE_FIELD found on file ' - WRITE ( iw, '( a )' ) set_fn - END IF - CALL stop_parser( 'input_bond', '&FORCE_FIELD' ) - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 5 - CALL cfield(string,ilen) - CALL uppercase ( string ) - IF (index(string,'BONDS') /= 0 ) THEN - DO - CALL read_line - ilen = 0 - CALL cfield(string2,ilen) - SELECT CASE (string2) - CASE DEFAULT - CALL p_error() - CALL stop_parser( 'input_bond','unknown option') - CASE ( 'HARMONIC') - nb = nb + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - bp1 = get_real() - bp2 = get_real() - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_bonds','atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_bonds','atom not found') - bond_parm(i1,i2) %type = string2 - bond_parm(i1,i2) %r0 = bp1 - bond_parm(i1,i2) %k = bp2 - bond_parm(i2,i1) = bond_parm(i1,i2) - CASE ( 'END') - ilen = 0 - CALL cfield(string2,ilen) - EXIT - END SELECT - END DO - END IF - CALL read_line - END DO - END IF - CALL parser_end - -!..write some information to output - IF ( globenv % ionode ) THEN - IF (globenv % print_level>=0 .AND. nb>0) THEN - WRITE ( iw, '( A )' ) ' FORCE FIELD| Bond interaction parameters' - DO i1 = 1, natom_types - DO i2 = i1, natom_types - IF (index(bond_parm(i1,i2)%type,'HARMONIC') /= 0 ) THEN - WRITE ( iw, '( A, A, T30, A, T40, A, T57, F10.4, F14.2 )' ) & - ' FIST| ', ADJUSTL ( bond_parm ( i1, i2 ) % type ), & - ADJUSTL ( atom_names ( i1 ) ), & - ADJUSTL ( atom_names ( i2 ) ), & - bond_parm ( i1, i2 ) % r0, & - bond_parm ( i1, i2 ) % k - END IF - END DO - END DO - WRITE ( iw, '( )' ) - END IF - END IF - -END SUBROUTINE input_bonds - -! -! read all the bend parameters. Put them in the -! bend_parm matrix. Fill this matrix since a bend between atoms -! A-B-C is the same as between C-B-A. While we read the bend_pot_type, -! we (so far) will do nothing with this information. It appears that -! all major parameters sets, such as CHARMM or AMBER, all have only -! only one type of bend interaction (harmonic). -! -!!>---------------------------------------------------------------------------! -!! SECTION: &force_field ... &end ! -!! ! -!! bends ! -!! harmonic atom1 atom2 atom3 bp1 bp2 ! -!! end bends ! -!! ! -!!<---------------------------------------------------------------------------! -SUBROUTINE input_bends ( bend_parm, atom_names, set_fn ) - - IMPLICIT NONE - -! Arguments - TYPE (bend_parameters_type ), POINTER :: bend_parm(:,:,:) - CHARACTER ( LEN = * ), INTENT ( IN ) :: atom_names ( : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - -! Locals - INTEGER :: i1, i2, i3, ierror, ilen, ios - INTEGER :: nb, iw, allgrp, source, natom_types - CHARACTER ( LEN = 20 ) :: type, at1, at2, at3 - CHARACTER ( LEN = 40 ) :: string, string2 - CHARACTER ( LEN = 12 ) :: label - REAL ( dbl ) :: bp1, bp2, torad, todeg - -!------------------------------------------------------------------------------ - - natom_types=SIZE(atom_names) - nb = 0 - ALLOCATE (bend_parm(natom_types,natom_types,natom_types),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'input_bends', & - 'bend_parm', natom_types ** 3 ) - torad = pi / 180.0_dbl - todeg = 180.0_dbl/pi - bend_parm(:,:,:) %type = 'null' - bend_parm(:,:,:) %theta0 = 0._dbl - bend_parm(:,:,:) %k = 0._dbl - - iw = scr -!..parse the input section - label = '&FORCE_FIELD' - CALL parser_init(set_fn,label,ierror,globenv) - IF (ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( a )' ) ' No input section &FORCE_FIELD found on file ' - WRITE ( iw, '( a )' ) set_fn - END IF - CALL stop_parser( 'input_bend', '&FORCE_FIELD' ) - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 5 - CALL cfield(string,ilen) - CALL uppercase ( string ) - IF (index(string,'BENDS') /= 0 ) THEN - DO - CALL read_line - ilen = 0 - CALL cfield(string2,ilen) - SELECT CASE (string2) - CASE DEFAULT - CALL p_error() - CALL stop_parser( 'input_bond','unknown option') - CASE ( 'HARMONIC') - nb = nb + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - ilen = 0 - CALL cfield(at3,ilen) - bp1 = get_real() - bp2 = get_real() - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_bends','atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_bends','atom not found') - i3 = str_search(atom_names,natom_types,at3) - IF (i2==0) CALL stop_parser( 'input_bends','atom not found') - bend_parm(i1,i2,i3) %type = string2 - bend_parm(i1,i2,i3) %theta0 = bp1*torad - bend_parm(i1,i2,i3) %k = bp2 - bend_parm(i3,i2,i1) = bend_parm(i1,i2,i3) - CASE ( 'END') - ilen = 0 - CALL cfield(string2,ilen) - EXIT - END SELECT - END DO - END IF - CALL read_line - END DO - END IF - CALL parser_end - -!..write some information to output - IF ( globenv % ionode ) THEN - IF (globenv % print_level>=0 .AND. nb>0) THEN - WRITE ( iw, '( A )' ) ' FORCE FIELD| Bend interaction parameters' - DO i1 = 1, natom_types - DO i2 = 1, natom_types - DO i3 = i1, natom_types - IF (index(bend_parm(i1,i2,i3)%type,'HARMONIC') /= 0 ) THEN - WRITE ( iw, '( A,A,T20,A,T30,A,T40,A,T57,F10.4,F14.2 )' ) & - ' FIST| ', adjustl(bend_parm(i1,i2,i3)%type ), & - adjustl(atom_names(i1)), adjustl(atom_names(i2)), & - adjustl(atom_names(i3)), bend_parm(i1,i2,i3) %theta0* & - todeg, bend_parm(i1,i2,i3) %k - END IF - END DO - END DO - END DO - WRITE ( iw, '( )' ) - END IF - END IF - -END SUBROUTINE input_bends - -! -! first, read all the torsion parameters. Put them in the -! torsion_parm matrix. Fill this matrix since a torsion between atoms -! A-B-C-D is the same as between D-C-B-A. We have defined the -! torsion_parameter type with 7 coefficients for 0 to 6. Hopefully -! this will be generic enough to handle all torsion potentials. -! Since different types will be used, we need to store the type of torsion as -! well. -! -!!>---------------------------------------------------------------------------! -!! SECTION: &force_field ... &end ! -!! ! -!! torsion ! -!! power atom1 atom2 atom3 atom4 parm[] ! -!! end torsion ! -!! ! -!!<---------------------------------------------------------------------------! -SUBROUTINE input_torsions ( torsion_parm, atom_names, set_fn ) - - IMPLICIT NONE - -! Arguments - TYPE ( torsion_parameters_type ), POINTER :: torsion_parm ( :, :, :, : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: atom_names ( : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - -! Locals - REAL ( dbl ) :: parm(0:6), torad, todeg - INTEGER :: i, i1, i2, i3, i4, ierror, ilen, ios - INTEGER :: nb, iw, allgrp, source, natom_types - CHARACTER ( LEN = 20 ) :: type, at1, at2, at3, at4 - CHARACTER ( LEN = 40 ) :: string, string2 - CHARACTER ( LEN = 12 ) :: label - -!------------------------------------------------------------------------------ - - torad = pi/180._dbl - todeg = 180._dbl/pi - natom_types=SIZE(atom_names) - nb = 0 - ALLOCATE ( & - torsion_parm ( natom_types, natom_types, natom_types, natom_types ), & - STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'input_torsions', & - 'torsion_parm', natom_types ** 4 ) - torsion_parm ( :, :, :, : ) % type = 'null' - DO i = 0, SIZE ( torsion_parm(1,1,1,1) % parm ) - 1 - torsion_parm(:,:,:,:) %parm(i) = 0._dbl - END DO - - iw = scr - -!..parse the input section - label = '&FORCE_FIELD' - CALL parser_init(set_fn,label,ierror,globenv) - IF ( ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( A )' ) & - ' No input section &FORCE_FIELD found on file ' - WRITE ( iw, '( A )' ) set_fn - END IF - CALL stop_parser( 'input_torsion', '&FORCE_FIELD' ) - - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 7 - CALL cfield(string,ilen) - CALL uppercase ( string ) - IF (index(string,'TORSION') /= 0 ) THEN - DO - CALL read_line - ilen = 0 - CALL cfield(string2,ilen) - SELECT CASE (string2) - CASE DEFAULT - CALL p_error() - CALL stop_parser( 'input_torsion','unknown option') - CASE ( 'POWER') - nb = nb + 1 - ilen = 0 - CALL cfield(at1,ilen) - ilen = 0 - CALL cfield(at2,ilen) - ilen = 0 - CALL cfield(at3,ilen) - ilen = 0 - CALL cfield(at4,ilen) - DO i = 1, size(parm) - parm(i) = get_real() - END DO - i1 = str_search(atom_names,natom_types,at1) - IF (i1==0) CALL stop_parser( 'input_torsions', & - 'atom not found') - i2 = str_search(atom_names,natom_types,at2) - IF (i2==0) CALL stop_parser( 'input_torsions', & - 'atom not found') - i3 = str_search(atom_names,natom_types,at3) - IF (i3==0) CALL stop_parser( 'input_torsions', & - 'atom not found') - i4 = str_search(atom_names,natom_types,at4) - IF (i4==0) CALL stop_parser( 'input_torsions', & - 'atom not found') - torsion_parm(i1,i2,i3,i4) %type = type - torsion_parm(i1,i2,i3,i4) %parm = parm - torsion_parm(i4,i3,i2,i1) = torsion_parm(i1,i2,i3,i4) - CASE ( 'END') - ilen = 0 - CALL cfield(string2,ilen) - EXIT - END SELECT - END DO - END IF - CALL read_line() - END DO - END IF - CALL parser_end() - -!..write some information to output - IF ( globenv % ionode ) THEN - IF ( globenv % print_level >= 0 .AND. nb > 0 ) THEN - WRITE ( iw, '( A )' ) & - ' FORCE FIELD| Torsion inatom_typeseraction parameters' - DO i1 = 1, natom_types - DO i2 = 1, natom_types - DO i3 = i2, natom_types - DO i4 = i1, natom_types - IF ( index ( torsion_parm(i1,i2,i3,i4) % type, & - 'POWER' ) == 0 ) THEN - WRITE ( iw, & - '( 2A, T20, A, T30, A, T40, A, T50, A, 7F10.4 )' )& - ' FIST| ', & - ADJUSTL ( torsion_parm ( i1,i2,i3,i4 ) % type ), & - ADJUSTL ( atom_names(i1)), & - ADJUSTL ( atom_names(i2)), & - ADJUSTL ( atom_names(i3)), & - ADJUSTL ( atom_names(i4)), & - torsion_parm ( i1, i2, i3, i4 ) % parm - END IF - END DO - END DO - END DO - END DO - WRITE ( iw, '( )' ) - END IF - END IF - -END SUBROUTINE input_torsions - -! -! first, read all the distance parameters. Put them in the -! constraint_distance array. Symmetrize this matrix since a bond between atoms -! A and B is the same as between B and A. -! -!!>---------------------------------------------------------------------------! -!! SECTION: &force_field ... &end ! -!! ! -!! distcon ! -!! atom1 atom2 dp ! -!! end distcon ! -!! ! -!!<---------------------------------------------------------------------------! -SUBROUTINE input_distance_constraints ( constraint_distance, atom_names, & - set_fn ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), POINTER :: constraint_distance ( :, : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: atom_names ( : ) - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - -! Locals - INTEGER :: i1, i2, ierror, ilen, ios - INTEGER :: nb, iw, allgrp, source, natom_types - CHARACTER ( LEN = 20 ) :: at1, at2 - CHARACTER ( LEN = 40 ) :: string, string2 - CHARACTER ( LEN = 12 ) :: label - REAL ( dbl ) :: dp - -!------------------------------------------------------------------------------ - - natom_types=SIZE(atom_names) - nb = 0 - ALLOCATE (constraint_distance(natom_types,natom_types),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'input_distance_constraints', & - 'constraint_distance', natom_types ** 2 ) - constraint_distance ( :, : ) = 0.0_dbl - - iw = scr - -!..parse the input section - label = '&FORCE_FIELD' - CALL parser_init(set_fn,label,ierror,globenv) - IF (ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( A )' ) ' No input section &FORCE_FIELD found on file ' - WRITE ( iw, '( A )' ) set_fn - END IF - CALL stop_parser ( 'input_distance_constraints', '&FORCE_FIELD' ) - ELSE - CALL read_line - DO WHILE ( test_next() /= 'X' ) - ilen = 7 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - - IF ( INDEX ( string, 'DISTCON' ) /= 0 ) THEN - DO - CALL read_line() - - ilen = 0 - CALL cfield ( string2, ilen ) - CALL uppercase ( string2 ) - IF ( INDEX ( string2, 'END' ) /= 0 ) EXIT - - at1 = string2 - nb = nb + 1 - ilen = 0 - CALL cfield ( at2, ilen ) - i1 = str_search ( atom_names, natom_types, at1 ) - IF ( i1 == 0 ) CALL stop_parser ( 'input_distance_constraints', & - 'atom not found' ) - i2 = str_search ( atom_names, natom_types, at2 ) - IF ( i2 == 0 ) CALL stop_parser ( 'input_distance_constraints', & - 'atom not found' ) - dp = get_real() - constraint_distance ( i1, i2 ) = dp - constraint_distance ( i2, i1 ) = dp - END DO - END IF - CALL read_line - END DO - END IF - CALL parser_end - -!..write some information to output - IF ( globenv % ionode ) THEN - IF ( globenv % print_level >= 0 .AND. nb > 0 ) THEN - WRITE ( iw, '( A )' ) ' FORCE FIELD| Distance constraints ' - DO i1 = 1, natom_types - DO i2 = i1, natom_types - IF ( constraint_distance ( i1, i2 ) /= 0.0_dbl ) THEN - WRITE ( iw, '( A, T30, A, T40, A, T71, F10.4 )' ) & - ' FORCE FIELD| Constraint: ', & - ADJUSTL ( atom_names ( i1 ) ), & - ADJUSTL ( atom_names ( i2 ) ), & - constraint_distance ( i1, i2 ) - END IF - END DO - END DO - WRITE ( iw, '()' ) - END IF - END IF - -END SUBROUTINE input_distance_constraints - -!****************************************************************************** - -END MODULE force_fields diff --git a/src/force_fit.c b/src/force_fit.c deleted file mode 100644 index 5298a4f..0000000 --- a/src/force_fit.c +++ /dev/null @@ -1,1089 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart ! -!-----------------------------------------------------------------------------! - -!!*apsi* Deleted units - -MODULE force_fit - - USE amoeba, ONLY : amoeba_evaluate - USE global_types, ONLY : globenv - USE io_parameters, ONLY : scr - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type, thermodynamic_type - USE pair_potential, ONLY : potentialparm_type, spline_nonbond_control - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int - USE stop_program, ONLY : stop_prg - USE structure_types, ONLY : structure_type - -! USE fist_input, ONLY : atom_names -! USE force_control, ONLY : force -! USE md, ONLY : simulation_parameters -! USE pair_potential, ONLY : potentialparm, spline_nonbond_control - - IMPLICIT NONE - - PRIVATE - PUBLIC :: fit_control - - TYPE linklist_real_type - REAL ( dbl ), POINTER :: real_value - TYPE ( linklist_real_type ), POINTER :: next - END TYPE linklist_real_type - - TYPE linklist_parameters_type - TYPE ( linklist_real_type ), POINTER :: lleps - TYPE ( linklist_real_type ), POINTER :: llsig - TYPE ( linklist_real_type ), POINTER :: lla - TYPE ( linklist_real_type ), POINTER :: llb - TYPE ( linklist_real_type ), POINTER :: llc - END TYPE linklist_parameters_type - - TYPE fit_parameter_type - CHARACTER ( len = 10 ) :: type, datatype, restart - INTEGER :: max_iter, nsteps, iskip, iwrite, idump - REAL ( dbl ) :: max_tol - END TYPE fit_parameter_type - - TYPE fit_info_type - REAL ( dbl ), DIMENSION ( 3 ) :: f_ref, f_fit, r - END TYPE fit_info_type - -! dbg -! REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: v_ref, v_fit -! dbg -! TYPE ( linklist_parameters ), ALLOCATABLE, DIMENSION ( :, : ) :: param -! TYPE ( fit_info ), ALLOCATABLE, DIMENSION ( :, : ) :: finfo -! REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: ave_sig, ave_eps -! REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: ave_a, ave_b, ave_c -! REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: y -! REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE, TARGET :: p -! REAL ( dbl ) :: ftol -! INTEGER :: iter, iwrite - -CONTAINS - -!****************************************************************************** - -!!>---------------------------------------------------------------------------! -!! SECTION: &fit ... &end ! -!! ! -!! type: [LJ, WILL] type of fit ! -!! restart: [INITIAL, ALL] restart option ! -!! data type: [POS_FORCE, POS_VEL] type of data to read ! -!! out unit: [ATOMIC, KELVIN] output unit ! -!! tol: max_tol maximum tolerance (fractional ) ! -!! iter: max_iter maximum number of iterations ! -!! nsteps: nsteps number of trajectory steps ! -!! iskip: iskip analyse every iskip step ! -!! idump: idump write to dump file every idump steps ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_fit_section ( fit_param ) - - IMPLICIT NONE - -! Arguments - TYPE ( fit_parameter_type ), INTENT ( OUT ) :: fit_param - -! Locals - INTEGER :: ierror, ilen - CHARACTER ( len = 20 ) :: string - CHARACTER ( len = 5 ) :: label - -!------------------------------------------------------------------------------ - -!..defaults - fit_param % max_tol = 1.0E-6_dbl - fit_param % max_iter = 10000 - fit_param % nsteps = 1 - fit_param % iskip = 1 - fit_param % type = 'LJ' - fit_param % datatype = 'POS_VEL' - fit_param % idump = 10 - fit_param % restart = 'INITIAL' - -!..parse the input section - - IF ( globenv % ionode ) THEN - - label = '&FIT' - - CALL parser_init ( globenv % input_file_name, label, ierror ) - IF ( ierror /= 0 ) THEN - CALL stop_prg ( 'read_fit_section', 'no input section &FIT found' ) - END IF - - CALL read_line() - - DO WHILE ( test_next ( ) /= 'X' ) - - ilen = 6 - CALL cfield ( string, ilen ) - - SELECT CASE ( string ) - CASE DEFAULT - CALL p_error ( ) - CALL stop_prg ( 'read_fit_section', 'unknown option' ) - - CASE ( 'TYPE' ) - ilen = 6 - CALL cfield ( string, ilen ) - fit_param % type = string ( 1:ilen ) - - CASE ( 'DATA' ) - ilen = 10 - CALL cfield ( string, ilen ) - fit_param % datatype = string ( 1:ilen ) - - CASE ( 'RESTAR' ) - ilen = 7 - CALL cfield ( string, ilen ) - fit_param % restart = string ( 1:ilen ) - - CASE ( 'TOL' ) - fit_param % max_tol = get_real ( ) - - CASE ( 'ITER' ) - fit_param % max_iter = get_int ( ) - - CASE ( 'NSTEPS' ) - fit_param % nsteps = get_int ( ) - - CASE ( 'IDUMP' ) - fit_param % idump = get_int ( ) - - CASE ( 'ISKIP' ) - fit_param % iskip = get_int ( ) - - END SELECT - -! Get the next line - CALL read_line - - END DO - - END IF - CALL parser_end - -!..end of parsing the input section -!..write some information to output - IF ( globenv % print_level >= 0 ) THEN - WRITE ( scr, '( A )' ) ' FIT| Fit Protocol ' - WRITE ( scr, '( A, T71, A )' ) & - ' FIT| Fit type ', ADJUSTR ( fit_param % type ) - WRITE ( scr, '( A, T71, A )' ) & - ' FIT| Data type ', ADJUSTR ( fit_param % datatype ) - WRITE ( scr, '( A, T71, A )' ) & - ' FIT| Restart type', ADJUSTR ( fit_param % restart ) - WRITE ( scr, '( A, T71, I10 )' ) & - ' FIT| Number of steps ', fit_param % nsteps - WRITE ( scr, '( A, T71, I10 )' ) & - ' FIT| Iskip ', fit_param % iskip - WRITE ( scr, '( A, T71, I10 )' ) & - ' FIT| Idump ', fit_param % idump - WRITE ( scr, '( A, T71, G10.4 )' ) & - ' FIT| Max tolerance ', fit_param % max_tol - WRITE ( scr, '( A, T71, I10 )' ) & - ' FIT| Max iterations ', fit_param % max_iter - END IF - -END SUBROUTINE read_fit_section - -!****************************************************************************** - -SUBROUTINE fit_control ( struc, potparm, thermo, simpar ) - - IMPLICIT NONE - -! Arguments - TYPE ( structure_type ), INTENT ( IN ) :: struc - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( thermodynamic_type ), INTENT ( IN ) :: thermo - -! Locals - LOGICAL :: conv_flag - INTEGER :: isos - TYPE ( fit_parameter_type ) :: fit_param - -!------------------------------------------------------------------------------ - - ALLOCATE ( param ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', 'failed to allocate param' ) - - CALL read_fit_section ( fit_param ) - -! allocating the arrays for the analysis - SELECT CASE ( fit_param % type ) - CASE ( 'LJ' ) - ALLOCATE ( ave_sig ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', & - 'failed to allocate LJ ave_sig' ) - ALLOCATE ( ave_eps ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', & - 'failed to allocate LJ ave_eps' ) - - CASE ( 'WILL' ) - ALLOCATE ( ave_a ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', & - 'failed to allocate WILL ave_a' ) - ALLOCATE ( ave_b ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', & - 'failed to allocate WILL ave_b' ) - ALLOCATE ( ave_c ( SIZE ( potparm, 1 ), SIZE ( potparm, 2 ) ), & - STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'fit_control', & - 'failed to allocate WILL ave_c' ) - - CASE DEFAULT - CALL stop_prg ( 'fit_control', 'no valid potential type' ) - END SELECT - - conv_flag = .FALSE. - - CALL fit ( conv_flag, fit_param, struc, simpar ) - - IF ( conv_flag ) THEN - WRITE ( scr, '( )' ) - WRITE ( scr, '( T23, A )' ) '******************************' - WRITE ( scr, '( T23, A )' ) '* *' - WRITE ( scr, '( T23, A )' ) '* CONVERGENCE ACHIEVED *' - WRITE ( scr, '( T23, A )' ) '* *' - WRITE ( scr, '( T23, A )' ) '******************************' - WRITE ( scr, '( )' ) - ELSE - WRITE ( scr, '( )' ) - WRITE ( scr, '( T23, A )' ) '******************************' - WRITE ( scr, '( T23, A )' ) '* *' - WRITE ( scr, '( T23, A )' ) '* WARNING: NO CONVERGENCE *' - WRITE ( scr, '( T23, A )' ) '* *' - WRITE ( scr, '( T23, A )' ) '******************************' - WRITE ( scr, '( )' ) - END IF - -END SUBROUTINE fit_control - -!****************************************************************************** - -!! Given the reference force, and the derived force, optimize -!! paramters with a least squares fit. - -SUBROUTINE fit ( conv_flag, fit_param, struc, simpar ) - - IMPLICIT NONE - -! Arguments - LOGICAL, INTENT ( INOUT ) :: conv_flag - TYPE ( fit_parameter_type ), INTENT ( INOUT ) :: fit_param - TYPE ( structure_type ), INTENT ( IN ) :: struc - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - -! Locals - INTEGER :: i, j - REAL ( dbl ) :: tol - REAL ( dbl ), DIMENSION ( : ), POINTER :: y - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: p - - INTERFACE - FUNCTION func ( x ) - USE kinds, ONLY : dbl - IMPLICIT NONE - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: x - REAL ( dbl ) :: func - END FUNCTION func - END INTERFACE - -!------------------------------------------------------------------------------ - -! Allocate and intialize arrays for amoeba - CALL copy_params ( fit_param, potparm ) - -! Get reference force - CALL force_ref ( y, p, fit_param, struc, simpar ) - -! initialize y - SELECT CASE ( fit_param % restart ) - CASE ( 'ALL' ) - - CALL fit_read_restart ( y, p ) - - CASE ( 'INITIAL' ) - - DO i = 1, SIZE ( y ) - y ( i ) = func ( p ( i, : ) ) - END DO - - CASE DEFAULT - CALL stop_prg ( "fit", "no valid restart option" ) - - END SELECT - -! optimize - DO iter = 1, fit_param % max_iter, fit_param % iwrite - - CALL amoeba ( p, y, fit_param % max_tol, tol, func, fit_param % iwrite ) - - SELECT CASE ( fit_param % type ) - CASE ( 'LJ' ) - CALL get_lj_params ( potparm ) - CASE ( 'WILL' ) - CALL get_will_params ( potparm ) - CASE DEFAULT - CALL stop_prg ( "fit", "no valid potential option" ) - END SELECT - - CALL fit_print_info ( fit_param, tol, potparm ) - -! write restart file - IF ( MOD ( iter, fit_param % idump ) == 0 ) & - CALL fit_write_restart ( y, p ) - -! convergence achieved - IF ( tol <= fit_param % max_tol ) THEN - conv_flag = .TRUE. - - CALL fit_write_restart ( y, p ) - - EXIT - END IF - - END DO - -END SUBROUTINE fit - -!****************************************************************************** - -SUBROUTINE copy_params ( fit_param, potparm, x ) - - IMPLICIT NONE - -! Arguments - TYPE ( fit_parameter_type ), INTENT ( IN ) :: fit_param - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ), OPTIONAL :: x - -! Locals - -!------------------------------------------------------------------------------ - - SELECT CASE ( fit_param % type ) - CASE ( 'LJ' ) - CALL lj_fit ( potparm, x ) - CASE ( 'WILL' ) - CALL will_fit ( potparm, x ) - CASE ( 'TB' ) - CALL stop_prg ( "copy_params", "case TB not implemented" ) - CASE DEFAULT - CALL stop_prg ( "copy_params", "no valid potential type" ) - END SELECT - -END SUBROUTINE copy_params - -!****************************************************************************** - -SUBROUTINE lj_fit ( potparm, x, y, p ) - - IMPLICIT NONE - -! Arguments - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - REAL ( dbl ), DIMENSION ( : ), POINTER, OPTIONAL :: y - REAL ( dbl ), DIMENSION ( :, : ), POINTER, OPTIONAL :: p - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ), OPTIONAL :: x - TYPE ( linklist_real_type ), POINTER :: llsig - TYPE ( linklist_real_type ), POINTER :: lleps - -! Locals - INTEGER :: i, icount, iatom, jatom, numpar, isos - REAL ( dbl ) :: sig, eps - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( x ) ) THEN - icount = 0 - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - icount = icount + 1 - potparm ( iatom, jatom ) % lj % epsilon = x ( icount ) ** 2 - -! symmetrizing - potparm ( jatom, iatom ) % lj % epsilon & - = potparm ( iatom, jatom ) % lj % epsilon - icount = icount + 1 - potparm ( iatom, jatom ) % lj % sigma6 = x ( icount ) - potparm ( iatom, jatom ) % lj % sigma12 = x ( icount ) ** 4 - -! symmetrizing - potparm ( jatom, iatom ) % lj % sigma6 & - = potparm ( iatom, jatom ) % lj % sigma6 - potparm ( jatom, iatom ) % lj % sigma12 & - = potparm ( iatom, jatom ) % lj % sigma12 - END DO - END DO - -! initialize splines - CALL spline_nonbond_control ( potparm, pstat, 2500, cff % ewald_type ) - - ELSE - -! number of potential parameters to be optimized is 2*number -! of interactions ( remember: we only need the upper triangle ) -! e.g. for LJ each interaction has 2 parameters, sigma and epsilon - numpar = 2*SIZE ( potparm, 1 ) * ( SIZE ( potparm, 1 ) +1 ) / 2 - ALLOCATE ( y ( numpar+1 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'lj_fit', 'failed to allocate y' ) - ALLOCATE ( p ( numpar+1, numpar ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'lj_fit', 'failed to allocate p' ) - -! i = 0, numpar is the numpar+1 vector in p ( i, j ) . It is also -! used to generate the initial guesses for the verticies -! of the amoeba - ALLOCATE ( lleps, STAT = isos ) - ALLOCATE ( llsig, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'lj_fit', & - 'failed to allocate lleps and llsig' ) - - icount = 0 - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - param ( iatom, jatom ) % lleps => lleps - param ( iatom, jatom ) % llsig => llsig - - icount = icount + 1 - -! loop for eps - DO i = 1, numpar + 1 - eps = potparm ( iatom, jatom ) % lj % epsilon - p ( i, icount ) = SQRT ( eps ) - lleps % eps => p ( i, icount ) - ALLOCATE ( lleps % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'lj_fit', & - 'failed to allocate lleps % next' ) - lleps => lleps % next - END DO - - icount = icount + 1 - -! loop for sig - DO i = 1, numpar + 1 - sig = potparm ( iatom, jatom ) % lj % sigma6 - p ( i, icount ) = SQRT ( sig ) - llsig % sig => p ( i, icount ) - ALLOCATE ( llsig % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'lj_fit', & - 'failed to allocate llsig % next' ) - llsig => llsig % next - END DO - END DO - END DO - -! scaling the appropriate interaction parameter by 1.1 -! to construct the amoeba - DO i = 0, numpar - IF ( i>0 ) p ( i + 1, i ) = p ( i + 1, i ) * 1.1_dbl - END DO - - END IF - -END SUBROUTINE lj_fit - -!****************************************************************************** - -SUBROUTINE will_fit ( potparm, x, y, p ) - - IMPLICIT NONE - -! Arguments - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - REAL ( dbl ), DIMENSION ( : ), POINTER, OPTIONAL :: y - REAL ( dbl ), DIMENSION ( :, : ), POINTER, OPTIONAL :: p - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ), OPTIONAL :: x - TYPE ( linklist_a ), POINTER :: lla - TYPE ( linklist_b ), POINTER :: llb - TYPE ( linklist_c ), POINTER :: llc - -! Locals - INTEGER :: i, icount, iatom, jatom, numpar, isos - REAL ( dbl ) a, b, c - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( x ) ) THEN - icount = 0 - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - icount = icount + 1 - potparm ( iatom, jatom ) % willis % a & - = x ( icount ) ** 2 -! symmetrizing - potparm ( jatom, iatom ) % willis % a & - = potparm ( iatom, jatom ) % willis % a - icount = icount + 1 - potparm ( iatom, jatom ) % willis % b & - = x ( icount ) ** 2 -! symmetrizing - potparm ( jatom, iatom ) % willis % b & - = potparm ( iatom, jatom ) % willis % b - icount = icount + 1 - potparm ( iatom, jatom ) % willis % c & - = x ( icount ) ** 2 -! symmetrizing - potparm ( jatom, iatom ) % willis % c & - = potparm ( iatom, jatom ) % willis % c - END DO - END DO - -! initialize splines - CALL spline_nonbond_control ( potparm, pstat, 2500, cff % ewald_type ) - - ELSE - -! number of potential parameters to be optimized is 3*number -! of interactions ( remember: we only need the upper triangle ) -! e.g. for WILL each interaction has 3 parameters, a, b, and c. - numpar = 3.0_dbl & - * SIZE ( potparm, 1 ) * ( SIZE ( potparm, 1 ) + 1 ) / 2 - - ALLOCATE ( y ( numpar+1 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', 'failed to allocate y' ) - ALLOCATE ( p ( numpar+1, numpar ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', 'failed to allocate p' ) - -! i = 0, numpar is the numpar+1 vector in p ( i, j ) . It is also -! used to generate the initial guesses for the verticies -! of the amoeba - ALLOCATE ( lla, STAT = isos ) - ALLOCATE ( llb, STAT = isos ) - ALLOCATE ( llc, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', 'failed to allocate lla' ) - - icount = 0 - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - param ( iatom, jatom ) % lla => lla - param ( iatom, jatom ) % llb => llb - param ( iatom, jatom ) % llc => llc - - icount = icount + 1 - -! loop for a - DO i = 1, numpar + 1 - a = potparm ( iatom, jatom ) % willis % a - p ( i, icount ) = SQRT ( a ) - lla % a => p ( i, icount ) - - ALLOCATE ( lla % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', & - 'failed to allocate lla % next' ) - lla => lla % next - END DO - - icount = icount + 1 - -! loop for b - DO i = 1, numpar + 1 - b = potparm ( iatom, jatom ) % willis % b - p ( i, icount ) = SQRT ( b ) - llb % b => p ( i, icount ) - ALLOCATE ( llb % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', & - 'failed to allocate llb % next' ) - llb => llb % next - END DO - - icount = icount + 1 - -! loop for c - DO i = 1, numpar + 1 - c = potparm ( iatom, jatom ) % willis % c - p ( i, icount ) = SQRT ( c ) - llc % c => p ( i, icount ) - ALLOCATE ( llc % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'will_fit', & - 'failed to allocate llc % next' ) - llc => llc % next - END DO - END DO - END DO - -! scaling the appropriate interaction parameter by 1.1 -! to construct the amoeba - DO i = 1, numpar - p ( i + 1, i ) = p ( i + 1, i ) * 1.1_dbl - END DO - - END IF - -END SUBROUTINE will_fit - -!****************************************************************************** - -!! From the first principles trajectory file obtain the total force -!! on the particle by inverting the velcocity Verlet equations - -SUBROUTINE force_ref ( y, p, fit_param, struc, simpar ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: y - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: p - TYPE ( fit_parameter_type ), INTENT ( INOUT ) :: fit_param - TYPE ( structure_type ), INTENT ( IN ) :: struc - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - -! Locals - INTEGER :: npart, ipart, itime, ii, it, isos - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, :, : ) :: r, v - REAL ( dbl ), DIMENSION ( 3 ) :: fref - LOGICAL :: copy -! dbg - REAL ( dbl ) :: dummy -! dbg - -!------------------------------------------------------------------------------ - - npart = SIZE ( struc % pnode ) - itime = fit_param % nsteps / fit_param % iskip - - IF ( fit_param % datatype == 'POS_FORCE' ) THEN - ALLOCATE ( finfo ( itime, npart ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to allocate finfo' ) -! dbg - ALLOCATE ( v_ref ( itime ), STAT = isos ) - ALLOCATE ( v_fit ( itime ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to allocate v_ref' ) -! dbg - - ELSE IF ( fit_param % datatype == 'POS_VEL' ) THEN - -! Can only compute force up to nsteps-1 step: thus allocated so - IF ( MOD ( fit_param % nsteps, itime ) == 0 ) THEN - ALLOCATE ( finfo ( itime-1, npart ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', & - 'failed to allocate finfo' ) - ELSE - ALLOCATE ( finfo ( itime, npart ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', & - 'failed to allocate finfo' ) - END IF - END IF - - SELECT CASE ( fit_param % datatype ) -! FOR DATA TYPE FORCES - CASE ( 'POS_FORCE' ) - ALLOCATE ( r ( 1, 1, 3 ), STAT = isos ) - ALLOCATE ( v ( 1, 1, 3 ), STAT = isos ) ! reads force data - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', & - 'failed to allocate r and v' ) - - copy = .FALSE. - it = 0 - DO itime = 1, fit_param % nsteps - IF ( MOD ( itime, fit_param % iskip ) == 0 ) THEN - copy = .TRUE. - it = it + 1 - END IF - - DO ipart = 1, npart - READ ( 250, FMT = * ) ii, r ( 1, 1, : ), v ( 1, 1, : ) - IF ( copy ) THEN - finfo ( it, ipart ) % r ( : ) = r ( 1, 1, : ) - finfo ( it, ipart ) % f_ref ( : ) = v ( 1, 1, : ) - END IF - END DO - READ ( 250, FMT = * ) ii, dummy -! dbg -! IF ( copy ) v_ref ( it ) = dummy -! dbg - copy = .FALSE. - END DO - -! Reassign fit_param % nsteps = it - fit_param % nsteps = it - - DEALLOCATE ( r, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to deallocate r' ) - DEALLOCATE ( v, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to deallocate v' ) - -! FOR DATA TYPE TRAJECTORY - CASE ( 'POS_VEL' ) - ALLOCATE ( r ( 2, npart, 3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to allocate r' ) - ALLOCATE ( v ( 2, npart, 3 ), STAT = isos ) ! reads velocity data - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to allocate v' ) - -! Read in particles from t = 1 - DO ipart = 1, npart - READ ( 200, FMT = * ) ii, r ( 1, ipart, : ), v ( 1, ipart, : ) - END DO - -! initialize counter and logical - copy = .FALSE. - - it = 1 - DO itime = 2, fit_param % nsteps - -! set flag - IF ( MOD ( itime-1, fit_param % iskip ) == 0 ) copy = .TRUE. - - DO ipart = 1, npart - READ ( 200, FMT = * ) ii, r ( 2, ipart, : ), v ( 2, ipart, : ) - -! Invert velocity verlet equations - fref ( : ) = 2.0_dbl & - * struc % pnode ( ipart ) % p % prop % mass & - * ( r ( 2, ipart, : ) -r ( 1, ipart, : ) & - - simpar % dt * v ( 1, ipart, : ) ) & - / ( simpar % dt ** 2 ) - -! reassigning r ( 1 ) to r ( 2 ) and v ( 1 ) to v ( 2 ) -! for next force calculation - IF ( copy ) THEN - finfo ( it, ipart ) % r ( : ) = r ( 1, ipart, : ) - finfo ( it, ipart ) % f_ref ( : ) = fref ( : ) - END IF - END DO - -! increment the counter - IF ( ( itime /= fit_param % nsteps ) .AND. copy ) it = it + 1 - -! reset logical - copy = .FALSE. - r ( 1, :, : ) = r ( 2, :, : ) - v ( 1, :, : ) = v ( 2, :, : ) - END DO - -! Reassign fit_param % nsteps = it-1 - fit_param % nsteps = it - 1 - - DEALLOCATE ( r, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to deallocate r' ) - - DEALLOCATE ( v, STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'force_ref', 'failed to deallocate v' ) - - CASE DEFAULT - CALL stop_prg ( 'force_ref', 'no valid type' ) - END SELECT - -END SUBROUTINE force_ref - -!****************************************************************************** - -!! From the first principles trajectory file obtain the fit force -!! using a CP2K force field. - -SUBROUTINE forcefit ( fit_param, struc ) - - IMPLICIT NONE - -! Arguments - TYPE ( fit_parameter_type ), INTENT ( INOUT ) :: fit_param - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - -! Locals - INTEGER :: itime, ipart, npart - -!------------------------------------------------------------------------------ - - npart = SIZE ( struc % pnode ) - - DO itime = 1, fit_param % nsteps - DO ipart = 1, npart - struc % pnode ( ipart ) % p % r ( : ) & - = finfo ( itime, ipart ) % r ( : ) - END DO - - CALL force ( struc, thermo, simpar ) - - DO ipart = 1, npart - finfo ( itime, ipart ) % f_fit ( : ) & - = struc % pnode ( ipart ) % p % f ( : ) - END DO - -! dbg -! v_fit ( itime ) = thermo % pot -! dbg - - END DO - -END SUBROUTINE forcefit - -!****************************************************************************** - -FUNCTION local ( x, fit_param, struc, potparm ) - - IMPLICIT NONE - -! Return type - REAL ( dbl ) :: local - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: x - TYPE ( fit_parameter_type ), INTENT ( INOUT ) :: fit_param - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - -! Locals - REAL ( dbl ), DIMENSION ( 3 ) :: vec -! dbg -! REAL ( dbl ) :: vdiff -! dbg - INTEGER :: itime, ipart, npart - -!------------------------------------------------------------------------------ - - npart = SIZE ( struc % pnode ) - CALL copy_params ( fit_param, potparm, x ) - CALL forcefit ( fit_param, struc ) - - local = 0.0_dbl -! dbg -! vdiff = 0.0_dbl -! dbg - DO itime = 1, fit_param % nsteps - DO ipart = 1, npart - vec ( : ) = finfo ( itime, ipart ) % f_fit ( : ) & - - finfo ( itime, ipart ) % f_ref ( : ) - local = local + DOT_PRODUCT ( vec, vec ) - END DO -! dbg -! vdiff = vdiff + ( v_ref ( itime ) - v_fit ( itime ) ) ** 2 -! dbg - END DO - -! The addition of the 1 is a safety mechanism so -! that one can define the FRACTIONAL tolerance for -! systems whos func value may be converged at zero. -! It does not effect other converged func values. -! dbg -! local = local / ( 3._dbl*npart*fit_param % nsteps ) + 1._dbl - local = local / ( 3.0_dbl * npart * fit_param % nsteps ) -! dbg - -! dbg -! local = local+vdiff / fit_param % nsteps -! dbg - -END FUNCTION local - -!****************************************************************************** - -SUBROUTINE fit_print_info ( fit_param, tol, potparm ) - - IMPLICIT NONE - -! Arguments - TYPE ( fit_parameter_type ), INTENT ( IN ) :: fit_param - REAL ( dbl ), INTENT ( IN ) :: tol - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - -! Locals - INTEGER :: iatom, jatom - -!------------------------------------------------------------------------------ - - WRITE ( scr, '( )' ) - WRITE ( scr, '( A, A )' ) ' **************************************', & - '*****************************************' - WRITE ( scr, '( A, T71, A )' ) ' FIT TYPE = ', & - ADJUSTR ( fit_param % type ) - WRITE ( scr, '( A, T71, I10 )' ) ' ITERATION NUMBER = ', iter -! dbg - WRITE ( scr, '( A, T66, E15.7 )' ) ' | ( F_REF-F_FIT ) |^2 = ', & - sum ( y ) / SIZE ( y ) -! WRITE ( scr, '( A, T66, E15.7 )' ) ' | ( F_REF-F_FIT ) |^2 = ', & -! sum ( y ) / SIZE ( y ) -1._dbl -! dbg - WRITE ( scr, '( A, T66, E15.7 )' ) ' TOLERANCE = ', tol - WRITE ( scr, '( )' ) - - IF ( fit_param % type == 'LJ' ) THEN - WRITE ( scr, '( T5, A, T15, A, T50, A, T73, A )' ) & - 'ATOMI', 'ATOMJ', 'EPSILON', 'SIGMA' - WRITE ( scr, '( )' ) - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - WRITE ( scr, '( T5, A, T15, A, T45, E15.8, T66, E15.8 )' ) & - atom_names ( iatom ), atom_names ( jatom ), & - ave_eps ( iatom, jatom ), ave_sig ( iatom, jatom ) - END DO - END DO - - ELSE IF ( fit_param % type == 'WILL' ) THEN - - WRITE ( scr, '( T5, A, T15, A, T44, A, T60, A, T75, A )' ) & - 'ATOMI', 'ATOMJ', 'A', 'B', 'C' - WRITE ( scr, '( )' ) - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - WRITE ( scr, & - '( T5, A, T15, A, T39, E12.6, T54, E12.6, T69, E12.6 )' ) & - atom_names ( iatom ), atom_names ( jatom ), & - ave_a ( iatom, jatom ), ave_b ( iatom, jatom ), & - ave_c ( iatom, jatom ) - END DO - END DO - - ELSE - CALL stop_prg ( "fit_print_info", "no valid potential type" ) - END IF - - WRITE ( scr, '( A, A )' ) ' **************************************', & - '*****************************************' - -END SUBROUTINE fit_print_info - -!****************************************************************************** - -SUBROUTINE get_lj_params ( potparm ) - - IMPLICIT NONE - -! Arguments - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - -! Locals - INTEGER :: iatom, jatom, i - TYPE ( linklist_real_type ), POINTER :: lleps - TYPE ( linklist_real_type ), POINTER :: llsig - -!------------------------------------------------------------------------------ - - ave_sig = 0.0_dbl - ave_eps = 0.0_dbl - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - lleps => param ( iatom, jatom ) % lleps - llsig => param ( iatom, jatom ) % llsig - DO i = 1, SIZE ( y ) - ave_sig ( iatom, jatom ) = ave_sig ( iatom, jatom ) & - + llsig % sig ** 2 - ave_eps ( iatom, jatom ) = ave_eps ( iatom, jatom ) & - + lleps % eps ** 2 - llsig => llsig % next - lleps => lleps % next - END DO - ave_sig ( iatom, jatom ) = ave_sig ( iatom, jatom ) / SIZE ( y ) - ave_eps ( iatom, jatom ) = ave_eps ( iatom, jatom ) / SIZE ( y ) - END DO - END DO - - ave_sig = ave_sig ** ( 1.0_dbl / 6.0_dbl ) - -END SUBROUTINE get_lj_params - -!****************************************************************************** - -SUBROUTINE get_will_params ( potparm ) - - IMPLICIT NONE - -! Arguments - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( INOUT ) :: potparm - -! Locals - INTEGER :: iatom, jatom, i - TYPE ( linklist_real_type ), POINTER :: lla - TYPE ( linklist_real_type ), POINTER :: llb - TYPE ( linklist_real_type ), POINTER :: llc - -!------------------------------------------------------------------------------ - - ave_a = 0.0_dbl - ave_b = 0.0_dbl - ave_c = 0.0_dbl - DO iatom = 1, SIZE ( potparm, 1 ) - DO jatom = iatom, SIZE ( potparm, 2 ) - lla => param ( iatom, jatom ) % lla - llb => param ( iatom, jatom ) % llb - llc => param ( iatom, jatom ) % llc - DO i = 1, SIZE ( y ) - ave_a ( iatom, jatom ) = ave_a ( iatom, jatom ) + lla % a * lla % a - ave_b ( iatom, jatom ) = ave_b ( iatom, jatom ) + llb % b * llb % b - ave_c ( iatom, jatom ) = ave_c ( iatom, jatom ) + llc % c * llc % c - lla => lla % next - llb => llb % next - llc => llc % next - END DO - ave_a ( iatom, jatom ) = ave_a ( iatom, jatom ) / SIZE ( y ) - ave_b ( iatom, jatom ) = ave_b ( iatom, jatom ) / SIZE ( y ) - ave_c ( iatom, jatom ) = ave_c ( iatom, jatom ) / SIZE ( y ) - END DO - END DO - -END SUBROUTINE get_will_params - -!****************************************************************************** - -SUBROUTINE fit_write_restart ( y, p ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: y - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: p - -! Locals - INTEGER :: i, j, iochannel = 99 - -!------------------------------------------------------------------------------ - -! write to the restart file - OPEN ( UNIT = iochannel, FILE = 'amoeba.rst', STATUS = 'UNKNOWN' ) - - DO i = 1, SIZE ( y ) - WRITE ( iochannel, FMT = * ) y ( i ) - END DO - - DO i = 1, SIZE ( y ) - WRITE ( iochannel, FMT = * ) ( p ( i, j ), j = 1, SIZE ( p, 2 ) ) - END DO - - CLOSE ( UNIT = iochannel ) - -END SUBROUTINE fit_write_restart - -!****************************************************************************** - -SUBROUTINE fit_read_restart ( y, p ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: y - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: p - -! Locals - INTEGER :: i, j, iochannel = 99 - -!------------------------------------------------------------------------------ - -! read from the restart file - OPEN ( UNIT = iochannel, FILE = 'amoeba.rst', STATUS = 'UNKNOWN' ) - - DO i = 1, SIZE ( y ) - READ ( iochannel, FMT = * ) y ( i ) - END DO - - DO i = 1, SIZE ( y ) - READ ( iochannel, FMT = * ) ( p ( i, j ), j = 1, SIZE ( p, 2 ) ) - END DO - - CLOSE ( UNIT = iochannel ) - -END SUBROUTINE fit_read_restart - -!****************************************************************************** - -END MODULE force_fit diff --git a/src/global_types.h b/src/global_types.h deleted file mode 100644 index c49932b..0000000 --- a/src/global_types.h +++ /dev/null @@ -1,32 +0,0 @@ -#ifndef _GLOBAL_TYPES_H -#define _GLOBAL_TYPES_H - -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#ifdef __cplusplus -namespace CP2K_NS { -#include -#endif - -typedef struct global_environment_type { - char *input_file_name; - char *program_name; - char *project_name; - bool ionode; // this processor performs global output - int group; // group handle for all processors - int source; // processor id for global output node - int num_pe; // total number of processors - int mepos; // position number for local processor - int print_level; // how much information is written - int idum; // random number seed - int scr; // output unit -} global_environment_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/header.c b/src/header.c deleted file mode 100644 index 2d2907f..0000000 --- a/src/header.c +++ /dev/null @@ -1,119 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include "header.h" - -//***************************************************************************** - -void fist_header(FILE *iw) { - -//----------------------------------------------------------------------------- - - fprintf(iw, "\n"); - fprintf(iw, " _ __ \n"); - fprintf(iw, " ___/ \\/ \\__ \n"); - fprintf(iw, " /| | | | \\ \n"); - fprintf(iw, " / | | | | | \n"); - fprintf(iw, " | | | | | | \n"); - fprintf(iw, " FRONTIERS IN | \\__| |__|__| SIMULATION TECHNOLOGY\n"); - fprintf(iw, " | \\__/ \\ \n"); - fprintf(iw, " C.J. Mundy \\ \\____/ | \n"); - fprintf(iw, " S. Balasubramanian / | 1998-2024\n"); - fprintf(iw, " Ken Bagchi \\ / Version 0.0\n"); - fprintf(iw, " \n"); -} - -//***************************************************************************** - -void tbmd_header(FILE *iw) { - -//----------------------------------------------------------------------------- - - fprintf(iw, "\n"); - fprintf(iw, " ********************** ************* ******** \n"); - fprintf(iw, " ************************ *************** ********** \n"); - fprintf(iw, " *************** *** *************** *********** \n"); - fprintf(iw, " **** **** **** **** **** *** **** \n"); - fprintf(iw, " **** *********** **** **** *** **** \n"); - fprintf(iw, " **** **** *** **** **** *********** \n"); - fprintf(iw, " **** *********** **** **** ********** \n"); - fprintf(iw, " **** ********* **** **** ******* \n"); - fprintf(iw, " \n"); - fprintf(iw, " University of Zurich \n"); - fprintf(iw, " 2000 \n"); - fprintf(iw, " \n"); - fprintf(iw, " Version 0.0 \n"); - fprintf(iw, " \n"); -} - -//***************************************************************************** - -void qs_header(FILE *iw) { - - fprintf(iw, "\n"); - fprintf(iw, " ***** \n"); - fprintf(iw, " ********* ** *** ** \n"); - fprintf(iw, " **** **** *** *** ****** \n"); - fprintf(iw, "**** **** ** *** ***** *** *** *********** ****** ****** \n"); - fprintf(iw, "**** ******** *** *** ******* ****** **** **** *** *** ** ***\n"); - fprintf(iw, " **** ***** *** *** *** *** **** ****** **** ******** *******\n"); - fprintf(iw, " ********** ******* *** ******* ****** ******** **** ***** \n"); - fprintf(iw, " ***** ** ***** *** ***** *** ******* **** ****** *** \n"); - fprintf(iw, " *** \n"); - fprintf(iw, " \n"); - fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 2024 \n"); - fprintf(iw, " \n"); - fprintf(iw, " Version 0.0 \n"); - fprintf(iw, " \n"); -} - -//***************************************************************************** - -void wave_header(FILE *iw) { - -//----------------------------------------------------------------------------- - - fprintf(iw, "\n"); - fprintf(iw, " **** **** ********* **** *********** \n"); - fprintf(iw, " **** **** *********** **** ************* \n"); - fprintf(iw, " **** *** ******* ******** ******** \n"); - fprintf(iw, " **** ***** ******* ******** **** ************ \n"); - fprintf(iw, " **** *** *** ******************* **** ************ \n"); - fprintf(iw, " ******** **************************** **** \n"); - fprintf(iw, " ****** ****** **** **** ******* ********** \n"); - fprintf(iw, " **** **** **** **** ****** ******** \n"); - fprintf(iw, " \n"); - fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 2024 \n"); - fprintf(iw, " \n"); - fprintf(iw, " Version 0.0 \n"); - fprintf(iw, " \n"); -} - -//***************************************************************************** - -void faust_header(FILE *iw) { - -//----------------------------------------------------------------------------- - - fprintf(iw, "\n"); - fprintf(iw, " **** **** ********* **** *********** \n"); - fprintf(iw, " **** **** *********** **** ************* \n"); - fprintf(iw, " **** *** ******* ******** ******** \n"); - fprintf(iw, " **** ***** ******* ******** **** ************ \n"); - fprintf(iw, " **** *** *** ******************* **** ************ \n"); - fprintf(iw, " ******** **************************** **** \n"); - fprintf(iw, " ****** ****** **** **** ******* ********** \n"); - fprintf(iw, " **** **** **** **** ****** ******** \n"); - fprintf(iw, " \n"); - fprintf(iw, " MPI Festkoerperforschung Stuttgart \n"); - fprintf(iw, " 2024 \n"); - fprintf(iw, " \n"); - fprintf(iw, " Version 0.0 \n"); - fprintf(iw, " \n"); -} - -/*****************************************************************************/ diff --git a/src/header.h b/src/header.h deleted file mode 100644 index 82c10f4..0000000 --- a/src/header.h +++ /dev/null @@ -1,21 +0,0 @@ -#ifndef _HEADER_H -#define _HEADER_H - -// Secure block -#ifdef __cplusplus -extern "C" { -#endif - -#include - -void fist_header(FILE *iw); -void tbmd_header(FILE *iw); -void qs_header(FILE *iw); -void wave_header(FILE *iw); -void faust_header(FILE *iw); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/initialize_ewalds.c b/src/initialize_ewalds.c deleted file mode 100644 index ad834cc..0000000 --- a/src/initialize_ewalds.c +++ /dev/null @@ -1,111 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE initialize_ewalds - - USE dg, ONLY : dg_grid_setup - USE ewalds, ONLY : ewald_self - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE io_parameters, ONLY : scr - USE kinds, ONLY : dbl - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : particle_node_type - USE particle_types, ONLY : particle_type - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup - USE simulation_cell, ONLY : cell_type - - PUBLIC :: initialize_ewald - PRIVATE - -CONTAINS - -!****************************************************************************** - -SUBROUTINE initialize_ewald ( part, pnode, ewald_param, box, thermo, & - ewald_grid, pme_small_grid, pme_big_grid ) - - IMPLICIT NONE - -! Arguments - TYPE ( ewald_parameters_type ), INTENT ( OUT ) :: ewald_param - TYPE ( particle_type ), INTENT ( IN ) :: part ( : ) - TYPE ( particle_node_type ), INTENT ( IN ) :: pnode ( : ) - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: ewald_grid - TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: pme_small_grid - TYPE ( pw_grid_type ), INTENT ( OUT ), OPTIONAL :: pme_big_grid - -! Locals - INTEGER :: natoms, iw, iat, jat, gmax, npts ( 3 ) - REAL ( dbl ) :: qi, qj, i, cutoff - -!------------------------------------------------------------------------------ - - iw = scr - natoms = SIZE ( part ) - - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - - WRITE ( iw, '( A,T71,A )' ) ' Ewald summation is done by:', & - ewald_param % ewald_type - WRITE ( iw, '( A,T71,F10.4 )' ) ' Ewald alpha parameter [A]', & - ewald_param % alpha - - SELECT CASE(ewald_param % ewald_TYPE ( 1:3)) - CASE DEFAULT - WRITE ( iw, '( A,T71,I10 )' ) & - ' Ewald G-space max. Miller index', ewald_param % gmax - - CASE ( 'PME') - WRITE ( iw, '( A,T71,I10 )' ) & - ' PME max small-grid points ', ewald_param % ns_max - WRITE ( iw, '( A,T71,F10.4 )' ) & - ' PME gaussian tolerance ', ewald_param % epsilon - END SELECT - - ELSE - - WRITE( iw, '( A )' ) ' No Ewald summation is performed' - - END IF - -! fire up the reciprocal space and compute self interaction and -! term from the neutralizing background. - - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - - CALL ewald_self ( ewald_param, thermo, pnode ) - -! set up EWALD_GAUSS - IF ( PRESENT ( ewald_grid)) THEN - gmax = ewald_param % gmax - IF ( gmax == 2 * ( gmax / 2 ) ) THEN - CALL stop_prg ( "initialize_ewalds", "gmax has to be odd" ) - END IF - ewald_grid % bounds ( 1, : ) = -gmax / 2 - ewald_grid % bounds ( 2, : ) = +gmax / 2 - npts=( / gmax, gmax, gmax / ) - - CALL dg_find_cutoff ( npts, box, cutoff ) - - CALL pw_grid_setup( box, ewald_grid, cutoff) - END IF -! set up PME_GAUSS - -!dbg -! IF ( PRESENT ( pme_small_grid).AND. PRESENT ( pme_big_grid)) -! CALL CALL dg_setup(box, npts_s, epsilon, alpha, pme_small_grid, & -! pme_big_grid, ewald_param % ewald_type ) -!dbg - - END IF - -END SUBROUTINE initialize_ewald - -!****************************************************************************** - -END MODULE initialize_ewalds diff --git a/src/initialize_extended_types.c b/src/initialize_extended_types.c deleted file mode 100644 index de285fe..0000000 --- a/src/initialize_extended_types.c +++ /dev/null @@ -1,120 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE initialize_extended_types - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type - USE molecule_types, ONLY : molecule_structure_type, molecule_type - USE mp, ONLY : mp_sum - USE nhc, ONLY : nhc_control - USE nose, ONLY : initial_nhc, extended_parameters_type, initial_npt - USE simulation_cell, ONLY : cell_type - - IMPLICIT NONE - - PUBLIC :: initialize_extended_type - PRIVATE - -CONTAINS - -!****************************************************************************** - -SUBROUTINE initialize_extended_type ( box, simpar, molecule, mol_setup, nhcp, & - globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( simulation_parameters_type ), INTENT ( INOUT ) :: simpar - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( INOUT ) :: mol_setup - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - -!------------------------------------------------------------------------------ - -! fire up the thermostats, if not NVE - IF ( simpar % ensemble /= 'NVE' ) THEN - CALL nhc_control ( simpar, molecule, mol_setup, nhcp, globenv ) - - IF ( simpar % read_type /= 'ALL' ) THEN - -! Initializing thermostat forces and velocities for the Nose-Hoover -! Chain variables - CALL initial_nhc ( nhcp, simpar % tau_nhc, simpar % temp_ext, globenv ) - END IF - - END IF -! compute the total number of degrees of freedom for temperature - -! Initialize simpar%nfree to dim (because at this point no -! assumptions have been made about thermostatting options -! and COM is ALWAYS zeroed in this code. If there are -! multiple thermostats etc...simpar%nfree will be set -! to zero in nhc_control.f) - simpar % nfree = 6 - SUM ( box % perd ( 1:3 ) ) - - CALL get_nfree ( simpar, molecule, globenv ) - - IF ( simpar % ensemble ( 1:3 ) == 'NPT' ) CALL initial_npt ( nhcp, & - simpar % tau_cell, simpar % temp_ext, box % deth, simpar % nfree, & - simpar % ensemble, globenv ) - -END SUBROUTINE initialize_extended_type - -!****************************************************************************** - -SUBROUTINE get_nfree ( simpar, molecule, globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( simulation_parameters_type ), INTENT ( INOUT ) :: simpar - TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - INTEGER :: imol, nconst, natoms, nfree, iw - -!------------------------------------------------------------------------------ - - nconst = 0 - natoms = 0 - DO imol = 1, SIZE ( molecule ) - nconst = nconst + molecule ( imol ) % ndistconst_mol - nconst = nconst + 3 * molecule ( imol ) % ng3x3const_mol - natoms = natoms + molecule ( imol ) % natoms_mol - END DO - -#if defined(__parallel) - CALL mp_sum(nconst,globenv % group) - CALL mp_sum(natoms,globenv % group) -#endif - -! definining simpar%nfree. If multiple thermostats present -! it is initialized to 0. It one thermostat or no thermostats -! it is initialized to 3 - nfree = 3 * natoms - nconst - simpar % nfree - IF ( globenv % ionode .AND. globenv % print_level > 2 ) THEN - iw = globenv % scr - WRITE ( iw, '( /, A )' ) ' Calculation of degrees of freedom' - WRITE ( iw, '( T48, A, T71, I10 )' ) ' Number of atoms:', natoms - WRITE ( iw, '( T48, A, T71, I10 )' ) ' Number of constraints:', nconst - WRITE ( iw, '( T34, A, T71, I10 )' ) & - ' Invariants(translation + rotations):', simpar % nfree - WRITE ( iw, '( T48, A, T71, I10 )' ) ' Degrees of freedom:', nfree - WRITE ( iw, '()' ) - END IF - simpar % nfree = nfree - -END SUBROUTINE get_nfree - -!****************************************************************************** - -END MODULE initialize_extended_types diff --git a/src/initialize_molecule_types.c b/src/initialize_molecule_types.c deleted file mode 100644 index 2c1bb39..0000000 --- a/src/initialize_molecule_types.c +++ /dev/null @@ -1,140 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE initialize_molecule_types - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklists, ONLY : atom_link_list, exclusion, bond_link_list, & - bend_link_list, torsion_link_list, distconst_link_list, g3x3_link_list - USE md, ONLY : simulation_parameters_type - USE molecule_types, ONLY : molecule_type, intra_parameters_type, & - particle_node_type, molecule_structure_type - USE particle_types, ONLY : particle_type, particle_prop_type - USE util, ONLY : get_limit - - IMPLICIT NONE - - PUBLIC :: initialize_molecule_type - PRIVATE - -CONTAINS - -!****************************************************************************** - -SUBROUTINE initialize_molecule_type ( mol_setup, intra_param, & - pnode, part, molecule, globenv ) - - IMPLICIT NONE - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( IN ) :: mol_setup - TYPE ( intra_parameters_type ), INTENT ( IN ) :: intra_param - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( INOUT ), TARGET :: part - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - INTEGER :: imol, i, j, k, atombase, iat, nlim ( 2 ), iw, nmol_type - -!------------------------------------------------------------------------------ - - iw = globenv % scr - IF ( globenv % num_pe == 1 ) THEN - imol = 0 - atombase = 1 - nmol_type = SIZE ( mol_setup ) - DO i = 1, nmol_type - DO k = 1, mol_setup ( i ) %num_mol - imol = imol + 1 - molecule(imol) % mol_name = mol_setup(i) % molpar% name - molecule(imol) % imol = imol - molecule(imol) % atombase = atombase - molecule(imol) % moltype = i - molecule(imol) % natoms_mol = mol_setup(i) % molpar% natom - molecule(imol) % nbonds_mol = mol_setup(i) % molpar% nbonds - molecule(imol) % nbends_mol = mol_setup(i) % molpar% nbends - molecule(imol) % ntorsions_mol = mol_setup(i) % molpar % ntorsions - molecule(imol) % ndistconst_mol = mol_setup(i) % molpar % ndcon - molecule(imol) % ng3x3const_mol = mol_setup(i) % molpar % n3x3con - IF (globenv%ionode .AND. globenv%print_level>9) WRITE (iw, & - '(A,I10,T40,A,I5,A,T61,A20 )' ) ' Molecule:', imol, & - ' Type:', i, ' Name:', & - ADJUSTR ( mol_setup(i) % molpar % name) - atombase = atombase + mol_setup(i) % molpar % natom - END DO - END DO - DO iat = 1, size(pnode) - pnode(iat) %p => part(iat) - END DO - - ELSE - - imol = 0 - atombase = 1 - nmol_type = SIZE ( mol_setup ) - DO i = 1, nmol_type - nlim = get_limit ( mol_setup ( i ) % num_mol, globenv % num_pe, & - globenv % mepos ) - j = SUM( mol_setup(1:i) % num_mol ) - DO k = nlim(1), nlim(2) - imol = imol + 1 - molecule(imol) % mol_name = mol_setup(i) % molpar%name - molecule(imol) % imol = j + k - molecule(imol) % atombase = atombase + & - (k-1)*mol_setup(i) % molpar % natom - molecule(imol) % moltype = i - molecule(imol) % natoms_mol = mol_setup(i) % molpar%natom - molecule(imol) % nbonds_mol = mol_setup(i) % molpar%nbonds - molecule(imol) % nbends_mol = mol_setup(i) % molpar%nbends - molecule(imol) % ntorsions_mol = mol_setup(i) % molpar%ntorsions - molecule(imol) % ndistconst_mol = mol_setup(i) % molpar%ndcon - molecule(imol) % ng3x3const_mol = mol_setup(i) % molpar%n3x3con - IF (globenv%ionode .AND. globenv%print_level>9) WRITE (iw, & - '(A,I10,T40,A,I5,A,T61,A20 )' ) ' Molecule:', imol, & - ' Type:', i, ' Name:', ADJUSTR ( mol_setup(i) % molpar%name) - END DO - atombase = atombase & - + mol_setup(i) % num_mol * mol_setup(i) % molpar % natom - END DO - - k = 0 - DO imol = 1, size(molecule) - atombase = molecule(imol) % atombase - 1 - DO j = 1, molecule(imol) % natoms_mol - k = k + 1 - pnode(k) % p => part(atombase+j) - END DO - END DO - END IF - -!..atom link list - CALL atom_link_list(molecule,pnode) - -!..initialize bonds - CALL bond_link_list(pnode,molecule,mol_setup,intra_param % bond_param) - -!..initialize bends - CALL bend_link_list(pnode,molecule,mol_setup,intra_param % bend_param) - -!..initialize torsions - CALL torsion_link_list(pnode,molecule,mol_setup,intra_param % torsion_param) - -!..initialize distance constraints - CALL distconst_link_list(pnode,molecule,mol_setup, & - intra_param % constraint_distance) - -!..initialize g3x3 constraints - CALL g3x3_link_list(pnode,molecule,mol_setup, & - intra_param % constraint_distance) - -!..create exclusion list - CALL exclusion(molecule,pnode) - -END SUBROUTINE initialize_molecule_type - -!****************************************************************************** - -END MODULE initialize_molecule_types diff --git a/src/initialize_particle_types.c b/src/initialize_particle_types.c deleted file mode 100644 index c46c1e2..0000000 --- a/src/initialize_particle_types.c +++ /dev/null @@ -1,81 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE initialize_particle_types - - USE atoms_input, ONLY : system_type - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type - USE molecule_types, ONLY : molecule_type - USE particle_types, ONLY : particle_type, particle_prop_type - USE stop_program, ONLY : stop_prg - USE string_utilities, ONLY : str_search - - IMPLICIT NONE - - PUBLIC :: initialize_particle_type - PRIVATE - -CONTAINS - -!****************************************************************************** - -SUBROUTINE initialize_particle_type ( atom_names, simpar, mol_setup, & - ainp, pstat, part ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( INOUT ) :: part - TYPE ( particle_prop_type ), INTENT ( IN ), DIMENSION ( : ), TARGET :: pstat - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( IN ) :: mol_setup - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( system_type ), INTENT ( INOUT ) :: ainp - CHARACTER ( len = * ), DIMENSION ( : ), INTENT ( IN ) :: atom_names - -!locals - INTEGER :: natoms,iat,nmol_type,i,j,k,n,iw,natom_types - -!------------------------------------------------------------------------------ - - natoms = SIZE ( ainp % c, 2 ) - DO iat = 1, natoms - part(iat) % iatom = iat - part(iat) % r(1) = ainp % c(1,iat) - part(iat) % r(2) = ainp % c(2,iat) - part(iat) % r(3) = ainp % c(3,iat) - END DO - - IF ( simpar%read_type=='POSVEL') THEN - DO iat = 1, natoms - part(iat) %v(1) = ainp%v(1,iat) - part(iat) %v(2) = ainp%v(2,iat) - part(iat) %v(3) = ainp%v(3,iat) - END DO - END IF - - iat = 0 - nmol_type = SIZE(mol_setup) - natom_types = SIZE(atom_names) - DO i = 1, nmol_type - DO k = 1, mol_setup(i) % num_mol - DO j = 1, mol_setup(i) % molpar % natom - iat = iat + 1 - n = str_search ( atom_names, natom_types, & - mol_setup ( i ) % molpar % aname ( j ) ) - part ( iat ) % prop => pstat ( n ) - -!!!! IF ( globenv % ionode .AND. globenv % print_level > 9 ) & -!!!! WRITE ( globenv % scr, '( A, I10, T60, A, T71, I10 )' ) & -!!!! ' DEBUG| Particle:', iat, ' Type:', n - END DO - END DO - END DO - -END SUBROUTINE initialize_particle_type - -!****************************************************************************** - -END MODULE initialize_particle_types diff --git a/src/input_types.c b/src/input_types.c deleted file mode 100644 index caebd95..0000000 --- a/src/input_types.c +++ /dev/null @@ -1,22 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE input_types - - IMPLICIT NONE - - TYPE setup_parameters_type - INTEGER :: nmol, natoms, natom_type - INTEGER :: perd ( 3 ) - CHARACTER ( LEN = 20 ) :: set_file_name - CHARACTER ( LEN = 20 ) :: input_file_name - CHARACTER ( LEN = 10 ) :: run_type - CHARACTER ( LEN = 10 ) :: unit_type - END TYPE setup_parameters_type - - PRIVATE - PUBLIC :: setup_parameters_type - -END MODULE input_types diff --git a/src/integrator.c b/src/integrator.c deleted file mode 100644 index a91e6e9..0000000 --- a/src/integrator.c +++ /dev/null @@ -1,1099 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE integrator - -! USE constraint, ONLY : shake_control, rattle_control, getold, & -! pv_constraint, initialize_roll, rattle_roll_control, & -! shake_roll_control - USE constraint - USE eigenvalueproblems, ONLY : diagonalise - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE force_control, ONLY : force - USE kinds, ONLY : dbl -!*apsi USE lapack, ONLY : rs - USE linklist_control, ONLY : get_ll_parm - USE mathconstants, ONLY : pi, zero - USE md, ONLY : simulation_parameters_type, thermodynamic_type, & - mdio_parameters_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type, & - linklist_atoms - USE mp, ONLY : mp_sum - USE nose, ONLY : extended_parameters_type, lnhc, lnhcp, lnhcpf - USE pair_potential, ONLY : potentialparm_type - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : get_cell_param - USE stop_program, ONLY : stop_prg, stop_memory - USE structure_types, ONLY : structure_type - USE timings, ONLY : timeset, timestop - USE util, ONLY : get_unit - - IMPLICIT NONE - - PRIVATE - PUBLIC :: velocity_verlet, force, energy, set_energy_parm, set_integrator - - TYPE old_variables_type - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: v - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: r - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: eps - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: veps - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: eta - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: veta - REAL ( dbl ), POINTER, DIMENSION ( :, : ) :: h - END TYPE old_variables_type - - TYPE ( old_variables_type ) :: old - - TYPE average_quantities_type - REAL ( dbl ) :: avetemp, avepot, avekin, avevol, aveca, avecb, avecc - REAL ( dbl ) :: aveal, avebe, avega, avepress, avekincoef - END TYPE average_quantities_type - - CHARACTER ( LEN = 10 ) :: pres_label, e_label, temp_label - CHARACTER ( LEN = 10 ) :: l_label, vol_label, angl_label - REAL ( dbl ) :: econs_avg - REAL ( dbl ) :: p_conv, temp_conv - TYPE (average_quantities_type ) :: averages - - LOGICAL :: ionode - INTEGER :: int_group - CHARACTER (LEN=50) :: crd_file_name, vel_file_name, ptens_file_name, & - ener_file_name, temp_file_name, dump_file_name - INTEGER :: crd, vel, ptn, ene, tem, scr - INTEGER :: icrd, ivel, iptens, iener, itemp, idump, iscreen - -CONTAINS - -!****************************************************************************** - -SUBROUTINE velocity_verlet ( itimes, constant, simpar, potparm, & - thermo, struc, ewald_param, nhcp ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -!------------------------------------------------------------------------------ - - SELECT CASE ( simpar % ensemble ) - CASE DEFAULT - CALL stop_prg ( 'velocity_verlet','integrator not implemented') - CASE ( 'NVE') - CALL nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) - CALL energy(itimes,constant,simpar,struc,thermo,nhcp) - CASE ( 'NVT') - CALL nvt(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) - CALL energy(itimes,constant,simpar,struc,thermo,nhcp) - CASE ( 'NPT_I') - CALL npt_i(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) - CALL energy(itimes,constant,simpar,struc,thermo,nhcp) - CASE ( 'NPT_F') - CALL npt_f(itimes,constant,simpar,potparm,thermo,struc,ewald_param,nhcp) - CALL energy(itimes,constant,simpar,struc,thermo,nhcp) - END SELECT - -END SUBROUTINE velocity_verlet - -!****************************************************************************** - -! call this subroutine before the first call to energy or velocity_verlet -! or if you want to change ionode and/or output files - -SUBROUTINE set_integrator ( ion, group, iw, mdio ) - IMPLICIT NONE - -! Arguments - LOGICAL, INTENT (IN) :: ion - INTEGER, INTENT (IN) :: group - INTEGER, INTENT (IN) :: iw - TYPE(mdio_parameters_type), INTENT (IN) :: mdio - -!------------------------------------------------------------------------------ - - ionode = ion - int_group = group - scr = iw - - crd_file_name = mdio % crd_file_name - vel_file_name = mdio % vel_file_name - ptens_file_name = mdio % ptens_file_name - ener_file_name = mdio % ener_file_name - temp_file_name = mdio % temp_file_name - dump_file_name = mdio % dump_file_name - - icrd = mdio % icrd - ivel = mdio % ivel - iptens = mdio % iptens - iener = mdio % iener - itemp = mdio % itemp - idump = mdio % idump - iscreen = mdio % iscreen - - crd = get_unit() - vel = get_unit() - ptn = get_unit() - ene = get_unit() - tem = get_unit() - -END SUBROUTINE set_integrator - -!****************************************************************************** - -SUBROUTINE set_energy_parm ( pconv, tempconv, l, vol, e, pres, temp, angl ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: pconv, tempconv - CHARACTER ( LEN = 10 ), INTENT ( IN ), OPTIONAL :: l, vol, e - CHARACTER ( LEN = 10 ), INTENT ( IN ), OPTIONAL :: pres, temp, angl - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( pconv)) p_conv = pconv - IF ( PRESENT ( tempconv)) temp_conv = tempconv - IF ( PRESENT ( l)) l_label = l - IF ( PRESENT ( vol)) vol_label = vol - IF ( PRESENT ( e)) e_label = e - IF ( PRESENT ( pres)) pres_label = pres - IF ( PRESENT ( temp)) temp_label = temp - IF ( PRESENT ( angl)) angl_label = angl -END SUBROUTINE set_energy_parm - -!****************************************************************************** -! this routine computes the conserved quantity, temperature -! and things like that and prints them out - -SUBROUTINE energy ( itimes, constant, simpar, struc, thermo, nhcp ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - -! Locals - INTEGER i, j, id, n, l, nnodes, iw, handle - REAL ( dbl ) :: nhc_pot, nhc_kin, baro_kin, baro_pot - REAL ( dbl ) :: alpha, epsilon0, qsq, lup, aup - REAL ( dbl ) :: cons, temp, econs - REAL ( dbl ), DIMENSION(3) :: cell, ang - REAL ( dbl ) :: pv_scalar - -!------------------------------------------------------------------------------ - - CALL timeset ( 'ENERGY', 'I', ' ', handle ) - - IF ( ionode .AND. itimes == 0 ) THEN - OPEN ( UNIT = tem, FILE = temp_file_name ) - OPEN ( UNIT = ene, FILE = ener_file_name ) - OPEN ( UNIT = crd, FILE = crd_file_name ) - OPEN ( UNIT = vel, FILE = vel_file_name ) - OPEN ( UNIT = ptn, FILE = ptens_file_name ) - END IF - - iw = scr - thermo % kin = zero - nnodes = SIZE ( struc % pnode ) - DO i = 1, nnodes - thermo%kin = thermo%kin + 0.5_dbl*struc%pnode(i) %p%prop%mass*(struc & - %pnode(i)%p%v(1)*struc%pnode(i)%p%v(1)+struc%pnode(i)%p%v(2)*struc & - %pnode(i)%p%v(2)+struc%pnode(i)%p%v(3)*struc%pnode(i)%p%v(3)) - END DO - -! sum all contributions to energy over calculated parts on all processors -#if defined(__parallel) - CALL mp_sum(thermo%kin,int_group) -#endif - - temp = 2.0_dbl*thermo%kin/float(simpar%nfree)/temp_conv - IF (ionode .AND. mod(itimes,itemp)==0) THEN - WRITE (tem, *) itimes, temp - END IF - - IF (ionode .AND. mod(itimes,iptens)==0) THEN - DO i=1,3 - WRITE (ptn,*) itimes, (thermo%ptens(i,j), j=1,3) - END DO - END IF - - IF (ionode .AND. mod(itimes,icrd)==0) THEN - DO i=1, nnodes - WRITE (crd,'(i6,3(x,f12.5) )' ) itimes, struc%pnode(i) %p%r - END DO - END IF - -IF (ionode .AND. mod(itimes,ivel)==0) THEN - DO i=1, nnodes - WRITE (vel,'(i6,3f10.5 )' ) itimes, struc%pnode(i) %p%v - END DO - END IF - - IF (simpar%ensemble/='NVE') THEN - nhc_kin = 0.0_dbl - nhc_pot = 0.0_dbl - DO n = 1, nhcp%num_nhc - DO l = 1, nhcp%nhc_len - nhc_kin = nhc_kin + 0.5_dbl*nhcp%nvt(l,n) %mass*nhcp%nvt(l,n) %v & - **2 - nhc_pot = nhc_pot + nhcp%nvt(l,n) %nkt*nhcp%nvt(l,n) %eta - END DO - END DO -#if defined(__parallel) - IF (nhcp%dis_type=='DIS_REP') THEN - CALL mp_sum(nhc_kin,int_group) - CALL mp_sum(nhc_pot,int_group) - END IF -#endif - END IF - - IF (simpar%ensemble=='NPT_I') THEN - baro_pot = simpar%p_ext*struc%box%deth - baro_kin = 0.5_dbl*nhcp%npt(1,1) %v*nhcp%npt(1,1) %v* & - nhcp%npt(1,1) %mass - ELSE IF (simpar%ensemble=='NPT_F') THEN - baro_pot = simpar%p_ext*struc%box%deth - baro_kin = 0._dbl - DO i = 1, 3 - DO j = 1, 3 - baro_kin = baro_kin + 0.5_dbl*nhcp%npt(i,j) %v*nhcp%npt(i,j) %v* & - nhcp%npt(i,j) %mass - END DO - END DO - END IF - - IF (simpar%ensemble(1:3)=='NPT') THEN -#if defined(__parallel) - IF (nhcp%dis_type=='DIS_REP') THEN - CALL mp_sum(baro_kin,int_group) - CALL mp_sum(baro_pot,int_group) - END IF -#endif - END IF - - SELECT CASE (simpar%ensemble(1:3)) - CASE ( 'NVE') - cons = thermo%kin + thermo%pot - CASE ( 'NVT') - cons = thermo%kin + thermo%pot + nhc_kin + nhc_pot - CASE ( 'NPT') - cons = thermo%kin + thermo%pot + nhc_kin + nhc_pot + baro_kin + & - baro_pot - END SELECT - - IF (itimes==1) THEN - constant = cons - END IF - IF (itimes /= 0 ) econs = abs((cons-constant)/constant) - -! cell parameters: - CALL get_cell_param ( struc % box, cell, ang ) - -! initializing pv_const=0 - IF (itimes==0) THEN - thermo%pv_const = 0._dbl - CALL pressure(struc%pnode,thermo) - END IF - -! computing the scalar pressure - pv_scalar = 0._dbl - DO i = 1, 3 - pv_scalar = pv_scalar + thermo%ptens(i,i) - END DO - pv_scalar = pv_scalar/3._dbl/struc%box%deth - pv_scalar = pv_scalar*p_conv - -! average quantities: - SELECT CASE (itimes) - CASE (0) - IF (ionode) THEN - WRITE (iw,*) - WRITE ( iw, '( A )' ) ' ENERGY| Initialization proceeding' - WRITE (iw,*) - END IF - CASE (1) - averages%avepress = pv_scalar - averages%avetemp = temp - averages%avepot = thermo%pot - averages%avekin = thermo%kin - averages%avevol = struc%box%deth - averages%aveca = cell(1) - averages%avecb = cell(2) - averages%avecc = cell(3) - averages%aveal = ang(3) - averages%avebe = ang(2) - averages%avega = ang(1) - econs_avg = 0._dbl - CASE DEFAULT - averages%avepress = (averages%avepress*real(itimes-1)+pv_scalar)/ & - REAL ( itimes, dbl ) - averages%avetemp = (averages%avetemp*real(itimes-1)+temp)/ & - real(itimes) - averages%avepot = (averages%avepot*real(itimes-1)+thermo%pot)/ & - real(itimes) - averages%avekin = (averages%avekin*real(itimes-1)+thermo%kin)/ & - real(itimes) - averages%avevol = (averages%avevol*real(itimes-1)+struc%box%deth)/ & - real(itimes) - averages%aveca = (averages%aveca*real(itimes-1)+cell(1))/real(itimes) - averages%avecb = (averages%avecb*real(itimes-1)+cell(2))/real(itimes) - averages%avecc = (averages%avecc*real(itimes-1)+cell(3))/real(itimes) - averages%aveal = (averages%aveal*real(itimes-1)+ang(3))/ & - real(itimes) - averages%avebe = (averages%avebe*real(itimes-1)+ang(2))/ & - real(itimes) - averages%avega = (averages%avega*real(itimes-1)+ang(1))/ & - real(itimes) - econs_avg = econs_avg + abs((cons-constant)/constant) - END SELECT - - IF (ionode .AND. (mod(itimes,iener)==0) .AND. (itimes /= 0 )) THEN - WRITE (ene, *) itimes, econs, econs_avg/real(itimes) - END IF - - IF (itimes==0 .AND. ionode) THEN - WRITE ( iw, '( )' ) - WRITE ( iw, '( A,A )' ) ' ******************************** ', & - 'GO CP2K GO! **********************************' - WRITE ( iw, '( A,A,T40,A,T65,1(1X,E15.7) )' ) ' INITIAL POTENTIAL ENERGY', & - adjustl(e_label), '= ', thermo%pot - WRITE ( iw, '( A,A,T40,A,T65,1(1X,E15.7) )' ) ' INITIAL KINETIC ENERGY', & - adjustl(e_label), '= ', thermo%kin - WRITE ( iw, '( A,A,T40,A,T65,1(1X,E15.7) )' ) ' INITIAL TEMPERATURE', & - adjustl(temp_label), '= ', temp - WRITE ( iw, '( A,A,T40,A,T65,1(1X,E15.7) )' ) ' INITIAL PRESSURE', & - adjustl(pres_label), '= ', pv_scalar - WRITE ( iw, '( A,A,T40,A,T65,1(1X,E15.7) )' ) ' INITIAL VOLUME', & - adjustl(vol_label), '= ', struc%box%deth - WRITE ( iw, '( A,A,T29,A,T33,3(1X,E15.7) )' ) ' INITIAL CELL LNTHS', & - adjustl(l_label), '= ', cell(1), cell(2), cell(3) - WRITE ( iw, '( A,A,T29,A,T33,3(1X,E15.7) )' ) ' INITIAL CELL ANGLS', & - adjustl(angl_label), '= ', ang(3), ang(2), ang(1) - WRITE ( iw, '( A,A )' ) ' ******************************** ', & - 'GO CP2K GO! **********************************' - END IF - - IF ( ( itimes /= 0 ) .AND. ( MOD ( itimes, iscreen ) == 0 ) & - .AND. ionode ) THEN - - WRITE ( iw, '( )' ) - WRITE ( iw, '( A,A )' ) ' **************************************', & - '*****************************************' - WRITE ( iw, '( A,T61,A )' ) ' ENSEMBLE TYPE = ', & - ADJUSTR ( simpar%ensemble) - WRITE ( iw, '( A,T71,I10 )' ) ' STEP NUMBER = ', itimes - WRITE ( iw, '( A,T65,1(1X,E15.7) )' ) ' CONSERVED QNTY = ', & - cons - WRITE ( iw, '( )' ) - WRITE ( iw, '( T52,A )' ) 'INSTANTANEOUS AVERAGES' - WRITE ( iw, '( A,T49,2(1X,E15.7) )' ) ' {E-E0}/E0 = ', & - econs, econs_avg/real(itimes) - WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' POTENTIAL ENERGY', & - adjustl(e_label), '= ', thermo%pot, averages%avepot - WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' KINETIC ENERGY', & - adjustl(e_label), '= ', thermo%kin, averages%avekin - WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' TEMPERATURE', & - adjustl(temp_label), '= ', temp, averages%avetemp - WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' PRESSURE', & - adjustl(pres_label), '= ', pv_scalar, averages%avepress - CALL get_ll_parm(lup,aup) - IF (simpar%ensemble(1:3)=='NPT') THEN - WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' VOLUME', & - adjustl(vol_label), '= ', struc%box%deth, averages%avevol - WRITE ( iw, '( A,A,T31,A,T33,3(1X,E15.7) )' ) ' CELL LNTHS', & - adjustl(l_label), '= ', cell(1), cell(2), cell(3) - WRITE ( iw, '( A,A,T31,A,T33,3(1X,E15.7) )' ) ' AVE. CELL LNTHS', & - adjustl(l_label), '= ', averages%aveca, averages%avecb, & - averages%avecc - END IF - IF (simpar%ensemble=='NPT_F') THEN - WRITE ( iw, '( A,A,T31,A,T33,3(1X,E15.7) )' ) ' CELL ANGLS', & - adjustl(angl_label), '= ', ang(3), ang(2), ang(1) - WRITE ( iw, '( A,A,T31,A,T33,3(1X,E15.7) )' ) ' AVE. CELL ANGLS', & - adjustl(angl_label), '= ', averages%aveal, averages%avebe, & - averages%avega - END IF - WRITE ( iw, '( A,A,T31,A,T49,2(1X,F15.2) )' ) & - ' LIST UPDATES', '[steps]', '= ', lup, aup - WRITE ( iw, '( A,A )' ) ' **************************************', & - '*****************************************' - WRITE ( iw, '( )' ) - END IF - - CALL timestop ( zero, handle ) - -END SUBROUTINE energy - -!****************************************************************************** - -! nve integrator for particle positions & momenta -! velocity Verlet - -SUBROUTINE nve(itimes,constant,simpar,potparm,thermo,struc,ewald_param) - IMPLICIT NONE - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - - INTEGER :: i, nnodes - REAL ( dbl ) :: dtom - -!------------------------------------------------------------------------------ - - IF ( simpar % constraint ) CALL getold ( struc % molecule ) - -! -! first half of velocity verlet -! - nnodes = size(struc%pnode) - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - struc%pnode(i) %p%r(1) = struc%pnode(i) %p%r(1) + & - struc%pnode(i) %p%v(1)*simpar%dt - struc%pnode(i) %p%r(2) = struc%pnode(i) %p%r(2) + & - struc%pnode(i) %p%v(2)*simpar%dt - struc%pnode(i) %p%r(3) = struc%pnode(i) %p%r(3) + & - struc%pnode(i) %p%v(3)*simpar%dt - END DO - - IF (simpar%constraint) CALL shake_control(struc%molecule,simpar) -#if defined(__parallel) - CALL update_structure(struc,'POS') -#endif - -! -! get new forces -! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) - -! -! second half of velocity verlet -! - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - END DO - - IF (simpar%constraint) CALL rattle_control(struc%molecule,simpar) -#if defined(__parallel) - CALL update_structure(struc,'VEL') -#endif - -! updating the virial - IF (simpar%constraint) CALL pv_constraint(struc%molecule,thermo, & - 'FULL', int_group ) - - CALL pressure(struc%pnode,thermo) - -END SUBROUTINE nve - -!****************************************************************************** - -SUBROUTINE nvt(itimes,constant,simpar,potparm,thermo,struc, & - ewald_param,nhcp) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - -! Locals - INTEGER :: i, nnodes - REAL ( dbl ) :: dtom - -!------------------------------------------------------------------------------ - - CALL lnhc ( nhcp, struc % pnode, int_group ) - - IF ( simpar % constraint ) CALL getold ( struc % molecule ) - -! -! first half of velocity verlet -! - nnodes = size(struc%pnode) - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - struc%pnode(i) %p%r(1) = struc%pnode(i) %p%r(1) + & - struc%pnode(i) %p%v(1)*simpar%dt - struc%pnode(i) %p%r(2) = struc%pnode(i) %p%r(2) + & - struc%pnode(i) %p%v(2)*simpar%dt - struc%pnode(i) %p%r(3) = struc%pnode(i) %p%r(3) + & - struc%pnode(i) %p%v(3)*simpar%dt - END DO - - IF ( simpar % constraint ) CALL shake_control ( struc % molecule, simpar ) -#if defined(__parallel) - CALL update_structure ( struc, 'POS' ) -#endif - -! -! get new forces -! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) - -! -! second half of velocity verlet -! - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - END DO - - IF ( simpar % constraint ) CALL rattle_control ( struc % molecule, simpar ) - - CALL lnhc ( nhcp, struc % pnode, int_group ) - -#if defined(__parallel) - CALL update_structure(struc,'VEL') -#endif - -! updating the virial - IF (simpar%constraint) CALL pv_constraint(struc%molecule,thermo, & - 'FULL', int_group) - CALL pressure(struc%pnode,thermo) - -END SUBROUTINE nvt - -!****************************************************************************** - -SUBROUTINE npt_i ( itimes, constant, simpar, potparm, thermo, struc, & - ewald_param, nhcp ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - -! Locals - INTEGER :: i, nnodes, iroll - REAL ( dbl ) :: dtom - REAL ( dbl ), PARAMETER :: e2 = 1._dbl/6._dbl, e4 = e2/20._dbl, & - e6 = e4/42._dbl, e8 = e6/72._dbl - REAL ( dbl ), SAVE :: eps_0 - REAL ( dbl ) :: arg, poly, scale, roll_tol - REAL ( dbl ), DIMENSION (3,3) :: pv_kinetic - REAL ( dbl ), DIMENSION (3) :: vector - LOGICAL :: first - -!------------------------------------------------------------------------------ - -! setting up for ROLL: saving old variables - roll_tol = -1.0E+10_dbl - IF (simpar%constraint) THEN - iroll = 1 - CALL set(struc,nhcp,'F') - CALL getold(struc%molecule) - END IF - -! initialize eps_0 the first time through - IF ( itimes == 1 ) eps_0 = nhcp%npt(1,1) % eps - - SR: DO WHILE (abs(roll_tol)>=1.E-10_dbl) ! SHAKE-ROLL LOOP - - IF (simpar%constraint) THEN - CALL set(struc,nhcp,'B') - CALL initialize_roll(struc%molecule) - END IF - CALL lnhcp(nhcp,struc%molecule,struc%pnode,thermo%pv,thermo%pv_kin, & - thermo%pv_const,simpar%p_ext,struc%box%deth,simpar%nfree, & - simpar%constraint, int_group) - -! -! first half of velocity verlet -! - arg = ( 0.5_dbl*nhcp%npt(1,1)%v*simpar%dt)*(0.5_dbl*nhcp%npt(1,1)%v* & - simpar%dt) - poly = 1._dbl + e2*arg + e4*arg*arg + e6*arg**3 + e8*arg**4 - - scale = EXP(0.5_dbl*simpar%dt*nhcp%npt(1,1)%v) - nnodes = size(struc%pnode) - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - struc%pnode(i) %p%r(1) = struc%pnode(i) %p%r(1)*scale*scale + & - scale*poly*struc%pnode(i) %p%v(1)*simpar%dt - struc%pnode(i) %p%r(2) = struc%pnode(i) %p%r(2)*scale*scale + & - scale*poly*struc%pnode(i) %p%v(2)*simpar%dt - struc%pnode(i) %p%r(3) = struc%pnode(i) %p%r(3)*scale*scale + & - scale*poly*struc%pnode(i) %p%v(3)*simpar%dt - END DO - roll_tol = 0._dbl - vector ( : ) = scale*poly - - IF ( simpar%constraint ) CALL shake_roll_control(struc%molecule,simpar, & - thermo,roll_tol,iroll,vector, int_group ) -! Update eps: - nhcp%npt ( :, : ) %eps = nhcp%npt ( :, : ) %eps & - + simpar%dt*nhcp%npt ( :, : ) %v - -! Update h_mat - struc%box%hmat ( :, : ) = struc%box%hmat ( :, : ) & - * EXP ( nhcp%npt(1,1)%eps - eps_0 ) - END DO SR - - eps_0 = nhcp%npt(1,1) % eps - -#if defined(__parallel) - CALL update_structure(struc,'POS') -#endif - -! -! get new forces -! - CALL force(struc,potparm,thermo,simpar,ewald_param) - -! -! second half of velocity verlet -! - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - END DO - - roll_tol = -1.E10_dbl - IF (simpar%constraint) THEN - first = .TRUE. - iroll = 1 - CALL set(struc,nhcp,'F') - END IF - - RR: DO WHILE (abs(roll_tol)>=1.E-10_dbl) ! RATTLE-ROLL LOOP - roll_tol = 0._dbl - IF (simpar%constraint) CALL rattle_init(nhcp,struc,thermo,simpar, & - roll_tol,iroll,first) - CALL lnhcp(nhcp,struc%molecule,struc%pnode,thermo%pv,thermo%pv_kin, & - thermo%pv_const,simpar%p_ext,struc%box%deth,simpar%nfree, & - simpar%constraint, int_group ) - END DO RR - -#if defined(__parallel) - CALL update_structure(struc,'VEL') -#endif - -! updating the virial - IF (simpar%constraint) CALL pv_constraint(struc%molecule,thermo, & - 'FULL', int_group ) - - CALL pressure(struc%pnode,thermo) - -END SUBROUTINE npt_i - -!****************************************************************************** - -! computes the kinetic part of the pressure tensor and updates -! the full VIRIAL (PV) - -SUBROUTINE pressure ( pnode, thermo ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - -! Locals - INTEGER :: i, j, iatom, nnodes - -!------------------------------------------------------------------------------ - - thermo%pv_kin = 0._dbl - nnodes = size(pnode) - DO i = 1, 3 - DO j = 1, 3 - DO iatom = 1, nnodes - thermo%pv_kin(i,j) = thermo%pv_kin(i,j) + & - pnode(iatom) %p%prop%mass*pnode(iatom) %p%v(i)* & - pnode(iatom) %p%v(j) - END DO - END DO - END DO - -#if defined(__parallel) - CALL mp_sum(thermo%pv_kin,int_group) -#endif - -! total virial - thermo%ptens = thermo%pv + thermo%pv_kin + thermo%pv_const - -END SUBROUTINE pressure - -!****************************************************************************** - -SUBROUTINE update_structure(struc,task) - - IMPLICIT NONE - -! Arguments - TYPE (structure_type ), INTENT ( INOUT ) :: struc - CHARACTER ( LEN = * ), INTENT ( IN ) :: task - -! Locals - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: atot - INTEGER :: natoms, ios, imol, atombase, iat, i - TYPE (linklist_atoms), POINTER :: current_atom - -!------------------------------------------------------------------------------ - - natoms = size(struc%part) - ALLOCATE (atot(3,natoms),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'update_structure', 'atot', 3 * natoms ) - atot = zero - DO imol = 1, size(struc%molecule) - current_atom => struc%molecule(imol) %ll_atoms - DO i = 1, struc%molecule(imol) %natoms_mol - iat = struc%molecule(imol) %atombase + i - 1 - IF (task=='POS') THEN - atot(1,iat) = current_atom%part%p%r(1) - atot(2,iat) = current_atom%part%p%r(2) - atot(3,iat) = current_atom%part%p%r(3) - ELSE IF (task=='VEL') THEN - atot(1,iat) = current_atom%part%p%v(1) - atot(2,iat) = current_atom%part%p%v(2) - atot(3,iat) = current_atom%part%p%v(3) - END IF - current_atom => current_atom%next - END DO - END DO - -#ifdef __parallel - CALL mp_sum(atot,int_group) -#endif - - IF (task=='POS') THEN - DO iat = 1, natoms - struc%part(iat) %r(1) = atot(1,iat) - struc%part(iat) %r(2) = atot(2,iat) - struc%part(iat) %r(3) = atot(3,iat) - END DO - ELSE IF (task=='VEL') THEN - DO iat = 1, natoms - struc%part(iat) %v(1) = atot(1,iat) - struc%part(iat) %v(2) = atot(2,iat) - struc%part(iat) %v(3) = atot(3,iat) - END DO - END IF - - DEALLOCATE ( atot, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'update_structure', 'atot' ) - -END SUBROUTINE update_structure - -!****************************************************************************** - -SUBROUTINE set(struc,nhcp,char) - - IMPLICIT NONE - -! Arguments - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - CHARACTER ( LEN = * ), INTENT ( IN ) :: char - -! Locals - INTEGER :: idim - INTEGER :: isos - -!------------------------------------------------------------------------------ - - isos = 0 - IF ( .NOT. associated(old%v)) ALLOCATE (old%v(size(struc%part),3), & - STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%v', 0 ) - IF ( .NOT. associated(old%r)) ALLOCATE (old%r(size(struc%part),3), & - STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%r', 0 ) - IF ( .NOT. associated(old%eps)) ALLOCATE (old%eps(size(nhcp%npt, & - 1),size(nhcp%npt,2)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%eps', 0 ) - IF ( .NOT. associated(old%veps)) ALLOCATE (old%veps(size(nhcp%npt, & - 1),size(nhcp%npt,2)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%veps', 0 ) - IF ( .NOT. associated(old%eta)) ALLOCATE (old%eta(size(nhcp%nvt, & - 1),size(nhcp%nvt,2)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%eta', 0 ) - IF ( .NOT. associated(old%veta)) ALLOCATE (old%veta(size(nhcp%nvt, & - 1),size(nhcp%nvt,2)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%veta', 0 ) - IF ( .NOT. associated(old%h)) ALLOCATE (old%h(size(struc%box%hmat,1), & - size(struc%box%hmat,2)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set', 'old%h', 0 ) - - SELECT CASE (char) - CASE ( 'F') ! forward assigning the old - DO idim = 1, 3 - old%v(:,idim) = struc%part ( : ) %v(idim) - old%r(:,idim) = struc%part ( : ) %r(idim) - END DO - old%eta ( :, : ) = nhcp%nvt ( :, : ) %eta - old%veta ( :, : ) = nhcp%nvt ( :, : ) %v - old%eps ( :, : ) = nhcp%npt ( :, : ) %eps - old%veps ( :, : ) = nhcp%npt ( :, : ) %v - old%h ( :, : ) = struc%box%hmat ( :, : ) - CASE ( 'B') ! back assigning the original variables - DO idim = 1, 3 - struc%part ( : ) %r(idim) = old%r(:,idim) - struc%part ( : ) %v(idim) = old%v(:,idim) - END DO - nhcp%nvt ( :, : ) %eta = old%eta ( :, : ) - nhcp%nvt ( :, : ) %v = old%veta ( :, : ) - nhcp%npt ( :, : ) %eps = old%eps ( :, : ) - nhcp%npt ( :, : ) %v = old%veps ( :, : ) - struc%box%hmat ( :, : )=old%h ( :, : ) - END SELECT - -END SUBROUTINE set - -!****************************************************************************** - -SUBROUTINE npt_f ( itimes, constant, simpar, potparm, thermo, struc, & - ewald_param, nhcp ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: itimes - REAL ( dbl ), INTENT ( INOUT ) :: constant - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - -! Locals - INTEGER :: i, j, nnodes, iroll - REAL ( dbl ) :: dtom - REAL ( dbl ), PARAMETER :: e2 = 1._dbl/6._dbl, e4 = e2/20._dbl, & - e6 = e4/42._dbl, e8 = e6/72._dbl - REAL ( dbl ), SAVE :: eps_0 - REAL ( dbl ) :: roll_tol - REAL ( dbl ), DIMENSION (3,3) :: pv_kinetic, u, uh - REAL ( dbl ), DIMENSION (3) :: arg, poly, scale, e_val, ur, uv - LOGICAL :: first - -!------------------------------------------------------------------------------ - -! setting up for ROLL: saving old variables - IF (simpar%constraint) THEN - iroll = 1 - roll_tol = -1.0E+10_dbl - CALL set(struc,nhcp,'F') - CALL getold(struc%molecule) - END IF - - SR: DO WHILE (abs(roll_tol)>=1.E-10_dbl) ! SHAKE-ROLL LOOP - - IF (simpar%constraint) THEN - CALL set(struc,nhcp,'B') - CALL initialize_roll(struc%molecule) - END IF - CALL lnhcpf(nhcp,struc%molecule,struc%pnode,thermo%pv,thermo%pv_kin, & - thermo%pv_const,simpar%p_ext,struc%box%deth,simpar%nfree, & - simpar%constraint, int_group ) - -! find eigenvalues and eigenvectors of nhcp%npt ( :, : )%v -! -!*apsi CALL rs(nhcp%npt%v,e_val,u) - CALL diagonalise ( matrix = nhcp % npt % v, mysize = 3, & - storageform = "UPPER", eigenvalues = e_val, eigenvectors = u ) - -! -! first half of velocity verlet -! - arg ( : ) = (0.5_dbl*e_val ( : )*simpar%dt)*(0.5_dbl*e_val ( : )*simpar%dt) - poly = 1._dbl + e2*arg + e4*arg*arg + e6*arg**3 + e8*arg**4 - scale ( : ) = EXP(0.5_dbl*simpar%dt*e_val ( : )) - - nnodes = size(struc%pnode) - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - -! Transform positions and velocities - ur = matmul(transpose(u),struc%pnode(i)%p%r) - uv = matmul(transpose(u),struc%pnode(i)%p%v) - ur(1) = ur(1)*scale(1)*scale(1) + uv(1)*scale(1)*poly(1)*simpar%dt - ur(2) = ur(2)*scale(2)*scale(2) + uv(2)*scale(2)*poly(2)*simpar%dt - ur(3) = ur(3)*scale(3)*scale(1) + uv(3)*scale(3)*poly(3)*simpar%dt - struc%pnode(i) %p%r ( : ) = matmul(u,ur) - END DO - - roll_tol = 0.0_dbl - IF ( simpar % constraint ) CALL shake_roll_control ( struc % molecule, & - simpar, thermo,roll_tol,iroll,scale*poly, int_group ,u) - END DO SR - -! Update h_mat - uh = matmul(transpose(u),struc%box%hmat) - DO i = 1, 3 - DO j = 1, 3 - uh(j,i) = uh(j,i)*scale(j)*scale(j) - END DO - END DO - struc%box%hmat = matmul(u,uh) - -#if defined(__parallel) - CALL update_structure(struc,'POS') -#endif - -! -! get new forces -! - CALL force ( struc, potparm, thermo, simpar, ewald_param ) - -! -! second half of velocity verlet -! - DO i = 1, nnodes - dtom = 0.5_dbl*simpar%dt/struc%pnode(i) %p%prop%mass - struc%pnode(i) %p%v(1) = struc%pnode(i) %p%v(1) + & - dtom*struc%pnode(i) %p%f(1) - struc%pnode(i) %p%v(2) = struc%pnode(i) %p%v(2) + & - dtom*struc%pnode(i) %p%f(2) - struc%pnode(i) %p%v(3) = struc%pnode(i) %p%v(3) + & - dtom*struc%pnode(i) %p%f(3) - END DO - - IF (simpar%constraint) THEN - roll_tol = -1.0E+10_dbl - first = .TRUE. - iroll = 1 - CALL set ( struc, nhcp, 'F' ) - END IF - - RR: DO WHILE ( ABS ( roll_tol ) >= 1.0E-10_dbl ) ! RATTLE-ROLL LOOP - roll_tol = 0.0_dbl - IF ( simpar%constraint ) CALL rattle_init(nhcp,struc,thermo,simpar, & - roll_tol,iroll,first) - CALL lnhcpf(nhcp,struc%molecule,struc%pnode,thermo%pv,thermo%pv_kin, & - thermo%pv_const,simpar%p_ext,struc%box%deth,simpar%nfree, & - simpar%constraint, int_group ) - - END DO RR - -#if defined(__parallel) - CALL update_structure(struc,'VEL') -#endif - -! updating the virial - IF (simpar%constraint) CALL pv_constraint(struc%molecule,thermo, & - 'FULL', int_group ) - CALL pressure(struc%pnode,thermo) - -END SUBROUTINE npt_f - -!****************************************************************************** - -SUBROUTINE rattle_init ( nhcp, struc, thermo, simpar, roll_tol, iroll, first ) - - IMPLICIT NONE - -! Arguments - TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar - TYPE (structure_type ), INTENT ( INOUT ) :: struc - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo - LOGICAL, INTENT ( INOUT ) :: first - REAL ( dbl ), INTENT ( OUT ) :: roll_tol - INTEGER, INTENT ( INOUT ) :: iroll - -! Locals - REAL ( dbl ), DIMENSION (3,3) :: veps - -!------------------------------------------------------------------------------ - - IF ( first ) THEN - CALL initialize_roll ( struc%molecule ) - CALL lnhcp ( nhcp,struc%molecule,struc%pnode,thermo%pv,thermo%pv_kin, & - thermo%pv_const,simpar%p_ext,struc%box%deth,simpar%nfree, & - simpar%constraint, int_group ) - END IF - first = .FALSE. - -! assigning local variable - veps ( :, : ) = 0._dbl - veps(1,1) = nhcp%npt(1,1) %v - veps(2,2) = veps(1,1) - veps(3,3) = veps(1,1) - -! resetting - CALL set(struc,nhcp,'B') - CALL rattle_roll_control(struc%molecule,simpar,thermo,veps, & - roll_tol,iroll, int_group ) - CALL initialize_roll(struc%molecule) - -END SUBROUTINE rattle_init - -!****************************************************************************** - -END MODULE integrator diff --git a/src/io_parameters.c b/src/io_parameters.c deleted file mode 100644 index 1bf0407..0000000 --- a/src/io_parameters.c +++ /dev/null @@ -1,55 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE io_parameters - - IMPLICIT NONE - -! Defaults for some global variables - -! ***************************************************************************** - -! scr: Logical unit number of the screen -! crd: Logical unit number of the coordinate file -! vel: Logical unit number of the velocity file -! ptn: Logical unit number of the pressure tensor file -! ene: Logical unit number of the energy file -! tem: Logical unit number of the temperature file -! dmp: Logical unit number of the dump file -! icrd : frequency of writing coordinate file -! ivel : frequency of writing velocity file -! iptens : frequency of writing pressure tensor file -! itemp : frequency of writing temperature file -! idump : frequency of writing dump file -! iscreen : frequency of writing screen file - -! ***************************************************************************** - - PRIVATE - PUBLIC :: crd_file_name, vel_file_name, ptens_file_name, ener_file_name, & - temp_file_name, dump_file_name - - PUBLIC :: crd, vel, ptn, ene, tem, scr, dmp - - PUBLIC :: icrd, ivel, iptens, iener, itemp, iscreen, idump - - CHARACTER ( LEN = 50 ) :: crd_file_name, & - vel_file_name, & - ptens_file_name,& - ener_file_name, & - temp_file_name, & - dump_file_name - INTEGER, PARAMETER :: crd = 1, & - vel = 2, & - ptn = 3, & - ene = 4, & - tem = 5, & - scr = 6, & - dmp = 7 - INTEGER :: icrd, ivel, iptens, & - iener, itemp, idump, & - iscreen - -END MODULE io_parameters diff --git a/src/kinds.cpp b/src/kinds.cpp deleted file mode 100644 index 6a033ab..0000000 --- a/src/kinds.cpp +++ /dev/null @@ -1,65 +0,0 @@ -/* -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2024 CP2K developers group ! -!-----------------------------------------------------------------------------! - Data type definitions; tested on: - - IBM AIX xlf90 - - SGI IRIX f90 - - CRAY T3E f90 - - DEC ALPHA f90 - - NAG_F90 - - SUN - - HITACHI -*/ - -#include -#include - -namespace kinds { - - const int dbl = std::numeric_limits::max_digits10; - const int sgl = std::numeric_limits::max_digits10; - const int qp = std::numeric_limits::max_digits10; - const int sp = sgl; - const int dp = dbl; - - const bool YES = true; - const bool NO = false; - - const bool TRUE = true; - const bool FALSE = false; - -//***************************************************************************** - -// Print informations about the used data types. - - void print_kind_info(int iw) { -//----------------------------------------------------------------------------- - - std::cout << "DATA TYPE INFORMATION:" << std::endl; - - std::cout << "REAL: Data type name: dbl Kind value: " << typeid(double).name() - << " Precision: " << dbl << " Smallest non-negligible quantity relative to 1: " - << std::numeric_limits::epsilon() << " Smallest positive number: " - << std::numeric_limits::min() << " Largest representable number: " - << std::numeric_limits::max() << std::endl; - - std::cout << " Data type name: sgl Kind value: " << typeid(float).name() - << " Precision: " << sgl << " Smallest non-negligible quantity relative to 1: " - << std::numeric_limits::epsilon() << " Smallest positive number: " - << std::numeric_limits::min() << " Largest representable number: " - << std::numeric_limits::max() << std::endl; - - std::cout << "INTEGER: Data type name: (default) Kind value: " << typeid(int).name() - << " Bit size: " << sizeof(int) * 8 << " Largest representable number: " - << std::numeric_limits::max() << std::endl; - - std::cout << "LOGICAL: Data type name: (default) Kind value: " << typeid(bool).name() << std::endl; - - std::cout << "CHARACTER: Data type name: (default) Kind value: " << typeid(char).name() << std::endl; - } -} - -//***************************************************************************** - diff --git a/src/lapack.c b/src/lapack.c deleted file mode 100644 index 58c2ded..0000000 --- a/src/lapack.c +++ /dev/null @@ -1,122 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -#if ! defined ( __YMP ) && ! defined ( __T3E ) - -!! We are using LAPACK interfaces, so please make sure in IBM/AIX you have -!! the lapack library before essl: "xlf90 ... -llapack -lessl" !!! - -MODULE lapack - - IMPLICIT NONE - - PRIVATE - PUBLIC :: lapack_ssyev, lapack_chpev, lapack_chpgv - - INTERFACE lapack_ssyev - SUBROUTINE ssyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: INFO, LDA, LWORK, N - REAL ( KIND = 4 ) :: A( LDA, * ), W( * ), WORK( * ) - END SUBROUTINE ssyev - - SUBROUTINE dsyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: INFO, LDA, LWORK, N - REAL ( KIND = 8 ) :: A( LDA, * ), W( * ), WORK( * ) - END SUBROUTINE dsyev - END INTERFACE - - INTERFACE lapack_chpev - SUBROUTINE chpev ( jobz, uplo, n, ap, w, z, ldz, work, rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: n, ldz, info - REAL ( KIND = 4 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 4 ) :: ap ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE chpev - - SUBROUTINE zhpev ( jobz, uplo, n, ap, w, z, ldz, work, rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: n, ldz, info - REAL ( KIND = 8 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 8 ) :: ap ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE zhpev - END INTERFACE - - INTERFACE lapack_chpgv - SUBROUTINE chpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, & - rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: itype, n, ldz, info - REAL ( KIND = 4 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 4 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE chpgv - - SUBROUTINE zhpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, & - rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: itype, n, ldz, info - REAL ( KIND = 8 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 8 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE zhpgv - END INTERFACE - -END MODULE lapack - -#else - -MODULE lapack - - INTERFACE lapack_ssyev - SUBROUTINE gsyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: INFO, LDA, LWORK, N - REAL ( KIND = 4 ) :: A( LDA, * ), W( * ), WORK( * ) - END SUBROUTINE gsyev - - SUBROUTINE ssyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: INFO, LDA, LWORK, N - REAL ( KIND = 8 ) :: A( LDA, * ), W( * ), WORK( * ) - END SUBROUTINE ssyev - END INTERFACE - - INTERFACE lapack_chpev - SUBROUTINE ghpev ( jobz, uplo, n, ap, w, z, ldz, work, rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: n, ldz, info - REAL ( KIND = 4 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 4 ) :: ap ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE ghpev - - SUBROUTINE chpev ( jobz, uplo, n, ap, w, z, ldz, work, rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: n, ldz, info - REAL ( KIND = 8 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 8 ) :: ap ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE chpev - END INTERFACE - - INTERFACE lapack_chpgv - SUBROUTINE ghpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, & - rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: itype, n, ldz, info - REAL ( KIND = 4 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 4 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE ghpgv - - SUBROUTINE chpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, & - rwork, info ) - CHARACTER :: jobz, uplo - INTEGER :: itype, n, ldz, info - REAL ( KIND = 8 ) :: w ( * ), rwork ( * ) - COMPLEX ( KIND = 8 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * ) - END SUBROUTINE chpgv - END INTERFACE - -END MODULE lapack - -#endif diff --git a/src/linklist.h b/src/linklist.h deleted file mode 100644 index 82a8790..0000000 --- a/src/linklist.h +++ /dev/null @@ -1,32 +0,0 @@ -#ifndef _LINKLIST_H -#define _LINKLIST_H - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct cell_atoms_linklist_type { - int atom; - bool used; - cell_atoms_linklist_type *next; - } cell_atoms_linklist_type; - - typedef struct cell_atoms_type { - cell_atoms_linklist_type *ll; - } cell_atoms_type; - - typedef struct neighbor_cells_type { - int **index; - } neighbor_cells_type; - - typedef struct cell_neighborlist_type { - int *natoms; - neighbor_cells_type **neighbor; - cell_atoms_type *ptype; - } cell_neighborlist_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/linklist_cell_list.c b/src/linklist_cell_list.c deleted file mode 100644 index ae80516..0000000 --- a/src/linklist_cell_list.c +++ /dev/null @@ -1,412 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklist_cell_list - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklist_cell_types, ONLY : cell_neighborlist_type, & - cell_atoms_linklist_type, neighbor_cells_type - USE molecule_types, ONLY : particle_node_type - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : cell_type, get_cell_param - USE stop_program, ONLY : stop_prg, stop_memory - USE timings, ONLY : timeset, timestop - - IMPLICIT NONE - - PRIVATE - PUBLIC :: cell_list - -CONTAINS - -!****************************************************************************** - -! to construct cells within the box so that it can be -! used in the construction of all neighbor lists - -SUBROUTINE cell_list ( natom_types, n_cell, rcut, tag, pnode, part, & - box, cell_ll, start_list, neighbor, globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ) :: pnode - TYPE ( particle_type ), INTENT ( INOUT ), DIMENSION ( : ) :: part - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( cell_neighborlist_type ), DIMENSION (:,:,:), POINTER :: cell_ll - TYPE ( cell_atoms_linklist_type ), DIMENSION (:,:,:,:), POINTER :: start_list - TYPE ( neighbor_cells_type ), DIMENSION ( :, : ), POINTER :: neighbor - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: rcut - INTEGER, INTENT ( IN ), DIMENSION ( : ) :: n_cell - INTEGER, INTENT ( IN ) :: natom_types - CHARACTER ( LEN = * ), INTENT ( IN ) :: tag - -! Locals - TYPE ( cell_atoms_linklist_type ), POINTER :: loc_ll - INTEGER, POINTER :: index_ij ( :, : ), index_ji ( :, : ) - INTEGER :: j, k, ii, jj, kk, ineighbor, i, natoms, nnodes - INTEGER :: ncell_tot, isos, ncells, itype, jtype, handle, iw - INTEGER, DIMENSION (3) :: bin, cell_i, next_cell,irange - REAL ( dbl ) :: delta, kint - REAL ( dbl ), DIMENSION (3) :: list_cell, cell_lengths, cell_ang - REAL ( dbl ), DIMENSION (3) :: s, s_list_cell, perd, r - REAL ( dbl ), DIMENSION (3,3) :: h_inv - LOGICAL :: first_time - -!------------------------------------------------------------------------------ - -! -! print banner if this is the first call to the routine -! - CALL timeset( 'CELL_INDEX', 'I', 'KIs', handle ) - - iw = globenv % scr - - first_time = .NOT. ASSOCIATED(cell_ll) - - IF (globenv % ionode .AND. first_time .AND. globenv % print_level>0) THEN - WRITE ( iw, '( A,A36,A )' ) ' **********************', tag, & - '*********************' - END IF - - CALL get_cell_param ( box, cell_lengths, cell_ang ) - - list_cell ( : ) = cell_lengths ( : )/real(n_cell ( : )) - - h_inv = box%h_inv - perd = box%perd - - IF (first_time) THEN - IF (globenv % ionode .AND. globenv % print_level>0 ) THEN - ncell_tot = n_cell(1)*n_cell(2)*n_cell(3) - WRITE ( iw, '( A,T71,I10 )' ) & - ' Total # of cells used for Verlet neighbor list ', ncell_tot - WRITE ( iw, '( A,T60,i5,a3,i5,a3,i5 )' ) & - ' # of cells in each direction = ', n_cell(1), ' X ', n_cell(2), & - ' X ', n_cell(3) - END IF - END IF - -! find out allocation parameters for neighboring cell calculation - IF (first_time .AND. ALL(n_cell>1)) THEN - ALLOCATE (neighbor(natom_types,natom_types),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', & - 'neighbor_cell', natom_types ** 2 ) - DO itype = 1, natom_types - DO jtype = 1, natom_types - irange ( : ) = INT(rcut(itype,jtype )/list_cell ( : )) + 1 - CALL get_neighbor_cells_est(irange,ncells) - IF (ncells>=ncell_tot) CALL stop_prg( 'cell_list', & - 'NUMBER OF NEIGHBOR CELLS','> TOTAL CELLS. REINITIALIZE') - ALLOCATE (neighbor(itype,jtype ) % index(3,ncells),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', & - 'neighbor%index', 3 * ncells ) - CALL get_neighbor_cells ( irange, neighbor ( itype, jtype ) ) - END DO - END DO - END IF - - nnodes = SIZE(pnode) - natoms = SIZE(part) - - IF ( .NOT. ASSOCIATED(cell_ll)) THEN - ALLOCATE (cell_ll(n_cell(1),n_cell(2),n_cell(3)),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', 'cell_ll', 0 ) - DO kk = 1, n_cell(3) - DO jj = 1, n_cell(2) - DO ii = 1, n_cell(1) - ALLOCATE (cell_ll(ii,jj,kk) % natoms(natom_types),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', & - 'cell_ll%natoms', natom_types ) - END DO - END DO - END DO - END IF - - s_list_cell = list_cell / cell_lengths - -! linked list that forms a list of all atoms in a particular cell - DO kk = 1, n_cell(3) - DO jj = 1, n_cell(2) - DO ii = 1, n_cell(1) - cell_ll(ii,jj,kk) % natoms ( : ) = 0 - END DO - END DO - END DO - - IF (first_time) THEN - DO kk = 1, n_cell(3) - DO jj = 1, n_cell(2) - DO ii = 1, n_cell(1) - ALLOCATE (cell_ll(ii,jj,kk) % pTYPE ( natom_types),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory( 'cell_list', 'cell_ll%ptype', natom_types ) - DO itype = 1, natom_types - ALLOCATE (start_list(itype,ii,jj,kk),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', 'start_list', 0 ) - NULLIFY (start_list(itype,ii,jj,kk) % next) - END DO - END DO - END DO - END DO - END IF - - DO kk = 1, n_cell(3) - DO jj = 1, n_cell(2) - DO ii = 1, n_cell(1) - DO itype = 1, natom_types - cell_ll(ii,jj,kk) % pTYPE ( itype ) % ll & - => start_list(itype,ii,jj,kk) - - loc_ll => cell_ll(ii,jj,kk) % pTYPE ( itype ) % ll - loc_ll % used = .FALSE. - - DO - IF ( ASSOCIATED ( loc_ll % next)) THEN - loc_ll => loc_ll % next - loc_ll % used = .FALSE. - ELSE - EXIT - END IF - END DO - - END DO - END DO - END DO - END DO - - DO i = 1, natoms - itype = part(i) % prop % ptype - -! pbc so that particles outside the central box are also mapped -! onto proper cells - r(1) = part(i) % r(1) - r(2) = part(i) % r(2) - r(3) = part(i) % r(3) - s(1) = h_inv(1,1)*r(1) + h_inv(1,2)*r(2) + h_inv(1,3)*r(3) - s(2) = h_inv(2,1)*r(1) + h_inv(2,2)*r(2) + h_inv(2,3)*r(3) - s(3) = h_inv(3,1)*r(1) + h_inv(3,2)*r(2) + h_inv(3,3)*r(3) - IF(ABS(s(1)) > 0.5_dbl) THEN - s(1) = s(1) - perd(1)*INT(s(1)+SIGN(0.5_dbl,s(1))) - END IF - IF(ABS(s(2)) > 0.5_dbl) THEN - s(2) = s(2) - perd(2)*INT(s(2)+SIGN(0.5_dbl,s(2))) - END IF - IF(ABS(s(3)) > 0.5_dbl) THEN - s(3) = s(3) - perd(3)*INT(s(3)+SIGN(0.5_dbl,s(3))) - END IF - -! compute the bin number - bin = int((s+0.5_dbl)/s_list_cell) + 1 - -! increment the counter - cell_ll(bin(1),bin(2),bin(3)) % natoms(itype ) = cell_ll(bin(1), & - bin(2),bin(3)) %natoms(itype ) + 1 - -! load in the atom number - loc_ll => cell_ll(bin(1),bin(2),bin(3)) % pTYPE ( itype ) % ll - DO - IF ( .NOT. loc_ll % used ) THEN - loc_ll % used = .TRUE. - EXIT - ELSE IF ( ASSOCIATED ( loc_ll % next)) THEN - loc_ll => loc_ll % next - ELSE - ALLOCATE (loc_ll % next, STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_list', 'll%next', 0 ) - loc_ll => loc_ll % next - NULLIFY (loc_ll % next) - loc_ll % used = .FALSE. - END IF - END DO - loc_ll % atom = i - part(i) % cell => cell_ll(bin(1),bin(2),bin(3)) - END DO - -! linked list that forms a list of all neighboring cells (done only once) - IF ( first_time .AND. ALL ( n_cell > 1 ) ) THEN - delta = 1.0E-5_dbl - -! Note: -! floor returns the largest integer < or = to its REAL argument. -! n_cell is the periodicity. Thus, floor(n_cell/n_cell) gives back 1, -! although we want it to be zero. So, we subtract the argument by a -! small number (delta) to give us zero. - DO kk = 1, n_cell(3) - DO jj = 1, n_cell(2) - DO ii = 1, n_cell(1) - ALLOCATE ( cell_ll ( ii, jj, kk ) & - % neighbor ( natom_types, natom_types), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_index', 'neighbor', 0 ) - cell_i(1) = ii - cell_i(2) = jj - cell_i(3) = kk - -! loop over number of types - DO itype = 1, natom_types - DO jtype = itype, natom_types - -! Define number of cells to loop over - ncells=SIZE(neighbor(itype,jtype ) % index, 2) - - ALLOCATE( cell_ll (ii,jj,kk) % neighbor(itype,jtype ) & - % index ( 3, ncells ) ) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_index', 'index', 0 ) - IF (itype/=jtype ) THEN - ALLOCATE( cell_ll (ii,jj,kk) % neighbor(jtype,itype ) & - % index (3, ncells ) ) - IF ( isos /= 0 ) CALL stop_memory ( 'cell_index', 'index', 0 ) - END IF - -! POINT index_ij => cell_ll % neighbor % index - index_ij => cell_ll(ii,jj,kk) % neighbor(itype,jtype ) % index - IF (itype/=jtype ) THEN - index_ji => cell_ll(ii,jj,kk) % neighbor(jtype,itype ) % index - END IF - -! loop over the number of cells to find the cell neighbors of -! cell_ll(ii,jj,kk) - DO ineighbor = 1, ncells - next_cell(1) = neighbor(itype,jtype ) % index(1, & - ineighbor) + cell_i(1) - next_cell(2) = neighbor(itype,jtype ) % index(2, & - ineighbor) + cell_i(2) - next_cell(3) = neighbor(itype,jtype ) % index(3, & - ineighbor) + cell_i(3) - -! pbc the cell number - next_cell(1) = next_cell(1) - n_cell(1)* & - floor((real(next_cell(1)))/ real(n_cell(1))-delta) - next_cell(2) = next_cell(2) - n_cell(2)* & - floor((real(next_cell(2)))/ real(n_cell(2))-delta) - next_cell(3) = next_cell(3) - n_cell(3)* & - floor((real(next_cell(3)))/ real(n_cell(3))-delta) - -! load in the index - index_ij(1,ineighbor) = next_cell(1) - index_ij(2,ineighbor) = next_cell(2) - index_ij(3,ineighbor) = next_cell(3) - IF (itype/=jtype ) THEN - index_ji(1,ineighbor) = next_cell(1) - index_ji(2,ineighbor) = next_cell(2) - index_ji(3,ineighbor) = next_cell(3) - END IF - - END DO - END DO - - END DO - END DO - END DO - END DO - END IF - - IF (globenv % ionode .AND. first_time .AND. globenv % print_level>0) THEN - WRITE ( iw, '( A,A,A,/ )' ) ' **************************', & - ' end subroutine cell_list ', '***************************' - END IF - - kint = PRODUCT ( n_cell ( 1:3 ) ) * 0.001_dbl - CALL timestop ( kint, handle ) - -END SUBROUTINE cell_list - -!****************************************************************************** - -! this routine gives back the indices of cell neighbors of a cell (0,0,0). -! only the neighbors on the right side are returned - -SUBROUTINE get_neighbor_cells ( n_max, neighbor ) - - IMPLICIT NONE - -! Arguments - TYPE ( neighbor_cells_type ), INTENT ( OUT ) :: neighbor - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n_max - -! Locals - INTEGER :: n, i, j, k - -!------------------------------------------------------------------------------ - -! along nz=0, ny=0, nx=1, nx_max - n = 0 - DO i = 1, n_max(1) - n = n + 1 - neighbor % index(1,n) = i - neighbor % index(2,n) = 0 - neighbor % index(3,n) = 0 - END DO - -! along nz=0, ny=1, ny_max, nx=-nx_max, nx_max - DO j = 1, n_max(2) - DO i = -n_max(1), n_max(1) - n = n + 1 - neighbor % index(1,n) = i - neighbor % index(2,n) = j - neighbor % index(3,n) = 0 - END DO - END DO - -! along nz=1, nz_max, ny=-ny_max, ny_max, nx=-nx_max, nx_max - DO k = 1, n_max(3) - DO j = -n_max(2), n_max(2) - DO i = -n_max(1), n_max(1) - n = n + 1 - neighbor % index(1,n) = i - neighbor % index(2,n) = j - neighbor % index(3,n) = k - END DO - END DO - END DO - -END SUBROUTINE get_neighbor_cells - -!****************************************************************************** - -! Returns the number of neighbor cells so we can ALLOCATE neighbor_cells - -SUBROUTINE get_neighbor_cells_est ( n_max, n ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( OUT ) :: n - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n_max - -! Locals - INTEGER :: i, j, k - -!------------------------------------------------------------------------------ - - n = 0 - DO i = 1, n_max(1) - n = n + 1 - END DO - -! along nz=0, ny=1, ny_max, nx=-nx_max, nx_max - DO j = 1, n_max(2) - DO i = -n_max(1), n_max(1) - n = n + 1 - END DO - END DO - -! along nz=1, nz_max, ny=-ny_max, ny_max, nx=-nx_max, nx_max - DO k = 1, n_max(3) - DO j = -n_max(2), n_max(2) - DO i = -n_max(1), n_max(1) - n = n + 1 - END DO - END DO - END DO - -END SUBROUTINE get_neighbor_cells_est - -!****************************************************************************** - -END MODULE linklist_cell_list - - diff --git a/src/linklist_cell_types.c b/src/linklist_cell_types.c deleted file mode 100644 index 48670bd..0000000 --- a/src/linklist_cell_types.c +++ /dev/null @@ -1,36 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklist_cell_types - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: cell_neighborlist_type, neighbor_cells_type - PUBLIC :: cell_atoms_type, cell_atoms_linklist_type - - TYPE cell_atoms_linklist_type - INTEGER :: atom - LOGICAL :: used - TYPE ( cell_atoms_linklist_type ), POINTER :: next - END TYPE cell_atoms_linklist_type - - TYPE cell_atoms_type - TYPE ( cell_atoms_linklist_type ), POINTER :: ll - END TYPE cell_atoms_type - - TYPE neighbor_cells_type - INTEGER, DIMENSION ( :, : ), POINTER :: index - END TYPE neighbor_cells_type - - TYPE cell_neighborlist_type - INTEGER, DIMENSION ( : ), POINTER :: natoms - TYPE ( neighbor_cells_type ), DIMENSION ( :, : ), POINTER :: neighbor - TYPE ( cell_atoms_type ), DIMENSION ( : ), POINTER :: ptype - END TYPE cell_neighborlist_type - -END MODULE linklist_cell_types diff --git a/src/linklist_control.c b/src/linklist_control.c deleted file mode 100644 index 6d30296..0000000 --- a/src/linklist_control.c +++ /dev/null @@ -1,242 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2k developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklist_control - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklist_cell_list, ONLY : cell_list - USE linklist_cell_types, ONLY : cell_neighborlist_type, & - cell_atoms_linklist_type, & - neighbor_cells_type - USE linklist_utilities, ONLY : startlist_images_type - USE linklist_verlet_list, ONLY : verlet_list - USE molecule_types, ONLY : particle_node_type,linklist_neighbor, & - linklist_exclusion, linklist_images - USE mp, ONLY : mp_max - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: set_ll_parm, get_ll_parm, list_control - -! globals specific to the particle-particle verlet list - TYPE ( cell_neighborlist_type ), DIMENSION (:,:,:), POINTER :: pp_cell_ll - TYPE ( cell_atoms_linklist_type ), DIMENSION (:,:,:,:), POINTER :: & - pp_startlist_cell - TYPE ( neighbor_cells_type ), DIMENSION ( :, : ), POINTER :: pp_neighbor - TYPE ( linklist_neighbor ), POINTER :: pp_startlist_nl - TYPE ( startlist_images_type ), POINTER :: pp_startlist_im ( : ) - INTEGER, DIMENSION ( 3 ) :: pp_cell - INTEGER, POINTER :: pp_images(:,:,:) - INTEGER, POINTER :: pp_ncell ( : ) - - TYPE ( global_environment_type ) :: globenv_ll - INTEGER :: natom_types=0 - INTEGER :: list_type = 0 - INTEGER :: counter = 0, last_update = 0, num_update = 0 - INTEGER :: print_level = 1 - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rlist_cut, rlist_cutsq - REAL ( dbl ) :: verlet_skin - REAL ( dbl ) :: lup, aup - -!print_level > 0 : no output -!print_level < 5 : normal output -!print_level < 10 : initial neighbor list info -!print_level > 10 : full neighbor list info at each update - -CONTAINS - -!****************************************************************************** - -SUBROUTINE set_ll_parm ( globenv_in, vskin, natype, rcut, & - ppcells, count, printlevel, ltype ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv_in - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: vskin - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: rcut ( :, : ) - INTEGER, INTENT ( IN ), DIMENSION ( : ), OPTIONAL :: ppcells - INTEGER, INTENT ( IN ), OPTIONAL :: natype - INTEGER, INTENT ( IN ), OPTIONAL :: count - INTEGER, INTENT ( IN ), OPTIONAL :: printlevel - CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: ltype - -! Locals - REAL ( dbl ) :: cut_off - INTEGER :: iat, jat - INTEGER :: isos - -!------------------------------------------------------------------------------ - - globenv_ll = globenv_in - -! Defines the number of cells for the particle-particle lists - IF ( PRESENT ( ppcells)) pp_cell = ppcells - -! Defines the verlet skin - IF ( PRESENT ( vskin)) verlet_skin = vskin - -! Defines the number of atom types - IF ( PRESENT ( natype )) natom_types = natype - -! Defines cut-off for particle-particle lists - IF ( PRESENT ( rcut)) THEN - -! allocating rlist and rlist_cut to upper triangular part -! of interaction matrix - ALLOCATE (rlist_cut(natom_types,natom_types),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'set_ll_param', & - 'rlist_cut', natom_types ** 2 ) - - ALLOCATE ( rlist_cutsq ( natom_types, natom_types ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'set_ll_param', & - 'rlist_cutsq', natom_types ** 2 ) - DO iat = 1, natom_types - DO jat = iat, natom_types - rlist_cut(iat,jat) = sqrt(rcut(iat,jat)) + verlet_skin - rlist_cutsq(iat,jat) = rlist_cut(iat,jat)*rlist_cut(iat,jat) - rlist_cut(jat,iat) = rlist_cut(iat,jat) - rlist_cutsq(jat,iat) = rlist_cutsq(iat,jat) - END DO - END DO - END IF - -! Defines the counting variable - IF ( PRESENT ( count ) ) counter = count - -! Defines the print level - IF ( PRESENT ( printlevel ) ) print_level = printlevel - -! Defines the type of list to be constructed - IF ( PRESENT ( ltype ) ) THEN - SELECT CASE ( ltype ) - CASE DEFAULT - list_type = 0 - CASE ( 'NONBOND') - list_type = 1 - END SELECT - END IF - -END SUBROUTINE set_ll_parm - -!****************************************************************************** - -SUBROUTINE get_ll_parm ( last_up, av_up ) - - IMPLICIT NONE - - REAL ( dbl ), INTENT ( OUT ) :: last_up, av_up - - last_up = lup - av_up = aup - -END SUBROUTINE get_ll_parm - -!****************************************************************************** - -! -! to decide whether the neighbor list is to be updated or not -! based on a displacement criterion; -! if any particle has moved by 0.5*skin_length from the previous -! list_update, then the list routine is called. -! -SUBROUTINE list_control ( pnode, part, box ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( INOUT ) :: part - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - TYPE ( cell_type ), INTENT ( IN ) :: box - -! Locals - REAL ( dbl ), DIMENSION (3) :: disp_vec - REAL ( dbl ), ALLOCATABLE, SAVE :: r_last_update ( :, : ) - REAL ( dbl ) :: displace, max_displace - LOGICAL :: list_update_flag, ionode - INTEGER :: i, nnodes, isos, iw - CHARACTER ( LEN = 36 ) :: string - -!------------------------------------------------------------------------------ - - nnodes = SIZE ( pnode ) - IF ( .NOT. ALLOCATED ( r_last_update ) ) THEN - ALLOCATE ( r_last_update ( 3, nnodes ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'list_control', & - 'r_last_update', 3 * nnodes ) - - r_last_update = 1.0E+10_dbl - END IF - -! check to see if neighbor list has to be updated - max_displace = -1.0E+15_dbl - DO i = 1, nnodes - disp_vec ( : ) = r_last_update(:,i) - pnode(i) %p%r ( : ) - displace = DOT_PRODUCT ( disp_vec, disp_vec ) - max_displace = MAX ( displace, max_displace ) - END DO -#if defined(__parallel) - CALL mp_max ( max_displace, globenv_ll%group ) -#endif - - IF ( max_displace >= 0.25_dbl * verlet_skin ** 2 ) THEN - list_update_flag = .TRUE. - DO i = 1, nnodes - r_last_update(1,i) = pnode(i) % p % r(1) - r_last_update(2,i) = pnode(i) % p % r(2) - r_last_update(3,i) = pnode(i) % p % r(3) - END DO - ELSE - list_update_flag = .FALSE. - END IF - - IF ( list_update_flag ) THEN - SELECT CASE ( list_type ) - CASE ( 0 ) - - CALL stop_prg ( 'list_control', 'list type not specified' ) - - CASE ( 1 ) - string = ' cell_index: nonbonded neighbor list' - - CALL cell_list(natom_types,pp_cell,rlist_cut,string,pnode,part, & - box,pp_cell_ll,pp_startlist_cell,pp_neighbor, globenv_ll) - - CALL verlet_list(natom_types,pp_images,pp_cell,pnode,part,box, & - verlet_skin,rlist_cut,rlist_cutsq,pp_neighbor,pp_cell_ll, & - pp_startlist_nl,pp_startlist_im, globenv_ll) - END SELECT - - iw = globenv_ll % scr - ionode = globenv_ll % ionode - IF ( ionode .AND. print_level > 5 ) WRITE (iw,'(a,T71,I10 )' ) & - ' list_control| Neighbor list updated at step: ', counter - IF ( counter > 0 ) THEN - num_update = num_update + 1 - lup = counter + 1 - last_update - last_update = counter + 1 - aup = aup + (lup-aup)/float(num_update) - ELSE - num_update = 0 - lup = 0 - last_update = 1 - aup = 0.0_dbl - END IF - - END IF - - counter = counter + 1 - -END SUBROUTINE list_control - -!****************************************************************************** - -END MODULE linklist_control diff --git a/src/linklist_utilities.c b/src/linklist_utilities.c deleted file mode 100644 index f6e67fc..0000000 --- a/src/linklist_utilities.c +++ /dev/null @@ -1,222 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklist_utilities - - USE kinds, ONLY : dbl - USE molecule_types, ONLY : particle_node_type, linklist_neighbor, & - linklist_images - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : get_cell_param, cell_type - USE stop_program, ONLY : stop_memory - - IMPLICIT NONE - - PUBLIC :: get_match, update_verlet_list, & - number_of_image_cells, startlist_images_type - PRIVATE - - TYPE startlist_images_type - TYPE ( linklist_images), POINTER :: image - END TYPE startlist_images_type - - - CONTAINS - -!------------------------------------------------------------------------------! - FUNCTION get_match(jatom,elist,nexcl) RESULT (match) - IMPLICIT NONE - INTEGER, INTENT ( IN ) :: jatom - INTEGER, INTENT ( IN ) :: elist ( : ) - INTEGER, INTENT ( IN ) :: nexcl - LOGICAL :: match - INTEGER :: iexclude - - match = .FALSE. - DO iexclude = 1, nexcl - IF (elist(iexclude)>jatom) EXIT - IF (elist(iexclude)==jatom) THEN - match = .TRUE. - EXIT - END IF - END DO - END FUNCTION get_match -!------------------------------------------------------------------------------! - SUBROUTINE update_verlet_list(n_images,part,j,pnode,hmat,h_inv,perd, & - distsq,current_neighbor) - IMPLICIT NONE - TYPE (particle_type ), INTENT ( IN ), TARGET :: part - TYPE (particle_node_type ), INTENT ( INOUT ) :: pnode - INTEGER, INTENT ( IN ) :: j - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n_images - REAL ( dbl ), INTENT ( IN ) :: hmat(3,3), h_inv(3,3), perd(3) - REAL ( dbl ), INTENT ( IN ) :: distsq - TYPE (linklist_neighbor), POINTER :: current_neighbor -! locals - REAL ( dbl ), DIMENSION (3) :: rij, s - REAL ( dbl ) :: rijsq - INTEGER :: isos - - rij(1) = part % r(1) - pnode % p % r(1) - rij(2) = part % r(2) - pnode % p % r(2) - rij(3) = part % r(3) - pnode % p % r(3) -! inline code for general function pbc - s(1) = h_inv(1,1)*rij(1) + h_inv(1,2)*rij(2) + h_inv(1,3)*rij(3) - s(2) = h_inv(2,1)*rij(1) + h_inv(2,2)*rij(2) + h_inv(2,3)*rij(3) - s(3) = h_inv(3,1)*rij(1) + h_inv(3,2)*rij(2) + h_inv(3,3)*rij(3) - IF (MAXVAL(n_images)==0) THEN - IF(ABS(s(1)) > 0.5_dbl) THEN - s(1) = s(1) - perd(1)*INT(s(1)+SIGN(0.5_dbl,s(1))) - END IF - IF(ABS(s(2)) > 0.5_dbl) THEN - s(2) = s(2) - perd(2)*INT(s(2)+SIGN(0.5_dbl,s(2))) - END IF - IF(abs(s(3)) > 0.5_dbl) THEN - s(3) = s(3) - perd(3)*INT(s(3)+sign(0.5_dbl,s(3))) - END IF - rij(1) = hmat(1,1)*s(1) + hmat(1,2)*s(2) + hmat(1,3)*s(3) - rij(2) = hmat(2,1)*s(1) + hmat(2,2)*s(2) + hmat(2,3)*s(3) - rij(3) = hmat(3,1)*s(1) + hmat(3,2)*s(2) + hmat(3,3)*s(3) - rijsq = rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3) - END IF -! -! -! if we are within the cutoff, let the current_neighor -! position in the link_list point to the jth atom -! - IF (rijsq<=distsq.OR.MAXVAL(n_images) /= 0 ) THEN - pnode%nneighbor = pnode%nneighbor + 1 - current_neighbor%p => part - current_neighbor%index = j - current_neighbor%nimages = 0 -! - IF (MAXVAL(n_images) /= 0 ) CALL find_images(n_images,s,hmat, & - perd,distsq,current_neighbor) -! -! advance the current position in the link_link by one. -! however, since we are constantly reusing this list -! and the number of neighbors may fluctuate, we have to check -! to see that the next member of the list exists. If not, create it -! and then advance by one. - IF ( .NOT. associated(current_neighbor%next)) THEN - ALLOCATE (current_neighbor%next,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'update_verlet_list', & - 'current_neighbor%next', 0 ) - current_neighbor => current_neighbor%next - NULLIFY (current_neighbor%next) - ELSE - current_neighbor => current_neighbor%next - END IF - END IF - - END SUBROUTINE update_verlet_list -!------------------------------------------------------------------------------! - SUBROUTINE update_image_list(sij,n,vec,hmat,perd,distsq,current_image) - IMPLICIT NONE - INTEGER, INTENT ( INOUT ) :: n - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: sij, perd, vec - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ) :: hmat - REAL ( dbl ), INTENT ( IN ) :: distsq - TYPE (linklist_images), POINTER :: current_image -! locals - REAL ( dbl ), DIMENSION (3) :: rij, s - REAL ( dbl ) :: rijsq - INTEGER :: isos -! add the lattice tranlation - s(1) = sij(1) + perd(1)*vec(1) - s(2) = sij(2) + perd(2)*vec(2) - s(3) = sij(3) + perd(3)*vec(3) -! compute distance - rij(1) = hmat(1,1)*s(1) + hmat(1,2)*s(2) + hmat(1,3)*s(3) - rij(2) = hmat(2,1)*s(1) + hmat(2,2)*s(2) + hmat(2,3)*s(3) - rij(3) = hmat(3,1)*s(1) + hmat(3,2)*s(2) + hmat(3,3)*s(3) -! - rijsq = rij(1)*rij(1) + rij(2)*rij(2) + rij(3)*rij(3) -! -! if we are within the cutoff, let the current_image -! position in the link_list point to the jth atom -! - IF (rijsq<=distsq) THEN - n = n + 1 - current_image%vec = vec -! -! advance the current position in the link_link by one. -! however, since we are constantly reusing this list -! and the number of images may fluctuate, we have to check -! to see that the next member of the list exists. If not, create it -! and then advance by one. - IF ( .NOT. ASSOCIATED ( current_image % next ) ) THEN - ALLOCATE ( current_image % next, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'update_verlet_list', & - 'current_image%next', 0 ) - current_image => current_image % next - NULLIFY ( current_image % next ) - ELSE - current_image => current_image % next - END IF - END IF - - END SUBROUTINE update_image_list -!------------------------------------------------------------------------------! - SUBROUTINE find_images(n_images,s,hmat,perd,distsq,current_neighbor) - IMPLICIT NONE - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: s - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: hmat - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: perd - REAL ( dbl ), INTENT ( IN ) :: distsq - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n_images - TYPE ( linklist_neighbor), POINTER :: current_neighbor -! locals - TYPE ( linklist_images), POINTER :: current_image - INTEGER :: icell,jcell,kcell - REAL ( dbl ), DIMENSION(3) :: vec - - current_image=>current_neighbor%image - - DO kcell=-n_images(3), n_images(3) - DO jcell=-n_images(2), n_images(2) - DO icell=-n_images(1), n_images(1) -! exclude the center cell - IF (icell==0.AND.jcell==0.AND.kcell==0) CYCLE - - vec ( : )=(/icell,jcell,kcell/) - - CALL update_image_list(s,current_neighbor%nimages,vec, & - hmat,perd,distsq,current_image) - - END DO - END DO - END DO - END SUBROUTINE find_images -!------------------------------------------------------------------------------! - SUBROUTINE number_of_image_cells(box,n_images,verlet_skin,list_cut) - IMPLICIT NONE - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ),DIMENSION ( :, : ), INTENT ( IN ) :: list_cut - INTEGER, DIMENSION(:,:,:), INTENT ( OUT ) :: n_images - REAL ( dbl ), INTENT ( IN ) :: verlet_skin -! locals - INTEGER :: itype, jtype, id, ntypes - REAL ( dbl ), DIMENSION(3) :: quotient, cell_lengths -! get cell parameters - CALL get_cell_param(box,cell_lengths) -! compute the maximum translation vector for each type - ntypes=SIZE(list_cut,1) - DO itype=1, ntypes - DO jtype=1, ntypes - quotient ( : )=(list_cut(itype,jtype )-verlet_skin)/cell_lengths ( : ) - DO id=1,3 - IF (quotient(id)<=.5_dbl) THEN - n_images(itype,jtype,id)=0 - ELSE - n_images(itype,jtype,id) = & - CEILING(list_cut(itype,jtype )/cell_lengths(id)) - END IF - END DO - END DO - END DO - END SUBROUTINE number_of_image_cells -!------------------------------------------------------------------------------! -END MODULE linklist_utilities diff --git a/src/linklist_verlet_list.c b/src/linklist_verlet_list.c deleted file mode 100644 index a7dfabd..0000000 --- a/src/linklist_verlet_list.c +++ /dev/null @@ -1,303 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklist_verlet_list - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklist_cell_types, ONLY : cell_neighborlist_type, & - neighbor_cells_type, cell_atoms_linklist_type - USE linklist_utilities, ONLY : get_match, update_verlet_list, & - number_of_image_cells, startlist_images_type - USE molecule_types, ONLY : particle_node_type, linklist_neighbor, & - linklist_exclusion - USE mp, ONLY : mp_max, mp_min, mp_sum - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_memory - USE timings, ONLY : timeset, timestop - USE util, ONLY : include_list, sort - - IMPLICIT NONE - - PRIVATE - PUBLIC :: verlet_list - -CONTAINS - -!****************************************************************************** - -! to get the Verlet neighbor list for nonbonded interactions - -SUBROUTINE verlet_list(natom_types,n_images,n_cell,pnode,part,box, & - verlet_skin,rlist_cut,rlist_cutsq,neighbor, & - cell_ll,start_list_nl,start_list_im, globenv) - - IMPLICIT NONE - -! -! neighbor_list lists all the neighbors of all atoms -! - -! Arguments - TYPE (particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ), TARGET :: & - pnode - TYPE (particle_type ), INTENT ( IN ), DIMENSION ( : ), TARGET :: part - TYPE (cell_type ), INTENT ( IN ) :: box - TYPE (linklist_neighbor), POINTER :: start_list_nl - TYPE (startlist_images_type ), POINTER :: start_list_im ( : ) - TYPE (cell_neighborlist_type ), INTENT ( IN ) :: cell_ll(:,:,:) - TYPE (neighbor_cells_type ), INTENT ( IN ) :: neighbor ( :, : ) - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ) :: rlist_cut, rlist_cutsq - REAL ( dbl ), INTENT ( IN ) :: verlet_skin - INTEGER, DIMENSION(:,:,:), POINTER :: n_images - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: n_cell - INTEGER, INTENT ( IN ) :: natom_types - -! Locals - TYPE (cell_atoms_linklist_type ), POINTER :: ll - INTEGER :: i, ii, j, natoms, nnodes, handle, ipair - INTEGER :: iatom, jatom, iexclude, isos - INTEGER :: nloc, nsum, nmax, nmin, nexcl, ncells - INTEGER :: k, ipart, jpart, itype, jtype, npairs - INTEGER, DIMENSION (3) :: index - INTEGER, PARAMETER :: els = 50 - INTEGER, DIMENSION ( : ), POINTER :: elist, ind - REAL ( dbl ) :: rijsq, fis - REAL ( dbl ), DIMENSION (3) :: perd - REAL ( dbl ), DIMENSION (3,3) :: hmat, h_inv - LOGICAL :: first_time - -! -! the following lines are used for the link_list of -! neighbors -! - TYPE (linklist_neighbor), POINTER :: current_neighbor - TYPE (linklist_exclusion), POINTER :: ll_exclude - -!------------------------------------------------------------------------------ - -! -! if we are entering this subroutine for the first time -! create the start of the link_list of neighbors. -! start_list and first_time are both of type save -! so this if statement will not be run or needed -! after the first call to the subroutine -! - CALL timeset ( 'VERLET_LIST', 'I', 'KIs', handle ) - fis = 0.0_dbl - - ALLOCATE (elist(els),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'elist', els ) - - ALLOCATE (ind(els),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'ind', els ) - -! local copies of box parameters - hmat = box%hmat - h_inv = box%h_inv - perd = box%perd - nnodes = size(pnode) - natoms = size(part) - - first_time = .NOT. ASSOCIATED ( n_images ) - - IF ( first_time ) THEN - -! compute the number of images for a given cut-off - ALLOCATE ( n_images ( natom_types, natom_types, 3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet list', & - 'n_images', 3 * natom_types ** 2 ) - - CALL number_of_image_cells ( box, n_images, verlet_skin, rlist_cut ) - -! allocate the start of the lists - ALLOCATE (start_list_nl,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'start_list', 0 ) - NULLIFY (start_list_nl%next) - - IF (MAXVAL(n_images) /= 0 ) THEN - npairs=natoms*(natoms-1)/2 - ALLOCATE(start_list_im(npairs),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'start_list_im', 0 ) - DO ipair=1,npairs - ALLOCATE(start_list_im(ipair)%image, STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', & - 'start_list_im%image', 0 ) - NULLIFY (start_list_im(ipair)%image%next) - END DO - END IF - - END IF - - IF (first_time .AND. globenv % print_level > 4 & - .OR. globenv % print_level > 9 ) THEN - IF (globenv % ionode) WRITE (globenv % scr,'(A,T71,i10 )' ) & - ' verlet_list| # of atoms : ', natoms - IF (globenv % ionode) WRITE (globenv % scr,'(A,T71,i10 )' ) & - ' verlet_list| # of atom nodes : ', nnodes - END IF - -! -! let the current_neighbor point to the start of the list -! - current_neighbor => start_list_nl - -! -! loop over all distinct i,j pairs of atoms -! - ipair=0 - DO i = 1, nnodes - ii = pnode(i) %p%iatom - itype = pnode(i) %p%prop%ptype - pnode(i) %nneighbor = 0 - nexcl = pnode(i) %nexcl - IF (nexcl>size(elist)) STOP 'els' - ll_exclude => pnode(i) %ex - -! list number of exclusion - DO iexclude = 1, nexcl - elist(iexclude) = ll_exclude%p%iatom - ll_exclude => ll_exclude%next - END DO - -! sort elist - CALL sort(elist,nexcl,ind) - -! -! pnode(i)%nl is the start of the neighbor link_list for -! atom i. Let it point to the current position in -! the link_list -! - pnode(i) %nl => current_neighbor - -! first: loop over all particles in the same cell - DO jtype = 1, natom_types - ll => part(ii) % cell % pTYPE ( jtype ) % ll - DO jpart = 1, part(ii) % cell % natoms(jtype ) - j = ll%atom -! use black/white scheme to avoid double counting - IF (include_list(ii,j)) THEN - ipair=ipair+1 - IF (MAXVAL(n_images(itype,jtype,:)) /= 0 ) & - current_neighbor%image=>start_list_im(ipair)%image -! look for a match in the exclusion list (j in excl of pnode(i)) - SELECT CASE (nexcl) - CASE DEFAULT - IF ( .NOT. get_match(j,elist,nexcl)) THEN - CALL update_verlet_list(n_images ( itype, jtype, : ), & - part(j), j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - END IF - CASE (0) - CALL update_verlet_list(n_images(itype,jtype,:),part(j),j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - CASE (1) - IF ( j/=elist(1)) THEN - CALL update_verlet_list(n_images(itype,jtype,:), & - part(j),j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - END IF - END SELECT - END IF - ll => ll%next - END DO - END DO - -! second: loop over all neighbor cells - DO jtype = 1, natom_types - IF (ALL(n_cell==1)) EXIT - ncells=SIZE (neighbor(itype,jtype ) % index, 2) - DO k = 1, ncells - index(1) = part(ii) % cell % neighbor(itype,jtype ) %index(1,k) - index(2) = part(ii) % cell % neighbor(itype,jtype ) %index(2,k) - index(3) = part(ii) % cell % neighbor(itype,jtype ) %index(3,k) - ll => cell_ll(index(1),index(2),index(3)) % pTYPE ( jtype ) %ll - DO jpart = 1, cell_ll(index(1),index(2),index(3)) %natoms( & - jtype ) - ipair=ipair+1 - j = ll%atom - SELECT CASE (nexcl) - CASE DEFAULT - IF ( .NOT. get_match(j,elist,nexcl)) THEN - CALL update_verlet_list(n_images(itype,jtype,:), & - part(j),j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - END IF - CASE (0) - CALL update_verlet_list(n_images(itype,jtype,:),part(j),j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - CASE (1) - IF ( j/=elist(1)) THEN - CALL update_verlet_list(n_images(itype,jtype,:), & - part(j),j, & - pnode(i),hmat,h_inv,perd,rlist_cutsq(itype,jtype ), & - current_neighbor) - END IF - END SELECT - ll => ll%next - END DO - END DO - END DO - - IF ( first_time .AND. globenv % print_level>4 & - .OR. globenv % print_level>9) THEN - IF (globenv % ionode) WRITE (globenv % scr,'(A,i10,T54,A,T71,I10 )' ) & - ' verlet_list| Atom :', i, ' # of neighbors:', & - pnode(i) %nneighbor - END IF - - END DO - -! -! write some info on the neighbor lists to output -! - nloc = sum(pnode ( : )%nneighbor) - IF ( first_time .AND. globenv % print_level > 4 & - .OR. globenv % print_level > 9 ) THEN - -#if defined(__parallel) - nsum = nloc - CALL mp_sum(nsum,globenv%group) - nmax = nloc - CALL mp_max(nmax,globenv%group) - nmin = nloc - CALL mp_min(nmin,globenv%group) - IF (globenv % ionode) WRITE (globenv % scr,'(A,T69,I12 )' ) & - ' verlet_list| Total number of interactions ', nsum - IF (globenv % ionode) WRITE (globenv % scr,'(A,T69,I12 )' ) & - ' verlet_list| Minimum number of interactions per node', nmin - IF (globenv % ionode) WRITE (globenv % scr,'(A,T69,I12 )' ) & - ' verlet_list| Maximum number of interactions per node', nmax - IF (globenv % ionode) WRITE (globenv % scr,'(A,T69,F10.2,A )' ) & - ' verlet_list| Load balancing error', 100.0_dbl & - * REAL ( nmax - nmin, dbl) & - / REAL ( nsum, dbl ) * globenv % num_pe, ' %' -#else - IF (globenv % ionode) WRITE (globenv % scr,'(A,T69,I12 )' ) & - ' verlet_list| Total number of interactions ', nloc -#endif - END IF - fis = nloc * 1.0E-3_dbl - - CALL timestop(fis,handle) - - DEALLOCATE (elist,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'elist' ) - - DEALLOCATE (ind,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'verlet_list', 'ind' ) - -END SUBROUTINE verlet_list - -!****************************************************************************** - -END MODULE linklist_verlet_list diff --git a/src/linklists.c b/src/linklists.c deleted file mode 100644 index 4209b47..0000000 --- a/src/linklists.c +++ /dev/null @@ -1,692 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE linklists - - USE kinds, ONLY : dbl - USE molecule_types, ONLY : molecule_structure_type, linklist_atoms, & - bond_parameters_type, linklist_bonds, bend_parameters_type, & - linklist_bends, torsion_parameters_type, linklist_torsions, & - linklist_dist_constraints, linklist_g3x3_constraints, & - linklist_neighbor, linklist_exclusion, particle_node_type, & - molecule_type - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: atom_link_list, exclusion, bond_link_list, bend_link_list - PUBLIC :: torsion_link_list, distconst_link_list, g3x3_link_list - PUBLIC :: bonds, bends, torsions, dist_constraints, g3x3_constraints - - LOGICAL :: bonds, bends, torsions, dist_constraints, g3x3_constraints - -CONTAINS - -!****************************************************************************** - -SUBROUTINE atom_link_list ( molecule, pnode ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ), TARGET :: & - pnode - -! Locals - INTEGER :: imol, iatom, jatom - TYPE ( linklist_atoms ), POINTER :: current_ll_atom - INTEGER :: ios - -!------------------------------------------------------------------------------ - - ALLOCATE ( current_ll_atom, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory( 'atom_link_list', 'current_ll_atom', 0 ) - jatom = 1 - DO imol = 1, size(molecule) - molecule(imol) %ll_atoms => current_ll_atom - DO iatom = 1, molecule(imol) %natoms_mol - current_ll_atom%part => pnode(jatom) - ALLOCATE ( current_ll_atom%next, STAT = ios ) - IF ( ios /= 0 ) & - CALL stop_memory( 'atom_link_list', 'current_ll_atom%next', 0 ) - current_ll_atom => current_ll_atom%next - jatom = jatom + 1 - END DO - END DO - -END SUBROUTINE atom_link_list - -!****************************************************************************** - -SUBROUTINE exclusion(molecule,pnode) - -! Routine to compute the exclusion list - - IMPLICIT NONE - -! Arguments - TYPE (molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule - TYPE (particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ) :: pnode - -! Locals - TYPE (linklist_exclusion), POINTER :: current_excl - TYPE (linklist_atoms), POINTER :: ll_atom - TYPE (linklist_bonds), POINTER :: ll_bond - TYPE (linklist_bends), POINTER :: ll_bend - TYPE (linklist_torsions), POINTER :: ll_tors - TYPE (linklist_dist_constraints), POINTER :: ll_dist - TYPE (linklist_g3x3_constraints), POINTER :: ll_g3x3 - INTEGER :: imol, iatom, jatom, ibond, ibend, itors, idist, i, ii - INTEGER :: jnode, ig3x3, ios - INTEGER, DIMENSION ( : ), ALLOCATABLE :: bond, bend, tors - INTEGER :: natoms_mol, nbonds_mol, nbends_mol, ntors_mol, ndist_mol, n3x3_mol - LOGICAL :: match - -!------------------------------------------------------------------------------ - -! allocating local variables containting intra atoms - ALLOCATE (bond(2),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory( 'exclusion','bond', 2 ) - ALLOCATE (bend(3),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory( 'exclusion','bend', 3 ) - ALLOCATE (tors(4),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory( 'exclusion','tors', 4 ) - -! allocating the exclusion pointer - ALLOCATE (current_excl,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory( 'exclusion', 'current_excl', 0 ) - -! initialize the nexcl counter for all atoms - pnode%nexcl = 0 - -! looping through all of the molecules - jnode = 0 - - MLOOP: DO imol = 1, size(molecule) - -! assigning local variables - natoms_mol = molecule(imol) %natoms_mol - nbonds_mol = molecule(imol) %nbonds_mol - nbends_mol = molecule(imol) %nbends_mol - ntors_mol = molecule(imol) %ntorsions_mol - ndist_mol = molecule(imol) %ndistconst_mol - n3x3_mol = molecule(imol) %ng3x3const_mol - -! pointing local pointers to the start of the list - ll_atom => molecule(imol) %ll_atoms - -! looping over all the atoms in molecule imol - ALOOP: DO iatom = 1, natoms_mol - jnode = jnode + 1 - -! finding the current atom in the molecule - jatom = ll_atom%part%p%iatom - pnode(jnode) %ex => current_excl - ll_bond => molecule(imol) %ll_bonds - -! doing the bonds - BONDL: DO ibond = 1, nbonds_mol - bond(1) = ll_bond%p1%iatom - bond(2) = ll_bond%p2%iatom - -! checking to see if jatom is bonded - DO ii = 1, 2 - IF (jatom==bond(ii)) THEN - match = .TRUE. - EXIT - END IF - END DO - BONDIF: IF (match) THEN - DO ii = 1, 2 - CALL checklist(pnode(jnode),match,jatom,bond(ii)) - IF ( .NOT. match) THEN - i = getnode(molecule,bond(ii)) - current_excl%p => pnode(i) %p - pnode(jnode) %nexcl = pnode(jnode) %nexcl + 1 - ALLOCATE (current_excl%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion', & - 'current_excl%next', 0 ) - current_excl => current_excl%next - END IF - END DO - END IF BONDIF - ll_bond => ll_bond%next - END DO BONDL - -! doing the bends - ll_bend => molecule(imol) %ll_bends - BENDL: DO ibend = 1, nbends_mol - bend(1) = ll_bend%p1%iatom - bend(2) = ll_bend%p2%iatom - bend(3) = ll_bend%p3%iatom -! checking to see if jatom is part of a bend - DO ii = 1, 3 - IF (jatom==bend(ii)) THEN - match = .TRUE. - EXIT - END IF - END DO - BENDIF: IF (match) THEN - DO ii = 1, 3 - CALL checklist(pnode(jatom),match,jatom,bend(ii)) - IF ( .NOT. match) THEN - i = getnode(molecule,bend(ii)) - current_excl%p => pnode(i) %p - pnode(jnode) %nexcl = pnode(jnode) %nexcl + 1 - ALLOCATE (current_excl%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion', & - 'current_excl%next', 0 ) - current_excl => current_excl%next - END IF - END DO - END IF BENDIF - ll_bend => ll_bend%next - END DO BENDL - -! doing the torsions - ll_tors => molecule(imol) %ll_torsions - TORSL: DO itors = 1, ntors_mol - tors(1) = ll_tors%p1%iatom - tors(2) = ll_tors%p2%iatom - tors(3) = ll_tors%p3%iatom - tors(4) = ll_tors%p4%iatom -! checking to see if jatom is part of a torsion - DO ii = 1, 4 - IF (jatom==tors(ii)) THEN - match = .TRUE. - EXIT - END IF - END DO - TORSIF: IF (match) THEN - DO ii = 1, 4 - CALL checklist(pnode(jnode),match,jatom,tors(ii)) - IF ( .NOT. match) THEN - i = getnode(molecule,tors(ii)) - current_excl%p => pnode(i) %p - pnode(jnode) %nexcl = pnode(jnode) %nexcl + 1 - ALLOCATE (current_excl%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion', & - 'current_excl%next', 0 ) - current_excl => current_excl%next - END IF - END DO - END IF TORSIF - ll_tors => ll_tors%next - END DO TORSL - -! doing the distance constraints - ll_dist => molecule(imol) %ll_dist_const - DISTL: DO idist = 1, ndist_mol - bond(1) = ll_dist%p1%iatom - bond(2) = ll_dist%p2%iatom - -! checking to see if jatom is bonded - DO ii = 1, 2 - IF (jatom==bond(ii)) THEN - match = .TRUE. - EXIT - END IF - END DO - DISTIF: IF (match) THEN - DO ii = 1, 2 - CALL checklist(pnode(jnode),match,jatom,bond(ii)) - IF ( .NOT. match) THEN - i = getnode(molecule,bond(ii)) - current_excl%p => pnode(i) %p - pnode(jnode) %nexcl = pnode(jnode) %nexcl + 1 - ALLOCATE (current_excl%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion', & - 'current_excl%next', 0 ) - current_excl => current_excl%next - END IF - END DO - END IF DISTIF - ll_dist => ll_dist%next - END DO DISTL - -! doing the group constraints - ll_g3x3 => molecule(imol) %ll_g3x3_const - G3X3L: DO ig3x3 = 1, n3x3_mol - bend(1) = ll_g3x3%p1%iatom - bend(2) = ll_g3x3%p2%iatom - bend(3) = ll_g3x3%p3%iatom - -! checking to see if jatom is bonded - DO ii = 1, 3 - IF (jatom==bend(ii)) THEN - match = .TRUE. - EXIT - END IF - END DO - G3X3IF: IF (match) THEN - DO ii = 1, 3 - CALL checklist(pnode(jnode),match,jatom,bend(ii)) - IF ( .NOT. match) THEN - i = getnode(molecule,bend(ii)) - current_excl%p => pnode(i) %p - pnode(jnode) %nexcl = pnode(jnode) %nexcl + 1 - ALLOCATE (current_excl%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion', & - 'current_excl%next', 0 ) - current_excl => current_excl%next - END IF - END DO - END IF G3X3IF - ll_g3x3 => ll_g3x3%next - END DO G3X3L - ll_atom => ll_atom%next - END DO ALOOP - END DO MLOOP - -! deallocating - DEALLOCATE (bond,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion','bond') - DEALLOCATE (bend,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion','bend') - DEALLOCATE (tors,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'exclusion','tors') - -END SUBROUTINE exclusion - -!****************************************************************************** - -SUBROUTINE checklist(pnode,match,jatom,ipart) - -! checks to see if excluded particle is already in the list - - IMPLICIT NONE - -! Arguments - TYPE (particle_node_type ), INTENT ( IN ) :: pnode - INTEGER, INTENT ( IN ) :: ipart, jatom - LOGICAL, INTENT ( OUT ) :: match - -! Locals - TYPE ( linklist_exclusion ), POINTER :: ll_exclude - INTEGER :: i - -!------------------------------------------------------------------------------ - -! initialize match - match = .FALSE. -!BIGIF: IF ((jatom==ipart) .OR. (ipart pnode%ex - LOOP: DO i = 1, pnode%nexcl - IF (ipart==ll_exclude%p%iatom) THEN - match = .TRUE. - EXIT LOOP - END IF - ll_exclude => ll_exclude%next - END DO LOOP - END IF BIGIF - -END SUBROUTINE checklist - -!****************************************************************************** - -FUNCTION getnode ( molecule, atom ) RESULT ( node ) - - IMPLICIT NONE - -! Return value - INTEGER :: node - -! Arguments - TYPE (molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - INTEGER, INTENT ( IN ) :: atom - -! Locals - INTEGER :: imol - -!------------------------------------------------------------------------------ - - node = 0 - DO imol = 1, SIZE ( molecule ) - IF ( molecule ( imol ) % atombase + molecule ( imol ) % natoms_mol & - > atom ) THEN - - IF ( molecule ( imol ) % atombase > atom ) & - CALL stop_prg ( "getnode", "error in atombase" ) - - node = node + ( atom - molecule ( imol ) % atombase + 1 ) - - EXIT - END IF - node = node + molecule(imol) % natoms_mol - END DO - -END FUNCTION getnode - -!****************************************************************************** - -SUBROUTINE bond_link_list ( pnode, molecule, mol_setup, bond_parm ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ), TARGET :: & - pnode - TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & - molecule - TYPE ( molecule_type ), INTENT ( IN ) :: mol_setup ( : ) - TYPE ( bond_parameters_type ), INTENT ( IN ), DIMENSION ( :, : ), & - TARGET :: bond_parm - -! Locals - INTEGER :: imol, jmol, nmol, ibond, nb, atombase, pTYPE ( 2 ) - INTEGER :: index ( 2 ), ios - TYPE ( linklist_bonds ), POINTER :: current_ll_bonds - -!------------------------------------------------------------------------------ - - ALLOCATE (current_ll_bonds,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'bond_link_list', 'current_ll_bonds', 0 ) - - bonds = .FALSE. - nmol = size(molecule) - atombase = 0 - DO imol = 1, nmol - jmol = molecule(imol) %moltype - nb = mol_setup(jmol) %molpar%nbonds - bonds = bonds .OR. (nb /= 0 ) - molecule(imol) %nbonds_mol = nb - molecule(imol) %ll_bonds => current_ll_bonds - DO ibond = 1, nb - -! -! index(1) and index(2) are the part array indices -! of the first and second atoms in -! the ibond bond pair. pTYPE ( 1) and pTYPE ( 2) are their atom types. -! - index(1) = atombase + mol_setup(jmol) %molpar%bonds(1,ibond) - index(2) = atombase + mol_setup(jmol) %molpar%bonds(2,ibond) - pTYPE ( 1) = pnode(index(1)) %p%prop%ptype - pTYPE ( 2) = pnode(index(2)) %p%prop%ptype - current_ll_bonds%p1 => pnode(index(1)) %p - current_ll_bonds%p2 => pnode(index(2)) %p - current_ll_bonds%index = index - current_ll_bonds%bond_param => bond_parm(pTYPE ( 1),pTYPE ( 2)) - ALLOCATE (current_ll_bonds%next,STAT=ios) - IF ( ios /= 0 ) & - CALL stop_memory ( 'bond_link_list', 'current_ll_bonds%next', 0 ) - current_ll_bonds => current_ll_bonds%next - END DO - atombase = atombase + mol_setup(jmol) %molpar%natom - END DO - -END SUBROUTINE bond_link_list - -!****************************************************************************** - -SUBROUTINE bend_link_list ( pnode, molecule, mol_setup, bend_parm ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ), TARGET :: & - pnode - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( molecule_type ), INTENT ( IN ) :: mol_setup ( : ) - TYPE ( bend_parameters_type ), DIMENSION (:,:,:), INTENT ( IN ), & - TARGET :: bend_parm - -! Locals - INTEGER :: imol, jmol, nmol, ibend, nb, atombase, pTYPE ( 3 ) - INTEGER :: index ( 3 ), ios - TYPE ( linklist_bends ), POINTER :: current_ll_bends - -!------------------------------------------------------------------------------ - - ALLOCATE (current_ll_bends,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'bend_link_list', 'current_ll_bends', 0 ) - - bends = .FALSE. - nmol = size(molecule) - atombase = 0 - DO imol = 1, nmol - jmol = molecule(imol) %moltype - nb = mol_setup(jmol) %molpar%nbends - bends = bends .OR. (nb /= 0 ) - molecule(imol) %nbends_mol = nb - molecule(imol) %ll_bends => current_ll_bends - DO ibend = 1, nb - -! -! index(1),index(2) and index(3) are the part array indices of the -! first, second and third atoms in -! the ibend bend trio. pTYPE(1), pTYPE(2) and pTYPE(3) are their atom types -! - index(1) = atombase + mol_setup(jmol) %molpar%bends(1,ibend) - index(2) = atombase + mol_setup(jmol) %molpar%bends(2,ibend) - index(3) = atombase + mol_setup(jmol) %molpar%bends(3,ibend) - pTYPE ( 1) = pnode(index(1)) %p%prop%ptype - pTYPE ( 2) = pnode(index(2)) %p%prop%ptype - pTYPE ( 3) = pnode(index(3)) %p%prop%ptype - current_ll_bends%p1 => pnode(index(1)) %p - current_ll_bends%p2 => pnode(index(2)) %p - current_ll_bends%p3 => pnode(index(3)) %p - current_ll_bends%bend_param => bend_parm(pTYPE ( 1),pTYPE ( 2), & - pTYPE ( 3)) - current_ll_bends%index = index - ALLOCATE (current_ll_bends%next,STAT=ios) - IF ( ios /= 0 ) & - CALL stop_memory ( 'bend_link_list', 'current_ll_bends%next', 0 ) - current_ll_bends => current_ll_bends%next - END DO - atombase = atombase + mol_setup(jmol) %molpar%natom - END DO - -END SUBROUTINE bend_link_list - -!****************************************************************************** - -SUBROUTINE torsion_link_list ( pnode, molecule, mol_setup, torsion_parm ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ), TARGET :: & - pnode - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( molecule_type ), INTENT ( IN ) :: mol_setup ( : ) - TYPE ( torsion_parameters_type ), INTENT ( IN ), DIMENSION (:,:,:,:), & - TARGET :: torsion_parm - -! Locals - INTEGER :: imol, jmol, nmol, itorsion, nb, atombase, pTYPE ( 4 ) - INTEGER :: index ( 4 ), ios - TYPE (linklist_torsions), POINTER :: current_ll_torsions - -!------------------------------------------------------------------------------ - - ALLOCATE (current_ll_torsions,STAT=ios) - IF ( ios /= 0 ) & - CALL stop_memory ( 'torsion_link_list', 'current_ll_torsions', 0 ) - - torsions = .FALSE. - nmol = size(molecule) - atombase = 0 - DO imol = 1, nmol - jmol = molecule(imol) %moltype - nb = mol_setup(jmol) %molpar%ntorsions - torsions = torsions .OR. (nb /= 0 ) - molecule(imol) %ntorsions_mol = nb - molecule(imol) %ll_torsions => current_ll_torsions - DO itorsion = 1, nb - -! -! index(1),index(2),index(3) and index(4) are the part array indices of the -! first,second,third and fourth atoms in -! the itorsion torsion quartet. pTYPE ( 1), pTYPE ( 2), pTYPE ( 3) -! and pTYPE ( 4) are their atom types. -! - - index(1) = atombase + mol_setup(jmol) %molpar%torsions(1,itorsion) - index(2) = atombase + mol_setup(jmol) %molpar%torsions(2,itorsion) - index(3) = atombase + mol_setup(jmol) %molpar%torsions(3,itorsion) - index(4) = atombase + mol_setup(jmol) %molpar%torsions(4,itorsion) - pTYPE ( 1) = pnode(index(1)) %p%prop%ptype - pTYPE ( 2) = pnode(index(2)) %p%prop%ptype - pTYPE ( 3) = pnode(index(3)) %p%prop%ptype - pTYPE ( 4) = pnode(index(4)) %p%prop%ptype - current_ll_torsions%p1 => pnode(index(1)) %p - current_ll_torsions%p2 => pnode(index(2)) %p - current_ll_torsions%p3 => pnode(index(3)) %p - current_ll_torsions%p4 => pnode(index(4)) %p - current_ll_torsions%torsion_param => torsion_parm(pTYPE ( 1), & - pTYPE ( 2),pTYPE ( 3),pTYPE ( 4)) - current_ll_torsions%index = index - ALLOCATE (current_ll_torsions%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'torsion_link_list', & - 'current_ll_torsions%next', 0 ) - current_ll_torsions => current_ll_torsions%next - END DO - atombase = atombase + mol_setup(jmol) %molpar%natom - END DO - -END SUBROUTINE torsion_link_list - -!****************************************************************************** - -SUBROUTINE distconst_link_list ( pnode, molecule, mol_setup, & - constraint_distance ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ), TARGET :: & - pnode - TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & - molecule - TYPE ( molecule_type ), INTENT ( IN ) :: mol_setup ( : ) - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( IN ), TARGET :: & - constraint_distance - -! Locals - INTEGER :: imol, jmol, nmol, idcon, nb, atombase, pTYPE ( 2 ) - INTEGER :: index ( 2 ), ios - TYPE ( linklist_dist_constraints ), POINTER :: current_ll_dconst - -!------------------------------------------------------------------------------ - - ALLOCATE (current_ll_dconst,STAT=ios) - IF ( ios /= 0 ) & - CALL stop_memory ( 'distconst_link_list', 'current_ll_dconst', 0 ) - - dist_constraints = .FALSE. - nmol = size(molecule) - atombase = 0 - DO imol = 1, nmol - jmol = molecule(imol) %moltype - nb = mol_setup(jmol) %molpar%ndcon - dist_constraints = dist_constraints .OR. (nb /= 0 ) - molecule(imol) %ndistconst_mol = nb - molecule(imol) %ll_dist_const => current_ll_dconst - DO idcon = 1, nb - -! -! index(1) and index(2) are the part array indices of the -! first and second atoms in -! the iconst const. pair. pTYPE ( 1) and pTYPE ( 2) are their atom types. -! - index(1) = atombase + mol_setup(jmol) %molpar%ndc(1,idcon) - index(2) = atombase + mol_setup(jmol) %molpar%ndc(2,idcon) - pTYPE ( 1) = pnode(index(1)) %p%prop%ptype - pTYPE ( 2) = pnode(index(2)) %p%prop%ptype - current_ll_dconst%p1 => pnode(index(1)) %p - current_ll_dconst%p2 => pnode(index(2)) %p - current_ll_dconst%distance => constraint_distance(pTYPE ( 1), & - pTYPE ( 2)) - current_ll_dconst%lambda = 0._dbl - ALLOCATE (current_ll_dconst%next,STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'distconst_link_list', & - 'current_ll_dconst%next', 0 ) - - current_ll_dconst => current_ll_dconst % next - END DO - - atombase = atombase + mol_setup ( jmol ) % molpar % natom - END DO - -END SUBROUTINE distconst_link_list - -!****************************************************************************** - -SUBROUTINE g3x3_link_list ( pnode, molecule, mol_setup, constraint_distance ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ), TARGET :: & - pnode - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( molecule_type ), INTENT ( IN ) :: mol_setup ( : ) - REAL ( dbl ), INTENT ( IN ), DIMENSION ( :, : ), TARGET :: & - constraint_distance -! Locals - INTEGER :: imol, jmol, nmol, ig3x3, nb, atombase, pTYPE ( 3 ) - INTEGER :: index ( 3 ), ios - TYPE ( linklist_g3x3_constraints ), POINTER :: current_ll_g3x3 - -!------------------------------------------------------------------------------ - - ALLOCATE ( current_ll_g3x3, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'g3x3_link_list', 'current_ll_g3x3', 0 ) - - g3x3_constraints = .FALSE. - nmol = size ( molecule ) - atombase = 0 - - DO imol = 1, nmol - jmol = molecule(imol) % moltype - nb = mol_setup(jmol) % molpar % n3x3con - g3x3_constraints = g3x3_constraints .OR. ( nb /= 0 ) - molecule(imol) %ng3x3const_mol = nb - molecule(imol) %ll_g3x3_const => current_ll_g3x3 - DO ig3x3 = 1, nb - -! -! index(1),index(2) and index(3) are the part array indices of the -! first,second and third atoms in -! the ibend bend trio. pTYPE(1), pTYPE(2) and pTYPE(3) are their atom types -! - index(1) = atombase + mol_setup(jmol) %molpar%n3x3c(1,ig3x3) - index(2) = atombase + mol_setup(jmol) %molpar%n3x3c(2,ig3x3) - index(3) = atombase + mol_setup(jmol) %molpar%n3x3c(3,ig3x3) - pTYPE ( 1) = pnode(index(1)) %p%prop%ptype - pTYPE ( 2) = pnode(index(2)) %p%prop%ptype - pTYPE ( 3) = pnode(index(3)) %p%prop%ptype - current_ll_g3x3%p1 => pnode(index(1)) % p - current_ll_g3x3%p2 => pnode(index(2)) % p - current_ll_g3x3%p3 => pnode(index(3)) % p - current_ll_g3x3%d12 => constraint_distance(pTYPE ( 1), pTYPE ( 2)) - current_ll_g3x3%d13 => constraint_distance(pTYPE ( 1), pTYPE ( 3)) - current_ll_g3x3%d23 => constraint_distance(pTYPE ( 2), pTYPE ( 3)) - current_ll_g3x3%lambda ( : ) = 0.0_dbl - - ALLOCATE ( current_ll_g3x3 % next, STAT = ios ) - IF ( ios /= 0 ) & - CALL stop_memory ( 'g3x3_link_list', 'current_ll_g3x3%next', 0 ) - - current_ll_g3x3 => current_ll_g3x3 % next - END DO - - atombase = atombase + mol_setup ( jmol ) % molpar % natom - END DO - -END SUBROUTINE g3x3_link_list - -!****************************************************************************** - -END MODULE linklists diff --git a/src/machine.c b/src/machine.c deleted file mode 100644 index 20b509c..0000000 --- a/src/machine.c +++ /dev/null @@ -1,34 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine - -#if defined ( __AIX ) - USE machine_aix, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#elif defined ( __IRIX ) - USE machine_irix, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#elif defined ( __PGI ) - USE machine_pgi, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#elif defined ( __T3E ) - USE machine_t3e, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#elif defined ( __DEC ) - USE machine_dec, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#elif defined ( __ABSOFT ) - USE machine_absoft, ONLY : m_walltime, m_cputime, m_datum, & - m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg -#endif - - IMPLICIT NONE - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -END MODULE machine diff --git a/src/machine_absoft.c b/src/machine_absoft.c deleted file mode 100644 index 4f83b1a..0000000 --- a/src/machine_absoft.c +++ /dev/null @@ -1,106 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -MODULE machine_absoft - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - REAL (sgl) etime,tarray(2),d - EXTERNAL etime - - d=ETIME(tarray) - ct = DBLE(tarray(1)) - -END FUNCTION m_cputime -! -!****************************************************************************** -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (sgl) :: etime - TYPE tb_type - SEQUENCE - REAL (sgl) usrtime - REAL (sgl) systime - END TYPE tb_type - TYPE (tb_type) etime_struct - - wt = etime(etime_struct) -END FUNCTION m_walltime -!****************************************************************************** -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - CHARACTER (len=24) :: datum - - CALL fdate(datum) - cal_date = datum -END SUBROUTINE m_datum -!****************************************************************************** -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - INTEGER :: hostnm, ierror - - ierror = hostnm(hname) -END SUBROUTINE m_hostnm -!****************************************************************************** -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - INTEGER :: getcwd, ierror - CHARACTER (len=255) :: dir - - ierror = getcwd(dir) - curdir = dir -END SUBROUTINE m_getcwd -!****************************************************************************** -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - - CALL getlog(user) -END SUBROUTINE m_getlog -!****************************************************************************** -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: getuid - - uid = getuid() -END SUBROUTINE m_getuid -!****************************************************************************** -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: getpid - - pid = getpid() -END SUBROUTINE m_getpid -!****************************************************************************** -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - - CALL getarg(i,arg) -END SUBROUTINE m_getarg -!****************************************************************************** - -END MODULE machine_absoft - -!****************************************************************************** diff --git a/src/machine_aix.c b/src/machine_aix.c deleted file mode 100644 index 8d79105..0000000 --- a/src/machine_aix.c +++ /dev/null @@ -1,118 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine_aix - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum, print_memory - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - INTEGER :: mclock - - ct = mclock()*0.01_dbl -END FUNCTION m_cputime -! -!****************************************************************************** -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (sgl) :: etime_ - TYPE tb_type - SEQUENCE - REAL (sgl) usrtime - REAL (sgl) systime - END TYPE tb_type - TYPE (tb_type) etime_struct - - wt = etime_(etime_struct) -END FUNCTION m_walltime -!****************************************************************************** -!! memory usage -SUBROUTINE print_memory(subr) - IMPLICIT NONE - CHARACTER(len=24), INTENT(IN) :: subr -!locals: - CHARACTER(len=100):: string - INTEGER :: ihpstat,getpid_,my_pid - MY_PID=GETPID_() - WRITE(6,'(A,A,T25,A,$)') ' ***',SUBR,' the size of the program is ' - WRITE(STRING,'(A,I10,A)') 'ps -Fvsz -p ',MY_PID,& - ' | sed -e "/VSZ/d" | sed -e "s/$/ KBytes ***/" ' - CALL SYSTEM(STRING) -END SUBROUTINE print_memory -!****************************************************************************** -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - INTEGER :: l, le - - CALL fdate_(cal_date) - l = len(cal_date) - le = len_trim(cal_date) - cal_date(le:l) = ' ' -END SUBROUTINE m_datum -!****************************************************************************** -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - INTEGER :: hostnm_, ierror - - ierror = hostnm_(hname) -END SUBROUTINE m_hostnm -!****************************************************************************** -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - INTEGER :: getcwd_, ierror - - ierror = getcwd_(curdir) -END SUBROUTINE m_getcwd -!****************************************************************************** -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - - CALL getlog_(user) -END SUBROUTINE m_getlog -!****************************************************************************** -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: getuid_ - - uid = getuid_() -END SUBROUTINE m_getuid -!****************************************************************************** -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: getpid_ - - pid = getpid_() -END SUBROUTINE m_getpid -!****************************************************************************** -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - - CALL getarg(i,arg) -END SUBROUTINE m_getarg -!****************************************************************************** - -END MODULE machine_aix - -!****************************************************************************** diff --git a/src/machine_dec.c b/src/machine_dec.c deleted file mode 100644 index f0211c9..0000000 --- a/src/machine_dec.c +++ /dev/null @@ -1,135 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine_dec - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum, print_memory - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** - -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - REAL ( KIND = 4 ) :: etime, timearray ( 2 ) - - ct = REAL ( etime ( timearray ), dbl ) -END FUNCTION m_cputime - -!****************************************************************************** - -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (sgl) :: etime - TYPE tb_type - SEQUENCE - REAL (sgl) usrtime - REAL (sgl) systime - END TYPE tb_type - TYPE (tb_type) etime_struct - - wt = etime(etime_struct) -END FUNCTION m_walltime - -!****************************************************************************** - -!! memory usage -SUBROUTINE print_memory(subr) - IMPLICIT NONE - CHARACTER(len=24), INTENT(IN) :: subr -!locals: - CHARACTER(len=100):: string - INTEGER :: ihpstat,getpid,my_pid - my_pid = getpid() - WRITE(6,'(A,A,T25,A,$)') ' ***',SUBR,' the size of the program is ' - WRITE(STRING,'(A,I10,A)') 'ps -Fvsz -p ',MY_PID,& - ' | sed -e "/VSZ/d" | sed -e "s/$/ KBytes ***/" ' - CALL SYSTEM(STRING) -END SUBROUTINE print_memory - -!****************************************************************************** - -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - INTEGER :: l, le - - CALL fdate(cal_date) - l = len(cal_date) - le = len_trim(cal_date) - cal_date(le:l) = ' ' -END SUBROUTINE m_datum - -!****************************************************************************** - -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - INTEGER :: hostnm, ierror - - ierror = hostnm(hname) -END SUBROUTINE m_hostnm - -!****************************************************************************** - -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - INTEGER :: getcwd, ierror - - ierror = getcwd(curdir) -END SUBROUTINE m_getcwd - -!****************************************************************************** - -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - - CALL getlog(user) -END SUBROUTINE m_getlog - -!****************************************************************************** - -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: getuid - - uid = getuid() -END SUBROUTINE m_getuid - -!****************************************************************************** - -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: getpid - - pid = getpid() -END SUBROUTINE m_getpid - -!****************************************************************************** - -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - - CALL getarg(i,arg) -END SUBROUTINE m_getarg - -!****************************************************************************** - -END MODULE machine_dec diff --git a/src/machine_irix.c b/src/machine_irix.c deleted file mode 100644 index efaa93d..0000000 --- a/src/machine_irix.c +++ /dev/null @@ -1,104 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine_irix - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - INTEGER :: mclock - - ct = mclock()*0.01_dbl -END FUNCTION m_cputime -! -!****************************************************************************** -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (sgl) :: etime - TYPE tb_type - SEQUENCE - REAL (sgl) usrtime - REAL (sgl) systime - END TYPE tb_type - TYPE (tb_type) etime_struct - - wt = etime(etime_struct) -END FUNCTION m_walltime -!****************************************************************************** -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - INTEGER :: l, le - - CALL fdate(cal_date) - l = len(cal_date) - le = len_trim(cal_date) - cal_date(le:l) = ' ' -END SUBROUTINE m_datum -!****************************************************************************** -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - INTEGER :: hostnm, ierror - - ierror = hostnm(hname) -END SUBROUTINE m_hostnm -!****************************************************************************** -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - INTEGER :: getcwd, ierror - - ierror = getcwd(curdir) -END SUBROUTINE m_getcwd -!****************************************************************************** -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - - CALL getlog(user) -END SUBROUTINE m_getlog -!****************************************************************************** -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: getuid - - uid = getuid() -END SUBROUTINE m_getuid -!****************************************************************************** -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: getpid - - pid = getpid() -END SUBROUTINE m_getpid -!****************************************************************************** -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - - CALL getarg(i,arg) -END SUBROUTINE m_getarg -!****************************************************************************** - -END MODULE machine_irix - -!****************************************************************************** diff --git a/src/machine_pgi.c b/src/machine_pgi.c deleted file mode 100644 index 0cd5bed..0000000 --- a/src/machine_pgi.c +++ /dev/null @@ -1,135 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine_pgi - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum, print_memory - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** - -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - INTEGER :: mclock - - ct = mclock()*0.01_dbl -END FUNCTION m_cputime - -!****************************************************************************** - -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (sgl) :: etime - TYPE tb_type - SEQUENCE - REAL (sgl) usrtime - REAL (sgl) systime - END TYPE tb_type - TYPE (tb_type) etime_struct - - wt = etime(etime_struct) -END FUNCTION m_walltime - -!****************************************************************************** - -!! memory usage -SUBROUTINE print_memory(subr) - IMPLICIT NONE - CHARACTER(len=24), INTENT(IN) :: subr -!locals: - CHARACTER(len=100):: string - INTEGER :: ihpstat,getpid,my_pid - my_pid = getpid() - WRITE(6,'(A,A,T25,A,$)') ' ***',SUBR,' the size of the program is ' - WRITE(STRING,'(A,I10,A)') 'ps -Fvsz -p ',MY_PID,& - ' | sed -e "/VSZ/d" | sed -e "s/$/ KBytes ***/" ' - CALL SYSTEM(STRING) -END SUBROUTINE print_memory - -!****************************************************************************** - -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - INTEGER :: l, le - - CALL fdate(cal_date) - l = len(cal_date) - le = len_trim(cal_date) - cal_date(le:l) = ' ' -END SUBROUTINE m_datum - -!****************************************************************************** - -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - INTEGER :: hostnm, ierror - - ierror = hostnm(hname) -END SUBROUTINE m_hostnm - -!****************************************************************************** - -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - INTEGER :: getcwd, ierror - - ierror = getcwd(curdir) -END SUBROUTINE m_getcwd - -!****************************************************************************** - -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - - CALL getlog(user) -END SUBROUTINE m_getlog - -!****************************************************************************** - -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: getuid - - uid = getuid() -END SUBROUTINE m_getuid - -!****************************************************************************** - -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: getpid - - pid = getpid() -END SUBROUTINE m_getpid - -!****************************************************************************** - -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - - CALL getarg(i,arg) -END SUBROUTINE m_getarg - -!****************************************************************************** - -END MODULE machine_pgi diff --git a/src/machine_t3e.c b/src/machine_t3e.c deleted file mode 100644 index 590092e..0000000 --- a/src/machine_t3e.c +++ /dev/null @@ -1,127 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE machine_t3e - - USE kinds, ONLY : dbl, sgl - - PRIVATE - PUBLIC :: m_walltime, m_cputime, m_datum, print_memory - PUBLIC :: m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg - -CONTAINS - -!****************************************************************************** -!! cpu time in seconds -FUNCTION m_cputime() RESULT (ct) - IMPLICIT NONE - REAL (dbl) :: ct - REAL (dbl) :: tsecnd - - ct = tsecnd() -END FUNCTION m_cputime -! -!****************************************************************************** -!! wall clock time in seconds -FUNCTION m_walltime() RESULT (wt) - IMPLICIT NONE - REAL (dbl) :: wt - REAL (dbl) :: time - EXTERNAL time - - wt = time() -END FUNCTION m_walltime -!****************************************************************************** -!! memory usage -SUBROUTINE print_memory(subr) - IMPLICIT NONE - CHARACTER(len=24), INTENT(IN) :: subr -!locals: - CHARACTER(len=200):: string - INTEGER :: ihpstat,getpid_,my_pid, ierror - CALL pxfgetpid ( MY_PID, ierror ) -!*apsi WRITE(6,'(A,A,T25,A,$)') ' ***',SUBR,' the size of the program is ' -!*apsi WRITE(STRING,'(A,I10,A)') 'ps -o vsz -p ', MY_PID, & -!*apsi ' | sed -e "/VSZ/d" | sed -e "s/$/ KBytes ***/" ' - WRITE(STRING,'(A,I10,3A)') 'ps -o vsz -p ', MY_PID, & - ' | sed -e "/VSZ/d" | sed -e "s/$/ KBytes ***/" | sed -e "s/^/ ***', & - subr, ' the size of the program is /"' - CALL ishell(string) -END SUBROUTINE print_memory -!****************************************************************************** -!! time and date -SUBROUTINE m_datum(cal_date) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: cal_date - INTEGER :: l, le - - WRITE (cal_date,'(a8,'' on '',a8)') clock(), date() - l = len(cal_date) - le = len_trim(cal_date) - cal_date(le:l) = ' ' -END SUBROUTINE m_datum -!****************************************************************************** -SUBROUTINE m_hostnm(hname) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: hname - - CALL gethost(hname) -END SUBROUTINE m_hostnm -!****************************************************************************** -SUBROUTINE m_getcwd(curdir) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: curdir - - CALL getcwd(curdir) -END SUBROUTINE m_getcwd -!****************************************************************************** -SUBROUTINE m_getlog(user) - IMPLICIT NONE - CHARACTER (len=*), INTENT (OUT) :: user - INTEGER :: ilen, ierror - - CALL pxfgetlogin(user,ilen,ierror) -END SUBROUTINE m_getlog -!****************************************************************************** -SUBROUTINE m_getuid(uid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: uid - INTEGER :: ierror - - CALL pxfgetuid(uid,ierror) -END SUBROUTINE m_getuid -!****************************************************************************** -SUBROUTINE m_getpid(pid) - IMPLICIT NONE - INTEGER, INTENT (OUT) :: pid - INTEGER :: ierror - - CALL pxfgetpid(pid,ierror) -END SUBROUTINE m_getpid -!****************************************************************************** -SUBROUTINE m_getarg(i,arg) - IMPLICIT NONE - INTEGER, INTENT (IN) :: i - CHARACTER (len=*), INTENT (OUT) :: arg - INTEGER :: ilen, ierror - - CALL pxfgetarg(i,arg,ilen,ierror) -END SUBROUTINE m_getarg -!****************************************************************************** - -END MODULE machine_t3e - -!****************************************************************************** - -!*apsi* Since this one does not exist... -SUBROUTINE gsyev ( jobz, uplo, n, a, lda, w, work, lwork, info ) - USE stop_program, ONLY : stop_prg - IMPLICIT NONE - CHARACTER :: jobz, uplo - INTEGER :: INFO, LDA, LWORK, N - REAL ( KIND = 4 ) :: A( LDA, * ), W( * ), WORK( * ) - - CALL stop_prg ( "gsyev", "not defined" ) -END SUBROUTINE gsyev diff --git a/src/mathconstants.c b/src/mathconstants.c deleted file mode 100644 index a71ca0e..0000000 --- a/src/mathconstants.c +++ /dev/null @@ -1,71 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -!! Definition of mathematical constants and functions. - -MODULE mathconstants - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: init_mathcon - PUBLIC :: maxfac, pi, pio2, twopi, fourpi, root2, rootpi, oorootpi, & - zero, one, half, degree, radians, gaussi, fac, dfac - - INTEGER, PARAMETER :: maxfac = 30 - - REAL ( dbl ), PARAMETER :: pi = 3.14159265358979323846264338_dbl - REAL ( dbl ), PARAMETER :: pio2 = 1.57079632679489661923132169_dbl - REAL ( dbl ), PARAMETER :: twopi = 6.28318530717958647692528677_dbl - REAL ( dbl ), PARAMETER :: fourpi = 12.56637061435917295385057353_dbl - REAL ( dbl ), PARAMETER :: root2 = 1.41421356237309504880168872_dbl - REAL ( dbl ), PARAMETER :: rootpi = 1.77245387556702677717522568_dbl - REAL ( dbl ), PARAMETER :: oorootpi = 1._dbl/rootpi - - REAL ( dbl ), PARAMETER :: zero = 0._dbl, one = 1._dbl, half = 0.5_dbl - REAL ( dbl ), PARAMETER :: degree = 180._dbl/pi, radians = one/degree - COMPLEX ( dbl ) :: gaussi - - REAL ( dbl ), DIMENSION (0:maxfac) :: fac - REAL ( dbl ), DIMENSION (-1:2*maxfac+1) :: dfac - -CONTAINS - -!****************************************************************************** - -SUBROUTINE init_mathcon - - IMPLICIT NONE - -! Locals - INTEGER :: i - -!------------------------------------------------------------------------------ - - gaussi = CMPLX ( zero, one ) - -! -! *** Factorial function *** -! - fac(0) = one - DO i = 1, maxfac - fac(i) = real(i,dbl)*fac(i-1) - END DO -! -! *** Double factorial function *** -! - dfac ( -1 ) = one - dfac ( 0 ) = one - dfac ( 1 ) = one - DO i = 3, 2 * maxfac + 1 - dfac(i) = REAL ( i, dbl ) * dfac ( i - 2 ) - END DO - -END SUBROUTINE init_mathcon - -!****************************************************************************** - -END MODULE mathconstants diff --git a/src/md.h b/src/md.h deleted file mode 100644 index 5b2eaef..0000000 --- a/src/md.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef _MD_H -#define _MD_H - - - -#endif \ No newline at end of file diff --git a/src/mol_force.c b/src/mol_force.c deleted file mode 100644 index 62e9b99..0000000 --- a/src/mol_force.c +++ /dev/null @@ -1,183 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE mol_force - - USE kinds, ONLY : dbl - - PRIVATE - PUBLIC :: force_bonds, force_bends, force_torsions - PUBLIC :: get_pv_bond, get_pv_bend, get_pv_torsion - -CONTAINS - -!****************************************************************************** - -! Computes the bonded force - -SUBROUTINE force_bonds ( rij, r0, k, energy, fscalar ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: rij - REAL ( dbl ), INTENT ( IN ) :: r0, k - REAL ( dbl ), INTENT ( OUT ) :: energy, fscalar - -! Locals - REAL ( dbl ) :: dij - -!------------------------------------------------------------------------------ - - dij = SQRT ( DOT_PRODUCT ( rij, rij ) ) - energy = 0.5_dbl * k * ( dij - r0 ) ** 2 - fscalar = k * ( dij - r0 ) / dij - -END SUBROUTINE force_bonds - -!****************************************************************************** - -SUBROUTINE force_bends ( b12, b32, d12, d32, id12, id32, dist, & - theta, theta0, k, g1, g2, g3, energy, fscalar ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: b12, b32 - REAL ( dbl ), INTENT ( OUT ), DIMENSION ( : ) :: g1, g2, g3 - REAL ( dbl ), INTENT ( IN ) :: d12, d32, id12, id32, dist, theta - REAL ( dbl ), INTENT ( IN ) :: theta0, k - REAL ( dbl ), INTENT ( OUT ) :: fscalar, energy - -! Locals - REAL ( dbl ) :: denom - -!------------------------------------------------------------------------------ - -! define denom - denom = id12*id12*id32*id32 - -! compute energy - energy = 0.5_dbl * k * ( theta - theta0 ) ** 2 - -! compute fscalar - fscalar = k*(theta-theta0)/sin(theta) - -! compute the gradients - g1 = (b32*d12*d32-dist*d32*id12*b12)*denom - g2 = (-(b12+b32)*d12*d32+dist*(d32*id12*b12+id32*d12*b32))*denom - g3 = (b12*d12*d32-dist*id32*d12*b32)*denom - -END SUBROUTINE force_bends - -!****************************************************************************** - -SUBROUTINE force_torsions - IMPLICIT NONE - - STOP 1991 -END SUBROUTINE force_torsions - -!****************************************************************************** - -SUBROUTINE get_pv_bond(f1,f2,r1,r2,pvbond) - IMPLICIT NONE - REAL ( dbl ), DIMENSION (3), INTENT ( IN ) :: f1, f2, r1, r2 - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: pvbond - -!------------------------------------------------------------------------------ - -! p(1,1) - pvbond(1,1) = pvbond(1,1) + f1(1)*r1(1) - pvbond(1,1) = pvbond(1,1) + f2(1)*r2(1) -! p(1,2) - pvbond(1,2) = pvbond(1,2) + f1(1)*r1(2) - pvbond(1,2) = pvbond(1,2) + f2(1)*r2(2) -! p(1,3) - pvbond(1,3) = pvbond(1,3) + f1(1)*r1(3) - pvbond(1,3) = pvbond(1,3) + f2(1)*r2(3) -! p(2,1) - pvbond(2,1) = pvbond(2,1) + f1(2)*r1(1) - pvbond(2,1) = pvbond(2,1) + f2(2)*r2(1) -! p(2,2) - pvbond(2,2) = pvbond(2,2) + f1(2)*r1(2) - pvbond(2,2) = pvbond(2,2) + f2(2)*r2(2) -! p(2,3) - pvbond(2,3) = pvbond(2,3) + f1(2)*r1(3) - pvbond(2,3) = pvbond(2,3) + f2(2)*r2(3) -! p(3,1) - pvbond(3,1) = pvbond(3,1) + f1(3)*r1(1) - pvbond(3,1) = pvbond(3,1) + f2(3)*r2(1) -! p(3,2) - pvbond(3,2) = pvbond(3,2) + f1(3)*r1(2) - pvbond(3,2) = pvbond(3,2) + f2(3)*r2(2) -! p(3,3) - pvbond(3,3) = pvbond(3,3) + f1(3)*r1(3) - pvbond(3,3) = pvbond(3,3) + f2(3)*r2(3) - -END SUBROUTINE get_pv_bond - -!****************************************************************************** - -SUBROUTINE get_pv_bend(f1,f2,f3,r1,r2,r3,pvbend) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION (3), INTENT ( IN ) :: f1, f2, f3, r1, r2, r3 - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: pvbend - -!------------------------------------------------------------------------------ - -!p(1,1) - pvbend(1,1) = pvbend(1,1) + f1(1)*r1(1) - pvbend(1,1) = pvbend(1,1) + f2(1)*r2(1) - pvbend(1,1) = pvbend(1,1) + f3(1)*r3(1) -!p(1,2) - pvbend(1,2) = pvbend(1,2) + f1(1)*r1(2) - pvbend(1,2) = pvbend(1,2) + f2(1)*r2(2) - pvbend(1,2) = pvbend(1,2) + f3(1)*r3(2) -!p(1,3) - pvbend(1,3) = pvbend(1,3) + f1(1)*r1(3) - pvbend(1,3) = pvbend(1,3) + f2(1)*r2(3) - pvbend(1,3) = pvbend(1,3) + f3(1)*r3(3) -!p(2,1) - pvbend(2,1) = pvbend(2,1) + f1(2)*r1(1) - pvbend(2,1) = pvbend(2,1) + f2(2)*r2(1) - pvbend(2,1) = pvbend(2,1) + f3(2)*r3(1) -!p(2,2) - pvbend(2,2) = pvbend(2,2) + f1(2)*r1(2) - pvbend(2,2) = pvbend(2,2) + f2(2)*r2(2) - pvbend(2,2) = pvbend(2,2) + f3(2)*r3(2) -!p(2,3) - pvbend(2,3) = pvbend(2,3) + f1(2)*r1(3) - pvbend(2,3) = pvbend(2,3) + f2(2)*r2(3) - pvbend(2,3) = pvbend(2,3) + f3(2)*r3(3) -!p(3,1) - pvbend(3,1) = pvbend(3,1) + f1(3)*r1(1) - pvbend(3,1) = pvbend(3,1) + f2(3)*r2(1) - pvbend(3,1) = pvbend(3,1) + f3(3)*r3(1) -!p(3,2) - pvbend(3,2) = pvbend(3,2) + f1(3)*r1(2) - pvbend(3,2) = pvbend(3,2) + f2(3)*r2(2) - pvbend(3,2) = pvbend(3,2) + f3(3)*r3(2) -!p(3,3) - pvbend(3,3) = pvbend(3,3) + f1(3)*r1(3) - pvbend(3,3) = pvbend(3,3) + f2(3)*r2(3) - pvbend(3,3) = pvbend(3,3) + f3(3)*r3(3) - -END SUBROUTINE get_pv_bend - -!****************************************************************************** - -SUBROUTINE get_pv_torsion() - IMPLICIT NONE - - STOP 1990 -END SUBROUTINE get_pv_torsion - -!****************************************************************************** - -END MODULE mol_force diff --git a/src/molecule.h b/src/molecule.h deleted file mode 100644 index 14db731..0000000 --- a/src/molecule.h +++ /dev/null @@ -1,165 +0,0 @@ -#ifndef _MOLECULE_H -#define _MOLECULE_H - -#include "particle.h" -#include "linklist.h" - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct linklist_images { - double vec[3]; - linklist_images *next; - } linklist_images; - - typedef struct linklist_exclusion { - particle_type *p; - linklist_exclusion *next; - } linklist_exclusion; - - typedef struct localization_list { - bool all; - int nloc; - int *atomlist; - } localization_list; - - typedef struct linklist_neighbor { - particle_type *p; - linklist_images *image; - int index, nimages; - linklist_neighbor *next; - } linklist_neighbor; - - typedef struct particle_node_type { - particle_type *p; - int in_mol, iat_in_mol; - int nneighbor, nexcl, nsneighbor; - linklist_neighbor *nl; - linklist_neighbor *sl; - linklist_exclusion *ex; - localization_list *llist; - } particle_node_type; - - typedef struct linklist_atoms { - particle_node_type *part; - linklist_atoms *next; - } linklist_atoms; - - typedef struct bond_parameters_type { - char type[21]; - double r0, k; - } bond_parameters_type; - - typedef struct linklist_bonds { - particle_type *p1, *p2; - bond_parameters_type *bond_param; - linklist_bonds *next; - int index[2]; - } linklist_bonds; - - typedef struct bend_parameters_type { - char type[21]; - double theta0, k; - } bend_parameters_type; - - typedef struct linklist_bends { - particle_type *p1, *p2, *p3; - bend_parameters_type *bend_param; - linklist_bends *next; - int index[3]; - } linklist_bends; - - typedef struct torsion_parameters_type { - char type[21]; - double parm[7]; - } torsion_parameters_type; - - typedef struct linklist_torsions { - particle_type *p1, *p2, *p3, *p4; - torsion_parameters_type *torsion_param; - linklist_torsions *next; - int index[4]; - } linklist_torsions; - - typedef struct linklist_dist_constraints { - particle_type *p1, *p2; - double *distance; - double del_lam, lambda, sigma; - double rold1[3], rold2[3], fc[3]; - double scale, scale_old; - linklist_dist_constraints *next; - } linklist_dist_constraints; - - typedef struct linklist_g3x3_constraints { - particle_type *p1, *p2, *p3; - double *d12, *d13, *d23; - double fc1[3], fc2[3], fc3[3]; - double lambda[3], del_lam[3]; - double rold1[3], rold2[3], rold3[3]; - double vold1[3], vold2[3], vold3[3]; - double v1[3], v2[3], v3[3]; - double scale, scale_old; - linklist_g3x3_constraints *next; - } linklist_g3x3_constraints; - - typedef struct intra_parameters_type { - bond_parameters_type **bond_param; - bend_parameters_type ***bend_param; - torsion_parameters_type ***torsion_param; - double **constraint_distance; - } intra_parameters_type; - - typedef struct molecule_parameter_type { - char name[21]; - int natom; - int natom_type; - char *aname[21]; - char *alabel[21]; - double *aweight; - double *acharge; - int nbonds; - int **bonds; - int nbends; - int **bends; - int ntorsions ; - int **torsions; - int ndcon ; - int **ndc; - int n3x3con; - int **n3x3c; - } molecule_parameter_type; - - typedef struct molecule_type { - char file_name[21]; - int num_mol; - char nhcopt[21]; - molecule_parameter_type molpar; - } molecule_type; - - typedef struct molecule_structure_type { - char mol_name[31]; // name of molecule - int moltype; // pointer to molecular type - int imol; // position counter - int atombase; // position counter of first atom in molecule - int natoms_mol; // # of atoms in molecule - int nvt_num; // thermostat number that it is connected. - // Used for constraints - linklist_atoms *ll_atoms; - int nbonds_mol; // # of bonds in molecule - linklist_bonds *ll_bonds; - int nbends_mol; // # of bends in molecule - linklist_bends *ll_bends; - int ntorsions_mol; // # of torsions in molecule - linklist_torsions *ll_torsions; - int ndistconst_mol; // # of distance constraints in molecule - linklist_dist_constraints *ll_dist_const; - int ng3x3const_mol; // # of 3x3 group constraints in molecule - linklist_g3x3_constraints *ll_g3x3_const; - } molecule_structure_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/molecule_input.c b/src/molecule_input.c deleted file mode 100644 index 3dfa995..0000000 --- a/src/molecule_input.c +++ /dev/null @@ -1,615 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE molecule_input - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi, zero - USE molecule_types, ONLY : molecule_type - USE mp, ONLY : mp_bcast - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int, stop_parser - USE stop_program, ONLY : stop_prg, stop_memory - USE string_utilities, ONLY : uppercase, xstring, str_search, & - str_comp, make_tuple - - IMPLICIT NONE - - PRIVATE - PUBLIC :: read_setup_section, read_molecule_section, charge, multiplicity - -!!total charge of the system - - REAL ( dbl ) :: charge - -!!multiplicity of the system - - INTEGER :: multiplicity - -CONTAINS - -!!>---------------------------------------------------------------------------! -!! SECTION: &setup ... &end ! -!! ! -!! charge charge ! -!! multiplicity multiplicity ! -!! moltype nmol_types ! -!! molecule ! -!! name molname ! -!! nummol nmol ! -!! nhcopt [molecule,global,massive,...] ! -!! end molecule ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_setup_section ( mol_setup, set_fn, globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_type ), DIMENSION ( : ), POINTER :: mol_setup - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - INTEGER :: ierror, ilen, iw, source, group, icount, nmol_type, ios, i - CHARACTER ( LEN = 20 ) :: string, string2 - CHARACTER ( LEN = 6 ) :: label - -!------------------------------------------------------------------------------ - - charge = 0.0_dbl - multiplicity = 0 - iw = globenv % scr - icount = 0 - -!..parse the input section - label = '&SETUP' - CALL parser_init ( set_fn, label, ierror, globenv ) - IF ( ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( A )' ) ' No input section &SETUP found on file ' - WRITE ( iw, '( T2, A )' ) set_fn - END IF - CALL stop_parser ( 'read_setup_section', '&SETUP' ) - ELSE - CALL read_line - DO WHILE ( test_next() /= 'X' ) - ilen = 8 - CALL cfield ( string, ilen ) - CALL uppercase ( string ) - SELECT CASE (string) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_setup_section','unknown option') - CASE ( 'CHARGE') - charge = get_real() - CASE ( 'MULTIPLI') - multiplicity = get_int() - CASE ( 'MOLTYPE') - nmol_type = get_int() - ALLOCATE (mol_setup(nmol_type ),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'read_setup_section', & - 'mol_setup', nmol_type ) - CASE ( 'MOLECULE') - IF ( .NOT. ASSOCIATED ( mol_setup ) ) & - CALL stop_prg ( 'read_setup_section', & - 'number of molecule types not yet specified') - icount = icount + 1 - IF (icount>nmol_type ) CALL stop_prg ( 'read_setup_section', & - 'too many molecule types specified') - DO - CALL read_line - ilen = 6 - CALL cfield ( string2, ilen ) - CALL uppercase ( string2 ) - SELECT CASE ( string2 ) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_setup_section','unknown option') - CASE ( 'NAME') - ilen = 0 - CALL cfield(mol_setup(icount) % molpar % name,ilen) - CASE ( 'NUMMOL') - mol_setup(icount) % num_mol = get_int() - CASE ( 'NHCOPT') - ilen = 0 - CALL cfield(mol_setup(icount) % nhcopt,ilen) - CALL uppercase(mol_setup(icount) % nhcopt) - CASE ( 'END') - ilen = 8 - CALL cfield(string2,ilen) - EXIT - END SELECT - END DO - END SELECT - CALL read_line - END DO - END IF - CALL parser_end - -!..write some information to output - IF ( globenv % ionode ) THEN - IF (globenv%print_level>=0) THEN - WRITE ( iw, '( A,T71,F10.4 )' ) ' MOLECULE| Total charge of system ', & - charge - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Multiplicity of system ', & - multiplicity - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of molecule types ', & - nmol_type - WRITE ( iw, '( A,T25,A,T50,A,T69,A )' ) ' MOLECULE| Molecule type', & - ' Molecule name ', 'Molecules', ' Nose option' - DO i = 1, nmol_type - WRITE ( iw, '( A,I6,T19,A,T50,I6,T61,A )' ) ' MOLECULE| ', i, & - ADJUSTR ( mol_setup(i) % molpar % name), & - mol_setup(i) % num_mol, & - ADJUSTR ( mol_setup(i) % nhcopt) - END DO - WRITE ( iw, '()' ) - END IF - END IF - -END SUBROUTINE read_setup_section - -!****************************************************************************** - -!!>---------------------------------------------------------------------------! -!! SECTION: &molecule ... &end ! -!! ! -!! moleculename ! -!! numat n ! -!! atom name label mass charge ! -!! bonds nbonds ! -!! bends nbends ! -!! torsion ntorsion ! -!! distcon ndcon ! -!! 3x3con n3x3con ! -!! basis name library nmax epsilon ! -!! drho name library nmax epsilon ! -!! end moleculename ! -!! ! -!!<---------------------------------------------------------------------------! - -SUBROUTINE read_molecule_section ( mol_setup, set_fn, globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( INOUT ) :: mol_setup - CHARACTER ( LEN = * ), INTENT ( IN ) :: set_fn - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - INTEGER :: ierror, ilen, iw, source, group, icount, nmol_type, ios - INTEGER :: i, j, imol, na, nat, j1, j2, nf, nt, ie, ia, i1, i2, i3, i4 - INTEGER :: isos, nbasis, ndrho, allgrp - CHARACTER ( LEN = 20 ) :: libstring, string, string2, at1, at2, at3, at4 - CHARACTER ( LEN = 6 ) :: label - CHARACTER ( LEN = 20 ), DIMENSION ( : ), ALLOCATABLE :: molname - CHARACTER ( LEN = 20 ), DIMENSION ( : ), ALLOCATABLE :: tuple - CHARACTER ( LEN = 80 ) :: bl = ' ' - -!------------------------------------------------------------------------------ - - nmol_type = SIZE ( mol_setup ) - - iw = globenv % scr - ALLOCATE ( molname ( nmol_type ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'molname', nmol_type ) - DO i = 1, nmol_type - molname(i) = mol_setup(i) %molpar%name - END DO - -!..parse the input section - label = '&MOLEC' - CALL parser_init(set_fn,label,ierror,globenv) - IF (ierror /= 0 ) THEN - IF ( globenv % ionode ) THEN - WRITE ( iw, '( A )' ) ' No input section &MOLECULE found on file ' - WRITE ( iw, '( T2, A )' ) set_fn - END IF - CALL stop_parser ( 'read_molecule_section', '&MOLEC' ) - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 8 - CALL cfield(string,ilen) - imol = str_search(molname,nmol_type,string) - nat = -1 - IF (imol>0) THEN - mol_setup(imol) %molpar%natom_type = 0 - mol_setup(imol) %molpar%nbonds = 0 - mol_setup(imol) %molpar%nbends = 0 - mol_setup(imol) %molpar%ntorsions = 0 - mol_setup(imol) %molpar%ndcon = 0 - mol_setup(imol) %molpar%n3x3con = 0 - - DO - CALL read_line - ilen = 6 - CALL cfield(string2,ilen) - CALL uppercase ( string2 ) - - SELECT CASE (string2) - CASE DEFAULT - CALL p_error() - CALL stop_parser ( 'read_molecule_section','unknown option') - - CASE ( 'NUMAT') - na = get_int() - mol_setup(imol) %molpar%natom = na - ALLOCATE (mol_setup(imol)%molpar%aname(na),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'aname', na ) - ALLOCATE (mol_setup(imol)%molpar%alabel(na),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'alabel', na ) - ALLOCATE (mol_setup(imol)%molpar%aweight(na),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'aweight', na ) - ALLOCATE (mol_setup(imol)%molpar%acharge(na),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'acharge', na ) - nat = 0 - - CASE ( 'ATOM' ) - IF ( nat < 0 ) CALL stop_parser ( 'read_molecule_section', & - 'aweight' ) !TMPTMPTMP - nat = nat + 1 - ilen = 0 - CALL cfield(mol_setup(imol)%molpar%aname(nat),ilen) - ilen = 0 - CALL cfield(mol_setup(imol)%molpar%alabel(nat),ilen) - mol_setup(imol) %molpar%aweight(nat) = get_real() - mol_setup(imol) %molpar%acharge(nat) = get_real() - - CASE ( 'BONDS') - mol_setup(imol) %molpar%nbonds = get_int() - na = mol_setup(imol) %molpar%nbonds - IF (na>=0) THEN - ALLOCATE (mol_setup(imol)%molpar%bonds(2,na),STAT=ios) - IF (ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'bonds', 2 * na ) - DO i = 1, na - ilen = 0 - CALL cfield(at1,ilen) - i1 = str_search ( & - mol_setup ( imol ) % molpar % alabel, nat, at1 ) - IF ( i1 == 0 ) & - CALL stop_parser ( 'read_molecule_section', & - 'atom label in bonds not found' ) - - ilen = 0 - CALL cfield(at2,ilen) - i2 = str_search ( & - mol_setup ( imol ) % molpar % alabel, nat, at2 ) - IF ( i2 == 0 ) & - CALL stop_parser ( 'read_molecule_section', & - 'atom label in bonds not found' ) - mol_setup(imol) %molpar%bonds(1,i) = i1 - mol_setup(imol) %molpar%bonds(2,i) = i2 - END DO - END IF - - CASE ( 'BENDS') - mol_setup(imol) %molpar%nbends = get_int() - na = mol_setup(imol) %molpar%nbends - IF (na>=0) THEN - ALLOCATE (mol_setup(imol)%molpar%bends(3,na),STAT=ios) - IF (ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'bends', 3 * na ) - DO i = 1, na - ilen = 0 - CALL cfield(at1,ilen) - i1 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at1) - IF ( i1 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in bends not found' ) - ilen = 0 - CALL cfield(at2,ilen) - i2 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at2) - IF ( i2 == 0 ) & - CALL stop_parser ( 'read_molecule_section', & - 'atom label in bends not found' ) - ilen = 0 - CALL cfield(at3,ilen) - i3 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at3) - IF ( i3 == 0 ) & - CALL stop_parser ( 'read_molecule_section', & - 'atom label in bends not found' ) - mol_setup(imol) %molpar%bends(1,i) = i1 - mol_setup(imol) %molpar%bends(2,i) = i2 - mol_setup(imol) %molpar%bends(3,i) = i3 - END DO - END IF - - CASE ( 'TORSIO') - mol_setup(imol) %molpar%ntorsions = get_int() - na = mol_setup(imol) %molpar%ntorsions - IF (na>=0) THEN - ALLOCATE ( & - mol_setup ( imol ) % molpar % torsions ( 4, na ), & - STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'torsions', 4 * na ) - DO i = 1, na - ilen = 0 - CALL cfield(at1,ilen) - i1 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at1) - IF ( i1 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in torsions not found' ) - ilen = 0 - CALL cfield(at2,ilen) - i2 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at2) - IF ( i2 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in torsions not found' ) - ilen = 0 - CALL cfield(at3,ilen) - i3 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at3) - IF ( i3 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in torsions not found' ) - ilen = 0 - CALL cfield(at4,ilen) - i4 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at4) - IF ( i4 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in torsions not found' ) - mol_setup(imol) %molpar%torsions(1,i) = i1 - mol_setup(imol) %molpar%torsions(2,i) = i2 - mol_setup(imol) %molpar%torsions(3,i) = i3 - mol_setup(imol) %molpar%torsions(4,i) = i4 - END DO - END IF - - CASE ( 'DISTCO') - mol_setup(imol) %molpar%ndcon = get_int() - na = mol_setup(imol) %molpar%ndcon - IF (na>=0) THEN - ALLOCATE (mol_setup(imol)%molpar%ndc(2,na),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'ndc', 2 * na ) - DO i = 1, na - ilen = 0 - CALL cfield(at1,ilen) - i1 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at1) - IF ( i1 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in distcons not found' ) - ilen = 0 - CALL cfield(at2,ilen) - i2 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at2) - IF ( i2 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in distcons not found' ) - mol_setup(imol) %molpar%ndc(1,i) = i1 - mol_setup(imol) %molpar%ndc(2,i) = i2 - END DO - END IF - - CASE ( '3X3CON') - mol_setup(imol) %molpar%n3x3con = get_int() - na = mol_setup(imol) %molpar%n3x3con - IF (na>=0) THEN - ALLOCATE (mol_setup(imol)%molpar%n3x3c(3,na),STAT=ios) - IF (ios /= 0 ) CALL stop_memory & - ( 'read_molecule_section', 'n3x3c', 3 * na ) - DO i = 1, na - ilen = 0 - CALL cfield(at1,ilen) - i1 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at1) - IF ( i1 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in g3x3con not found' ) - ilen = 0 - CALL cfield(at2,ilen) - i2 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at2) - IF ( i2 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in g3x3con not found' ) - ilen = 0 - CALL cfield(at3,ilen) - i3 = str_search ( & - mol_setup(imol)%molpar%alabel,nat,at3) - IF ( i3 == 0 ) CALL stop_parser & - ( 'read_molecule_section', & - 'atom label in g3x3con not found' ) - mol_setup(imol) %molpar%n3x3c(1,i) = i1 - mol_setup(imol) %molpar%n3x3c(2,i) = i2 - mol_setup(imol) %molpar%n3x3c(3,i) = i3 - END DO - END IF - - CASE ( 'END') - ilen = 0 - CALL cfield(string2,ilen) - EXIT - END SELECT - - END DO - -!..count number of atom types - mol_setup(imol) %molpar%natom_type = 1 - DO i = 2, mol_setup(imol) %molpar%natom - j = str_search ( & - mol_setup ( imol ) % molpar % aname ( 1:i-1 ), i-1, & - mol_setup ( imol ) % molpar % aname ( i ) ) - IF ( j == 0 ) mol_setup ( imol ) % molpar % natom_type & - = mol_setup ( imol ) % molpar % natom_type + 1 - END DO - ELSE - WRITE ( iw, '( A )' ) ' molecule type not found ' - WRITE ( iw, '( T2, A )' ) string - CALL stop_parser ( 'read_molecule_section', ' ' ) - END IF - CALL read_line - END DO - END IF - CALL parser_end - - DEALLOCATE (molname,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', 'molname') - -! ..write some information to output - IF (globenv%ionode) THEN - IF (globenv%print_level>=0) THEN - DO imol = 1, nmol_type - WRITE ( iw, '( A,T61,A )' ) ' MOLECULE| Molecule name ', & - ADJUSTR ( mol_setup(imol)%molpar%name) - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of atoms ', & - mol_setup(imol) %molpar%natom - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of atom types ', & - mol_setup(imol) %molpar%natom_type - WRITE ( iw, '( A,T40,A,T55,A )' ) ' MOLECULE|', 'Atom', & - ' Weight Charge' - DO i = 1, mol_setup(imol) %molpar%natom - CALL xstring(mol_setup(imol)%molpar%aname(i),ia,ie) - WRITE ( iw, '( A,T40,A,T55,F13.5,F13.5 )' ) ' MOLECULE| ', & - mol_setup(imol) %molpar%aname(i) (ia:ie), & - mol_setup(imol) %molpar%aweight(i), & - mol_setup(imol) %molpar%acharge(i) - END DO - - na = mol_setup(imol) %molpar%nbonds - IF (na>0) THEN - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of bonds ', & - mol_setup(imol) %molpar%nbonds - ALLOCATE ( tuple ( na ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple', na ) - CALL make_tuple(mol_setup(imol)%molpar%bonds,2,na,tuple) - CALL xstring(tuple(1),ia,ie) - ilen = ie - ia + 1 - nt = 69/ilen - DO i = 1, na, nt - j1 = i - j2 = min(j1+nt-1,na) - nf = 69 - ilen*(j2-j1+1) - WRITE ( iw, '( 80(A) )' ) ' MOLECULE| ', bl(1:nf), & - (tuple(j)(ia:ie),j=j1,j2) - END DO - DEALLOCATE (tuple,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple' ) - END IF - - na = mol_setup(imol) %molpar%nbends - IF (na>0) THEN - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of bends ', & - mol_setup(imol) %molpar%nbends - ALLOCATE (tuple(na),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple', na ) - CALL make_tuple(mol_setup(imol)%molpar%bends,3,na,tuple) - CALL xstring(tuple(1),ia,ie) - ilen = ie - ia + 1 - nt = 69/ilen - DO i = 1, na, nt - j1 = i - j2 = min(j1+nt-1,na) - nf = 69 - ilen*(j2-j1+1) - WRITE ( iw, '( 80(A) )' ) ' MOLECULE| ', bl(1:nf), & - (tuple(j)(ia:ie),j=j1,j2) - END DO - DEALLOCATE (tuple,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple') - END IF - - na = mol_setup(imol) %molpar%ntorsions - IF (na>0) THEN - WRITE ( iw, '( A,T71,I10 )' ) ' MOLECULE| Number of torsions ', & - mol_setup(imol) %molpar%ntorsions - ALLOCATE (tuple(na),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple', na ) - CALL make_tuple(mol_setup(imol)%molpar%torsions,4,na,tuple) - CALL xstring(tuple(1),ia,ie) - ilen = ie - ia + 1 - nt = 69/ilen - DO i = 1, na, nt - j1 = i - j2 = min(j1+nt-1,na) - nf = 69 - ilen*(j2-j1+1) - WRITE ( iw, '( 80(A) )' ) ' MOLECULE| ', bl(1:nf), & - (tuple(j)(ia:ie),j=j1,j2) - END DO - DEALLOCATE (tuple,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple') - END IF - - na = mol_setup(imol) %molpar%ndcon - IF (na>0) THEN - WRITE ( iw, '( A,T71,I10 )' ) & - ' MOLECULE| Number of distance constraints', & - mol_setup(imol) %molpar%ndcon - ALLOCATE (tuple(na),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple', na ) - CALL make_tuple(mol_setup(imol)%molpar%ndc,2,na,tuple) - CALL xstring(tuple(1),ia,ie) - ilen = ie - ia + 1 - nt = 69/ilen - DO i = 1, na, nt - j1 = i - j2 = min(j1+nt-1,na) - nf = 69 - ilen*(j2-j1+1) - WRITE ( iw, '( 80(A) )' ) ' MOLECULE| ', bl(1:nf), & - (tuple(j)(ia:ie),j=j1,j2) - END DO - DEALLOCATE (tuple,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple') - END IF - - na = mol_setup(imol) %molpar%n3x3con - IF (na>0) THEN - WRITE ( iw, '( A,T71,I10 )' ) & - ' MOLECULE| Number of 3x3 constraints', & - mol_setup(imol) %molpar%n3x3con - ALLOCATE (tuple(na),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple', na ) - CALL make_tuple(mol_setup(imol)%molpar%n3x3c,3,na,tuple) - CALL xstring(tuple(1),ia,ie) - ilen = ie - ia + 1 - nt = 69/ilen - DO i = 1, na, nt - j1 = i - j2 = min(j1+nt-1,na) - nf = 69 - ilen*(j2-j1+1) - WRITE ( iw, '( 80(A) )' ) ' MOLECULE| ', bl(1:nf), & - (tuple(j)(ia:ie),j=j1,j2) - END DO - DEALLOCATE (tuple,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'read_molecule_section', & - 'tuple' ) - END IF - WRITE ( iw,'( )' ) - END DO - END IF - END IF - -END SUBROUTINE read_molecule_section - -!****************************************************************************** - -END MODULE molecule_input diff --git a/src/molecule_types.c b/src/molecule_types.c deleted file mode 100644 index ae6f8ff..0000000 --- a/src/molecule_types.c +++ /dev/null @@ -1,173 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE molecule_types - - USE kinds, ONLY : dbl - USE particle_types, ONLY : particle_type, particle_prop_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: molecule_structure_type, linklist_atoms, bond_parameters_type, & - linklist_bonds, bend_parameters_type, linklist_bends, & - torsion_parameters_type, linklist_torsions, linklist_dist_constraints, & - linklist_g3x3_constraints, linklist_neighbor, linklist_exclusion, & - particle_node_type, localization_list, linklist_images - PUBLIC :: particle_type, particle_prop_type - PUBLIC :: molecule_type, molecule_parameter_type - PUBLIC :: intra_parameters_type - - TYPE linklist_images - REAL ( dbl ), DIMENSION(3) :: vec - TYPE (linklist_images), POINTER :: next - END TYPE linklist_images - - TYPE linklist_exclusion - TYPE (particle_type ), POINTER :: p - TYPE (linklist_exclusion), POINTER :: next - END TYPE linklist_exclusion - - TYPE localization_list - LOGICAL :: all - INTEGER :: nloc - INTEGER, DIMENSION ( : ), POINTER :: atomlist - END TYPE localization_list - - TYPE linklist_neighbor - TYPE (particle_type ), POINTER :: p - TYPE (linklist_images), POINTER :: image - INTEGER :: index, nimages - TYPE (linklist_neighbor), POINTER :: next - END TYPE linklist_neighbor - - TYPE particle_node_type - TYPE (particle_type ), POINTER :: p - INTEGER :: in_mol, iat_in_mol - INTEGER :: nneighbor, nexcl, nsneighbor - TYPE (linklist_neighbor), POINTER :: nl - TYPE (linklist_neighbor), POINTER :: sl - TYPE (linklist_exclusion), POINTER :: ex - TYPE (localization_list), POINTER :: llist - END TYPE particle_node_type - - TYPE linklist_atoms - TYPE (particle_node_type ), POINTER :: part - TYPE (linklist_atoms), POINTER :: next - END TYPE linklist_atoms - - TYPE bond_parameters_type - CHARACTER ( LEN = 20 ) :: type - REAL ( dbl ) :: r0, k - END TYPE bond_parameters_type - - TYPE linklist_bonds - TYPE (particle_type ), POINTER :: p1, p2 - TYPE (bond_parameters_type ), POINTER :: bond_param - TYPE (linklist_bonds), POINTER :: next - INTEGER, DIMENSION (2) :: index - END TYPE linklist_bonds - - TYPE bend_parameters_type - CHARACTER ( LEN = 20 ) :: type - REAL ( dbl ) :: theta0, k - END TYPE bend_parameters_type - - TYPE linklist_bends - TYPE (particle_type ), POINTER :: p1, p2, p3 - TYPE (bend_parameters_type ), POINTER :: bend_param - TYPE (linklist_bends), POINTER :: next - INTEGER, DIMENSION (3) :: index - END TYPE linklist_bends - - TYPE torsion_parameters_type - CHARACTER ( LEN = 20 ) :: type - REAL ( dbl ), DIMENSION (0:6) :: parm - END TYPE torsion_parameters_type - - TYPE linklist_torsions - TYPE (particle_type ), POINTER :: p1, p2, p3, p4 - TYPE (torsion_parameters_type ), POINTER :: torsion_param - TYPE (linklist_torsions), POINTER :: next - INTEGER, DIMENSION (4) :: index - END TYPE linklist_torsions - - TYPE linklist_dist_constraints - TYPE (particle_type ), POINTER :: p1, p2 - REAL ( dbl ), POINTER :: distance - REAL ( dbl ) :: del_lam, lambda, sigma - REAL ( dbl ), DIMENSION (3) :: rold1, rold2, fc - REAL ( dbl ) :: scale, scale_old - TYPE (linklist_dist_constraints), POINTER :: next - END TYPE linklist_dist_constraints - - TYPE linklist_g3x3_constraints - TYPE (particle_type ), POINTER :: p1, p2, p3 - REAL ( dbl ), POINTER :: d12, d13, d23 - REAL ( dbl ), DIMENSION(3) :: fc1, fc2, fc3 - REAL ( dbl ), DIMENSION(3) :: lambda, del_lam - REAL ( dbl ), DIMENSION(3) :: rold1, rold2, rold3 - REAL ( dbl ), DIMENSION(3) :: vold1, vold2, vold3 - REAL ( dbl ), DIMENSION(3) :: v1, v2, v3 - REAL ( dbl ) :: scale, scale_old - TYPE (linklist_g3x3_constraints), POINTER :: next - END TYPE linklist_g3x3_constraints - - TYPE intra_parameters_type - TYPE (bond_parameters_type ), POINTER :: bond_param ( :, : ) - TYPE (bend_parameters_type ), POINTER :: bend_param(:,:,:) - TYPE (torsion_parameters_type ), POINTER :: torsion_param(:,:,:,:) - REAL ( dbl ), POINTER :: constraint_distance ( :, : ) - END TYPE intra_parameters_type - - TYPE molecule_parameter_type - CHARACTER ( LEN = 20 ) :: name - INTEGER :: natom - INTEGER :: natom_type - CHARACTER ( LEN = 20 ), POINTER :: aname ( : ) - CHARACTER ( LEN = 20 ), POINTER :: alabel ( : ) - REAL ( dbl ), POINTER :: aweight ( : ) - REAL ( dbl ), POINTER :: acharge ( : ) - INTEGER :: nbonds - INTEGER, POINTER :: bonds ( :, : ) - INTEGER :: nbends - INTEGER, POINTER :: bends ( :, : ) - INTEGER :: ntorsions - INTEGER, POINTER :: torsions ( :, : ) - INTEGER :: ndcon - INTEGER, POINTER :: ndc ( :, : ) - INTEGER :: n3x3con - INTEGER, POINTER :: n3x3c ( :, : ) - END TYPE molecule_parameter_type - - TYPE molecule_type - CHARACTER ( LEN = 20 ) :: file_name - INTEGER :: num_mol - CHARACTER ( LEN = 20 ) :: nhcopt - TYPE ( molecule_parameter_type ) :: molpar - END TYPE molecule_type - - TYPE molecule_structure_type - CHARACTER ( LEN = 30 ) :: mol_name ! name of molecule - INTEGER :: moltype ! pointer to molecular type - INTEGER :: imol ! position counter - INTEGER :: atombase ! position counter of first atom in molecule - INTEGER :: natoms_mol ! # of atoms in molecule - INTEGER :: nvt_num ! thermostat number that it is connected. -! Used for constraints - TYPE (linklist_atoms), POINTER :: ll_atoms - INTEGER :: nbonds_mol ! # of bonds in molecule - TYPE (linklist_bonds), POINTER :: ll_bonds - INTEGER :: nbends_mol ! # of bends in molecule - TYPE (linklist_bends), POINTER :: ll_bends - INTEGER :: ntorsions_mol ! # of torsions in molecule - TYPE (linklist_torsions), POINTER :: ll_torsions - INTEGER :: ndistconst_mol ! # of distance constraints in molecule - TYPE (linklist_dist_constraints), POINTER :: ll_dist_const - INTEGER :: ng3x3const_mol ! # of 3x3 group constraints in molecule - TYPE (linklist_g3x3_constraints), POINTER :: ll_g3x3_const - END TYPE molecule_structure_type - -END MODULE molecule_types diff --git a/src/mp.cpp b/src/mp.cpp deleted file mode 100644 index d1e4b83..0000000 --- a/src/mp.cpp +++ /dev/null @@ -1,512 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include - -void mp_start() { - - int ierr = 0; - #if defined(__parallel) - mpi_init(ierr); - if (ierr != 0) mp_stop(8000); - #endif - -} - -void mp_end() { - - int ierr = 0; - #if defined(__parallel) - mpi_finalize(ierr); - if (ierr != 0) mp_stop(8999); - #endif - -} - -void mp_stop(int code) { - - int numtask, taskid, groupid; - - #if defined(__parallel) - mpi_abort(mpi_comm_world, code); - #endif - - mp_environ(numtask, taskid, groupid); - - std::cout << " CP2K| Stopped by processor number " << taskid; - - std::cout << "mp_stop" << std::endl; - exit(1); -} - -void mp_sync(int group) { - - int ierr = 0; - #if defined(__parallel) - mpi_barrier(group, ierr); - if (ierr != 0) mp_stop(8400); - #endif -} - -void mp_environ(int numtask, int taskid, int groupid) { - - int ierr = 0; - - numtask = 1; - taskid = 0; - groupid = 0; - - #if defined(__parallel) - mpi_comm_rank(mpi_comm_world, taskid, ierr); - if (ierr != 0) mp_stop(8001); - - mpi_comm_size(mpi_comm_world, numtask, ierr); - if (ierr != 0) mp_stop(8002); - groupid = mpi_comm_world; - #endif - -} - -void mp_group(int *group_list, int group_size, int base_group, int *groupid) { - - int base, newgroup, ierr; - - ierr = 0; - *groupid = base_group; - #if defined(__parallel) - mpi_comm_group(base_group, base, ierr); - if (ierr != 0) mp_stop(8010); - - mpi_group_incl(base, group_size, group_list, newgroup, ierr); - if (ierr != 0) mp_stop(8011); - - mpi_comm_create(base_group, newgroup, groupid, ierr); - if (ierr != 0) mp_stop(8012); - #endif - -} - -void mp_cart_create (int comm_old, int ndims, int *dims, int *pos, int *comm_cart ) { - - size_t i; - int ierr, nodes; - bool period[ndims], reorder; - - ierr = 0; - for (i = 0; i < ndims; i++) { - dims[i] = 1; - pos[i] = 1; - } - - comm_cart = comm_old; - #if defined(__parallel) - for (i = 0; i < ndims; i++) { - dims[i] = 0; - } - - mpi_comm_siz ( comm_old, nodes, ierr ); - if ( ierr != 0 ) mp_stop ( 8020 ); - - mpi_dims_create ( nodes, ndims, dims, ierr ); - if ( ierr != 0 ) mp_stop ( 8021 ); - - reorder = true; - period = true; - mpi_cart_create ( comm_old, ndims, dims, period, reorder, comm_cart, ierr ); - if ( ierr != 0 ) mp_stop ( 8022 ); - - mpi_cart_get ( comm_cart, ndims, dims, period, pos, ierr ); - IF ( ierr != 0 ) mp_stop ( 8023 ); - #endif - -} - -!..mp_bcast -SUBROUTINE mp_bcast_i1(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = 1 -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_integer,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8101) -#endif -END SUBROUTINE mp_bcast_i1 -SUBROUTINE mp_bcast_iv(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg ( : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_integer,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8102) -#endif -END SUBROUTINE mp_bcast_iv -SUBROUTINE mp_bcast_im(msg,source,gid) - IMPLICIT NONE - INTEGER :: msg ( :, : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_integer,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8102) -#endif -END SUBROUTINE mp_bcast_im -SUBROUTINE mp_bcast_r1(msg,source,gid) - IMPLICIT NONE - REAL ( dbl ) :: msg - INTEGER :: msglen, source, gid - INTEGER :: ierr - - ierr = 0 - msglen = 1 -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_precision,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8111) -#endif -END SUBROUTINE mp_bcast_r1 -SUBROUTINE mp_bcast_rv(msg,source,gid) - IMPLICIT NONE - REAL ( dbl ) :: msg ( : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_precision,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8112) -#endif -END SUBROUTINE mp_bcast_rv -SUBROUTINE mp_bcast_rm(msg,source,gid) - IMPLICIT NONE - REAL ( dbl ) :: msg ( :, : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_precision,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8113) -#endif -END SUBROUTINE mp_bcast_rm -SUBROUTINE mp_bcast_c1(msg,source,gid) - IMPLICIT NONE - COMPLEX ( dbl ) :: msg - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = 1 -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_complex,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8121) -#endif -END SUBROUTINE mp_bcast_c1 -SUBROUTINE mp_bcast_cv(msg,source,gid) - IMPLICIT NONE - COMPLEX ( dbl ) :: msg ( : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_complex,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8122) -#endif -END SUBROUTINE mp_bcast_cv -SUBROUTINE mp_bcast_cm(msg,source,gid) - IMPLICIT NONE - COMPLEX ( dbl ) :: msg ( :, : ) - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = size(msg) -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_double_complex,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8123) -#endif -END SUBROUTINE mp_bcast_cm -SUBROUTINE mp_bcast_l(msg,source,gid) - IMPLICIT NONE - LOGICAL :: msg - INTEGER :: source, gid - INTEGER :: msglen, ierr - - ierr = 0 - msglen = 1 -#if defined(__parallel) - CALL mpi_bcast(msg,msglen,mpi_logical,source,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8130) -#endif -END SUBROUTINE mp_bcast_l -SUBROUTINE mp_bcast_z(msg,source,gid) - IMPLICIT NONE - CHARACTER ( LEN = * ) :: msg - INTEGER :: source, gid - INTEGER :: msglen, ierr, i - INTEGER, ALLOCATABLE :: imsg ( : ) - - ierr = 0 - msglen = len(msg) -#if defined(__parallel) -! this is a workaround to avoid problems on the T3E -! at the moment we have a data alignment error when trying to -! broadcats characters on the T3E (not always!) -! JH 19/3/99 on galileo -! CALL mpi_bcast(msg,msglen,mpi_character,source,gid,ierr) - ALLOCATE (imsg(1:msglen)) - DO i = 1, msglen - imsg(i) = ichar(msg(i:i)) - END DO - CALL mpi_bcast(imsg,msglen,mpi_integer,source,gid,ierr) - DO i = 1, msglen - msg(i:i) = char(imsg(i)) - END DO - DEALLOCATE (imsg) - IF ( ierr /= 0 ) CALL mp_stop(8140) -#endif -END SUBROUTINE mp_bcast_z - -!****************************************************************************** - -!..mp_sum -SUBROUTINE mp_sum_i1(msg,gid) - IMPLICIT NONE - INTEGER, INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, res, ierr - - msglen = 1 -#if defined(__parallel) - CALL mpi_allreduce(msg,res,msglen,mpi_integer,mpi_sum,gid,ierr) - msg = res - IF ( ierr /= 0 ) CALL mp_stop(8200) -#endif -END SUBROUTINE mp_sum_i1 -SUBROUTINE mp_sum_iv(msg,gid) - IMPLICIT NONE - INTEGER, INTENT ( INOUT ) :: msg ( : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - INTEGER, ALLOCATABLE :: res ( : ) -#if defined(__parallel) - msglen = size(msg) - ALLOCATE (res(1:msglen),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8201) - CALL mpi_allreduce(msg,res,msglen,mpi_integer,mpi_sum,gid,ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8202) -#endif -END SUBROUTINE mp_sum_iv -SUBROUTINE mp_sum_r1(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ) :: res - - msglen = 1 -#if defined(__parallel) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - IF ( ierr /= 0 ) CALL mp_stop(8203) -#endif -END SUBROUTINE mp_sum_r1 -SUBROUTINE mp_sum_rv(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg ( : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ), ALLOCATABLE :: res ( : ) -#if defined(__parallel) - msglen = size(msg) - ALLOCATE (res(1:msglen),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8204) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8205) -#endif -END SUBROUTINE mp_sum_rv -SUBROUTINE mp_sum_rm(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg ( :, : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, m1, m2, ierr - REAL ( dbl ), ALLOCATABLE :: res ( :, : ) -#if defined(__parallel) - msglen = size(msg) - m1 = size(msg(:,1)) - m2 = size(msg(1,:)) - ALLOCATE (res(m1,m2),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8204) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8205) -#endif -END SUBROUTINE mp_sum_rm -SUBROUTINE mp_sum_c1(msg,gid) - IMPLICIT NONE - COMPLEX ( dbl ), INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - COMPLEX ( dbl ) :: res - - msglen = 2 -#if defined(__parallel) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - IF ( ierr /= 0 ) CALL mp_stop(8205) -#endif -END SUBROUTINE mp_sum_c1 -SUBROUTINE mp_sum_cv(msg,gid) - IMPLICIT NONE - COMPLEX ( dbl ), INTENT ( INOUT ) :: msg ( : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - COMPLEX ( dbl ), ALLOCATABLE :: res ( : ) -#if defined(__parallel) - msglen = size(msg) - ALLOCATE (res(1:msglen),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8206) - CALL mpi_allreduce(msg,res,2*msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8207) -#endif -END SUBROUTINE mp_sum_cv -SUBROUTINE mp_sum_cm(msg,gid) - IMPLICIT NONE - COMPLEX ( dbl ), INTENT ( INOUT ) :: msg ( :, : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, m1, m2, ierr - COMPLEX ( dbl ), ALLOCATABLE :: res ( :, : ) -#if defined(__parallel) - msglen = 2*size(msg) - m1 = size(msg(:,1)) - m2 = size(msg(1,:)) - ALLOCATE (res(m1,m2),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8204) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_sum,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8208) -#endif -END SUBROUTINE mp_sum_cm - -!****************************************************************************** - -SUBROUTINE mp_max_i(msg,gid) - IMPLICIT NONE - INTEGER, INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - INTEGER :: res -#if defined(__parallel) - msglen = 1 - CALL mpi_allreduce(msg,res,msglen,mpi_integer,mpi_max,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8300) - msg = res -#endif -END SUBROUTINE mp_max_i -SUBROUTINE mp_max_r(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ) :: res -#if defined(__parallel) - msglen = 1 - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_max,gid, & - ierr) - IF ( ierr /= 0 ) CALL mp_stop(8301) - msg = res -#endif -END SUBROUTINE mp_max_r -SUBROUTINE mp_max_rv(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg ( : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ), ALLOCATABLE :: res ( : ) -#if defined(__parallel) - msglen = size(msg) - ALLOCATE (res(1:msglen),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8302) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_max,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8303) -#endif -END SUBROUTINE mp_max_rv - -!****************************************************************************** - -SUBROUTINE mp_min_i(msg,gid) - IMPLICIT NONE - INTEGER, INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - INTEGER :: res -#if defined(__parallel) - msglen = 1 - CALL mpi_allreduce(msg,res,msglen,mpi_integer,mpi_min,gid,ierr) - IF ( ierr /= 0 ) CALL mp_stop(8310) - msg = res -#endif -END SUBROUTINE mp_min_i -SUBROUTINE mp_min_r(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ) :: res -#if defined(__parallel) - msglen = 1 - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_min,gid, & - ierr) - IF ( ierr /= 0 ) CALL mp_stop(8311) - msg = res -#endif -END SUBROUTINE mp_min_r -SUBROUTINE mp_min_rv(msg,gid) - IMPLICIT NONE - REAL ( dbl ), INTENT ( INOUT ) :: msg ( : ) - INTEGER, INTENT ( IN ) :: gid - INTEGER :: msglen, ierr - REAL ( dbl ), ALLOCATABLE :: res ( : ) -#if defined(__parallel) - msglen = size(msg) - ALLOCATE (res(1:msglen),STAT=ierr) - IF ( ierr /= 0 ) CALL mp_stop(8312) - CALL mpi_allreduce(msg,res,msglen,mpi_double_precision,mpi_min,gid, & - ierr) - msg = res - DEALLOCATE (res) - IF ( ierr /= 0 ) CALL mp_stop(8313) -#endif -END SUBROUTINE mp_min_rv \ No newline at end of file diff --git a/src/nhc.c b/src/nhc.c deleted file mode 100644 index 04d3e6b..0000000 --- a/src/nhc.c +++ /dev/null @@ -1,651 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE nhc - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : simulation_parameters_type - USE molecule_types, ONLY : molecule_structure_type, molecule_type - USE mp, ONLY : mp_sum - USE nose, ONLY : extended_parameters_type, yoshida_coef - USE util, ONLY : get_share - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: nhc_control - - REAL ( dbl ), TARGET :: scale - -CONTAINS - -!****************************************************************************** - -! creates the thermostatting maps use global_mod - -SUBROUTINE nhc_control ( simpar, molecule, mol_setup, nhcp, globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( simulation_parameters_type ), INTENT ( INOUT ) :: simpar - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( molecule_type ), DIMENSION ( : ), INTENT ( INOUT ) :: mol_setup - TYPE ( extended_parameters_type ), INTENT ( OUT ) :: nhcp - TYPE ( global_environment_type ), INTENT ( IN ) :: globenv - -! Locals - CHARACTER ( LEN = 20 ) :: opt - INTEGER :: i, j, k, nmol_type, number, iw, natoms, sum - INTEGER :: const_per_molecule, nmol - INTEGER :: atm_offset, mol_offset, start, finish, iconst, iglobal - INTEGER :: icust, ii, jj, kk, ieq, isos - INTEGER, DIMENSION ( : ), ALLOCATABLE :: mnum, tnum, deg_of_freedom - INTEGER, DIMENSION ( : ), ALLOCATABLE :: const_mol, tot_const - INTEGER, DIMENSION ( : ), ALLOCATABLE :: natoms_mol, mol_off - INTEGER, DIMENSION ( :, : ), ALLOCATABLE :: point - LOGICAL :: match, noneflag, nointer - -!------------------------------------------------------------------------------ - - iw = globenv % scr - - nhcp%nyosh = simpar%nyosh - nhcp%nc = simpar%nc - nhcp%nhc_len = simpar%nhclen - -! allocating the temporary arrays mnum and tnum, and nfree - nmol_type = size(mol_setup) - nmol = size(molecule) - ALLOCATE (mnum(nmol_type ),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'mnum', nmol_type ) - ALLOCATE (tnum(nmol_type ),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'tnum', nmol_type ) - ALLOCATE (const_mol(nmol),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'const_mol', nmol ) - ALLOCATE (tot_const(nmol),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'tot_const', nmol ) - ALLOCATE (natoms_mol(nmol),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'natoms_mol', nmol ) - ALLOCATE (point(2,nmol),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control','point', 2 * nmol ) - ALLOCATE (mol_off(nmol_type+1),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control','mol_off', nmol_type + 1 ) - -! Counting the total number of thermostats - number = 0 - match = .FALSE. - noneflag = .FALSE. - nointer = .TRUE. - -! 1) count the 'global' -! (In principle, every moleule type can have GLOBAL but -! there is only ONE thermostat. So, only count it once) - DO i = 1, nmol_type - IF ((mol_setup(i)%nhcopt=="GLOBAL") .AND. ( .NOT. match)) THEN - number = number + 1 - match = .TRUE. - nointer = .FALSE. - END IF - END DO - -! 2) count the user defined options - DO i = 1, nmol_type - opt = mol_setup(i) %nhcopt - IF ((opt/="GLOBAL") .AND. (opt/="MASSIVE") .AND. & - (opt/="MOLECULE") .AND. (opt/="NONE")) THEN -! checking to see if 2 or more molecules are on the same user -! defined thermostat. Again, only one thermostat per -! unique user defined option - match = .FALSE. - CHECK: DO j = 1, i - 1 - IF (opt==mol_setup(j)%nhcopt) THEN - match = .TRUE. - EXIT CHECK - END IF - END DO CHECK - IF ( .NOT. match) number = number + 1 - IF ( .NOT. match) nointer = .FALSE. - END IF - END DO - -! 3) count the 'molecule' - DO i = 1, nmol_type - IF (mol_setup(i)%nhcopt=="MOLECULE") THEN - number = number + mol_setup(i) %num_mol - END IF - END DO - -! 4) count the 'massive' - DO i = 1, nmol_type - IF (mol_setup(i)%nhcopt=="MASSIVE") THEN - number = number + 3*mol_setup(i) %num_mol*mol_setup(i) %molpar%natom - END IF - END DO - IF (number==0) THEN - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) 'PUT THE CRACK PIPE DOWN! THE NUMBER OF NHC = 0.' - WRITE ( iw, '( A )' ) ' USE NVE, MAN!!!' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - CALL stop_prg ( 'nhc_control' ) - END IF - -! -! here we decide on what parallel algorithm to use -! if there are only massive and molecule type thermostats we can use -! a local scheme, in all other cases we assume a coupling of -! degrees of freedom from different processors -! - nhcp%dis_type = 'NONE' - IF (globenv%num_pe>1) THEN - IF (nointer) THEN - -! no interaction between thermostats on different processors - nhcp%dis_type = 'DIS_REP' - -! we only count thermostats on this processor - number = 0 - DO i = 1, size(molecule) - j = molecule(i) %moltype - IF (mol_setup(j)%nhcopt=="MOLECULE") THEN - number = number + 1 - ELSE IF (mol_setup(j)%nhcopt=="MASSIVE") THEN - number = number + 3*mol_setup(j) %molpar%natom - ELSE - CALL stop_prg ( 'nhc_control' ) - END IF - END DO - ELSE -! interaction between thermostats on different processors - nhcp%dis_type = 'INTER_REP' - END IF - END IF - -! some utility arrays for the setup of thermostats -! Define the local variable point(i,j) i=1,2 and j=1->nmol_type. -! This array stores the locations of the first and last atom in -! of a molecule type. It will be used to map a specific atom -! belonging to a molecule onto a thermostat. nconst(j) j=1->nmol_type -! stores the TOTAL number of constraints of each molecule type to -! compute the degrees of freedom. - IF (nhcp%dis_type=='NONE' .OR. nhcp%dis_type=='DIS_REP' ) THEN - atm_offset = 0 - DO i = 1, size(molecule) - j = molecule(i) %moltype - natoms = mol_setup(j) %molpar%natom - natoms_mol(i) = mol_setup(j) %molpar%natom - point(1,i) = atm_offset + 1 - point(2,i) = atm_offset + natoms - const_mol(i) = mol_setup(j) %molpar%ndcon & - + 3*mol_setup(j) %molpar%n3x3con - tot_const(i) = const_mol(i) - atm_offset = point(2,i) - END DO - - ELSE IF (nhcp%dis_type=='INTER_REP' ) THEN - atm_offset = 0 - mol_off = 0 - DO i = 1, nmol_type - natoms = mol_setup(i) %num_mol*mol_setup(i) %molpar%natom - natoms_mol(i) = mol_setup(i) %molpar%natom - point(1,i) = atm_offset + 1 - point(2,i) = atm_offset + natoms_mol(i)*get_share(mol_setup(i)%num_mol, & - globenv%num_pe,globenv%mepos) - const_mol(i) = mol_setup(i) %molpar%ndcon + 3*mol_setup(i) %molpar%n3x3con - tot_const(i) = const_mol(i)*mol_setup(i) %num_mol - atm_offset = point(2,i) - END DO - DO i = 1, nmol_type - mol_off(i+1) = mol_off(i) + get_share(mol_setup(i)%num_mol,globenv%num_pe, & - globenv%mepos) - END DO - END IF - -! count the number of atoms on this processor - natoms = sum(molecule ( : )%natoms_mol) - -! Now we can allocate the target array s_kin and p_kin - SELECT CASE (simpar%ensemble(1:3)) - CASE ( 'NPT' ) - ALLOCATE (deg_of_freedom(number+1),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', & - 'deg_of_freedom', number + 1 ) - CASE DEFAULT - ALLOCATE (deg_of_freedom(number),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', & - 'deg_of_freedom', number ) - END SELECT - - ALLOCATE (nhcp%s_kin(number),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'nhcp%s_kin', number ) - ALLOCATE (nhcp%v_scale(number),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'nhcp%v_scale', number ) - ALLOCATE (nhcp%p_kin(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'nhcp%p_kin', 3 * natoms ) - ALLOCATE (nhcp%p_scale(3,natoms),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', & - 'nhcp%p_scale', 3 * natoms ) - -! Check to see if there is at least one global thermostatting option defined - iglobal = 0 - DO i = 1, nmol_type - IF (mol_setup(i)%nhcopt=="GLOBAL") THEN - iglobal = 1 - EXIT - END IF - END DO - -! initialize variable 'scale' for the 'none' option - scale = 1.0_dbl - -! counter variable number is to determine total number of thermostats -! since the global is ALWAYS on thermostat one, if there is at least -! one GLOBAL option, the counter starts at 1 else, it starts at 0 - IF (iglobal==1) THEN - number = 1 - ELSE - number = 0 - END IF - icust = 0 - -! initialize deg_of_freedom - deg_of_freedom = 0 - IF (nhcp%dis_type=="NONE" .OR. nhcp%dis_type=="DIS_REP") THEN - -! Begin the mapping loop - DO i = 1, size(molecule) - j = molecule(i) %moltype - opt = mol_setup(j) %nhcopt - -! Search for user defined thermostatting options first - IF ((opt/="GLOBAL") .AND. (opt/="MOLECULE") .AND. & - (opt/="MASSIVE") .AND. (opt/="NONE")) THEN - icust = icust + 1 - -! The first user defined option gets thrown on a thermostat, no questions asked - IF (icust==1) THEN - number = number + 1 - -! map the thermostat number to the molecule - molecule(i) %nvt_num = number - -! save the molecule number that is customized - mnum(icust) = i - -! save the thermostat number that is customized - tnum(icust) = number - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(number) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom(number) = deg_of_freedom(number) + tot_const(i) - ELSE - -! if icust > 1 check to see if it is equal to the previous user-defined options - ieq = 0 -! The loop is to icust-1 because we know that it is equal to itself - DO jj = 1, icust - 1 - IF (mol_setup(j)%nhcopt==mol_setup(mnum(jj))%nhcopt) THEN - ieq = jj - EXIT - END IF - END DO - -! if the user defined option found a match, map everything ! -! on the same thermostat - IF (ieq /= 0 ) THEN -! map the thermostat number to the molecule - molecule(i) %nvt_num = tnum(mnum(ieq)) - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(tnum(mnum(ieq))) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(tnum(mnum( & - ieq))) - END DO - END DO - deg_of_freedom(tnum(mnum(ieq))) = deg_of_freedom(tnum(mnum( & - ieq))) + tot_const(i) - -! if the user defined option does not find a match. Map it to a new -! thermostat, no questions asked - ELSE - number = number + 1 - -! map the thermostat number to the molecule - molecule(i) %nvt_num = number - mnum(icust) = i - tnum(icust) = number - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(number) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom ( number ) = deg_of_freedom ( number ) & - + tot_const ( i ) - END IF - END IF - -! doing global thermostat option - ELSE IF (mol_setup(j)%nhcopt=="GLOBAL") THEN -! map the thermostat number to the molecule - molecule(i) %nvt_num = 1 - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(1) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(1) - END DO - END DO - deg_of_freedom(1) = deg_of_freedom(1) + tot_const(i) - -! doing molecular thermostat option - ELSE IF (mol_setup(j)%nhcopt=="MOLECULE") THEN - DO ii = point(1,i), point(2,i), natoms_mol(i) - number = number + 1 - -! map the thermostat number to the molecule - molecule(i) %nvt_num = number - start = ii - finish = ii + molecule(i) %natoms_mol - 1 - DO jj = 1, 3 - DO kk = start, finish - nhcp%p_kin(jj,kk) %point => nhcp%s_kin(number) - nhcp%p_scale(jj,kk) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom(number) = const_mol(j) - END DO - -! doing massive thermostat option - ELSE IF (mol_setup(j)%nhcopt=="MASSIVE") THEN - IF (tot_const(i)>0) THEN - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) & - 'PUT THE CRACK PIPE DOWN! MASSIVE THERMOSTATS WITH' - WRITE ( iw, '( A )' ) & - ' CONSTRAINTS IS NOT POSSIBLE, MAN! ' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - CALL stop_prg ( 'nhc_control' ) - END IF - DO ii = point(1,i), point(2,i) - DO jj = 1, 3 - number = number + 1 - nhcp%p_kin(jj,ii) %point => nhcp%s_kin(number) - nhcp%p_scale(jj,ii) %point => nhcp%v_scale(number) - END DO - END DO - - ELSE IF (mol_setup(j)%nhcopt=="NONE") THEN - noneflag = .TRUE. -! NOTE: the thermostat counter is not incremented here. -! vscale(i,j) points to scale=1.d0 for eternity. Thus -! the the velocites of particles that are not connected -! to a thermostat will not get scaled in lnhc.f - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_scale(ii,jj) %point => scale - END DO - END DO - END IF - END DO - - ELSE IF (nhcp%dis_type=="INTER_REP") THEN - -! Begin the mapping loop - DO i = 1, nmol_type - opt = mol_setup(i) %nhcopt - -! Search for user defined thermostatting options first - IF ((opt/="GLOBAL") .AND. (opt/="MOLECULE") .AND. & - (opt/="MASSIVE") .AND. (opt/="NONE")) THEN - icust = icust + 1 - -! The first user defined option gets thrown on a thermostat, no questions asked - IF (icust==1) THEN - number = number + 1 - -! map the thermostat number to the molecule - DO k = mol_off(i) + 1, mol_off(i+1) - molecule(k) %nvt_num = number - END DO - -! save the molecule number that is customized - mnum(icust) = i - -! save the thermostat number that is customized - tnum(icust) = number - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(number) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom(number) = deg_of_freedom(number) + tot_const(i) - ELSE - -! if icust > 1 check to see if it is equal to the previous user-defined options - ieq = 0 - -! The loop is to icust-1 because we know that it is equal to itself - DO jj = 1, icust - 1 - IF (mol_setup(i)%nhcopt==mol_setup(mnum(jj))%nhcopt) THEN - ieq = jj - EXIT - END IF - END DO - -! if the user defined option found a match, map everything -! on the same thermostat - IF (ieq /= 0 ) THEN - -! map the thermostat number to the molecule - DO k = mol_off(i) + 1, mol_off(i+1) - molecule(k) %nvt_num = number - END DO - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(tnum(mnum(ieq))) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(tnum(mnum( & - ieq))) - END DO - END DO - deg_of_freedom(tnum(mnum(ieq))) = deg_of_freedom(tnum(mnum( & - ieq))) + tot_const(i) - -! if the user defined option does not find a match. Map it to a new -! thermostat, no questions asked - ELSE - number = number + 1 - -! map the thermostat number to the molecule - DO k = mol_off(i) + 1, mol_off(i+1) - molecule(k) %nvt_num = number - END DO - mnum(icust) = i - tnum(icust) = number - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(number) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom(number) = deg_of_freedom(number) + & - tot_const(i) - END IF - END IF - -! doing global thermostat option - ELSE IF (mol_setup(i)%nhcopt=="GLOBAL") THEN - -! map the thermostat number to the molecule - DO k = mol_off(i) + 1, mol_off(i+1) - molecule(k) %nvt_num = number - END DO - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_kin(ii,jj) %point => nhcp%s_kin(1) - nhcp%p_scale(ii,jj) %point => nhcp%v_scale(1) - END DO - END DO - deg_of_freedom(1) = deg_of_freedom(1) + tot_const(i) - -! doing molecular thermostat option - ELSE IF (mol_setup(i)%nhcopt=="MOLECULE") THEN - -! map the thermostat number to the molecule - DO k = mol_off(i) + 1, mol_off(i+1) - molecule(k) %nvt_num = number - END DO - DO ii = point(1,i), point(2,i), natoms_mol(i) - number = number + 1 - start = ii - finish = ii + molecule(i) %natoms_mol - 1 - DO jj = 1, 3 - DO kk = start, finish - nhcp%p_kin(jj,kk) %point => nhcp%s_kin(number) - nhcp%p_scale(jj,kk) %point => nhcp%v_scale(number) - END DO - END DO - deg_of_freedom(number) = const_mol(i) - END DO - -! doing massive thermostat option - ELSE IF (mol_setup(i)%nhcopt=="MASSIVE") THEN - IF (tot_const(i)>0) THEN - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) & - 'PUT THE CRACK PIPE DOWN! MASSIVE THERMOSTATS WITH' - WRITE ( iw, '( A )' ) & - ' CONSTRAINTS IS NOT POSSIBLE, MAN! ' - WRITE ( iw, '( A )' ) ' ' - WRITE ( iw, '( A )' ) & - '******************ERROR MESSAGE********************' - CALL stop_prg ( 'nhc_control' ) - END IF - DO ii = point(1,i), point(2,i) - DO jj = 1, 3 - number = number + 1 - nhcp%p_kin(jj,ii) %point => nhcp%s_kin(number) - nhcp%p_scale(jj,ii) %point => nhcp%v_scale(number) - END DO - END DO - - ELSE IF (mol_setup(i)%nhcopt=="NONE") THEN - noneflag = .TRUE. -! NOTE: the thermostat counter is not incremented here. -! vscale(i,j) points to scale=1.d0 for eternity. Thus -! the the velocites of particles that are not connected -! to a thermostat will not get scaled in lnhc.f - DO ii = 1, 3 - DO jj = point(1,i), point(2,i) - nhcp%p_scale(ii,jj) %point => scale - END DO - END DO - END IF - END DO - END IF - -! deallocating the temporary arrays mnum and tnum - DEALLOCATE (mnum,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control','mnum' ) - DEALLOCATE (tnum,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control','tnum' ) - DEALLOCATE (const_mol,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'const_mol' ) - DEALLOCATE (tot_const,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'tot_const' ) - DEALLOCATE (natoms_mol,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'natoms_mol' ) - DEALLOCATE (mol_off,STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', 'mol_off' ) - -! Allocating the extended variables - IF (simpar%ensemble(1:3)=='NPT' ) number = number + 1 - SELECT CASE (simpar%ensemble) - CASE ( 'NPT_I' ) - deg_of_freedom(number) = 1 - CASE ( 'NPT_F' ) - deg_of_freedom(number) = 9 - END SELECT - ALLOCATE (nhcp%nvt(nhcp%nhc_len,number),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control','nhcp%nvt', 0 ) - -! Sum up the number of degrees of freedom on each thermostat. -! first: initialize the target - natoms = sum(molecule ( : )%natoms_mol) - nhcp%s_kin = 0._dbl - DO i = 1, 3 - DO j = 1, natoms - nhcp%p_kin(i,j) %point = nhcp%p_kin(i,j) %point + 1 - END DO - END DO - -#if defined(__parallel) -! if thermostats are replicated but molecules distributed, we have to -! sum s_kin over all processors - IF (nhcp%dis_type=='INTER_REP' ) THEN - CALL mp_sum(nhcp%s_kin,globenv%group) - END IF -#endif - -! -! Now that we know how many there are stick this into nhc%static%nkt -! (number of degrees of freedom times k_B T for the first thermostat -! on the chain) - nhcp%num_nhc = number -! We know the total number of system thermostats. For npt_i it -! is number-1, for nvt it is number - IF (simpar%ensemble(1:3)=='NPT' ) number = nhcp%num_nhc - 1 - - IF ((number==1) .AND. ( .NOT. noneflag) .AND. & - ( .NOT. nhcp%dis_type=='DIS_REP' )) THEN - nhcp%nvt(1,1) %nkt = simpar%temp_ext*(nhcp%s_kin(1)-deg_of_freedom(1 & - )-3) - ELSE - -! re-initializing simpar%nfree to zero because of multiple thermostats - simpar%nfree = 0._dbl - DO i = 1, number - nhcp%nvt(1,i) %nkt = simpar%temp_ext*(nhcp%s_kin(i)-deg_of_freedom & - (i)) - END DO - END IF - -! getting the number of degrees of freedom times k_B T -! for the rest of the chain - DO i = 2, nhcp%nhc_len - nhcp%nvt(i,:) %nkt = simpar%temp_ext - END DO - -! doing the barostat - IF (simpar%ensemble(1:3)=='NPT' ) nhcp%nvt(1,nhcp%num_nhc) & - %nkt = deg_of_freedom(nhcp%num_nhc)*simpar%temp_ext - -! Set up the Yoshida weights - ALLOCATE (nhcp%dt_yosh(1:nhcp%nyosh),STAT=isos) - IF ( isos /= 0 ) CALL stop_memory ( 'nhc_control', & - 'nhcp%dt_yosh', nhcp % nyosh ) - CALL yoshida_coef(nhcp,simpar%dt) - -END SUBROUTINE nhc_control - -!****************************************************************************** - -END MODULE nhc diff --git a/src/nose.c b/src/nose.c deleted file mode 100644 index db50816..0000000 --- a/src/nose.c +++ /dev/null @@ -1,831 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE nose - - USE constraint, ONLY : roll - USE eigenvalueproblems, ONLY : diagonalise - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl -!*apsi USE lapack, ONLY : rs - USE molecule_types, ONLY : particle_node_type, molecule_structure_type - USE mp, ONLY : mp_bcast, mp_sum - USE stop_program, ONLY : stop_prg - USE timings, ONLY : timeset, timestop - USE util, ONLY : gasdev - - IMPLICIT NONE - - PRIVATE - PUBLIC :: lnhc, lnhcp, lnhcpf, initial_npt, initial_nhc - PUBLIC :: extended_parameters_type, nhc_info_type, npt_info_type - PUBLIC :: yoshida_coef - PUBLIC :: particle_kinetic_type, particle_scale_type - - TYPE npt_info_type - REAL ( dbl ) :: eps - REAL ( dbl ) :: v - REAL ( dbl ) :: f - REAL ( dbl ) :: mass - END TYPE npt_info_type - - TYPE nhc_info_type - REAL ( dbl ) :: eta - REAL ( dbl ) :: v - REAL ( dbl ) :: f - REAL ( dbl ) :: nkt - REAL ( dbl ) :: mass - END TYPE nhc_info_type - - TYPE particle_kinetic_type - REAL ( dbl ), POINTER :: point - END TYPE particle_kinetic_type - - TYPE particle_scale_type - REAL ( dbl ), POINTER :: point - END TYPE particle_scale_type - - TYPE extended_parameters_type - CHARACTER ( LEN = 10 ) :: dis_type - INTEGER :: nyosh, nc, nhc_len, num_nhc - REAL ( dbl ), POINTER :: dt_yosh ( : ) - TYPE (nhc_info_type ), POINTER :: nvt ( :, : ) - TYPE (npt_info_type ), POINTER :: npt ( :, : ) - TYPE (particle_kinetic_type ), POINTER :: p_kin ( :, : ) - TYPE (particle_scale_type ), POINTER :: p_scale ( :, : ) - REAL ( dbl ), POINTER :: v_scale ( : ) - REAL ( dbl ), POINTER :: s_kin ( : ) - END TYPE extended_parameters_type - -CONTAINS - -!****************************************************************************** - -SUBROUTINE lnhc ( nhcp, pnode, group ) - - IMPLICIT NONE - -! Arguments - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - INTEGER, INTENT ( IN ) :: group - -! Locals - INTEGER :: i, nnodes, inc, iyosh, n, nhc, handle, nx1, nx2 - REAL ( dbl ) :: scale, flops - -!------------------------------------------------------------------------------ - - CALL timeset('LNHC','I','Mflops',handle) - flops = 0.0_dbl - - nx1 = SIZE ( nhcp % nvt, 1 ) - nx2 = SIZE ( nhcp % nvt, 2 ) - -! get force on first thermostat for all the chains in the system. - nhcp % v_scale = 1.0_dbl - nhcp % s_kin = 0.0_dbl - nnodes = SIZE ( pnode ) - DO i = 1, nnodes - nhcp % p_kin(1,i) % point = nhcp % p_kin(1,i) % point & - + pnode(i) % p % prop % mass*pnode(i) % p % v(1)*pnode(i) % p % v(1) - nhcp % p_kin(2,i) % point = nhcp % p_kin(2,i) % point & - + pnode(i) % p % prop % mass*pnode(i) % p % v(2)*pnode(i) % p % v(2) - nhcp % p_kin(3,i) % point = nhcp % p_kin(3,i) % point & - + pnode(i) % p % prop % mass*pnode(i) % p % v(3)*pnode(i) % p % v(3) - END DO -#if defined(__parallel) -! for replicated thermostats and distributed molecules, we have to -! sum s_kin (pointed to by p_kin%point) over all processors - IF ( nhcp % dis_type == 'INTER_REP' ) THEN - CALL mp_sum ( nhcp % s_kin, group ) - END IF -#endif - flops = flops + REAL ( nnodes * 9, dbl ) - -! force on the first bead in every thermostat chain - DO n = 1, nhcp % num_nhc - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)-nhcp % nvt(1,n) % nkt)/ & - nhcp % nvt(1,n) % mass - END DO - flops = flops + REAL ( nhcp % num_nhc * 2, dbl ) - -! perform multiple time stepping using Yoshida - NCLOOP: DO inc = 1, nhcp % nc - YOSH: DO iyosh = 1, nhcp % nyosh - -! update velocity on the last thermostat in the chain ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL ( 3 * nx2, dbl ) - -! update velocity of other thermostats on chain (from nhc_len-1 to 1) ! O2 - DO n = 1, nhcp % num_nhc - DO nhc = nhcp % nhc_len - 1, 1, -1 - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO - END DO - flops = flops & - + REAL ( nhcp % num_nhc * (nhcp % nhc_len - 1 ) * 8, dbl ) - -! the core of the operator ----- START------ -! update nhc positions - nhcp % nvt ( :, : ) % eta = nhcp % nvt ( :, : ) % eta + & - 0.5_dbl*nhcp % nvt ( :, : ) % v*nhcp % dt_yosh(iyosh) - flops = flops + REAL(2*nx1*nx2) -! now accumulate the scale factor for particle velocities - DO n = 1, nhcp % num_nhc - nhcp % v_scale(n) = nhcp % v_scale(n)*exp(-0.5_dbl*nhcp % dt_yosh( & - iyosh)*nhcp % nvt(1,n) % v) - END DO - flops = flops + REAL(nhcp % num_nhc*4) -! the core of the operator ------ END ------ - -! update the force on first thermostat again (since particle velocities -! have changed) - DO n = 1, nhcp % num_nhc - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)*nhcp % v_scale(n)*nhcp % v_scale(n & - )-nhcp % nvt(1,n) % nkt)/nhcp % nvt(1,n) % mass - END DO - flops = flops + REAL(nhcp % num_nhc*4) - -! update velocity of other thermostats on chain (from 1 to nhc_len-1) ! O2 - DO nhc = 1, nhcp % nhc_len - 1 - DO n = 1, nhcp % num_nhc - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO -! updating the forces on all the thermostats - DO n = 1, nhcp % num_nhc - nhcp % nvt(nhc+1,n) % f = (nhcp % nvt(nhc,n) % mass*nhcp % nvt(nhc,n) % v & - *nhcp % nvt(nhc,n) % v-nhcp % nvt(nhc+1,n) % nkt)/ & - nhcp % nvt(nhc+1,n) % mass - END DO - END DO - flops = flops + REAL(nhcp % nhc_len-1)*REAL(nhcp % num_nhc*12) -! update velocity on last thermostat ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL(3*nx2) - END DO YOSH - END DO NCLOOP - -! now scale the particle velocities - DO i = 1, nnodes - pnode(i) % p % v(1) = pnode(i) % p % v(1)*nhcp % p_scale(1,i) % point - pnode(i) % p % v(2) = pnode(i) % p % v(2)*nhcp % p_scale(2,i) % point - pnode(i) % p % v(3) = pnode(i) % p % v(3)*nhcp % p_scale(3,i) % point - END DO - flops = flops + REAL ( nnodes*3, dbl ) - - flops = flops * 1.E-6_dbl - CALL timestop(flops,handle) - -END SUBROUTINE lnhc - -!****************************************************************************** - -SUBROUTINE lnhcp ( nhcp, molecule, pnode, pv_virial, pv_kin, pv_const, pext, & - deth, nfree, flag, group ) - - IMPLICIT NONE - -! Arguments - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( molecule_structure_type ), INTENT ( INOUT ), DIMENSION ( : ) :: & - molecule - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ) :: pnode - REAL ( dbl ), DIMENSION (3,3), INTENT ( IN ) :: pv_virial, pv_kin, pv_const - REAL ( dbl ), INTENT ( IN ) :: pext, deth - INTEGER, INTENT ( IN ) :: nfree - LOGICAL, INTENT ( IN ) :: flag - INTEGER, INTENT ( IN ) :: group - -! Locals - INTEGER :: i, ii, nnodes, inc, iyosh, n, nhc, handle, nx1, nx2, isos - REAL ( dbl ) :: scale, flops, baro_kin, aa, infree, fdotr, kin -! roll stuff - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ), SAVE :: veps, veta, mass - -!------------------------------------------------------------------------------ - - CALL timeset('LNHC','I','Mflops', handle ) - flops = 0.0_dbl - - infree = 1.0_dbl / REAL ( nfree, dbl ) - - nx1 = size(nhcp % nvt(:,1)) - nx2 = size(nhcp % nvt(1,:)) - -! get force on barostat - kin = 0.0_dbl - fdotr = 0.0_dbl - DO ii = 1, 3 - kin = kin + pv_kin(ii,ii) - fdotr = fdotr + pv_virial(ii,ii) + pv_const(ii,ii) - END DO - nhcp % npt ( :, : ) % f = (1._dbl+(3._dbl*infree))*kin + fdotr - & - 3._dbl*pext*deth - -! get force on first thermostat for all the chains in the system. - nhcp % v_scale = 1.0_dbl - nhcp % s_kin = 0.0_dbl - nnodes = size(pnode) - DO i = 1, nnodes - nhcp % p_kin(1,i) % point = nhcp % p_kin(1,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(1)*pnode(i) % p % v(1) - nhcp % p_kin(2,i) % point = nhcp % p_kin(2,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(2)*pnode(i) % p % v(2) - nhcp % p_kin(3,i) % point = nhcp % p_kin(3,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(3)*pnode(i) % p % v(3) - END DO - -#if defined(__parallel) -! for replicated thermostats and distributed molecules, we have to -! sum s_kin (pointed to by p_kin%point) over all processors - IF (nhcp % dis_type=='INTER_REP') THEN - CALL mp_sum(nhcp % s_kin,group) - END IF -#endif - - flops = flops + REAL ( nnodes * 9, dbl ) - -! force on the first bead in every thermostat chain attached to system - DO n = 1, nhcp % num_nhc - 1 - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)-nhcp % nvt(1,n) % nkt)/ & - nhcp % nvt(1,n) % mass - END DO - -! force on the first bead attached to barostat - baro_kin = nhcp % npt(1,1) % mass*nhcp % npt(1,1) % v*nhcp % npt(1,1) % v - nhcp % nvt(1,nhcp % num_nhc) % f = (baro_kin-nhcp % nvt(1,nhcp % num_nhc) % nkt)/ & - nhcp % nvt(1,nhcp % num_nhc) % mass - - flops = flops + REAL(nhcp % num_nhc*2) - -! perform multiple time stepping using Yoshida - NCLOOP: DO inc = 1, nhcp % nc - YOSH: DO iyosh = 1, nhcp % nyosh - -! update velocity on the last thermostat in the chain ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL(3*nx2) - -! update velocity of other thermostats on chain (from nhc_len-1 to 1) ! O2 - DO n = 1, nhcp % num_nhc - DO nhc = nhcp % nhc_len - 1, 1, -1 - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO - END DO -! updating veps: - aa = exp(-.125_dbl*nhcp % dt_yosh(iyosh)*nhcp % nvt(1,nhcp % num_nhc) % v) - nhcp % npt ( :, : ) % v = nhcp % npt ( :, : ) % v*aa*aa + & - .25_dbl*nhcp % dt_yosh(iyosh)*nhcp % npt ( :, : ) % f*aa/ & - nhcp % npt ( :, : ) % mass -! - flops = flops + REAL(nhcp % num_nhc*(nhcp % nhc_len-1)*8) - -! the core of the operator ----- START------ -! update nhc positions - nhcp % nvt ( :, : ) % eta = nhcp % nvt ( :, : ) % eta + & - 0.5_dbl*nhcp % nvt ( :, : ) % v*nhcp % dt_yosh(iyosh) - flops = flops + REAL(2*nx1*nx2) -! now accumulate the scale factor for particle velocities - DO n = 1, nhcp % num_nhc - 1 - nhcp % v_scale(n) = nhcp % v_scale(n)*exp(-0.5_dbl*nhcp % dt_yosh( & - iyosh)*(nhcp % nvt(1,n) % v+(1._dbl+3._dbl*infree)*nhcp % npt(1, & - 1) % v)) - END DO - flops = flops + REAL(nhcp % num_nhc*4) -! the core of the operator ------ END ------ - -! when constraints, call roll -! - IF (flag) THEN - isos = 0 - IF ( .NOT. ALLOCATED ( veta)) ALLOCATE (veta(size(nhcp % nvt, & - 1),size(nhcp % nvt,2)),STAT=isos) - IF ( .NOT. ALLOCATED ( veps)) ALLOCATE (veps(1,1),STAT=isos) - IF ( .NOT. ALLOCATED ( mass)) ALLOCATE (mass(1,1),STAT=isos) - IF ( isos /= 0 ) CALL stop_prg ( 'lnhcp','failed to allocate') - veta ( :, : ) = nhcp % nvt ( :, : ) % v - veps(1,1) = nhcp % npt(1,1) % v - mass(1,1) = nhcp % npt(1,1) % mass - CALL roll(molecule,veps,veta,mass,nhcp % dt_yosh(iyosh), & - nhcp % num_nhc,nfree) - END IF -! -! update the force on first thermostat again (since particle velocities -! have changed) connected to the system - kin = 0._dbl - DO n = 1, nhcp % num_nhc - 1 - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)*nhcp % v_scale(n)*nhcp % v_scale(n & - )-nhcp % nvt(1,n) % nkt)/nhcp % nvt(1,n) % mass - kin = kin + nhcp % s_kin(n)*nhcp % v_scale(n)*nhcp % v_scale(n) - END DO - flops = flops + REAL(nhcp % num_nhc*4) - - nhcp % npt ( :, : ) % f = (1._dbl+(3._dbl*infree))*kin + fdotr - & - 3._dbl*pext*deth -! updating veps: - aa = exp(-.125_dbl*nhcp % dt_yosh(iyosh)*nhcp % nvt(1,nhcp % num_nhc) % v) - nhcp % npt ( :, : ) % v = nhcp % npt ( :, : ) % v*aa*aa + & - .25_dbl*nhcp % dt_yosh(iyosh)*nhcp % npt ( :, : ) % f*aa/ & - nhcp % npt ( :, : ) % mass -! update force on first thermostat connected to barostat - baro_kin = nhcp % npt(1,1) % mass*nhcp % npt(1,1) % v*nhcp % npt(1,1) % v - nhcp % nvt(1,nhcp % num_nhc) % f = (baro_kin-nhcp % nvt(1,nhcp % num_nhc) % & - nkt)/nhcp % nvt(1,nhcp % num_nhc) % mass - -! update velocity of other thermostats on chain (from 1 to nhc_len-1) ! O2 - DO nhc = 1, nhcp % nhc_len - 1 - DO n = 1, nhcp % num_nhc - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO -! updating the forces on all the thermostats - DO n = 1, nhcp % num_nhc - nhcp % nvt(nhc+1,n) % f = (nhcp % nvt(nhc,n) % mass*nhcp % nvt(nhc,n) % v & - *nhcp % nvt(nhc,n) % v-nhcp % nvt(nhc+1,n) % nkt)/ & - nhcp % nvt(nhc+1,n) % mass - END DO - END DO - flops = flops + REAL(nhcp % nhc_len-1)*REAL(nhcp % num_nhc*12) -! update velocity on last thermostat ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL(3*nx2) - END DO YOSH - END DO NCLOOP - -! now scale the particle velocities - DO i = 1, nnodes - pnode(i) % p % v(1) = pnode(i) % p % v(1)*nhcp % p_scale(1,i) % point - pnode(i) % p % v(2) = pnode(i) % p % v(2)*nhcp % p_scale(2,i) % point - pnode(i) % p % v(3) = pnode(i) % p % v(3)*nhcp % p_scale(3,i) % point - END DO - flops = flops + REAL ( nnodes * 3, dbl ) - - flops = flops * 1.0E-6_dbl - CALL timestop ( flops, handle ) - -END SUBROUTINE lnhcp - -!****************************************************************************** - -SUBROUTINE lnhcpf ( nhcp, molecule, pnode, pv_virial, pv_kin, pv_const, pext, & - deth, nfree, flag, group ) - - IMPLICIT NONE - -! Arguments - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: & - molecule - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( IN ) :: pv_virial, pv_kin - REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( IN ) :: pv_const - REAL ( dbl ), INTENT ( IN ) :: pext, deth - INTEGER, INTENT ( IN ) :: nfree - LOGICAL, INTENT ( IN ) :: flag - INTEGER, INTENT ( IN ) :: group - -! Locals - INTEGER :: i, ipart, ii, jj, nnodes, inc, iyosh, n, nhc, handle, nx1, nx2 - INTEGER :: isos - REAL ( dbl ) :: scale, flops, baro_kin, aa, infree, trvg, kin - REAL ( dbl ), DIMENSION (3,3) :: u, unit, pv_kin_loc - REAL ( dbl ), DIMENSION (3) :: uv, e, e_val - REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ), SAVE :: veps, veta, mass - -!------------------------------------------------------------------------------ - - CALL timeset ( 'LNHC', 'I', 'Mflops', handle ) - flops = 0.0_dbl - -! initializing locals - unit = 0.0_dbl - unit(1,1) = 1.0_dbl - unit(2,2) = 1.0_dbl - unit(3,3) = 1.0_dbl - infree = 1.0_dbl / REAL ( nfree, dbl ) - - nx1 = size(nhcp % nvt(:,1)) - nx2 = size(nhcp % nvt(1,:)) - -! get force on barostat - kin = 0._dbl - DO ii = 1, 3 - kin = kin + pv_kin(ii,ii) - END DO - nhcp % npt ( :, : ) % f = pv_kin ( :, : ) + infree*kin*unit ( :, : ) + & - pv_virial ( :, : ) + pv_const ( :, : ) - pext*deth*unit ( :, : ) - -! get force on first thermostat for all the chains in the system. - nhcp % v_scale = 1.0_dbl - nhcp % s_kin = 0.0_dbl - nnodes = size(pnode) - DO i = 1, nnodes - nhcp % p_kin(1,i) % point = nhcp % p_kin(1,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(1)*pnode(i) % p % v(1) - nhcp % p_kin(2,i) % point = nhcp % p_kin(2,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(2)*pnode(i) % p % v(2) - nhcp % p_kin(3,i) % point = nhcp % p_kin(3,i) % point + & - pnode(i) % p % prop % mass*pnode(i) % p % v(3)*pnode(i) % p % v(3) - END DO -#if defined(__parallel) -! for replicated thermostats and distributed molecules, we have to -! sum s_kin (pointed to by p_kin % point) over all processors - IF (nhcp % dis_type=='INTER_REP') THEN - CALL mp_sum(nhcp % s_kin,group) - END IF -#endif - flops = flops + REAL(nnodes*9) - -! force on the first bead in every thermostat chain attached to system - DO n = 1, nhcp % num_nhc - 1 - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)-nhcp % nvt(1,n) % nkt)/ & - nhcp % nvt(1,n) % mass - END DO -! force on the first bead attached to barostat - baro_kin = 0._dbl - DO ii = 1, 3 - DO jj = 1, 3 - baro_kin = baro_kin*nhcp % npt(ii,jj) % v*nhcp % npt(ii,jj) % v* & - nhcp % npt(ii,jj) % mass - END DO - END DO - nhcp % nvt(1,nhcp % num_nhc) % f = (baro_kin-nhcp % nvt(1,nhcp % num_nhc) % nkt)/ & - nhcp % nvt(1,nhcp % num_nhc) % mass - - flops = flops + REAL(nhcp % num_nhc*2) - -! perform multiple time stepping using Yoshida - NCLOOP: DO inc = 1, nhcp % nc - YOSH: DO iyosh = 1, nhcp % nyosh - -! update velocity on the last thermostat in the chain ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL(3*nx2) - -! update velocity of other thermostats on chain (from nhc_len-1 to 1) ! O2 - DO n = 1, nhcp % num_nhc - DO nhc = nhcp % nhc_len - 1, 1, -1 - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO - END DO -! updating veps: - aa = exp(-.125_dbl*nhcp % dt_yosh(iyosh)*nhcp % nvt(1,nhcp % num_nhc) % v) - nhcp % npt ( :, : ) % v = nhcp % npt ( :, : ) % v*aa*aa + & - .25_dbl*nhcp % dt_yosh(iyosh)*nhcp % npt ( :, : ) % f*aa/ & - nhcp % npt ( :, : ) % mass -! computing the trace - trvg = infree*(nhcp % npt(1,1) % v+nhcp % npt(2,2) % v+nhcp % npt(3,3) % v) -! - flops = flops + REAL(nhcp % num_nhc*(nhcp % nhc_len-1)*8) -! the core of the operator ----- START------ -! update nhc positions - nhcp % nvt ( :, : ) % eta = nhcp % nvt ( :, : ) % eta + & - 0.5_dbl*nhcp % nvt ( :, : ) % v*nhcp % dt_yosh(iyosh) - flops = flops + REAL(2*nx1*nx2) -! -! accumulate the matrix part of the scale factor on the velocities -! Get eigenvectors and eigenvalues of nhcp % npt % v -! -!*apsi CALL rs(nhcp % npt % v,e_val,u) - CALL diagonalise ( matrix = nhcp % npt % v, mysize = 3, & - storageform = "UPPER", eigenvalues = e_val, eigenvectors = u ) - - e = exp(-.5_dbl*nhcp % dt_yosh(iyosh)*e_val) -! now get the scalar part of the scale factor - DO n = 1, nhcp % num_nhc - 1 - nhcp % v_scale(n) = exp(-0.5_dbl*nhcp % dt_yosh(iyosh)*(nhcp % nvt(1, & - n) % v+trvg)) - END DO - nhcp % s_kin = 0._dbl - pv_kin_loc = 0._dbl - kin = 0._dbl - DO ipart = 1, nnodes -! update the particles with the matrix contribution - uv = matmul(transpose(u),pnode(ipart) % p % v) - uv = uv*e - pnode(ipart) % p % v = matmul(u,uv) -! update velocites to compute kinetic energy dependent pieces - pnode(ipart) % p % v(1) = pnode(ipart) % p % v(1)* & - nhcp % p_scale(1,ipart) % point - pnode(ipart) % p % v(2) = pnode(ipart) % p % v(2)* & - nhcp % p_scale(2,ipart) % point - pnode(ipart) % p % v(3) = pnode(ipart) % p % v(3)* & - nhcp % p_scale(3,ipart) % point - nhcp % p_kin(1,ipart) % point = nhcp % p_kin(1,ipart) % point + & - pnode(ipart) % p % prop % mass*pnode(ipart) % p % v(1)* & - pnode(ipart) % p % v(1) - nhcp % p_kin(2,ipart) % point = nhcp % p_kin(2,ipart) % point + & - pnode(ipart) % p % prop % mass*pnode(ipart) % p % v(2)* & - pnode(ipart) % p % v(2) - nhcp % p_kin(3,ipart) % point = nhcp % p_kin(3,ipart) % point + & - pnode(ipart) % p % prop % mass*pnode(ipart) % p % v(3)* & - pnode(ipart) % p % v(3) - DO ii = 1, 3 - kin = kin + pnode(ipart) % p % prop % mass*pnode(ipart) % p % v(ii)* & - pnode(ipart) % p % v(ii) - DO jj = 1, 3 - pv_kin_loc(ii,jj) = pv_kin_loc(ii,jj) + & - pnode(ipart) % p % prop % mass*pnode(ipart) % p % v(ii)* & - pnode(ipart) % p % v(jj) - END DO - END DO - END DO -#if defined(__parallel) -! for replicated thermostats and distributed molecules, we have to -! sum s_kin (pointed to by p_kin % point) over all processors - IF (nhcp % dis_type=='INTER_REP') THEN - CALL mp_sum(nhcp % s_kin,group) - END IF -#endif - flops = flops + REAL(nhcp % num_nhc*4) -! the core of the operator ------ END ------ - -! when constraints, call roll -! - IF (flag) THEN - IF ( .NOT. ALLOCATED ( veta)) ALLOCATE (veta(size(nhcp % nvt, & - 1),size(nhcp % nvt,2)),STAT=isos) - IF ( .NOT. ALLOCATED ( veps)) ALLOCATE (veps(3,3),STAT=isos) - IF ( .NOT. ALLOCATED ( mass)) ALLOCATE (mass(3,3),STAT=isos) - IF ( isos /= 0 ) CALL stop_prg ( 'lnhcpf','failed to allocate') - veta ( :, : ) = nhcp % nvt ( :, : ) % v - mass ( :, : ) = nhcp % npt ( :, : ) % mass - CALL roll(molecule,veps,veta,mass,nhcp % dt_yosh(iyosh), & - nhcp % num_nhc,nfree,e_val,u) - END IF -! -! update the force on first thermostat again (since particle velocities -! have changed) connected to the system - DO n = 1, nhcp % num_nhc - 1 - nhcp % nvt(1,n) % f = (nhcp % s_kin(n)-nhcp % nvt(1,n) % nkt)/ & - nhcp % nvt(1,n) % mass - END DO - flops = flops + REAL(nhcp % num_nhc*4) - - nhcp % npt ( :, : ) % f = pv_kin_loc ( :, : ) + infree*kin*unit ( :, : ) + & - pv_virial ( :, : ) + pv_const ( :, : ) - pext*deth*unit ( :, : ) -! updating veps: - aa = exp(-.125_dbl*nhcp % dt_yosh(iyosh)*nhcp % nvt(1,nhcp % num_nhc) % v) - nhcp % npt ( :, : ) % v = nhcp % npt ( :, : ) % v*aa*aa + & - .25_dbl*nhcp % dt_yosh(iyosh)*nhcp % npt ( :, : ) % f*aa/ & - nhcp % npt ( :, : ) % mass -! update force on first thermostat connected to barostat - baro_kin = 0._dbl - DO ii = 1, 3 - DO jj = 1, 3 - baro_kin = baro_kin*nhcp % npt(ii,jj) % v*nhcp % npt(ii,jj) % v* & - nhcp % npt(ii,jj) % mass - END DO - END DO - nhcp % nvt(1,nhcp % num_nhc) % f = (baro_kin-nhcp % nvt(1,nhcp % num_nhc) % & - nkt)/nhcp % nvt(1,nhcp % num_nhc) % mass - -! update velocity of other thermostats on chain (from 1 to nhc_len-1) ! O2 - DO nhc = 1, nhcp % nhc_len - 1 - DO n = 1, nhcp % num_nhc - scale = exp(-0.125_dbl*nhcp % nvt(nhc+1,n) % v*nhcp % dt_yosh(iyosh) & - ) - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v + & - nhcp % nvt(nhc,n) % f*0.25_dbl*nhcp % dt_yosh(iyosh) ! shift - nhcp % nvt(nhc,n) % v = nhcp % nvt(nhc,n) % v*scale ! scale - END DO -! updating the forces on all the thermostats - DO n = 1, nhcp % num_nhc - nhcp % nvt(nhc+1,n) % f = (nhcp % nvt(nhc,n) % mass*nhcp % nvt(nhc,n) % v & - *nhcp % nvt(nhc,n) % v-nhcp % nvt(nhc+1,n) % nkt)/ & - nhcp % nvt(nhc+1,n) % mass - END DO - END DO - flops = flops + REAL(nhcp % nhc_len-1)*REAL(nhcp % num_nhc*12) -! update velocity on last thermostat ! O1 - nhcp % nvt(nhcp % nhc_len,:) % v = nhcp % nvt(nhcp % nhc_len,:) % v + & - nhcp % nvt(nhcp % nhc_len,:) % f*0.25_dbl*nhcp % dt_yosh(iyosh) - flops = flops + REAL(3*nx2) - END DO YOSH - END DO NCLOOP - - flops = flops + REAL(nnodes*3) -! - flops = flops*1.E-6_dbl - CALL timestop(flops,handle) -END SUBROUTINE lnhcpf -!****************************************************************************** - -SUBROUTINE initial_nhc(nhcp,tau_nhc,temp_ext, globenv ) -! Initializes the NHC velocities to the Maxwellian distribution - IMPLICIT NONE - TYPE (extended_parameters_type ), INTENT ( INOUT ) :: nhcp - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - REAL ( dbl ), INTENT ( IN ) :: tau_nhc, temp_ext - INTEGER :: i, j, number - REAL ( dbl ) :: akin, temp, v - -! first initializing the mass of the nhc variables - nhcp % nvt ( :, : ) % mass = nhcp % nvt ( :, : ) % nkt*tau_nhc*tau_nhc -! initializing velocities - DO i = 1, nhcp % num_nhc - DO j = 1, nhcp % nhc_len - v = gasdev(globenv % idum) -#if defined(__parallel) - IF (nhcp % dis_type=='INTER_REP') CALL mp_bcast(v,globenv % source, & - globenv % group) -#endif - nhcp % nvt(j,i) % v = v - END DO - END DO - akin = 0.0_dbl - DO i = 1, nhcp % num_nhc - DO j = 1, nhcp % nhc_len - akin = akin + 0.5_dbl*(nhcp % nvt(j,i) % mass*nhcp % nvt(j,i) % v*nhcp % nvt & - (j,i) % v) - END DO - END DO - number = nhcp % num_nhc -#if defined(__parallel) - IF (nhcp % dis_type=='DIS_REP') CALL mp_sum(akin,globenv % group) - IF (nhcp % dis_type=='DIS_REP') CALL mp_sum(number,globenv % group) -#endif - - temp = 2.0_dbl*akin/REAL(number) - -! scale velocities to get the correct initial temperature - DO i = 1, nhcp % num_nhc - DO j = 1, nhcp % nhc_len - nhcp % nvt(j,i) % v = sqrt(temp_ext/temp)*nhcp % nvt(j,i) % v -! dbg -! nhcp % nvt(j,i) % v = 0._dbl -! dbg - nhcp % nvt(j,i) % eta = 0.0_dbl - END DO - END DO - -! initializing all of the forces on the thermostats - DO i = 1, nhcp % num_nhc - DO j = 2, nhcp % nhc_len - nhcp % nvt(j,i) % f = nhcp % nvt(j-1,i) % mass*nhcp % nvt(j-1,i) % v* & - nhcp % nvt(j-1,i) % v - nhcp % nvt(j,i) % nkt - nhcp % nvt(j,i) % f = nhcp % nvt(j,i) % f/nhcp % nvt(j,i) % mass - END DO - END DO - -END SUBROUTINE initial_nhc - -!****************************************************************************** - -! Initializes the NHC velocities to the Maxwellian distribution - -SUBROUTINE initial_npt ( nhcp, tau_cell, temp_ext, deth, nfree, ensemble, & - globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - REAL ( dbl ), INTENT ( IN ) :: tau_cell, temp_ext, deth - CHARACTER ( LEN = 20 ), INTENT ( IN ) :: ensemble - INTEGER, INTENT ( IN ) :: nfree - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - -! Locals - INTEGER :: i, j, number, isos - REAL ( dbl ) :: akin, temp, v - -!------------------------------------------------------------------------------ - -! first initializing the mass of the nhc variables - SELECT CASE ( ensemble ) - CASE ( 'NPT_I') - ALLOCATE ( nhcp % npt ( 1, 1 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'initial_npt', & - 'failed to allocate nhcp % npt') - nhcp % npt ( :, : ) % mass = REAL ( nfree + 3, dbl ) & - * temp_ext * tau_cell ** 2 - - CASE ( 'NPT_F') - ALLOCATE ( nhcp % npt ( 3, 3 ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_prg ( 'initial_npt', & - 'failed to allocate nhcp % npt') - nhcp % npt ( :, : ) % mass = REAL ( nfree + 3, dbl ) & - * temp_ext * tau_cell ** 2 / 3.0_dbl - END SELECT - -! initializing velocities - DO i = 1, size ( nhcp % npt,1) - DO j = 1, size ( nhcp % npt,2) - v = gasdev ( globenv % idum) -#if defined(__parallel) - CALL mp_bcast ( v, globenv % source, globenv % group ) -#endif - nhcp % npt(j,i) % v = v - END DO - END DO - - akin = 0.0_dbl - DO i = 1, size(nhcp % npt,1) - DO j = 1, size(nhcp % npt,2) - akin = akin + 0.5_dbl*(nhcp % npt(j,i) % mass*nhcp % npt(j,i) % v*nhcp % npt & - (j,i) % v) - END DO - END DO - number = SIZE ( nhcp % npt, 1 ) * SIZE ( nhcp % npt, 2 ) - - temp = 2.0_dbl * akin / REAL ( number, dbl ) - -! scale velocities to get the correct initial temperature - DO i = 1, size(nhcp % npt,1) - DO j = 1, size(nhcp % npt,2) - nhcp % npt(j,i) % v = sqrt(temp_ext/temp)*nhcp % npt(j,i) % v -! dbg -! nhcp % npt(j,i) % v = 0._dbl -! dbg - END DO - END DO - -! initialize the position - IF ( ensemble == 'NPT_I' ) nhcp % npt ( :, : ) % eps = LOG ( deth ) / 3.0_dbl - -END SUBROUTINE initial_npt - -!****************************************************************************** - -! this lists the coefficients for the Yoshida method (higher -! order integrator used in NVT) - -SUBROUTINE yoshida_coef ( nhcp, dt ) - - IMPLICIT NONE - -! Arguments - TYPE ( extended_parameters_type ), INTENT ( INOUT ) :: nhcp - REAL ( dbl ), INTENT ( IN ) :: dt - -! Locals - REAL ( dbl ), DIMENSION (nhcp % nyosh) :: yosh_wt - -!------------------------------------------------------------------------------ - - SELECT CASE (nhcp % nyosh) - CASE (1) - yosh_wt(1) = 1.0_dbl - CASE (3) - yosh_wt(1) = 1.0_dbl/(2.0_dbl-(2.0_dbl)**(1.0_dbl/3.0_dbl)) - yosh_wt(2) = 1.0_dbl - 2.0_dbl*yosh_wt(1) - yosh_wt(3) = yosh_wt(1) - CASE (5) - yosh_wt(1) = 1.0_dbl/(4.0_dbl-(4.0_dbl)**(1.0_dbl/3.0_dbl)) - yosh_wt(2) = yosh_wt(1) - yosh_wt(4) = yosh_wt(1) - yosh_wt(5) = yosh_wt(1) - yosh_wt(3) = 1.0_dbl - 4.0_dbl*yosh_wt(1) - CASE (7) - yosh_wt(1) = .78451361047756_dbl - yosh_wt(2) = .235573213359357_dbl - yosh_wt(3) = -1.17767998417887_dbl - yosh_wt(4) = 1.0_dbl - 2.0_dbl*(yosh_wt(1)+yosh_wt(2)+yosh_wt(3)) - yosh_wt(5) = yosh_wt(3) - yosh_wt(6) = yosh_wt(2) - yosh_wt(7) = yosh_wt(1) - END SELECT - - nhcp % dt_yosh = dt * yosh_wt / REAL ( nhcp % nc, dbl ) - -END SUBROUTINE yoshida_coef - -!****************************************************************************** - -END MODULE nose - diff --git a/src/nrutil.cpp b/src/nrutil.cpp deleted file mode 100644 index 42d5b68..0000000 --- a/src/nrutil.cpp +++ /dev/null @@ -1,935 +0,0 @@ -#include -#include -#include -#include - -namespace CP2K_NS { - const double twopi = 6.283185307179586476925286766559005768394; - const int npar_arth = 16; - const int npar2_arth = 8; - const int npar_geop = 4; - const int npar2_geop = 2; - const int npar_cumsum = 16; - const int npar_cumprod = 8; - const int npar_poly = 8; - const int npar_polyterm = 8; - - void array_copy_r(float* src, float* dest, int& n_copied, int& n_not_copied) { - n_copied = std::min(std::size(src), std::size(dest)); - n_not_copied = std::size(src) - n_copied; - std::copy(src, src + n_copied, dest); - } - - void array_copy_i(int* src, int* dest, int& n_copied, int& n_not_copied) { - n_copied = std::min(std::size(src), std::size(dest)); - n_not_copied = std::size(src) - n_copied; - std::copy(src, src + n_copied, dest); - } - - - void swap_i(int& a, int& b) { - int dum = a; - a = b; - b = dum; - } - - SUBROUTINE swap_r(a,b) - REAL (sp), INTENT (INOUT) :: a, b - REAL (sp) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_r - - SUBROUTINE swap_rv(a,b) - REAL (sp), DIMENSION (:), INTENT (INOUT) :: a, b - REAL (sp), DIMENSION (size(a)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_rv - - SUBROUTINE swap_c(a,b) - COMPLEX (spc), INTENT (INOUT) :: a, b - COMPLEX (spc) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_c - - SUBROUTINE swap_cv(a,b) - COMPLEX (spc), DIMENSION (:), INTENT (INOUT) :: a, b - COMPLEX (spc), DIMENSION (size(a)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_cv - - SUBROUTINE swap_cm(a,b) - COMPLEX (spc), DIMENSION (:,:), INTENT (INOUT) :: a, b - COMPLEX (spc), DIMENSION (size(a,1),size(a,2)) :: dum - - dum = a - a = b - b = dum - END SUBROUTINE swap_cm - - SUBROUTINE masked_swap_rs(a,b,mask) - REAL (sp), INTENT (INOUT) :: a, b - LOGICAL (lgt), INTENT (IN) :: mask - REAL (sp) :: swp - - IF (mask) THEN - swp = a - a = b - b = swp - END IF - END SUBROUTINE masked_swap_rs - - SUBROUTINE masked_swap_rv(a,b,mask) - REAL (sp), DIMENSION (:), INTENT (INOUT) :: a, b - LOGICAL (lgt), DIMENSION (:), INTENT (IN) :: mask - REAL (sp), DIMENSION (size(a)) :: swp - - WHERE (mask) - swp = a - a = b - b = swp - END WHERE - END SUBROUTINE masked_swap_rv - - SUBROUTINE masked_swap_rm(a,b,mask) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: a, b - LOGICAL (lgt), DIMENSION (:,:), INTENT (IN) :: mask - REAL (sp), DIMENSION (size(a,1),size(a,2)) :: swp - - WHERE (mask) - swp = a - a = b - b = swp - END WHERE - END SUBROUTINE masked_swap_rm - - - FUNCTION reallocate_rv(p,n) - REAL (sp), DIMENSION (:), POINTER :: p, reallocate_rv - INTEGER (i4b), INTENT (IN) :: n - INTEGER (i4b) :: nold, ierr - - ALLOCATE (reallocate_rv(n),STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_rv: problem in attempt to allocate memory') - IF ( .NOT. associated(p)) RETURN - nold = size(p) - reallocate_rv(1:min(nold,n)) = p(1:min(nold,n)) - DEALLOCATE (p,STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_rv: problem in attempt to deallocate memory') - END FUNCTION reallocate_rv - - FUNCTION reallocate_iv(p,n) - INTEGER (i4b), DIMENSION (:), POINTER :: p, reallocate_iv - INTEGER (i4b), INTENT (IN) :: n - INTEGER (i4b) :: nold, ierr - - ALLOCATE (reallocate_iv(n),STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_iv: problem in attempt to allocate memory') - IF ( .NOT. associated(p)) RETURN - nold = size(p) - reallocate_iv(1:min(nold,n)) = p(1:min(nold,n)) - DEALLOCATE (p,STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_iv: problem in attempt to deallocate memory') - END FUNCTION reallocate_iv - - FUNCTION reallocate_hv(p,n) - CHARACTER (1), DIMENSION (:), POINTER :: p, reallocate_hv - INTEGER (i4b), INTENT (IN) :: n - INTEGER (i4b) :: nold, ierr - - ALLOCATE (reallocate_hv(n),STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_hv: problem in attempt to allocate memory') - IF ( .NOT. associated(p)) RETURN - nold = size(p) - reallocate_hv(1:min(nold,n)) = p(1:min(nold,n)) - DEALLOCATE (p,STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_hv: problem in attempt to deallocate memory') - END FUNCTION reallocate_hv - - FUNCTION reallocate_rm(p,n,m) - REAL (sp), DIMENSION (:,:), POINTER :: p, reallocate_rm - INTEGER (i4b), INTENT (IN) :: n, m - INTEGER (i4b) :: nold, mold, ierr - - ALLOCATE (reallocate_rm(n,m),STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_rm: problem in attempt to allocate memory') - IF ( .NOT. associated(p)) RETURN - nold = size(p,1) - mold = size(p,2) - reallocate_rm(1:min(nold,n),1:min(mold,m)) = p(1:min(nold,n), & - 1:min(mold,m)) - DEALLOCATE (p,STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_rm: problem in attempt to deallocate memory') - END FUNCTION reallocate_rm - - FUNCTION reallocate_im(p,n,m) - INTEGER (i4b), DIMENSION (:,:), POINTER :: p, reallocate_im - INTEGER (i4b), INTENT (IN) :: n, m - INTEGER (i4b) :: nold, mold, ierr - - ALLOCATE (reallocate_im(n,m),STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_im: problem in attempt to allocate memory') - IF ( .NOT. associated(p)) RETURN - nold = size(p,1) - mold = size(p,2) - reallocate_im(1:min(nold,n),1:min(mold,m)) = p(1:min(nold,n), & - 1:min(mold,m)) - DEALLOCATE (p,STAT=ierr) - IF (ierr/=0) CALL nrerror( & - 'reallocate_im: problem in attempt to deallocate memory') - END FUNCTION reallocate_im - - FUNCTION ifirstloc(mask) - LOGICAL (lgt), DIMENSION (:), INTENT (IN) :: mask - INTEGER (i4b) :: ifirstloc - INTEGER (i4b), DIMENSION (1) :: loc - - loc = maxloc(merge(1,0,mask)) - ifirstloc = loc(1) - IF ( .NOT. mask(ifirstloc)) ifirstloc = size(mask) + 1 - END FUNCTION ifirstloc - - FUNCTION imaxloc_r(arr) - REAL (sp), DIMENSION (:), INTENT (IN) :: arr - INTEGER (i4b) :: imaxloc_r - INTEGER (i4b), DIMENSION (1) :: imax - - imax = maxloc(arr(:)) - imaxloc_r = imax(1) - END FUNCTION imaxloc_r - - FUNCTION imaxloc_i(iarr) - INTEGER (i4b), DIMENSION (:), INTENT (IN) :: iarr - INTEGER (i4b), DIMENSION (1) :: imax - INTEGER (i4b) :: imaxloc_i - - imax = maxloc(iarr(:)) - imaxloc_i = imax(1) - END FUNCTION imaxloc_i - - FUNCTION iminloc(arr) - REAL (sp), DIMENSION (:), INTENT (IN) :: arr - INTEGER (i4b), DIMENSION (1) :: imin - INTEGER (i4b) :: iminloc - - imin = minloc(arr(:)) - iminloc = imin(1) - END FUNCTION iminloc - -void assert1(bool n1, std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - LOGICAL, INTENT (IN) :: n1 - - IF ( .NOT. n1) THEN - WRITE (*,*) 'nrerror: an assertion failed with this tag:', string - STOP 'program terminated by assert1' - END IF -} - -void assert2(bool n1, bool n2, std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - LOGICAL, INTENT (IN) :: n1, n2 - - IF ( .NOT. (n1 .AND. n2)) THEN - WRITE (*,*) 'nrerror: an assertion failed with this tag:', string - STOP 'program terminated by assert2' - END IF -} - -void assert3(bool n1, bool n2, bool n3, std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - LOGICAL, INTENT (IN) :: n1, n2, n3 - - IF ( .NOT. (n1 .AND. n2 .AND. n3)) THEN - WRITE (*,*) 'nrerror: an assertion failed with this tag:', string - STOP 'program terminated by assert3' - END IF -} - -void assert4(bool n1, bool n2, bool n3, bool n4, std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - LOGICAL, INTENT (IN) :: n1, n2, n3, n4 - - IF ( .NOT. (n1 .AND. n2 .AND. n3 .AND. n4)) THEN - WRITE (*,*) 'nrerror: an assertion failed with this tag:', string - STOP 'program terminated by assert4' - END IF -} - -void assert_v(bool n[], std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - LOGICAL, DIMENSION (:), INTENT (IN) :: n - - IF ( .NOT. all(n)) THEN - WRITE (*,*) 'nrerror: an assertion failed with this tag:', string - STOP 'program terminated by assert_v' - END IF -} - - int assert_eq2(int n1, int n2, std::string string) { - - if (n1 == n2) { - return n1; - } else { - std::cout << "nrerror: an assert_eq failed with this tag: " << string << std::endl; - exit("program terminated by assert_eq2"); - } - } - -int assert_eq3(int n1, int n2, int n3, std::string) { - CHARACTER (len=*), INTENT (IN) :: string - INTEGER, INTENT (IN) :: n1, n2, n3 - INTEGER :: assert_eq3 - - IF (n1==n2 .AND. n2==n3) THEN - assert_eq3 = n1 - ELSE - WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string - STOP 'program terminated by assert_eq3' - END IF -} - -int assert_eq4(int n1, int n2, int n3, int n4, std::string) { - CHARACTER (len=*), INTENT (IN) :: string - INTEGER, INTENT (IN) :: n1, n2, n3, n4 - INTEGER :: assert_eq4 - - IF (n1==n2 .AND. n2==n3 .AND. n3==n4) THEN - assert_eq4 = n1 - ELSE - WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string - STOP 'program terminated by assert_eq4' - END IF -} - -int assert_eqn(int nn[], std::string string) { - CHARACTER (len=*), INTENT (IN) :: string - INTEGER, DIMENSION (:), INTENT (IN) :: nn - INTEGER :: assert_eqn - - IF (all(nn(2:)==nn(1))) THEN - assert_eqn = nn(1) - ELSE - WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', string - STOP 'program terminated by assert_eqn' - END IF -} - -void nrerror(std::string string) { - printf("nrerror: %s", string); - printf("program terminated by nerror"); - exit(1); -} - - -double *arth_r(double first, double increment, int n) { - - int k, k2; - double temp; - double *arth_r = new double[n]; - if (n > 0) arth_r[0] = first; - - IF (n<=npar_arth) THEN - DO k = 2, n - arth_r(k) = arth_r(k-1) + increment - END DO - ELSE - DO k = 2, npar2_arth - arth_r(k) = arth_r(k-1) + increment - END DO - temp = increment*npar2_arth - k = npar2_arth - DO - IF (k>=n) EXIT - k2 = k + k - arth_r(k+1:min(k2,n)) = temp + arth_r(1:min(k,n-k)) - temp = temp + temp - k = k2 - END DO - END IF -} - - FUNCTION arth_i(first,increment,n) - INTEGER (i4b), INTENT (IN) :: first, increment, n - INTEGER (i4b), DIMENSION (n) :: arth_i - INTEGER (i4b) :: k, k2, temp - - IF (n>0) arth_i(1) = first - IF (n<=npar_arth) THEN - DO k = 2, n - arth_i(k) = arth_i(k-1) + increment - END DO - ELSE - DO k = 2, npar2_arth - arth_i(k) = arth_i(k-1) + increment - END DO - temp = increment*npar2_arth - k = npar2_arth - DO - IF (k>=n) EXIT - k2 = k + k - arth_i(k+1:min(k2,n)) = temp + arth_i(1:min(k,n-k)) - temp = temp + temp - k = k2 - END DO - END IF - END FUNCTION arth_i - - - FUNCTION geop_r(first,factor,n) - REAL (sp), INTENT (IN) :: first, factor - INTEGER (i4b), INTENT (IN) :: n - REAL (sp), DIMENSION (n) :: geop_r - INTEGER (i4b) :: k, k2 - REAL (sp) :: temp - - IF (n>0) geop_r(1) = first - IF (n<=npar_geop) THEN - DO k = 2, n - geop_r(k) = geop_r(k-1)*factor - END DO - ELSE - DO k = 2, npar2_geop - geop_r(k) = geop_r(k-1)*factor - END DO - temp = factor**npar2_geop - k = npar2_geop - DO - IF (k>=n) EXIT - k2 = k + k - geop_r(k+1:min(k2,n)) = temp*geop_r(1:min(k,n-k)) - temp = temp*temp - k = k2 - END DO - END IF - END FUNCTION geop_r - - FUNCTION geop_i(first,factor,n) - INTEGER (i4b), INTENT (IN) :: first, factor, n - INTEGER (i4b), DIMENSION (n) :: geop_i - INTEGER (i4b) :: k, k2, temp - - IF (n>0) geop_i(1) = first - IF (n<=npar_geop) THEN - DO k = 2, n - geop_i(k) = geop_i(k-1)*factor - END DO - ELSE - DO k = 2, npar2_geop - geop_i(k) = geop_i(k-1)*factor - END DO - temp = factor**npar2_geop - k = npar2_geop - DO - IF (k>=n) EXIT - k2 = k + k - geop_i(k+1:min(k2,n)) = temp*geop_i(1:min(k,n-k)) - temp = temp*temp - k = k2 - END DO - END IF - END FUNCTION geop_i - - FUNCTION geop_c(first,factor,n) - COMPLEX (sp), INTENT (IN) :: first, factor - INTEGER (i4b), INTENT (IN) :: n - COMPLEX (sp), DIMENSION (n) :: geop_c - INTEGER (i4b) :: k, k2 - COMPLEX (sp) :: temp - - IF (n>0) geop_c(1) = first - IF (n<=npar_geop) THEN - DO k = 2, n - geop_c(k) = geop_c(k-1)*factor - END DO - ELSE - DO k = 2, npar2_geop - geop_c(k) = geop_c(k-1)*factor - END DO - temp = factor**npar2_geop - k = npar2_geop - DO - IF (k>=n) EXIT - k2 = k + k - geop_c(k+1:min(k2,n)) = temp*geop_c(1:min(k,n-k)) - temp = temp*temp - k = k2 - END DO - END IF - END FUNCTION geop_c - - - RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT (ans) - REAL (sp), DIMENSION (:), INTENT (IN) :: arr - REAL (sp), OPTIONAL, INTENT (IN) :: seed - REAL (sp), DIMENSION (size(arr)) :: ans - INTEGER (i4b) :: n, j - REAL (sp) :: sd - - n = size(arr) - IF (n==0_i4b) RETURN - sd = 0.0_sp - IF (present(seed)) sd = seed - ans(1) = arr(1) + sd - IF (n=nn) EXIT - zroots_unity(k+1) = cmplx(cos(k*theta),sin(k*theta),spc) - zroots_unity(k+2:min(2*k,nn)) = zroots_unity(k+1)* & - zroots_unity(2:min(k,nn-k)) - k = 2*k - END DO - END FUNCTION zroots_unity - - FUNCTION outerprod_r(a,b) - REAL (sp), DIMENSION (:), INTENT (IN) :: a, b - REAL (sp), DIMENSION (size(a),size(b)) :: outerprod_r - - outerprod_r = spread(a,dim=2,ncopies=size(b))* & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerprod_r - - FUNCTION outerdiv(a,b) - REAL (sp), DIMENSION (:), INTENT (IN) :: a, b - REAL (sp), DIMENSION (size(a),size(b)) :: outerdiv - - outerdiv = spread(a,dim=2,ncopies=size(b))/spread(b,dim=1,ncopies=size & - (a)) - END FUNCTION outerdiv - - FUNCTION outersum(a,b) - REAL (sp), DIMENSION (:), INTENT (IN) :: a, b - REAL (sp), DIMENSION (size(a),size(b)) :: outersum - - outersum = spread(a,dim=2,ncopies=size(b)) + & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outersum - - FUNCTION outerdiff_r(a,b) - REAL (sp), DIMENSION (:), INTENT (IN) :: a, b - REAL (sp), DIMENSION (size(a),size(b)) :: outerdiff_r - - outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerdiff_r - - FUNCTION outerdiff_i(a,b) - INTEGER (i4b), DIMENSION (:), INTENT (IN) :: a, b - INTEGER (i4b), DIMENSION (size(a),size(b)) :: outerdiff_i - - outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerdiff_i - - FUNCTION outerand(a,b) - LOGICAL (lgt), DIMENSION (:), INTENT (IN) :: a, b - LOGICAL (lgt), DIMENSION (size(a),size(b)) :: outerand - - outerand = spread(a,dim=2,ncopies=size(b)) .AND. & - spread(b,dim=1,ncopies=size(a)) - END FUNCTION outerand - - SUBROUTINE scatter_add_r(dest,source,dest_index) - REAL (sp), DIMENSION (:), INTENT (OUT) :: dest - REAL (sp), DIMENSION (:), INTENT (IN) :: source - INTEGER (i4b), DIMENSION (:), INTENT (IN) :: dest_index - INTEGER (i4b) :: m, n, j, i - - n = assert_eq2(size(source),size(dest_index),'scatter_add_r') - m = size(dest) - DO j = 1, n - i = dest_index(j) - IF (i>0 .AND. i<=m) dest(i) = dest(i) + source(j) - END DO - END SUBROUTINE scatter_add_r - SUBROUTINE scatter_max_r(dest,source,dest_index) - REAL (sp), DIMENSION (:), INTENT (OUT) :: dest - REAL (sp), DIMENSION (:), INTENT (IN) :: source - INTEGER (i4b), DIMENSION (:), INTENT (IN) :: dest_index - INTEGER (i4b) :: m, n, j, i - - n = assert_eq2(size(source),size(dest_index),'scatter_max_r') - m = size(dest) - DO j = 1, n - i = dest_index(j) - IF (i>0 .AND. i<=m) dest(i) = max(dest(i),source(j)) - END DO - END SUBROUTINE scatter_max_r - - SUBROUTINE diagadd_rv(mat,diag) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - REAL (sp), DIMENSION (:), INTENT (IN) :: diag - INTEGER (i4b) :: j, n - - n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') - DO j = 1, n - mat(j,j) = mat(j,j) + diag(j) - END DO - END SUBROUTINE diagadd_rv - - SUBROUTINE diagadd_r(mat,diag) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - REAL (sp), INTENT (IN) :: diag - INTEGER (i4b) :: j, n - - n = min(size(mat,1),size(mat,2)) - DO j = 1, n - mat(j,j) = mat(j,j) + diag - END DO - END SUBROUTINE diagadd_r - - SUBROUTINE diagmult_rv(mat,diag) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - REAL (sp), DIMENSION (:), INTENT (IN) :: diag - INTEGER (i4b) :: j, n - - n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') - DO j = 1, n - mat(j,j) = mat(j,j)*diag(j) - END DO - END SUBROUTINE diagmult_rv - - SUBROUTINE diagmult_r(mat,diag) - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - REAL (sp), INTENT (IN) :: diag - INTEGER (i4b) :: j, n - - n = min(size(mat,1),size(mat,2)) - DO j = 1, n - mat(j,j) = mat(j,j)*diag - END DO - END SUBROUTINE diagmult_r - - FUNCTION get_diag_rv(mat) - REAL (sp), DIMENSION (:,:), INTENT (IN) :: mat - REAL (sp), DIMENSION (size(mat,1)) :: get_diag_rv - INTEGER (i4b) :: j - - j = assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') - DO j = 1, size(mat,1) - get_diag_rv(j) = mat(j,j) - END DO - END FUNCTION get_diag_rv - - SUBROUTINE put_diag_rv(diagv,mat) - REAL (sp), DIMENSION (:), INTENT (IN) :: diagv - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - INTEGER (i4b) :: j, n - - n = assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') - DO j = 1, n - mat(j,j) = diagv(j) - END DO - END SUBROUTINE put_diag_rv - - SUBROUTINE put_diag_r(scal,mat) - REAL (sp), INTENT (IN) :: scal - REAL (sp), DIMENSION (:,:), INTENT (INOUT) :: mat - INTEGER (i4b) :: j, n - - n = min(size(mat,1),size(mat,2)) - DO j = 1, n - mat(j,j) = scal - END DO - END SUBROUTINE put_diag_r - - void put_diag(std::vector diagv, std::vector> &mat) { - n = assert_eq2(diagv.size(), std::min(mat.size(), mat[0].size())); - for (int i = 0; i < n; i++) { - mat[i][i] = diagv[i]; - } - } - - void unit_matrix(std::vector> &mat) { - - int n = std::min(mat.size(), mat[0].size()); - for (int i = 0; i < mat.size(); i++) { - for (int j = 0; j < mat[0].size(); j++) { - mat[i][j] = 0.0; - } - if (i < n) { - mat[i][i] = 1.0; - } - } - } - - bool upper_triangle(int j, int k, int extra = 0) { - return (outerdiff(arth_i(1,1,j),arth_i(1,1,k))-extra); - } - - float vabs(float* v, int size) { - float vabs = 0.0; - for (int i = 0; i < size; i++) { - vabs += v[i] * v[i]; - } - return sqrt(vabs); - } - -} \ No newline at end of file diff --git a/src/output_utilities.c b/src/output_utilities.c deleted file mode 100644 index 6e00665..0000000 --- a/src/output_utilities.c +++ /dev/null @@ -1,220 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -! Purpose: Output utilities. -! History: - Creation (06.10.1999, Matthias Krack) -! - CP2K by JH 21.08.2000 - -MODULE output_utilities - - IMPLICIT NONE - - PRIVATE - PUBLIC :: print_message, print_warning - - INTEGER, PARAMETER :: out = 6 - -CONTAINS - -!****************************************************************************** - -! Purpose: Write a message string to the logical output unit lunit. -! History: - Creation (28.08.1996, Matthias Krack) -! - Translated to Fortran 90/95 (07.10.1999, Matthias Krack) -! - CP2K by JH 21.08.2000 - -SUBROUTINE print_message ( message, lunit, declev, before, after ) - -! *************************************************************************** - -! after : Number of empty lines after the message. -! before : Number of empty lines before the message. -! declev : Decoration level (0,1,2, ... star lines). -! lunit : Number of the logical output unit. -! message: String with the message text. - -! *************************************************************************** - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: message - INTEGER, INTENT ( IN ), OPTIONAL :: after, before, declev, lunit - -! Locals - CHARACTER ( LEN = 12 ) :: fmtstr1 - CHARACTER ( LEN = 23 ) :: fmtstr2 - INTEGER :: blank_lines_after, blank_lines_before, decoration_level - INTEGER :: i, ibreak, ipos1, ipos2, maxrowlen - INTEGER :: msglen, nrow, output_unit, rowlen - -!------------------------------------------------------------------------------ - -! IF (my_pe /= io_pe) RETURN - - IF ( PRESENT ( after ) ) THEN - blank_lines_after = MAX ( after, 0 ) - ELSE - blank_lines_after = 1 - END IF - - IF ( PRESENT ( before ) ) THEN - blank_lines_before = MAX ( before, 0 ) - ELSE - blank_lines_before = 1 - END IF - - IF ( PRESENT ( declev ) ) THEN - decoration_level = MAX ( declev, 0 ) - ELSE - decoration_level = 0 - END IF - - IF ( PRESENT ( lunit ) ) THEN - output_unit = lunit - IF ( output_unit < 1 ) output_unit = out - ELSE - output_unit = out - END IF - - IF ( decoration_level == 0) THEN - rowlen = 78 - ELSE - rowlen = 70 - END IF - - msglen = LEN_TRIM ( message ) - -! *** Calculate number of rows *** - - nrow = msglen / ( rowlen + 1 ) + 1 - -! *** Calculate appropriate row length *** - - rowlen = MIN ( msglen, msglen / nrow, rowlen ) - -! *** Generate the blank lines before the message *** - - DO i = 1, blank_lines_before - WRITE ( output_unit, ' ( )' ) - END DO - -! *** Scan for the longest row *** - - ipos1 = 1 - ipos2 = rowlen - maxrowlen = 0 - - DO - IF ( ipos2 < msglen) THEN - ibreak = ipos1 & - + INDEX ( message ( ipos1:ipos2 ), " ", BACK = .TRUE. ) - 2 - ELSE - ibreak = ipos2 - END IF - - maxrowlen = MAX ( maxrowlen, ibreak - ipos1 + 1) - - ipos1 = ibreak + 2 - ipos2 = MIN ( msglen, ipos1 + rowlen - 1) - -! *** When the last row is processed, exit loop *** - - IF ( ipos1 > msglen) EXIT - - END DO - -! *** Generate the first set of star rows *** - - IF ( decoration_level > 1) THEN - fmtstr1 = '( T2, ("*") )' - WRITE ( fmtstr1 ( 5:6 ), '( I2 )' ) maxrowlen + 8 - DO i = 1, decoration_level - 1 - WRITE ( output_unit, fmtstr1 ) - END DO - END IF - -! *** Break long messages *** - - ipos1 = 1 - ipos2 = rowlen - - DO - IF ( ipos2 < msglen ) THEN - ibreak = ipos1 & - + INDEX ( message ( ipos1:ipos2 ), " ", BACK = .TRUE. ) - 2 - ELSE - ibreak = ipos2 - END IF - - IF ( decoration_level == 0 ) THEN - WRITE ( output_unit, '( T2, A )' ) message ( ipos1:ibreak ) - ELSE IF ( decoration_level > 0 ) THEN - fmtstr2 = '( T2, "*** ", A, X, "***" )' - WRITE ( fmtstr2 ( 14:15 ), '( I2 )' ) ipos1 + maxrowlen - ibreak - WRITE ( output_unit, fmtstr2 ) message ( ipos1:ibreak ) - END IF - - ipos1 = ibreak + 2 - ipos2 = MIN ( msglen, ipos1 + rowlen - 1 ) - -! *** When the last row is processed, exit loop *** - - IF ( ipos1 > msglen ) EXIT - - END DO - -! *** Generate the second set star rows *** - - IF ( decoration_level > 1 ) THEN - DO i = 1, decoration_level - 1 - WRITE ( output_unit, fmtstr1 ) - END DO - END IF - -! *** Generate the blank lines after the message *** - - DO i = 1, blank_lines_after - WRITE ( output_unit, '( )' ) - END DO - -END SUBROUTINE print_message - -!****************************************************************************** - -! Purpose: Print a warning message. -! History: - Creation (28.08.1996, Matthias Krack) -! - Translated to Fortran 90/95 (07.10.1999, Matthias Krack) -! - CP2K by JH 21.08.2000 - -SUBROUTINE print_warning ( routine, message, lunit ) - -! *************************************************************************** - -! message: Message text. -! routine: Name of the calling routine. -! lunit : Output unit - -! *************************************************************************** - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: message, routine - INTEGER, INTENT ( IN ), OPTIONAL :: lunit - - INTEGER :: io -!------------------------------------------------------------------------------ - - IF(PRESENT(lunit)) THEN - io = lunit - ELSE - io = out - ENDIF - - CALL print_message ( "WARNING in " // TRIM ( routine ), io, 1, 2, 0 ) - CALL print_message ( message, io, 1, 1, 1 ) - -END SUBROUTINE print_warning - -!****************************************************************************** - -END MODULE output_utilities diff --git a/src/pair_potential.c b/src/pair_potential.c deleted file mode 100644 index 506ce46..0000000 --- a/src/pair_potential.c +++ /dev/null @@ -1,298 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE pair_potential - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE kinds, ONLY : dbl - USE mathconstants, ONLY : zero, pi - USE particle_types, ONLY : particle_prop_type - USE splines, ONLY : init_spline, init_splinexy, & - spline, spline_1, kill_spline, spline_data, splineh - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: get_potrange, potential_f, potential_s, ener_coul - PUBLIC :: potentialparm_type, spline_nonbond_control - PUBLIC :: lj_pot_type, williams_pot_type, goodwin_pot_type - - TYPE lj_pot_type - REAL ( dbl ) :: epsilon - REAL ( dbl ) :: sigma6 - REAL ( dbl ) :: sigma12 - END TYPE lj_pot_type - - TYPE williams_pot_type - REAL ( dbl ) :: a - REAL ( dbl ) :: b - REAL ( dbl ) :: c - END TYPE williams_pot_type - - TYPE goodwin_pot_type - REAL ( dbl ) :: vr0 - REAL ( dbl ) :: m, mc - REAL ( dbl ) :: d, dc - END TYPE goodwin_pot_type - - TYPE potentialparm_type - CHARACTER ( LEN = 40 ) :: type - TYPE (lj_pot_type ) :: lj - TYPE (williams_pot_type ) :: willis - TYPE (goodwin_pot_type ) :: goodwin - REAL ( dbl ) :: rcutsq - REAL ( dbl ) :: energy_cutoff - REAL ( dbl ) :: e_cutoff_coul - REAL ( dbl ) :: lrc - END TYPE potentialparm_type - -! look-up table (i,j)->n - INTEGER, DIMENSION ( :, : ), ALLOCATABLE, SAVE :: spltab - -! splines for interaction n - TYPE ( spline_data ), DIMENSION ( : ), POINTER, SAVE :: spline_table - -CONTAINS - -!****************************************************************************** - -FUNCTION get_potrange ( potparm ) RESULT ( potrange ) - - IMPLICIT NONE - -! Result - REAL ( dbl ) :: potrange - -! Arguments - TYPE ( potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -!------------------------------------------------------------------------------ - - potrange = MAXVAL( abs ( potparm ( :, : ) % rcutsq ) ) - potrange = SQRT ( potrange ) - -END FUNCTION get_potrange - -!****************************************************************************** - -FUNCTION ener_pot ( pot, qi, qj, r ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: qi, qj, r - TYPE (potentialparm_type ), INTENT ( IN ) :: pot - -! Locals - REAL ( dbl ) :: ener_pot, scale - -!------------------------------------------------------------------------------ - - IF (pot%type=='LENNARD-JONES') THEN - ener_pot = 4.0_dbl*pot%lj%epsilon*(pot%lj%sigma12*r**(-12)-pot%lj% & - sigma6*r**(-6)) - pot%energy_cutoff - ELSE IF (pot%type=='WILLIAMS') THEN - ener_pot = pot%willis%a*exp(-pot%willis%b*r) - pot%willis%c/r**6 & - - pot%energy_cutoff - ELSE IF (pot%type=='GOODWIN') THEN - scale = exp(pot%goodwin%m*(-(r/pot%goodwin%dc)**pot%goodwin%mc+(pot% & - goodwin%d/pot%goodwin%dc)**pot%goodwin%mc)) - ener_pot = scale*pot%goodwin%vr0*(pot%goodwin%d/r)**pot%goodwin%m - ELSE - CALL stop_prg("pair_potential%ener_pot","Potential type unknown") - END IF - -END FUNCTION ener_pot - -!****************************************************************************** - -FUNCTION ener_coul ( pot, qi, qj, r, ewald_param ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: qi, qj, r - TYPE (potentialparm_type ), INTENT ( IN ) :: pot - TYPE (ewald_parameters_type ), INTENT ( IN ) :: ewald_param - -! Locals - EXTERNAL erfc - REAL ( dbl ) :: ener_coul, erfc - REAL ( dbl ), PARAMETER :: ifourpi = 1.0_dbl / ( 4.0_dbl * pi ) - REAL ( dbl ), PARAMETER:: eps = 1.0E-6_dbl - -!------------------------------------------------------------------------------ - - SELECT CASE( ewald_param % ewald_type ) - CASE( 'EWALD_GAUSS', 'PME_GAUSS' ) - ener_coul = ifourpi / ewald_param % eps0 * qi * qj & - * erfc ( ewald_param % alpha * r ) / r - pot % e_cutoff_coul - CASE( 'NONE') - ener_coul= 0._dbl - END SELECT - -END FUNCTION ener_coul - -!****************************************************************************** - -! creates the splines for the potentials - -SUBROUTINE spline_nonbond_control ( potparm, pstat, npoints, ewald_param ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: npoints - TYPE (potentialparm_type ), INTENT ( INOUT ), DIMENSION ( :, : ) :: potparm - TYPE (particle_prop_type ), INTENT ( IN ) :: pstat ( : ) - TYPE (ewald_parameters_type ), INTENT ( IN ) :: ewald_param - -! Locals - LOGICAL, SAVE :: first_visit = .TRUE. - INTEGER :: ntype, ntab, n, i, j, jx, isos - REAL ( dbl ) :: qi, qj, e, ee, x, x2, dx2, locut, hicut, a, cutmax, cutmin - -!------------------------------------------------------------------------------ - - ntype = SIZE ( potparm, 1 ) - ntab = ( ntype * ntype + ntype ) / 2 - - IF ( first_visit ) THEN - NULLIFY ( spline_table ) - first_visit = .FALSE. - END IF - - IF ( ASSOCIATED ( spline_table ) ) THEN - DO i = 1, ntab - CALL kill_spline ( spline_table(i), 'a' ) - END DO - DEALLOCATE ( spline_table, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'spline_nonbond_control', & - 'spline_table' ) - NULLIFY ( spline_table ) - END IF - - ALLOCATE ( spline_table ( ntab ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'spline_nonbond_control', & - 'spline_table', ntab ) - DO i = 1, ntab - NULLIFY ( spline_table(i) % x ) - NULLIFY ( spline_table(i) % y ) - NULLIFY ( spline_table(i) % y2 ) - END DO - IF ( ALLOCATED ( spltab ) ) THEN - DEALLOCATE ( spltab, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'spline_nonbond_control', 'spltab' ) - END IF - ALLOCATE ( spltab ( ntype, ntype ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'spline_nonbond_control', & - 'spltab', ntype ** 2 ) - - cutmin = 1.0E+30_dbl - cutmax = 0.0_dbl - n = 0 - DO i = 1, ntype ! i: first atom type - qi = pstat(i) %charge - DO j = i, ntype ! j: second atom type - qj = pstat(j) %charge - n = n + 1 - spltab(i,j) = n - spltab(j,i) = n -!ODER: n=j+(i-1)*n-(i-1)*i/2 mit j>=i - CALL init_splinexy(spline_table(n),npoints+1) - - IF (potparm(i,j)%type=='LENNARD-JONES') THEN - locut = 0.5_dbl - ELSE IF (potparm(i,j)%type=='WILLIAMS') THEN - locut = 0.5 ! else put locut to 0.5 Angstrom - ELSE - locut = 0.5 ! else put locut to 0.5 Angstrom - END IF - hicut = sqrt(potparm(i,j)%rcutsq) - IF ( hicut > cutmax ) cutmax = hicut - IF ( locut < cutmin ) cutmin = locut - - potparm(i,j) %energy_cutoff = ener_pot(potparm(i,j),qi,qj,hicut) - potparm(i,j) %e_cutoff_coul & - = ener_coul ( potparm ( i, j ), qi, qj, hicut, ewald_param ) - - dx2 = (hicut**2-locut**2)/real(npoints) - x2 = locut**2 - DO jx = 1, npoints + 1 ! jx: loop over distance**2 - x = SQRT ( x2 ) - e = ener_pot ( potparm ( i, j ), qi, qj, x ) & - + ener_coul ( potparm ( i, j ), qi, qj, x, ewald_param ) - spline_table(n) %x(jx) = x2 - spline_table(n) %y(jx) = e - x2 = x2 + dx2 - END DO ! jx: loop over distance - - CALL init_spline(spline_table(n),'s') - - END DO ! j: second atom type - END DO ! i: first atom type - -END SUBROUTINE spline_nonbond_control - -!****************************************************************************** - -! calculates energy=V(r^2) and fscalar=-V^{prime}(r^2)/r -! qi,qj are not used any more. only kept to have same args as potential() - -SUBROUTINE potential_s ( rijsq, potparm, iatom, jatom, energy, fscalar ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ) :: rijsq - REAL ( dbl ), INTENT ( OUT ) :: energy, fscalar - INTEGER, INTENT ( IN ) :: iatom, jatom - TYPE (potentialparm_type ), DIMENSION ( :, : ), INTENT ( IN ) :: potparm - -!------------------------------------------------------------------------------ - - energy = splineh ( spline_table ( spltab ( iatom, jatom ) ), rijsq, fscalar ) - fscalar = -2.0_dbl * fscalar - -END SUBROUTINE potential_s - -!****************************************************************************** - -SUBROUTINE potential_f ( rijsq, potparm, qi, qj, iatom, jatom, energy, & - ewald_param ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: iatom, jatom - REAL ( dbl ), INTENT ( IN ) :: rijsq - REAL ( dbl ), INTENT ( OUT ) :: energy - REAL ( dbl ), INTENT ( IN ) :: qi, qj - TYPE (potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - TYPE (ewald_parameters_type ), INTENT ( IN ), OPTIONAL :: ewald_param - -! Locals - REAL ( dbl ) :: rij - -!------------------------------------------------------------------------------ - - rij = SQRT ( rijsq ) - -! non-bond energy - energy = ener_pot ( potparm ( iatom, jatom ), qi, qj, rij ) - -! real-space ewald non-bond energy - IF ( PRESENT ( ewald_param ) ) THEN - energy = energy & - + ener_coul ( potparm ( iatom, jatom ), qi, qj, rij, ewald_param ) - END IF - -END SUBROUTINE potential_f - -!****************************************************************************** - -END MODULE pair_potential - diff --git a/src/parallel.c b/src/parallel.c deleted file mode 100644 index 1ea54a3..0000000 --- a/src/parallel.c +++ /dev/null @@ -1,49 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE parallel - - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE mp, ONLY : mp_start, mp_environ, mp_end - - PRIVATE - PUBLIC :: start_parallel, end_parallel - -CONTAINS - -!****************************************************************************** - -SUBROUTINE start_parallel ( globenv ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ) :: globenv - -!------------------------------------------------------------------------------ - - CALL mp_start() - CALL mp_environ(globenv % num_pe,globenv % mepos,globenv % group) - globenv % source = 0 - globenv % ionode = (globenv % mepos==globenv % source) - -END SUBROUTINE start_parallel - -!****************************************************************************** - -SUBROUTINE end_parallel() - - IMPLICIT NONE - -!------------------------------------------------------------------------------ - - CALL mp_end() - -END SUBROUTINE end_parallel - -!****************************************************************************** - -END MODULE parallel diff --git a/src/parallel_include.c b/src/parallel_include.c deleted file mode 100644 index d0d3114..0000000 --- a/src/parallel_include.c +++ /dev/null @@ -1,26 +0,0 @@ -c-----------------------------------------------------------------------------! -c CP2K: A general program to perform molecular dynamics simulations ! -c Copyright (C) 2000 CP2K developers group ! -c-----------------------------------------------------------------------------! -c -c This is a fixed format file -c -c------------------------------------------------------------------------------ -c -c Holds External information for Message Passing Systems -c -c------------------------------------------------------------------------------ - - MODULE parallel_include -#if defined(__parallel) -c -c Include file for MPI -c - INCLUDE 'mpif.h' -#endif - - PUBLIC - - INTEGER :: nothing - - END MODULE parallel_include diff --git a/src/parser.cpp b/src/parser.cpp deleted file mode 100644 index f2415dd..0000000 --- a/src/parser.cpp +++ /dev/null @@ -1,737 +0,0 @@ -/*----------------------------------------------------------------------------| -| CP2K: A general program to perform molecular dynamics simulations | -| Copyright (C) 2024 CP2K developers group | -|-----------------------------------------------------------------------------| -|-----------------------------------------------------------------------------| -| > F R E E - F O R M A T I N P U T R O U T I N E S | -| | -| Function INSCAN(iunit,label) : looks for an input dection started by | -| label un file associated with unit iunit | -| Subroutine READ_LINE(iunit) : reads an input line, physical end of lines | -| can be masked by a & character, no further | -| characters are alowed to the right | -| Function TEST_NEXT() : tests contains of next input field, return values| -| are : E (blank); C (text); N (number); | -| K (bracket); S (! comment); X (&END); | -| O all other | -| Subroutine CFIELD(string,length) : extracts the next field from the | -| input line, at most length charcters | -| are returned in string, if length is 0 | -| the full field is returned, possible | -| field seperators are: blank, comma, | -| colon, semicolon, bracket, equal sign | -| Subroutine P_ERROR : writes out current input line and current position | -| within the line, does not stop code | -| Function GET_INT() : read an integer from the input line | -| Function GET_REAL() : read an real value from the input line | -| ionode; - parallel_io = true; - parenv = *globenv; - } else { - ionode = true; - parallel_io = false; - } - - if (ionode) { - //..find a not associated unit - iunit = get_unit(); - line = blank; - } - -} - -!****************************************************************************** - -SUBROUTINE parser_end - - IMPLICIT NONE - - IF(ionode) CLOSE ( UNIT = iunit ) - -END SUBROUTINE parser_end - -!****************************************************************************** - -SUBROUTINE read_line - IMPLICIT NONE - INTEGER :: llen, i, j, ii, ios - CHARACTER ( LEN = 132 ) :: line - CHARACTER ( LEN = 1 ) :: last - LOGICAL :: comment - -!------------------------------------------------------------------------------ - - IF(ionode) THEN - -!..skip all empty lines - llen = 0 - DO WHILE (llen==0) - READ (iunit,iostat=ios,fmt='(a )' ) line - IF ( ios /= 0 ) CALL stop_parser ( 'read_line','error while reading file') - llen = len_trim(line) - END DO - -!..now read the input line - last = line(llen:llen) - num_inp_line = 1 - inp_line(num_inp_line) = line - - DO WHILE (last==newline) - IF (num_inp_line>=max_line) CALL stop_parser ( 'read_line','max_line') - READ (iunit,iostat=ios,fmt='(a )' ) line - IF ( ios /= 0 ) CALL stop_parser ( 'read_line','error while reading file') - llen = len_trim(line) - last = line(llen:llen) - num_inp_line = num_inp_line + 1 - inp_line(num_inp_line) = line - END DO - -!..delete newline characters - DO i = 1, num_inp_line - 1 - llen = len_trim(inp_line(i)) - inp_line(i) (llen:llen) = blank - END DO - -!..delete empty lines - j = 0 - DO i = 1, num_inp_line - llen = len_trim(inp_line(i)) - IF (llen>0) THEN - j = j + 1 - IF (j/=i) inp_line(j) = inp_line(i) - END IF - END DO - - num_inp_line = j - -!..convert all delimiter characters to blanks - DO i = 1, num_inp_line - llen = len_trim(inp_line(i)) - DO j = 1, llen - SELECT CASE (inp_line(i)(j:j)) - CASE DEFAULT - CASE ( '=') - inp_line(i) (j:j) = blank - CASE ( ',') - inp_line(i) (j:j) = blank - CASE ( ':') - inp_line(i) (j:j) = blank - CASE ( ';') - inp_line(i) (j:j) = blank - END SELECT - END DO - END DO - -!..delete multiple blanks - DO i = 1, num_inp_line - CALL compress ( inp_line ( i ) ) - END DO - -!..delete comment sections - DO i = 1, num_inp_line - line = blank - llen = len_trim(inp_line(i)) - ii = 0 - comment = .FALSE. - DO j = 1, llen - IF (inp_line(i)(j:j)=='!' .AND. .NOT. comment) THEN - comment = .TRUE. - ELSE IF (inp_line(i)(j:j)=='!' .AND. comment) THEN - comment = .FALSE. - ELSE IF (comment) THEN - ELSE - ii = ii + 1 - line(ii:ii) = inp_line(i) (j:j) - END IF - END DO - END DO - -!..add line seperators - DO i = 1, num_inp_line - 1 - llen = len_trim(inp_line(i)) - inp_line(i) (llen+2:llen+2) = '$' - END DO - IF (num_inp_line>0) THEN - llen = len_trim(inp_line(num_inp_line)) - inp_line(num_inp_line) (llen+2:llen+2) = '%' - END IF - - END IF - -!..distribute the input line to all processors (for parallel parser) - IF(parallel_io) THEN - CALL mp_bcast(num_inp_line,parenv%source,parenv%group) - DO i = 1, num_inp_line - CALL mp_bcast(inp_line(i),parenv%source,parenv%group) - END DO - END IF - -!..initialize pointers - p_line = 1 - p_char = 1 - -END SUBROUTINE read_line - -!****************************************************************************** - -FUNCTION test_next() - - IMPLICIT NONE - -! Locals - CHARACTER ( LEN = 1 ) :: test_next - -!------------------------------------------------------------------------------ - - SELECT CASE (inp_line(p_line)(p_char:p_char)) - CASE (blank) - test_next = 'E' - CASE ( 'A':'Z') - test_next = 'C' - CASE ( 'a':'z') - test_next = 'C' - CASE ( '0':'9') - test_next = 'N' - CASE ( '+') - test_next = 'N' - CASE ( '-') - test_next = 'N' - CASE ( '.') - test_next = 'N' - CASE ( '[') - test_next = 'K' - CASE ( '!') - test_next = 'S' - CASE ( '%') - test_next = 'P' - CASE DEFAULT - test_next = 'O' - END SELECT - IF (test_next=='O') THEN - IF (inp_line(p_line)(p_char:p_char+3)=='&END') test_next = 'X' - END IF -END FUNCTION test_next - -!****************************************************************************** - -SUBROUTINE cfield ( string, length ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( INOUT ) :: string - INTEGER, INTENT ( INOUT ) :: length - -! Locals - CHARACTER ( LEN = 1 ) :: char1 - INTEGER :: l, ll, i, ii - -!------------------------------------------------------------------------------ - - string = blank - IF (length==0) length = 999 - l = len(inp_line(p_line)(p_char:)) - ll = length - IF (l EPSILON ( rival ) ) THEN - CALL p_error() - CALL stop_parser ( 'get_int','not an integer field') - END IF - -END FUNCTION get_int - -!****************************************************************************** - -FUNCTION get_real() RESULT ( reval ) - - IMPLICIT NONE - -!..most general format : I((sign)_._E(sign)_/(sign)_._E(sign)_) - -! Return value - REAL ( dbl ) :: reval - -! Locals - REAL ( dbl ) :: xx, v1, v2 - REAL ( dbl ), SAVE :: value - LOGICAL, SAVE :: repetition - INTEGER, SAVE :: rep_num - CHARACTER ( LEN = 256 ) :: string - INTEGER :: ie, llen, state, ii - REAL ( dbl ) :: s1, s2, e1, e2, se1, se2, x1, x2, y1, y2 - -!------------------------------------------------------------------------------ - - IF (repetition) THEN - reval = value - rep_num = rep_num - 1 - IF (rep_num==0) repetition = .FALSE. - ELSE - s1 = one - s2 = one - e1 = zero - e2 = zero - se1 = one - se2 = one - x1 = zero - x2 = one - y1 = zero - y2 = zero - IF (test_next()/='N') THEN - CALL p_error - CALL stop_parser ( 'get_real','not an numeric field') - END IF - llen = 0 - CALL cfield(string,llen) - ie = scan(string,'(') - IF (ie /= 0 ) THEN - xx = zero - CALL get_num(string(1:ie),xx,llen) - rep_num = nint(xx) - IF (rep_num<=0) THEN - CALL p_error - CALL stop_parser ( 'get_real','non valid repetition number') - END IF - IF (rep_num>1) repetition = .TRUE. - rep_num = rep_num - 1 - string(1:ie) = blank - ie = scan(string,' )' ) - string(ie:) = blank - string = adjustl(string) - END IF - state = 0 - llen = len_trim(string) - ii = 1 - DO WHILE (ii<=llen) - SELECT CASE (string(ii:ii)) - CASE ( '-') - IF (state==0) THEN - s1 = -one - state = 1 - ii = ii + 1 - ELSE IF (state==5) THEN - se1 = -one - state = 6 - ii = ii + 1 - ELSE IF (state==8) THEN - s2 = -one - state = 9 - ii = ii + 1 - ELSE IF (state==13) THEN - se2 = -one - state = 14 - ii = ii + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE ( '+') - IF (state==0) THEN - state = 1 - ii = ii + 1 - ELSE IF (state==5) THEN - state = 6 - ii = ii + 1 - ELSE IF (state==8) THEN - state = 9 - ii = ii + 1 - ELSE IF (state==13) THEN - state = 14 - ii = ii + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE ( '.') - IF (state<=2) THEN - state = 3 - ii = ii + 1 - ELSE IF (state>7 .AND. state<=10) THEN - state = 11 - ii = ii + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE ( 'E', 'e', 'D', 'd' ) - IF (state>=2 .AND. state<=4) THEN - state = 5 - ii = ii + 1 - ELSE IF (state>=10 .AND. state<=12) THEN - state = 13 - ii = ii + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE ( '/') - x2 = zero - IF (state>=2 .AND. state<=4) THEN - state = 8 - ii = ii + 1 - ELSE IF (state==7) THEN - state = 8 - ii = ii + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE ( '0':'9') - IF (state==0 .OR. state==1) THEN - CALL get_num(string(ii:),x1,ie) - state = 2 - ii = ii + ie - ELSE IF (state==3) THEN - CALL get_num(string(ii:),y1,ie) - y1 = y1*10._dbl**(-ie) - state = 4 - ii = ii + ie - ELSE IF (state==5 .OR. state==6) THEN - CALL get_num(string(ii:),e1,ie) - state = 7 - ii = ii + ie - ELSE IF (state==8 .OR. state==9) THEN - CALL get_num(string(ii:),x2,ie) - state = 10 - ii = ii + ie - ELSE IF (state==11) THEN - CALL get_num(string(ii:),y2,ie) - y2 = y2*10._dbl**(-ie) - state = 12 - ii = ii + ie - ELSE IF (state==13 .OR. state==14) THEN - CALL get_num(string(ii:),e2,ie) - state = 15 - ii = llen + 1 - ELSE - CALL p_error () - CALL stop_parser ( 'get_real','not a valid number') - END IF - CASE DEFAULT - ii = ii + 1 - END SELECT - END DO - - v1 = s1*(x1+y1)*10._dbl**(se1*e1) - v2 = s2*(x2+y2)*10._dbl**(se2*e2) - IF (abs(v2) -#endif - - -const int max_line = 20; -std::string inp_line[max_line]; -int num_inp_line; -int p_line, p_har; -int iunit; -char newline = '&'; -char blank = ' '; - -bool parallel_io, ionode; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/particle.h b/src/particle.h deleted file mode 100644 index d807080..0000000 --- a/src/particle.h +++ /dev/null @@ -1,36 +0,0 @@ -#ifndef _PARTICLE_H -#define _PARTILCE_H - -#include "linklist.h" - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct particle_prop_type { - double charge; - double mass; - int ptype; - } particle_prop_type; - - typedef struct particle_type { - int iatom; - double r[3]; - double f[3]; - double v[3]; - particle_prop_type *prop; - cell_neighborlist_type *cell; - } particle_type; - - typedef struct particle_list_type { - int particle_index; - double *r; - double *charge; - particle_list_type *next; - } particle_list_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/particle_lists.c b/src/particle_lists.c deleted file mode 100644 index 7e8f045..0000000 --- a/src/particle_lists.c +++ /dev/null @@ -1,81 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE particle_lists - - USE kinds, ONLY : dbl - USE molecule_types, ONLY : particle_node_type - USE stop_program, ONLY : stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: particle_list_type, particle_list_select - - TYPE particle_list_type - INTEGER :: particle_index - REAL ( dbl ), DIMENSION ( : ), POINTER :: r - REAL ( dbl ), POINTER :: charge - TYPE ( particle_list_type ), POINTER :: next - END TYPE particle_list_type - -CONTAINS - -!****************************************************************************** - -SUBROUTINE particle_list_select ( pnode, plist, nparts) - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ), TARGET :: pnode - TYPE ( particle_list_type ), POINTER :: plist - INTEGER , INTENT ( OUT ) :: nparts - -! Locals - INTEGER :: node, nnodes, isos - TYPE ( particle_list_type ), POINTER :: plist_loc - -!------------------------------------------------------------------------------ - - nnodes = SIZE ( pnode ) - - ! 'plist' will always point to the beginning of the list, 'plist_loc' - ! to the current position - NULLIFY ( plist ) - NULLIFY ( plist_loc ) - - nparts = 0 - DO node = 1, nnodes - IF ( pnode ( node ) % p % prop % charge /= 0.0_dbl ) THEN - - IF ( .NOT. ASSOCIATED ( plist_loc ) ) THEN - ALLOCATE ( plist, STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( "get_atom_list", "plist", 0 ) - plist_loc => plist - NULLIFY ( plist_loc % next ) - ELSE - ALLOCATE ( plist_loc % next, STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( "get_atom_list", "next", 0 ) - - plist_loc => plist_loc % next - - NULLIFY ( plist_loc % next ) - END IF - - nparts = nparts + 1 - plist_loc % particle_index = node - plist_loc % r => pnode ( node ) % p % r - plist_loc % charge => pnode ( node ) % p % prop % charge - - END IF - END DO - -END SUBROUTINE particle_list_select - -!****************************************************************************** - -END MODULE particle_lists diff --git a/src/particle_types.c b/src/particle_types.c deleted file mode 100644 index 946c95f..0000000 --- a/src/particle_types.c +++ /dev/null @@ -1,31 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE particle_types - - USE kinds, ONLY : dbl - USE linklist_cell_types, ONLY : cell_neighborlist_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: particle_type, particle_prop_type - - TYPE particle_prop_type - REAL ( dbl ) :: charge - REAL ( dbl ) :: mass - INTEGER :: ptype - END TYPE particle_prop_type - - TYPE particle_type - INTEGER :: iatom - REAL ( dbl ), DIMENSION (3) :: r - REAL ( dbl ), DIMENSION (3) :: f - REAL ( dbl ), DIMENSION (3) :: v - TYPE (particle_prop_type ), POINTER :: prop - TYPE ( cell_neighborlist_type ), POINTER :: cell - END TYPE particle_type - -END MODULE particle_types diff --git a/src/periodic_table.c b/src/periodic_table.c deleted file mode 100644 index f75cb95..0000000 --- a/src/periodic_table.c +++ /dev/null @@ -1,1232 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -!! Periodic Table related data definitions - -MODULE periodic_table - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: init_periodic_table, ptable, atom - - TYPE atom - CHARACTER ( LEN = 2 ) :: symbol - CHARACTER ( LEN = 14 ) :: name - INTEGER :: number - REAL ( dbl ) :: amass ! average mass in formula units - REAL ( dbl ) :: mass ! mass of most abundant isotope in formula units - REAL ( dbl ) :: covalent_radius ! in Angstroms - REAL ( dbl ) :: vdw_radius ! in Angstroms - INTEGER :: e_conv ( 0:3 ) - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: slater_exp - REAL ( dbl ) :: eht_param ( 0:3 ) ! in eV - END TYPE atom - - INTEGER, PARAMETER :: nelem = 106 - TYPE ( atom ) :: ptable ( 0:nelem ) - -CONTAINS - -!****************************************************************************** - -SUBROUTINE init_periodic_table() - - IMPLICIT NONE - REAL ( dbl ), PARAMETER :: z = 0.0_dbl - -!------------------------------------------------------------------------------ - -! Dummy - ptable(0) % symbol = 'X ' - ptable(0) % name = 'Dummy' - ptable(0) % number = 0 - ptable(0) % amass = z - ptable(0) % mass = z - ptable(0) % covalent_radius = z - ptable(0) % vdw_radius = z - ptable(0) % e_conv(0:3) = (/ 0, 0, 0, 0 /) - ptable(0) % eht_param(0:3) = (/ z, z, z, z/) - -! Hydrogen - ptable(1) % symbol = 'H ' - ptable(1) % name = 'Hydrogen' - ptable(1) % number = 1 - ptable(1) % amass = 1.00797_dbl - ptable(1) % mass = 1.007825_dbl - ptable(1) % covalent_radius = 0.32_dbl - ptable(1) % vdw_radius = 1.2_dbl - ptable(1) % e_conv(0:3) = (/ 1, 0, 0, 0 /) - ptable(1) % eht_param(0:3) = (/ -13.60_dbl, z, z, z/) - -! Helium - ptable(2) % symbol = 'He' - ptable(2) % name = 'Helium' - ptable(2) % number = 2 - ptable(2) % amass = 4.00260_dbl - ptable(2) % mass = 4.00260_dbl - ptable(2) % covalent_radius = 0.9300_dbl - ptable(2) % vdw_radius = z - ptable(2) % e_conv(0:3) = (/ 2, 0, 0, 0 /) - ptable(2) % eht_param(0:3) = (/ -23.40_dbl, z, z, z/) - -! Lithium - ptable(3) % symbol = 'Li' - ptable(3) % name = 'Lithium' - ptable(3) % number = 3 - ptable(3) % amass = 6.93900_dbl - ptable(3) % mass = 7.01600_dbl - ptable(3) % covalent_radius = 1.2300_dbl - ptable(3) % vdw_radius = z - ptable(3) % e_conv(0:3) = (/ 3, 0, 0, 0 /) - ptable(3) % eht_param(0:3) = (/ -5.40_dbl, -3.50_dbl, z, z/) - -! Beryllium - ptable(4) % symbol = 'Be' - ptable(4) % name = 'Beryllium' - ptable(4) % number = 4 - ptable(4) % amass = 9.01220_dbl - ptable(4) % mass = 9.01218_dbl - ptable(4) % covalent_radius = 0.9000_dbl - ptable(4) % vdw_radius = z - ptable(4) % e_conv(0:3) = (/ 4, 0, 0, 0 /) - ptable(4) % eht_param(0:3) = (/ -10.00_dbl, -6.00_dbl, z, z/) - -! Boron - ptable(5) % symbol = 'B ' - ptable(5) % name = 'Boron' - ptable(5) % number = 5 - ptable(5) % amass = 10.81100_dbl - ptable(5) % mass = 11.00931_dbl - ptable(5) % covalent_radius = 0.8200_dbl - ptable(5) % vdw_radius = z - ptable(5) % e_conv(0:3) = (/ 4, 1, 0, 0 /) - ptable(5) % eht_param(0:3) = (/ -15.20_dbl, -8.50_dbl, z, z/) - -! Carbon - ptable(6) % symbol = 'C ' - ptable(6) % name = 'Carbon' - ptable(6) % number = 6 - ptable(6) % amass = 12.01115_dbl - ptable(6) % mass = 12.0000_dbl - ptable(6) % covalent_radius = 0.7700_dbl - ptable(6) % vdw_radius = z - ptable(6) % e_conv(0:3) = (/ 4, 2, 0, 0 /) - ptable(6) % eht_param(0:3) = (/ -21.40_dbl, -11.40_dbl, z, z/) - -! Nitrogen - ptable(7) % symbol = 'N ' - ptable(7) % name = 'Nitrogen' - ptable(7) % number = 7 - ptable(7) % amass = 14.00670_dbl - ptable(7) % mass = 14.00307_dbl - ptable(7) % covalent_radius = 0.7500_dbl - ptable(7) % vdw_radius = 1.5_dbl - ptable(7) % e_conv(0:3) = (/ 4, 3, 0, 0 /) - ptable(7) % eht_param(0:3) = (/ -26.00_dbl, -13.40_dbl, z, z/) - -! Oxygen - ptable(8) % symbol = 'O ' - ptable(8) % name = 'Oxygen' - ptable(8) % number = 8 - ptable(8) % amass = 15.99940_dbl - ptable(8) % mass = 15.99491_dbl - ptable(8) % covalent_radius = 0.7300_dbl - ptable(8) % vdw_radius = 1.40_dbl - ptable(8) % e_conv(0:3) = (/ 4, 4, 0, 0 /) - ptable(8) % eht_param(0:3) = (/ -32.30_dbl, -14.80_dbl, z, z/) - -! Fluorine - ptable(9) % symbol = 'F ' - ptable(9) % name = 'Fluorine' - ptable(9) % number = 9 - ptable(9) % amass = 18.99840_dbl - ptable(9) % mass = 18.99840_dbl - ptable(9) % covalent_radius = 0.7200_dbl - ptable(9) % vdw_radius = 1.35_dbl - ptable(9) % e_conv(0:3) = (/ 4, 5, 0, 0 /) - ptable(9) % eht_param(0:3) = (/ -40.00_dbl, -18.10_dbl, z, z/) - -! Neon - ptable(10) % symbol = 'Ne' - ptable(10) % name = 'Neon' - ptable(10) % number = 10 - ptable(10) % amass = 20.18300_dbl - ptable(10) % mass = 19.99244_dbl - ptable(10) % covalent_radius = 0.7100_dbl - ptable(10) % vdw_radius = z - ptable(10) % e_conv(0:3) = (/ 4, 6, 0, 0 /) - ptable(10) % eht_param(0:3) = (/ -43.20_dbl, -20.00_dbl, z, z/) - -! Sodium - ptable(11) % symbol = 'Na' - ptable(11) % name = 'Sodium' - ptable(11) % number = 11 - ptable(11) % amass = 22.98980_dbl - ptable(11) % mass = 22.9898_dbl - ptable(11) % covalent_radius = 1.5400_dbl - ptable(11) % vdw_radius = z - ptable(11) % e_conv(0:3) = (/ 5, 6, 0, 0 /) - ptable(11) % eht_param(0:3) = (/ -5.10_dbl, -3.00_dbl, z, z/) - -! Magnesium - ptable(12) % symbol = 'Mg' - ptable(12) % name = 'Magnesium' - ptable(12) % number = 12 - ptable(12) % amass = 24.31200_dbl - ptable(12) % mass = 23.98504_dbl - ptable(12) % covalent_radius = 1.3600_dbl - ptable(12) % vdw_radius = z - ptable(12) % e_conv(0:3) = (/ 6, 6, 0, 0 /) - ptable(12) % eht_param(0:3) = (/ -9.00_dbl, -4.50_dbl, z, z/) - -! Aluminium - ptable(13) % symbol = 'Al' - ptable(13) % name = 'Aluminium' - ptable(13) % number = 13 - ptable(13) % amass = 26.98153_dbl - ptable(13) % mass = 26.98153_dbl - ptable(13) % covalent_radius = 1.1800_dbl - ptable(13) % vdw_radius = z - ptable(13) % e_conv(0:3) = (/ 6, 7, 0, 0 /) - ptable(13) % eht_param(0:3) = (/ -12.30_dbl, -6.50_dbl, z, z/) - -! Silicon - ptable(14) % symbol = 'Si' - ptable(14) % name = 'Silicon' - ptable(14) % number = 14 - ptable(14) % amass = 28.08600_dbl - ptable(14) % mass = 27.97693_dbl - ptable(14) % covalent_radius = 1.1100_dbl - ptable(14) % vdw_radius = z - ptable(14) % e_conv(0:3) = (/ 6, 8, 0, 0 /) - ptable(14) % eht_param(0:3) = (/ -17.30_dbl, -9.20_dbl, z, z/) - -! Phosphorus - ptable(15) % symbol = 'P ' - ptable(15) % name = 'Phosphorus' - ptable(15) % number = 15 - ptable(15) % amass = 30.97380_dbl - ptable(15) % mass = 30.97376_dbl - ptable(15) % covalent_radius = 1.0600_dbl - ptable(15) % vdw_radius = 1.9_dbl - ptable(15) % e_conv(0:3) = (/ 6, 9, 0, 0 /) - ptable(15) % eht_param(0:3) = (/ -18.60_dbl, -14.00_dbl, z, z/) - -! Sulfur - ptable(16) % symbol = 'S ' - ptable(16) % name = 'Sulfur' - ptable(16) % number = 16 - ptable(16) % amass = 32.06400_dbl - ptable(16) % mass = 31.97207_dbl - ptable(16) % covalent_radius = 1.0200_dbl - ptable(16) % vdw_radius = 1.85_dbl - ptable(16) % e_conv(0:3) = (/ 6, 10, 0, 0 /) - ptable(16) % eht_param(0:3) = (/ -20.00_dbl, -11.00_dbl, z, z/) - -! Chlorine - ptable(17) % symbol = 'Cl' - ptable(17) % name = 'Chlorine' - ptable(17) % number = 17 - ptable(17) % amass = 35.45300_dbl - ptable(17) % mass = 34.96885_dbl - ptable(17) % covalent_radius = 0.9900_dbl - ptable(17) % vdw_radius = 1.80_dbl - ptable(17) % e_conv(0:3) = (/ 6, 11, 0, 0 /) - ptable(17) % eht_param(0:3) = (/ -26.30_dbl, -14.20_dbl, z, z/) - -! Argon - ptable(18) % symbol = 'Ar' - ptable(18) % name = 'Argon' - ptable(18) % number = 18 - ptable(18) % amass = 39.94800_dbl - ptable(18) % mass = 39.94800_dbl - ptable(18) % covalent_radius = 0.9800_dbl - ptable(18) % vdw_radius = 3.83_dbl - ptable(18) % e_conv(0:3) = (/ 6, 12, 0, 0 /) - ptable(18) % eht_param(0:3) = (/ z, z, z, z/) - -! Potassium - ptable(19) % symbol = 'K ' - ptable(19) % name = 'Potassium' - ptable(19) % number = 19 - ptable(19) % amass = 39.10200_dbl - ptable(19) % mass = 38.96371_dbl - ptable(19) % covalent_radius = 2.0300_dbl - ptable(19) % vdw_radius = z - ptable(19) % e_conv(0:3) = (/ 7, 12, 0, 0 /) - ptable(19) % eht_param(0:3) = (/ -4.34_dbl, -2.73_dbl, z, z/) - -! Calcium - ptable(20) % symbol = 'Ca' - ptable(20) % name = 'Calcium' - ptable(20) % number = 20 - ptable(20) % amass = 40.08000_dbl - ptable(20) % mass = 39.96259_dbl - ptable(20) % covalent_radius = 1.7400_dbl - ptable(20) % vdw_radius = z - ptable(20) % e_conv(0:3) = (/ 8, 12, 0, 0 /) - ptable(20) % eht_param(0:3) = (/ -7.00_dbl, -4.00_dbl, z, z/) - -! Scandium - ptable(21) % symbol = 'Sc' - ptable(21) % name = 'Scandium' - ptable(21) % number = 21 - ptable(21) % amass = 44.95600_dbl - ptable(21) % mass = 44.95592_dbl - ptable(21) % covalent_radius = 1.4400_dbl - ptable(21) % vdw_radius = z - ptable(21) % e_conv(0:3) = (/ 8, 12, 1, 0 /) - ptable(21) % eht_param(0:3) = (/ -8.87_dbl, -2.75_dbl, -8.51_dbl, z/) - -! Titanium - ptable(22) % symbol = 'Ti' - ptable(22) % name = 'Titanium' - ptable(22) % number = 22 - ptable(22) % amass = 47.90000_dbl - ptable(22) % mass = 48.00000_dbl - ptable(22) % covalent_radius = 1.3200_dbl - ptable(22) % vdw_radius = z - ptable(22) % e_conv(0:3) = (/ 8, 12, 2, 0 /) - ptable(22) % eht_param(0:3) = (/ -8.97_dbl, -5.44_dbl, -10.81_dbl, z/) - -! Vanadium - ptable(23) % symbol = 'V ' - ptable(23) % name = 'Vanadium' - ptable(23) % number = 23 - ptable(23) % amass = 50.94200_dbl - ptable(23) % mass = 50.94400_dbl - ptable(23) % covalent_radius = 1.2200_dbl - ptable(23) % vdw_radius = z - ptable(23) % e_conv(0:3) = (/ 8, 12, 3, 0 /) - ptable(23) % eht_param(0:3) = (/ -8.81_dbl, -5.52_dbl, -11.00_dbl, z/) - -! Chromium - ptable(24) % symbol = 'Cr' - ptable(24) % name = 'Chromium' - ptable(24) % number = 24 - ptable(24) % amass = 51.99600_dbl - ptable(24) % mass = 51.94050_dbl - ptable(24) % covalent_radius = 1.1800_dbl - ptable(24) % vdw_radius = z - ptable(24) % e_conv(0:3) = (/ 7, 12, 5, 0 /) - ptable(24) % eht_param(0:3) = (/ -8.66_dbl, -5.24_dbl, -11.22_dbl, z/) - -! Manganese - ptable(25) % symbol = 'Mn' - ptable(25) % name = 'Manganese' - ptable(25) % number = 25 - ptable(25) % amass = 54.93800_dbl - ptable(25) % mass = 54.93810_dbl - ptable(25) % covalent_radius = 1.1700_dbl - ptable(25) % vdw_radius = z - ptable(25) % e_conv(0:3) = (/ 8, 12, 5, 0 /) - ptable(25) % eht_param(0:3) = (/ -9.75_dbl, -5.89_dbl, -11.67_dbl, z/) - -! Iron - ptable(26) % symbol = 'Fe' - ptable(26) % name = 'Iron' - ptable(26) % number = 26 - ptable(26) % amass = 55.84700_dbl - ptable(26) % mass = 55.93490_dbl - ptable(26) % covalent_radius = 1.1700_dbl - ptable(26) % vdw_radius = z - ptable(26) % e_conv(0:3) = (/ 8, 12, 6, 0 /) - ptable(26) % eht_param(0:3) = (/ -9.10_dbl, -5.32_dbl, -12.60_dbl, z/) - -! Cobalt - ptable(27) % symbol = 'Co' - ptable(27) % name = 'Cobalt' - ptable(27) % number = 27 - ptable(27) % amass = 58.93300_dbl - ptable(27) % mass = 58.93320_dbl - ptable(27) % covalent_radius = 1.1600_dbl - ptable(27) % vdw_radius = z - ptable(27) % e_conv(0:3) = (/ 8, 12, 7, 0 /) - ptable(27) % eht_param(0:3) = (/ -9.21_dbl, -5.29_dbl, -13.18_dbl, z/) - -! Nickel - ptable(28) % symbol = 'Ni' - ptable(28) % name = 'Nickel' - ptable(28) % number = 28 - ptable(28) % amass = 58.71000_dbl - ptable(28) % mass = 57.93530_dbl - ptable(28) % covalent_radius = 1.1500_dbl - ptable(28) % vdw_radius = z - ptable(28) % e_conv(0:3) = (/ 8, 12, 8, 0 /) - ptable(28) % eht_param(0:3) = (/ -9.17_dbl, -5.15_dbl, -13.49_dbl, z/) - -! Copper - ptable(29) % symbol = 'Cu' - ptable(29) % name = 'Copper' - ptable(29) % number = 29 - ptable(29) % amass = 63.54000_dbl - ptable(29) % mass = 63.20000_dbl - ptable(29) % covalent_radius = 1.1700_dbl - ptable(29) % vdw_radius = z - ptable(29) % e_conv(0:3) = (/ 7, 12, 10, 0 /) - ptable(29) % eht_param(0:3) = (/ -11.40_dbl, -6.06_dbl, -14.00_dbl, z/) - -! Zinc - ptable(30) % symbol = 'Zn' - ptable(30) % name = 'Zinc' - ptable(30) % number = 30 - ptable(30) % amass = 65.37000_dbl - ptable(30) % mass = 63.92910_dbl - ptable(30) % covalent_radius = 1.2500_dbl - ptable(30) % vdw_radius = z - ptable(30) % e_conv(0:3) = (/ 8, 12, 10, 0 /) - ptable(30) % eht_param(0:3) = (/ -12.41_dbl, -6.53_dbl, z, z/) - -! Gallium - ptable(31) % symbol = 'Ga' - ptable(31) % name = 'Gallium' - ptable(31) % number = 31 - ptable(31) % amass = 69.72000_dbl - ptable(31) % mass = 68.92570_dbl - ptable(31) % covalent_radius = 1.2600_dbl - ptable(31) % vdw_radius = z - ptable(31) % e_conv(0:3) = (/ 8, 13, 10, 0 /) - ptable(31) % eht_param(0:3) = (/ -14.58_dbl, -6.75_dbl, z, z/) - -! Germanium - ptable(32) % symbol = 'Ge' - ptable(32) % name = 'Germanium' - ptable(32) % number = 32 - ptable(32) % amass = 72.59000_dbl - ptable(32) % mass = 73.92140_dbl - ptable(32) % covalent_radius = 1.2200_dbl - ptable(32) % vdw_radius = z - ptable(32) % e_conv(0:3) = (/ 8, 14, 10, 0 /) - ptable(32) % eht_param(0:3) = (/ -16.00_dbl, -9.00_dbl, z, z/) - -! Arsenic - ptable(33) % symbol = 'As' - ptable(33) % name = 'Arsenic' - ptable(33) % number = 33 - ptable(33) % amass = 74.92200_dbl - ptable(33) % mass = 74.92160_dbl - ptable(33) % covalent_radius = 1.2000_dbl - ptable(33) % vdw_radius = 2.0_dbl - ptable(33) % e_conv(0:3) = (/ 8, 15, 10, 0 /) - ptable(33) % eht_param(0:3) = (/ -16.22_dbl, -12.16_dbl, z, z/) - -! Selenium - ptable(34) % symbol = 'Se' - ptable(34) % name = 'Selenium' - ptable(34) % number = 34 - ptable(34) % amass = 78.96000_dbl - ptable(34) % mass = 79.91650_dbl - ptable(34) % covalent_radius = 1.1600_dbl - ptable(34) % vdw_radius = 2.00_dbl - ptable(34) % e_conv(0:3) = (/ 8, 16, 10, 0 /) - ptable(34) % eht_param(0:3) = (/ -20.50_dbl, -14.40_dbl, z, z/) - -! Bromine - ptable(35) % symbol = 'Br' - ptable(35) % name = 'Bromine' - ptable(35) % number = 35 - ptable(35) % amass = 79.90900_dbl - ptable(35) % mass = 78.91830_dbl - ptable(35) % covalent_radius = 1.1400_dbl - ptable(35) % vdw_radius = 1.95_dbl - ptable(35) % e_conv(0:3) = (/ 8, 17, 10, 0 /) - ptable(35) % eht_param(0:3) = (/ -22.07_dbl, -13.10_dbl, z, z/) - -! Krypton - ptable(36) % symbol = 'Kr' - ptable(36) % name = 'Krypton' - ptable(36) % number = 36 - ptable(36) % amass = 83.80000_dbl - ptable(36) % mass = 84.00000_dbl - ptable(36) % covalent_radius = 1.1200_dbl - ptable(36) % vdw_radius = z - ptable(36) % e_conv(0:3) = (/ 8, 18, 10, 0 /) - ptable(36) % eht_param(0:3) = (/ z, z, z, z/) - -! Rubidium - ptable(37) % symbol = 'Rb' - ptable(37) % name = 'Rubidium' - ptable(37) % number = 37 - ptable(37) % amass = 85.47000_dbl - ptable(37) % mass = 84.91170_dbl - ptable(37) % covalent_radius = 2.1600_dbl - ptable(37) % vdw_radius = z - ptable(37) % e_conv(0:3) = (/ 9, 18, 10, 0 /) - ptable(37) % eht_param(0:3) = (/ -4.18_dbl, -2.60_dbl, z, z/) - -! Strontium - ptable(38) % symbol = 'Sr' - ptable(38) % name = 'Strontium' - ptable(38) % number = 38 - ptable(38) % amass = 87.62000_dbl - ptable(38) % mass = 87.90560_dbl - ptable(38) % covalent_radius = 1.9100_dbl - ptable(38) % vdw_radius = z - ptable(38) % e_conv(0:3) = (/ 10, 18, 10, 0 /) - ptable(38) % eht_param(0:3) = (/ -6.62_dbl, -3.92_dbl, z, z/) - -! Yttrium - ptable(39) % symbol = 'Y ' - ptable(39) % name = 'Yttrium' - ptable(39) % number = 39 - ptable(39) % amass = 88.90500_dbl - ptable(39) % mass = 88.90590_dbl - ptable(39) % covalent_radius = 1.6200_dbl - ptable(39) % vdw_radius = z - ptable(39) % e_conv(0:3) = (/ 10, 18, 11, 0 /) - ptable(39) % eht_param(0:3) = (/ z, z, z, z/) - -! Zirconium - ptable(40) % symbol = 'Zr' - ptable(40) % name = 'Zirconium' - ptable(40) % number = 40 - ptable(40) % amass = 91.22000_dbl - ptable(40) % mass = 89.90430_dbl - ptable(40) % covalent_radius = 1.4500_dbl - ptable(40) % vdw_radius = z - ptable(40) % e_conv(0:3) = (/ 10, 18, 12, 0 /) - ptable(40) % eht_param(0:3) = (/ -8.00_dbl, -5.40_dbl, -10.20_dbl, z/) - -! Niobium - ptable(41) % symbol = 'Nb' - ptable(41) % name = 'Niobium' - ptable(41) % number = 41 - ptable(41) % amass = 92.90600_dbl - ptable(41) % mass = 92.90600_dbl - ptable(41) % covalent_radius = 1.3400_dbl - ptable(41) % vdw_radius = z - ptable(41) % e_conv(0:3) = (/ 9, 18, 14, 0 /) - ptable(41) % eht_param(0:3) = (/ -10.10_dbl, -6.86_dbl, -12.10_dbl, z/) - -! Molybdenum - ptable(42) % symbol = 'Mo' - ptable(42) % name = 'Molybdenum' - ptable(42) % number = 42 - ptable(42) % amass = 95.94000_dbl - ptable(42) % mass = 97.90550_dbl - ptable(42) % covalent_radius = 1.3000_dbl - ptable(42) % vdw_radius = z - ptable(42) % e_conv(0:3) = (/ 9, 18, 15, 0 /) - ptable(42) % eht_param(0:3) = (/ -8.34_dbl, -5.25_dbl, -10.50_dbl, z/) - -! Technetium - ptable(43) % symbol = 'Tc' - ptable(43) % name = 'Technetium' - ptable(43) % number = 43 - ptable(43) % amass = 98.90600_dbl - ptable(43) % mass = 98.90600_dbl - ptable(43) % covalent_radius = 1.2700_dbl - ptable(43) % vdw_radius = z - ptable(43) % e_conv(0:3) = (/ 9, 18, 16, 0 /) - ptable(43) % eht_param(0:3) = (/ -10.07_dbl, -5.40_dbl, -12.82_dbl, z/) - -! Ruthenium - ptable(44) % symbol = 'Ru' - ptable(44) % name = 'Ruthenium' - ptable(44) % number = 44 - ptable(44) % amass = 101.07000_dbl - ptable(44) % mass = 101.90370_dbl - ptable(44) % covalent_radius = 1.2500_dbl - ptable(44) % vdw_radius = z - ptable(44) % e_conv(0:3) = (/ 9, 18, 17, 0 /) - ptable(44) % eht_param(0:3) = (/ -10.40_dbl, -6.87_dbl, -14.90_dbl, z/) - -! Rhodium - ptable(45) % symbol = 'Rh' - ptable(45) % name = 'Rhodium' - ptable(45) % number = 45 - ptable(45) % amass = 102.90500_dbl - ptable(45) % mass = 102.90480_dbl - ptable(45) % covalent_radius = 1.2500_dbl - ptable(45) % vdw_radius = z - ptable(45) % e_conv(0:3) = (/ 9, 18, 18, 0 /) - ptable(45) % eht_param(0:3) = (/ -8.09_dbl, -4.57_dbl, -12.50_dbl, z/) - -! Palladium - ptable(46) % symbol = 'Pd' - ptable(46) % name = 'Palladium' - ptable(46) % number = 46 - ptable(46) % amass = 106.40000_dbl - ptable(46) % mass = 105.90320_dbl - ptable(46) % covalent_radius = 1.2800_dbl - ptable(46) % vdw_radius = z - ptable(46) % e_conv(0:3) = (/ 8, 18, 20, 0 /) - ptable(46) % eht_param(0:3) = (/ -7.32_dbl, -3.75_dbl, -12.02_dbl, z/) - -! Silver - ptable(47) % symbol = 'Ag' - ptable(47) % name = 'Silver' - ptable(47) % number = 47 - ptable(47) % amass = 107.87000_dbl - ptable(47) % mass = 106.90509_dbl - ptable(47) % covalent_radius = 1.3400_dbl - ptable(47) % vdw_radius = z - ptable(47) % e_conv(0:3) = (/ 9, 18, 20, 0 /) - ptable(47) % eht_param(0:3) = (/ z, z, z, z/) - -! Cadmium - ptable(48) % symbol = 'Cd' - ptable(48) % name = 'Cadmium' - ptable(48) % number = 48 - ptable(48) % amass = 112.40000_dbl - ptable(48) % mass = 113.90360_dbl - ptable(48) % covalent_radius = 1.4800_dbl - ptable(48) % vdw_radius = z - ptable(48) % e_conv(0:3) = (/ 10, 18, 20, 0 /) - ptable(48) % eht_param(0:3) = (/ z, z, z, z/) - -! Indium - ptable(49) % symbol = 'In' - ptable(49) % name = 'Indium' - ptable(49) % number = 49 - ptable(49) % amass = 114.82000_dbl - ptable(49) % mass = 114.90410_dbl - ptable(49) % covalent_radius = 1.4400_dbl - ptable(49) % vdw_radius = z - ptable(49) % e_conv(0:3) = (/ 10, 19, 20, 0 /) - ptable(49) % eht_param(0:3) = (/ -12.60_dbl, -6.19_dbl, z, z/) - -! Tin - ptable(50) % symbol = 'Sn' - ptable(50) % name = 'Tin' - ptable(50) % number = 50 - ptable(50) % amass = 118.69000_dbl - ptable(50) % mass = 120.00000_dbl - ptable(50) % covalent_radius = 1.4100_dbl - ptable(50) % vdw_radius = z - ptable(50) % e_conv(0:3) = (/ 10, 20, 20, 0 /) - ptable(50) % eht_param(0:3) = (/ -16.16_dbl, -8.32_dbl, z, z/) - -! Antimony - ptable(51) % symbol = 'Sb' - ptable(51) % name = 'Antimony' - ptable(51) % number = 51 - ptable(51) % amass = 121.75000_dbl - ptable(51) % mass = 120.90380_dbl - ptable(51) % covalent_radius = 1.4000_dbl - ptable(51) % vdw_radius = 2.2_dbl - ptable(51) % e_conv(0:3) = (/ 10, 21, 20, 0 /) - ptable(51) % eht_param(0:3) = (/ -18.80_dbl, -11.70_dbl, z, z/) - -! Tellurium - ptable(52) % symbol = 'Te' - ptable(52) % name = 'Tellurium' - ptable(52) % number = 52 - ptable(52) % amass = 127.60000_dbl - ptable(52) % mass = 129.90670_dbl - ptable(52) % covalent_radius = 1.3600_dbl - ptable(52) % vdw_radius = 2.20_dbl - ptable(52) % e_conv(0:3) = (/ 10, 22, 20, 0 /) - ptable(52) % eht_param(0:3) = (/ -20.80_dbl, -13.20_dbl, z, z/) - -! Iodine - ptable(53) % symbol = 'I ' - ptable(53) % name = 'Iodine' - ptable(53) % number = 53 - ptable(53) % amass = 126.90440_dbl - ptable(53) % mass = 126.90440_dbl - ptable(53) % covalent_radius = 1.3300_dbl - ptable(53) % vdw_radius = 2.15_dbl - ptable(53) % e_conv(0:3) = (/ 10, 23, 20, 0 /) - ptable(53) % eht_param(0:3) = (/ -18.00_dbl, -12.70_dbl, z, z/) - -! Xenon - ptable(54) % symbol = 'Xe' - ptable(54) % name = 'Xenon' - ptable(54) % number = 54 - ptable(54) % amass = 131.30000_dbl - ptable(54) % mass = 131.90420_dbl - ptable(54) % covalent_radius = 1.3100_dbl - ptable(54) % vdw_radius = z - ptable(54) % e_conv(0:3) = (/ 10, 24, 20, 0 /) - ptable(54) % eht_param(0:3) = (/ z, z, z, z/) - -! Cesium - ptable(55) % symbol = 'Cs' - ptable(55) % name = 'Cesium' - ptable(55) % number = 55 - ptable(55) % amass = 132.90500_dbl - ptable(55) % mass = 132.90510_dbl - ptable(55) % covalent_radius = 2.3500_dbl - ptable(55) % vdw_radius = z - ptable(55) % e_conv(0:3) = (/ 11, 24, 20, 0 /) - ptable(55) % eht_param(0:3) = (/ -3.88_dbl, -2.49_dbl, z, z/) - -! Barium - ptable(56) % symbol = 'Ba' - ptable(56) % name = 'Barium' - ptable(56) % number = 56 - ptable(56) % amass = 137.34000_dbl - ptable(56) % mass = 137.90500_dbl - ptable(56) % covalent_radius = 1.9800_dbl - ptable(56) % vdw_radius = z - ptable(56) % e_conv(0:3) = (/ 12, 24, 20, 0 /) - ptable(56) % eht_param(0:3) = (/ z, z, z, z/) - -! Lantanum - ptable(57) % symbol = 'La' - ptable(57) % name = 'Lantanum' - ptable(57) % number = 57 - ptable(57) % amass = 138.91000_dbl - ptable(57) % mass = 138.90610_dbl - ptable(57) % covalent_radius = 1.6900_dbl - ptable(57) % vdw_radius = z - ptable(57) % e_conv(0:3) = (/ 12, 24, 21, 0 /) - ptable(57) % eht_param(0:3) = (/ -7.67_dbl, -5.01_dbl, -8.21_dbl, z/) - -! Cerium - ptable(58) % symbol = 'Ce' - ptable(58) % name = 'Cerium' - ptable(58) % number = 58 - ptable(58) % amass = 140.12000_dbl - ptable(58) % mass = 139.90530_dbl - ptable(58) % covalent_radius = 1.6500_dbl - ptable(58) % vdw_radius = z - ptable(58) % e_conv(0:3) = (/ 12, 24, 20, 2 /) - ptable(58) % eht_param(0:3) = (/ z, z, z, z/) - -! Praseodymium - ptable(59) % symbol = 'Pr' - ptable(59) % name = 'Praseodymium' - ptable(59) % number = 59 - ptable(59) % amass = 140.90700_dbl - ptable(59) % mass = 140.90740_dbl - ptable(59) % covalent_radius = 1.6500_dbl - ptable(59) % vdw_radius = z - ptable(59) % e_conv(0:3) = (/ 12, 24, 20, 3 /) - ptable(59) % eht_param(0:3) = (/ z, z, z, z/) - -! Neodymium - ptable(60) % symbol = 'Nd' - ptable(60) % name = 'Neodymium' - ptable(60) % number = 60 - ptable(60) % amass = 144.24000_dbl - ptable(60) % mass = 141.90750_dbl - ptable(60) % covalent_radius = 1.6400_dbl - ptable(60) % vdw_radius = z - ptable(60) % e_conv(0:3) = (/ 12, 24, 20, 4 /) - ptable(60) % eht_param(0:3) = (/ z, z, z, z/) - -! Promethium - ptable(61) % symbol = 'Pm' - ptable(61) % name = 'Promethium' - ptable(61) % number = 61 - ptable(61) % amass = 144.91300_dbl - ptable(61) % mass = 144.91300_dbl - ptable(61) % covalent_radius = 1.6300_dbl - ptable(61) % vdw_radius = z - ptable(61) % e_conv(0:3) = (/ 12, 24, 20, 5 /) - ptable(61) % eht_param(0:3) = (/ z, z, z, z/) - -! Samarium - ptable(62) % symbol = 'Sm' - ptable(62) % name = 'Samarium' - ptable(62) % number = 62 - ptable(62) % amass = 150.35000_dbl - ptable(62) % mass = 151.91950_dbl - ptable(62) % covalent_radius = 1.6200_dbl - ptable(62) % vdw_radius = z - ptable(62) % e_conv(0:3) = (/ 12, 24, 20, 6 /) - ptable(62) % eht_param(0:3) = (/ -4.86_dbl, -4.86_dbl, -6.06_dbl, & - -11.28_dbl/) - -! Europium - ptable(63) % symbol = 'Eu' - ptable(63) % name = 'Europium' - ptable(63) % number = 63 - ptable(63) % amass = 151.96000_dbl - ptable(63) % mass = 152.92090_dbl - ptable(63) % covalent_radius = 1.8500_dbl - ptable(63) % vdw_radius = z - ptable(63) % e_conv(0:3) = (/ 12, 24, 20, 7 /) - ptable(63) % eht_param(0:3) = (/ z, z, z, z/) - -! Gadolinium - ptable(64) % symbol = 'Gd' - ptable(64) % name = 'Gadolinium' - ptable(64) % number = 64 - ptable(64) % amass = 157.25000_dbl - ptable(64) % mass = 157.92410_dbl - ptable(64) % covalent_radius = 1.6100_dbl - ptable(64) % vdw_radius = z - ptable(64) % e_conv(0:3) = (/ 12, 24, 21, 7 /) - ptable(64) % eht_param(0:3) = (/ z, z, z, z/) - -! Terbium - ptable(65) % symbol = 'Tb' - ptable(65) % name = 'Terbium' - ptable(65) % number = 65 - ptable(65) % amass = 158.92400_dbl - ptable(65) % mass = 158.92500_dbl - ptable(65) % covalent_radius = 1.5900_dbl - ptable(65) % vdw_radius = z - ptable(65) % e_conv(0:3) = (/ 12, 24, 20, 9 /) - ptable(65) % eht_param(0:3) = (/ z, z, z, z/) - -! Dysprosium - ptable(66) % symbol = 'Dy' - ptable(66) % name = 'Dysprosium' - ptable(66) % number = 66 - ptable(66) % amass = 162.50000_dbl - ptable(66) % mass = 163.92880_dbl - ptable(66) % covalent_radius = 1.5900_dbl - ptable(66) % vdw_radius = z - ptable(66) % e_conv(0:3) = (/ 12, 24, 20, 10 /) - ptable(66) % eht_param(0:3) = (/ z, z, z, z/) - -! Holmium - ptable(67) % symbol = 'Ho' - ptable(67) % name = 'Holmium' - ptable(67) % number = 67 - ptable(67) % amass = 164.93000_dbl - ptable(67) % mass = 164.93000_dbl - ptable(67) % covalent_radius = 1.5800_dbl - ptable(67) % vdw_radius = z - ptable(67) % e_conv(0:3) = (/ 12, 24, 20, 11 /) - ptable(67) % eht_param(0:3) = (/ z, z, z, z/) - -! Erbium - ptable(68) % symbol = 'Er' - ptable(68) % name = 'Erbium' - ptable(68) % number = 68 - ptable(68) % amass = 167.26000_dbl - ptable(68) % mass = 165.93040_dbl - ptable(68) % covalent_radius = 1.5700_dbl - ptable(68) % vdw_radius = z - ptable(68) % e_conv(0:3) = (/ 12, 24, 20, 12 /) - ptable(68) % eht_param(0:3) = (/ z, z, z, z/) - -! Thulium - ptable(69) % symbol = 'Tm' - ptable(69) % name = 'Thulium' - ptable(69) % number = 69 - ptable(69) % amass = 168.93400_dbl - ptable(69) % mass = 168.93440_dbl - ptable(69) % covalent_radius = 1.5600_dbl - ptable(69) % vdw_radius = z - ptable(69) % e_conv(0:3) = (/ 12, 24, 20, 13 /) - ptable(69) % eht_param(0:3) = (/ z, z, z, z/) - -! Ytterbium - ptable(70) % symbol = 'Yb' - ptable(70) % name = 'Ytterbium' - ptable(70) % number = 70 - ptable(70) % amass = 173.04000_dbl - ptable(70) % mass = 173.93900_dbl - ptable(70) % covalent_radius = 1.5600_dbl - ptable(70) % vdw_radius = z - ptable(70) % e_conv(0:3) = (/ 12, 24, 20, 14 /) - ptable(70) % eht_param(0:3) = (/ -5.35_dbl, -5.35_dbl, -5.21_dbl, & - -13.86_dbl/) - -! Lutetium - ptable(71) % symbol = 'Lu' - ptable(71) % name = 'Lutetium' - ptable(71) % number = 71 - ptable(71) % amass = 174.97000_dbl - ptable(71) % mass = 174.94090_dbl - ptable(71) % covalent_radius = 1.5600_dbl - ptable(71) % vdw_radius = z - ptable(71) % e_conv(0:3) = (/ 12, 24, 21, 14 /) - ptable(71) % eht_param(0:3) = (/ -6.05_dbl, -6.05_dbl, -5.12_dbl, & - -22.40_dbl/) - -! Hafnium - ptable(72) % symbol = 'Hf' - ptable(72) % name = 'Hafnium' - ptable(72) % number = 72 - ptable(72) % amass = 178.49000_dbl - ptable(72) % mass = 179.94680_dbl - ptable(72) % covalent_radius = 1.4400_dbl - ptable(72) % vdw_radius = z - ptable(72) % e_conv(0:3) = (/ 12, 24, 22, 14 /) - ptable(72) % eht_param(0:3) = (/ z, z, z, z/) - -! Tantalum - ptable(73) % symbol = 'Ta' - ptable(73) % name = 'Tantalum' - ptable(73) % number = 73 - ptable(73) % amass = 180.94800_dbl - ptable(73) % mass = 180.94800_dbl - ptable(73) % covalent_radius = 1.3400_dbl - ptable(73) % vdw_radius = z - ptable(73) % e_conv(0:3) = (/ 12, 24, 23, 14 /) - ptable(73) % eht_param(0:3) = (/ -10.10_dbl, -6.86_dbl, -12.10_dbl, z/) - -! Tungsten - ptable(74) % symbol = 'W ' - ptable(74) % name = 'Tungsten' - ptable(74) % number = 74 - ptable(74) % amass = 183.85000_dbl - ptable(74) % mass = 183.95100_dbl - ptable(74) % covalent_radius = 1.3000_dbl - ptable(74) % vdw_radius = z - ptable(74) % e_conv(0:3) = (/ 12, 24, 24, 14 /) - ptable(74) % eht_param(0:3) = (/ -8.26_dbl, -5.17_dbl, -10.37_dbl, z/) - -! Rhenium - ptable(75) % symbol = 'Re' - ptable(75) % name = 'Rhenium' - ptable(75) % number = 75 - ptable(75) % amass = 186.20000_dbl - ptable(75) % mass = 186.95600_dbl - ptable(75) % covalent_radius = 1.2800_dbl - ptable(75) % vdw_radius = z - ptable(75) % e_conv(0:3) = (/ 12, 24, 25, 14 /) - ptable(75) % eht_param(0:3) = (/ -9.36_dbl, -5.96_dbl, -12.66_dbl, z/) - -! Osmium - ptable(76) % symbol = 'Os' - ptable(76) % name = 'Osmium' - ptable(76) % number = 76 - ptable(76) % amass = 190.20000_dbl - ptable(76) % mass = 192.00000_dbl - ptable(76) % covalent_radius = 1.2600_dbl - ptable(76) % vdw_radius = z - ptable(76) % e_conv(0:3) = (/ 12, 24, 26, 14 /) - ptable(76) % eht_param(0:3) = (/ -8.17_dbl, -4.81_dbl, -11.84_dbl, z/) - -! Iridium - ptable(77) % symbol = 'Ir' - ptable(77) % name = 'Iridium' - ptable(77) % number = 77 - ptable(77) % amass = 192.20000_dbl - ptable(77) % mass = 192.96330_dbl - ptable(77) % covalent_radius = 1.2700_dbl - ptable(77) % vdw_radius = z - ptable(77) % e_conv(0:3) = (/ 12, 24, 27, 14 /) - ptable(77) % eht_param(0:3) = (/ -11.36_dbl, -4.50_dbl, -12.17_dbl, z/) - -! Platinum - ptable(78) % symbol = 'Pt' - ptable(78) % name = 'Platinum' - ptable(78) % number = 78 - ptable(78) % amass = 195.09000_dbl - ptable(78) % mass = 194.96480_dbl - ptable(78) % covalent_radius = 1.3000_dbl - ptable(78) % vdw_radius = z - ptable(78) % e_conv(0:3) = (/ 11, 24, 29, 14 /) - ptable(78) % eht_param(0:3) = (/ -9.077_dbl, -5.475_dbl, -12.59_dbl, & - z/) - -! Gold - ptable(79) % symbol = 'Au' - ptable(79) % name = 'Gold' - ptable(79) % number = 79 - ptable(79) % amass = 196.96700_dbl - ptable(79) % mass = 196.96660_dbl - ptable(79) % covalent_radius = 1.3400_dbl - ptable(79) % vdw_radius = z - ptable(79) % e_conv(0:3) = (/ 11, 24, 30, 14 /) - ptable(79) % eht_param(0:3) = (/ -10.92_dbl, -5.55_dbl, -15.076_dbl, & - z/) - -! Mercury - ptable(80) % symbol = 'Hg' - ptable(80) % name = 'Mercury' - ptable(80) % number = 80 - ptable(80) % amass = 200.59000_dbl - ptable(80) % mass = 201.97060_dbl - ptable(80) % covalent_radius = 1.4900_dbl - ptable(80) % vdw_radius = z - ptable(80) % e_conv(0:3) = (/ 12, 24, 30, 14 /) - ptable(80) % eht_param(0:3) = (/ -13.68_dbl, -8.47_dbl, -17.50_dbl, z/) - -! Thallium - ptable(81) % symbol = 'Tl' - ptable(81) % name = 'Thallium' - ptable(81) % number = 81 - ptable(81) % amass = 204.37000_dbl - ptable(81) % mass = 204.97450_dbl - ptable(81) % covalent_radius = 1.4800_dbl - ptable(81) % vdw_radius = z - ptable(81) % e_conv(0:3) = (/ 12, 25, 30, 14 /) - ptable(81) % eht_param(0:3) = (/ -11.60_dbl, -5.80_dbl, z, z/) - -! Lead - ptable(82) % symbol = 'Pb' - ptable(82) % name = 'Lead' - ptable(82) % number = 82 - ptable(82) % amass = 207.19000_dbl - ptable(82) % mass = 207.97660_dbl - ptable(82) % covalent_radius = 1.4700_dbl - ptable(82) % vdw_radius = z - ptable(82) % e_conv(0:3) = (/ 12, 26, 30, 14 /) - ptable(82) % eht_param(0:3) = (/ -15.70_dbl, -8.00_dbl, z, z/) - -! Bismuth - ptable(83) % symbol = 'Bi' - ptable(83) % name = 'Bismuth' - ptable(83) % number = 83 - ptable(83) % amass = 208.98000_dbl - ptable(83) % mass = 208.98040_dbl - ptable(83) % covalent_radius = 1.4600_dbl - ptable(83) % vdw_radius = z - ptable(83) % e_conv(0:3) = (/ 12, 27, 30, 14 /) - ptable(83) % eht_param(0:3) = (/ -15.19_dbl, -7.79_dbl, z, z/) - -! Polonium - ptable(84) % symbol = 'Po' - ptable(84) % name = 'Polonium' - ptable(84) % number = 84 - ptable(84) % amass = 209.98290_dbl - ptable(84) % mass = 209.98290_dbl - ptable(84) % covalent_radius = 1.4600_dbl - ptable(84) % vdw_radius = z - ptable(84) % e_conv(0:3) = (/ 12, 28, 30, 14 /) - ptable(84) % eht_param(0:3) = (/ z, z, z, z/) - -! Astatine - ptable(85) % symbol = 'At' - ptable(85) % name = 'Astatine' - ptable(85) % number = 85 - ptable(85) % amass = 209.98700_dbl - ptable(85) % mass = 209.98700_dbl - ptable(85) % covalent_radius = 1.4500_dbl - ptable(85) % vdw_radius = z - ptable(85) % e_conv(0:3) = (/ 12, 29, 30, 14 /) - ptable(85) % eht_param(0:3) = (/ z, z, z, z/) - -! Radon - ptable(86) % symbol = 'Rn' - ptable(86) % name = 'Radon' - ptable(86) % number = 86 - ptable(86) % amass = 222.01750_dbl - ptable(86) % mass = 222.01750_dbl - ptable(86) % covalent_radius = z - ptable(86) % vdw_radius = z - ptable(86) % e_conv(0:3) = (/ 12, 30, 30, 14 /) - ptable(86) % eht_param(0:3) = (/ z, z, z, z/) - -! Francium - ptable(87) % symbol = 'Fr' - ptable(87) % name = 'Francium' - ptable(87) % number = 87 - ptable(87) % amass = 223.01980_dbl - ptable(87) % mass = 223.01980_dbl - ptable(87) % covalent_radius = z - ptable(87) % vdw_radius = z - ptable(87) % e_conv(0:3) = (/ 13, 30, 30, 14 /) - ptable(87) % eht_param(0:3) = (/ z, z, z, z/) - -! Radium - ptable(88) % symbol = 'Ra' - ptable(88) % name = 'Radium' - ptable(88) % number = 88 - ptable(88) % amass = 226.02540_dbl - ptable(88) % mass = 226.02540_dbl - ptable(88) % covalent_radius = z - ptable(88) % vdw_radius = z - ptable(88) % e_conv(0:3) = (/ 14, 30, 30, 14 /) - ptable(88) % eht_param(0:3) = (/ z, z, z, z/) - -! Actinium - ptable(89) % symbol = 'Ac' - ptable(89) % name = 'Actinium' - ptable(89) % number = 89 - ptable(89) % amass = 227.02780_dbl - ptable(89) % mass = 227.02780_dbl - ptable(89) % covalent_radius = z - ptable(89) % vdw_radius = z - ptable(89) % e_conv(0:3) = (/ 14, 30, 31, 14 /) - ptable(89) % eht_param(0:3) = (/ z, z, z, z/) - -! Thorium - ptable(90) % symbol = 'Th' - ptable(90) % name = 'Thorium' - ptable(90) % number = 90 - ptable(90) % amass = 232.03810_dbl - ptable(90) % mass = 232.03810_dbl - ptable(90) % covalent_radius = 1.6500_dbl - ptable(90) % vdw_radius = z - ptable(90) % e_conv(0:3) = (/ 14, 30, 32, 14 /) - ptable(90) % eht_param(0:3) = (/ -5.39_dbl, -5.39_dbl, -10.11_dbl, & - -9.64_dbl/) - -! Proctactinium - ptable(91) % symbol = 'Pa' - ptable(91) % name = 'Proctactinium' - ptable(91) % number = 91 - ptable(91) % amass = 231.03590_dbl - ptable(91) % mass = 231.03590_dbl - ptable(91) % covalent_radius = z - ptable(91) % vdw_radius = z - ptable(91) % e_conv(0:3) = (/ 14, 30, 31, 16 /) - ptable(91) % eht_param(0:3) = (/ z, z, z, z/) - -! Uranium - ptable(92) % symbol = 'U ' - ptable(92) % name = 'Uranium' - ptable(92) % number = 92 - ptable(92) % amass = 238.05080_dbl - ptable(92) % mass = 238.05080_dbl - ptable(92) % covalent_radius = 1.4200_dbl - ptable(92) % vdw_radius = z - ptable(92) % e_conv(0:3) = (/ 14, 30, 31, 17 /) - ptable(92) % eht_param(0:3) = (/ -5.50_dbl, -5.50_dbl, -9.19_dbl, & - -10.62_dbl/) - -! Neptunium - ptable(93) % symbol = 'Np' - ptable(93) % name = 'Neptunium' - ptable(93) % number = 93 - ptable(93) % amass = 237.04820_dbl - ptable(93) % mass = 237.04820_dbl - ptable(93) % covalent_radius = z - ptable(93) % vdw_radius = z - ptable(93) % e_conv(0:3) = (/ 14, 30, 31, 18 /) - ptable(93) % eht_param(0:3) = (/ z, z, z, z/) - -! Plutonium - ptable(94) % symbol = 'Pu' - ptable(94) % name = 'Plutonium' - ptable(94) % number = 94 - ptable(94) % amass = 244.0640_dbl - ptable(94) % mass = 244.0640_dbl - ptable(94) % covalent_radius = z - ptable(94) % vdw_radius = z - ptable(94) % e_conv(0:3) = (/ 14, 30, 30, 20 /) - ptable(94) % eht_param(0:3) = (/ z, z, z, z/) - -! Americum - ptable(95) % symbol = 'Am' - ptable(95) % name = 'Americum' - ptable(95) % number = 95 - ptable(95) % amass = 243.0614_dbl - ptable(95) % mass = 243.0614_dbl - ptable(95) % covalent_radius = z - ptable(95) % vdw_radius = z - ptable(95) % e_conv(0:3) = (/ 14, 30, 30, 21 /) - ptable(95) % eht_param(0:3) = (/ z, z, z, z/) - -! Curium - ptable(96) % symbol = 'Cm' - ptable(96) % name = 'Curium' - ptable(96) % number = 96 - ptable(96) % amass = 247.0700_dbl - ptable(96) % mass = 247.0700_dbl - ptable(96) % covalent_radius = z - ptable(96) % vdw_radius = z - ptable(96) % e_conv(0:3) = (/ 14, 30, 31, 21 /) - ptable(96) % eht_param(0:3) = (/ z, z, z, z/) - -! Berkelium - ptable(97) % symbol = 'Bk' - ptable(97) % name = 'Berkelium' - ptable(97) % number = 97 - ptable(97) % amass = 251.0800_dbl - ptable(97) % mass = 251.0800_dbl - ptable(97) % covalent_radius = z - ptable(97) % vdw_radius = z - ptable(97) % e_conv(0:3) = (/ 14, 30, 31, 22 /) - ptable(97) % eht_param(0:3) = (/ z, z, z, z/) - -! Californium - ptable(98) % symbol = 'Cf' - ptable(98) % name = 'Californium' - ptable(98) % number = 98 - ptable(98) % amass = 252.0820_dbl - ptable(98) % mass = 252.0820_dbl - ptable(98) % covalent_radius = z - ptable(98) % vdw_radius = z - ptable(98) % e_conv(0:3) = (/ 14, 30, 30, 24 /) - ptable(98) % eht_param(0:3) = (/ z, z, z, z/) - -! Einsteinium - ptable(99) % symbol = 'Es' - ptable(99) % name = 'Einsteinium' - ptable(99) % number = 99 - ptable(99) % amass = 252.0829_dbl - ptable(99) % mass = 252.0829_dbl - ptable(99) % covalent_radius = z - ptable(99) % vdw_radius = z - ptable(99) % e_conv(0:3) = (/ 14, 30, 30, 25 /) - ptable(99) % eht_param(0:3) = (/ z, z, z, z/) - -! Fermium - ptable(100) % symbol = 'Fm' - ptable(100) % name = 'Fermium' - ptable(100) % number = 100 - ptable(100) % amass = 257.0950_dbl - ptable(100) % mass = 257.0950_dbl - ptable(100) % covalent_radius = z - ptable(100) % vdw_radius = z - ptable(100) % e_conv(0:3) = (/ 14, 30, 30, 26 /) - ptable(100) % eht_param(0:3) = (/ z, z, z, z/) - -! Mendelevium - ptable(101) % symbol = 'Md' - ptable(101) % name = 'Mendelevium' - ptable(101) % number = 101 - ptable(101) % amass = 256.0000_dbl - ptable(101) % mass = 256.0000_dbl - ptable(101) % covalent_radius = z - ptable(101) % vdw_radius = z - ptable(101) % e_conv(0:3) = (/ 14, 30, 30, 27 /) - ptable(101) % eht_param(0:3) = (/ z, z, z, z/) - -! Nobelium - ptable(102) % symbol = 'No' - ptable(102) % name = 'Nobelium' - ptable(102) % number = 102 - ptable(102) % amass = 254.0000_dbl - ptable(102) % mass = 254.0000_dbl - ptable(102) % covalent_radius = z - ptable(102) % vdw_radius = z - ptable(102) % e_conv(0:3) = (/ 14, 30, 30, 28 /) - ptable(102) % eht_param(0:3) = (/ z, z, z, z/) - -! Lawrencium - ptable(103) % symbol = 'Lr' - ptable(103) % name = 'Lawrencium' - ptable(103) % number = 103 - ptable(103) % amass = 257.0000_dbl - ptable(103) % mass = 257.0000_dbl - ptable(103) % covalent_radius = z - ptable(103) % vdw_radius = z - ptable(103) % e_conv(0:3) = (/ 14, 30, 31, 28 /) - ptable(103) % eht_param(0:3) = (/ z, z, z, z/) - -! Unnilquadium - ptable(104) % symbol = 'Uq' - ptable(104) % name = 'Unnilquadium' - ptable(104) % number = 104 - ptable(104) % amass = 261.0000_dbl - ptable(104) % mass = 261.0000_dbl - ptable(104) % covalent_radius = z - ptable(104) % vdw_radius = z - ptable(104) % e_conv(0:3) = (/ 14, 30, 32, 28 /) - ptable(104) % eht_param(0:3) = (/ z, z, z, z/) - -! Unnilpentium - ptable(105) % symbol = 'Up' - ptable(105) % name = 'Unnilpentium' - ptable(105) % number = 105 - ptable(105) % amass = 262.0000_dbl - ptable(105) % mass = 262.0000_dbl - ptable(105) % covalent_radius = z - ptable(105) % vdw_radius = z - ptable(105) % e_conv(0:3) = (/ 14, 30, 33, 28 /) - ptable(105) % eht_param(0:3) = (/ z, z, z, z/) - -! Unnilhexium - ptable(106) % symbol = 'Uh' - ptable(106) % name = 'Unnilhexium' - ptable(106) % number = 106 - ptable(106) % amass = 263.0000_dbl - ptable(106) % mass = 263.0000_dbl - ptable(106) % covalent_radius = z - ptable(106) % vdw_radius = z - ptable(106) % e_conv(0:3) = (/ 14, 30, 34, 28 /) - ptable(106) % eht_param(0:3) = (/ z, z, z, z/) - -END SUBROUTINE init_periodic_table - -!****************************************************************************** - -END MODULE periodic_table diff --git a/src/physcon.c b/src/physcon.c deleted file mode 100644 index 39494ad..0000000 --- a/src/physcon.c +++ /dev/null @@ -1,221 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -! -!!>Definition of physical constants. -!! -!! List of variables: -!! -!! a_bohr : Bohr radius [m]. -!! a_fine : Fine-structure constant. -!! angstrom : Conversion factor [Bohr] -> [Angstrom] -!! bohr : Conversion factor [Angstrom] -> [Bohr]. -!! c_light : Speed of light in vacuum [m/s]. -!! e_charge : Elementary charge [C]. -!! e_mass : Electron mass [kg]. -!! a_mass : Atomic mass unit[kg]. -!! esu : Conversion factors [Hartree] -> [esu]. -!! evolt : Conversion factor [Hartree] -> [eV]. -!! h_planck : Planck constant [J*s]. -!! hz : Conversion factor [Hartree] -> [Hz]. -!! kcalmol : Conversion factor [Hartree] -> [kcal/mol]. -!! kjmol : Conversion factor [Hartree] -> [kJ/mol]. -!! joule : Conversion factor [Hartree] -> [J]. -!! mhz : Conversion factor [Hartree] -> [MHz]. -!! mu_perm : Permeability of vacuum [N/A**2]. -!! boltzmann : Boltzman constant [J/Kelvin]. -!! n_avogadro: Avogrado constant [1/mol]. -!! rydberg : Rydberg constant [1/m]. -!! vibfac : Conversion factor [Hartree/Bohr**2] -> [1/cm]. -!! [1/cm] (wave numbers). - -MODULE physcon - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: a_bohr, a_fine, angstrom, bohr, c_light, e_charge, e_mass, & - evolt, h_planck, hz, joule, kcalmol, kjmol, mhz, mu_perm, n_avogadro, & - rydberg, vibfac, wavenum, massunit, init_physcon, a_mass, boltzmann, & - print_physcon - - INTEGER, PARAMETER :: maxmom = 3 - - REAL ( dbl ) :: a_bohr, a_fine, angstrom, bohr, c_light, e_charge, e_mass, & - evolt, h_planck, hz, joule, kcalmol, kjmol, mhz, mu_perm, n_avogadro, & - rydberg, vibfac, wavenum, massunit, a_mass, boltzmann - - REAL ( dbl ), DIMENSION (maxmom) :: esu - -CONTAINS - -!****************************************************************************** - -!! Initialization of physical constants. - -SUBROUTINE init_physcon() - - USE mathconstants, ONLY : pi - USE periodic_table, ONLY : init_periodic_table - - IMPLICIT NONE - -! Locals - INTEGER :: i - -!-----------------------------------------------------------------------------! -! -! *** Fundamental physical constants (SI units) *** -! -! *** Literature: The 1986 CODATA Recommended Values of the *** -! *** Fundamental Physical Constants, *** -! *** E. R. Cohen, B. N. Taylor, *** -! *** J. Res. Natl. Bur. Stand. 92(2), 1 (1987) *** - -! *** Speed of light in vacuum [m/s] *** - c_light = 2.99792458E+8_dbl - -! *** Permeability of vacuum [N/A**2] *** - mu_perm = 4.0_dbl * pi * 1.0E-7_dbl - -! *** Planck constant [J*s] *** - h_planck = 6.6260755E-34_dbl - -! *** Elementary charge [C] *** - e_charge = 1.60217733E-19_dbl - -! *** Electron mass [kg] *** - e_mass = 9.1093897E-31_dbl - -! *** Atomic mass unit [kg] *** - a_mass = 1.6605402E-27_dbl - -! *** Avogradro constant [1/mol] *** - n_avogadro = 6.0221367E23_dbl - -! *** Fine-structure constant *** - a_fine = 0.5_dbl * mu_perm * c_light * e_charge ** 2 / h_planck - -! *** Rydberg constant [1/m] *** - rydberg = 0.5_dbl * e_mass * c_light * a_fine ** 2 / h_planck - -! *** Bohr radius [m] *** - a_bohr = a_fine / ( 4.0_dbl * pi * rydberg ) - -! *** Conversion factors *** - -! *** [Bohr] -> [Angstrom] *** - angstrom = 1.0E+10_dbl * a_bohr - -! *** [Angstrom] -> [Bohr] *** - bohr = 1.0_dbl / angstrom - -! *** [Hartree] -> [J] *** - joule = 2.0_dbl * rydberg * h_planck * c_light - -! *** [Hartree] -> [kJ/mol] *** - kjmol = 0.001_dbl * joule * n_avogadro - -! *** [Hartree] -> [kcal/mol] *** - kcalmol = kjmol / 4.184_dbl - -! *** [Hartree] -> [eV] *** - evolt = joule / e_charge - -! *** [Hartree] -> [Hz] *** - hz = joule / h_planck - mhz = 1.0E-6_dbl * hz - -! *** [Hartree] -> [1/cm] (wave numbers) *** - wavenum = 0.02_dbl * rydberg - -! *** [Hartree/Bohr**2] -> [1/cm] (wave numbers) *** - vibfac = 5.0_dbl * SQRT ( kjmol ) / ( pi * a_bohr * c_light ) - -! *** [Hartree] -> [esu] (electrostatic units) *** - esu(1) = 1.0E+21_dbl * a_bohr * c_light * e_charge - DO i = 2, maxmom - esu ( i ) = esu ( i - 1 )/ bohr - END DO - -! *** Electron mass [amu] *** - massunit = a_mass / e_mass - -! *** Boltzmann constant [Joule/Kelvin] *** - boltzmann = 1.380658E-23_dbl - -! *** Periodic Table *** - CALL init_periodic_table() - -END SUBROUTINE init_physcon - -!****************************************************************************** - -SUBROUTINE print_physcon ( iunit ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: iunit - -!------------------------------------------------------------------------------ - - WRITE (iunit,'(9x,A )' ) & - ' *** Fundamental physical constants (SI units) *** ' - WRITE (iunit,'(9x,A )' ) & - ' *** Literature: The 1986 CODATA Recommended Values of the *** ' - WRITE (iunit,'(9x,A )' ) & - ' *** Fundamental Physical Constants, *** ' - WRITE (iunit,'(9x,A )' ) & - ' *** E. R. Cohen, B. N. Taylor, *** ' - WRITE (iunit,'(9x,A )' ) & - ' *** J. Res. Natl. Bur. Stand. 92(2), 1 (1987) *** ' - WRITE (iunit,'(A )' ) - WRITE (iunit,'(A,T61,G20.14 )' ) ' Bohr radius [m].', a_bohr - WRITE (iunit,'(A,T61,G20.14 )' ) ' Fine-structure constant.', a_fine - WRITE (iunit,'(A,T61,F20.14 )' ) & - ' Conversion factor [Bohr] -> [Angstrom]', angstrom - WRITE (iunit,'(A,T61,F20.14 )' ) & - ' Conversion factor [Angstrom] -> [Bohr].', bohr - WRITE (iunit,'(A,T61,F20.0 )' ) ' Speed of light in vacuum [m/s].', & - c_light - WRITE (iunit,'(A,T61,G20.9 )' ) ' Elementary charge [C].', e_charge - WRITE (iunit,'(A,T61,G20.9 )' ) ' Atomic mass unit[kg].', a_mass - WRITE (iunit,'(A,T61,G20.9 )' ) ' Electron mass [kg].', e_mass - WRITE (iunit,'(A,T61,F20.5 )' ) ' Electron mass [amu].', massunit - WRITE (iunit,'(A,T61,F20.14 )' ) & - ' Conversion factors [Hartree] -> [esu].', esu(1) - WRITE (iunit,'(A,T61,F20.14 )' ) ' Conversion factor [Hartree] -> [eV].' & - , evolt - WRITE (iunit,'(A,T61,G20.8 )' ) ' Planck constant [J*s].', h_planck - WRITE (iunit,'(A,T61,G20.8 )' ) ' Boltzmann constant [J/Kelvin].', & - boltzmann - WRITE (iunit,'(A,T61,G20.14 )' ) ' Conversion factor [Hartree] -> [Hz].' & - , hz - WRITE (iunit,'(A,T61,F20.14 )' ) & - ' Conversion factor [Hartree] -> [kcal/mol].', kcalmol - WRITE (iunit,'(A,T61,F20.14 )' ) & - ' Conversion factor [Hartree] -> [kJ/mol].', kjmol - WRITE (iunit,'(A,T61,G20.14 )' ) ' Conversion factor [Hartree] -> [J].', & - joule - WRITE (iunit,'(A,T61,F20.4 )' ) ' Conversion factor [Hartree] -> [MHz].' & - , mhz - WRITE (iunit,'(A,T61,G20.14 )' ) ' Permeability of vacuum [N/A**2].', & - mu_perm - WRITE (iunit,'(A,T61,E20.9 )' ) ' Avogrado constant [1/mol].', & - n_avogadro - WRITE (iunit,'(A,T61,F20.8 )' ) ' Rydberg constant [1/m].', rydberg - WRITE (iunit,'(A,T61,F20.10 )' ) & - ' Conversion factor [Hartree/Bohr**2] -> [1/cm].', vibfac - WRITE (iunit,'(A,T61,F20.10 )' ) & - ' Conversion factor [Hartree] -> [1/cm] (wave numbers).', wavenum - WRITE ( iunit, '()' ) - -END SUBROUTINE print_physcon - -!****************************************************************************** - -END MODULE physcon diff --git a/src/pme.c b/src/pme.c deleted file mode 100644 index a3912d3..0000000 --- a/src/pme.c +++ /dev/null @@ -1,507 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE pme - - USE coefficients, ONLY : integral - USE coefficient_types, ONLY : coeff_type, coeff_allocate, & - coeff_deallocate, coeff_zero, PW_COMPLEXDATA3D, PW_REALDATA3D - USE dgs, ONLY : dg_sum_patch, dg_sum_patch_force, & - dg_get_1x_patch, dg_get_2x_patch, dg_get_strucfac, dg_get_rho_tot - USE dg_rho0s, ONLY : dg_rho0_setup - USE dg_types, ONLY : dg_type - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE kinds, ONLY: dbl, sgl, YES, NO - USE mathconstants, ONLY : fourpi - USE molecule_types, ONLY : particle_node_type - USE particle_lists, ONLY : particle_list_type, particle_list_select - USE pw_grid_types, ONLY : pw_grid_type - USE pws, ONLY : pw_poisson_solver - USE simulation_cell, ONLY : cell_type, get_hinv - USE stop_program, ONLY : stop_prg, stop_memory - USE structure_factors, ONLY : structure_factor_allocate, & - structure_factor_deallocate - USE structure_factor_types, ONLY : structure_factor_type - USE timings, ONLY: timeset, timestop - - IMPLICIT NONE - - PRIVATE - PUBLIC :: pme_evaluate, pme_setup - -CONTAINS - -!****************************************************************************** - -SUBROUTINE pme_setup ( pnode, grid_s, ewald_param, dg ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_s - TYPE ( dg_type ), INTENT ( OUT ) :: dg - -! Locals - INTEGER :: isos - -!------------------------------------------------------------------------------ - -! This is the first (and only) double grid - dg % grid_index = 1 - - ALLOCATE ( dg % dg_rho0 % zet (1) , STAT = isos) - IF ( isos /= 0 ) CALL stop_memory ('pme_setup', 'zet', 0 ) - -! No contracted Gaussians are used here - NULLIFY ( dg % dg_rho0 % gcc ) - - dg % dg_rho0 % type = ewald_param % ewald_type - dg % dg_rho0 % zet ( 1 ) = ewald_param % alpha - - CALL particle_list_select ( pnode, dg % plist, dg % nparts ) - - CALL dg_rho0_setup ( dg % dg_rho0, grid_s ) - -END SUBROUTINE pme_setup - -!****************************************************************************** - -SUBROUTINE pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, & - grid_s, grid_b, ewald_param ) - - IMPLICIT NONE - -! Arguments - TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg - TYPE ( cell_type ), INTENT ( IN ) :: box - TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: grid_s - TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: grid_b - TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: fg_coulomb - REAL ( dbl ), INTENT ( OUT ) :: vg_coulomb - REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_g - -! Locals - LOGICAL :: doublepack - INTEGER :: handle, part1, part2, i, allocstatus, p_idx - INTEGER :: lb_pbc ( 3 ), ub_pbc ( 3 ), lb_dvhartree ( 3 ), lb_rhob ( 3 ) - INTEGER, DIMENSION ( : ), POINTER :: centre1, centre2 - INTEGER :: handle2, handle3 - REAL ( dbl ) :: r1 ( 3 ), r2 ( 3 ), q1, q2, force ( 3 ), inv_fourpi_eps0 - COMPLEX ( dbl ), DIMENSION ( : ), POINTER :: ex1, ey1, ez1, ex2, ey2, ez2 - TYPE ( particle_list_type ), POINTER :: plist - TYPE ( structure_factor_type ), TARGET :: exp_igr - TYPE ( coeff_type ), POINTER :: rho0 - TYPE ( coeff_type ) :: rhos1_r, rhos2_r, rhob_r, phi_r, dphi_r ( 3 ), rhos_r -!*apsi* TYPE ( coeff_type ) :: rho_r - -! For saved FFTs - LOGICAL, SAVE :: saved_ffts_singleprecision = YES - INTEGER :: nsaved_ffts_maxmemory = 512 !*apsi in megabytes - INTEGER :: nsaved_ffts_max, nsaved_ffts, highest_fft_saved, nsize - INTEGER :: size_of_rhos_r_save - INTEGER, SAVE :: previous_size_of_rhos_r_save = -1 - -!*apsi Change to f9x intrinsic? - INTEGER :: bytes_per_real_sgl = 4 - INTEGER :: bytes_per_real_dbl = 8 - INTEGER :: bytes_per_real - - INTEGER, DIMENSION ( : ), ALLOCATABLE :: pbc1_b, pbc2_b, pbc3_b - INTEGER, DIMENSION ( : ), POINTER :: npts_b, npts_s - INTEGER, DIMENSION ( :, : ), POINTER :: bounds_s, bounds_b - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho_b - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho_s - -! To store the values of the allocated pointers - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos1_ptr, rhos2_ptr - - REAL ( sgl ), DIMENSION ( :, :, : ), POINTER :: rhos_r_sgl - REAL ( sgl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: & - rhos_r_save_sgl - REAL ( dbl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: & - rhos_r_save_dbl - - REAL ( dbl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: & - dvhartree - -!------------------------------------------------------------------------------ - - CALL timeset ( 'PME', 'I', ' ', handle ) - - npts_b => grid_b % npts - npts_s => grid_s % npts - bounds_b => grid_b % bounds - bounds_s => grid_s % bounds - -! Determine the number of small FFTs to be stored - IF ( saved_ffts_singleprecision ) THEN - bytes_per_real = bytes_per_real_sgl - ELSE - bytes_per_real = bytes_per_real_dbl - END IF - - nsize = grid_s % ngpts - nsaved_ffts_max = ( nsaved_ffts_maxmemory * 1024 ** 2 ) & - / ( nsize * bytes_per_real ) - - nsaved_ffts_max = MAX ( 0, nsaved_ffts_max ) - - nsaved_ffts = MIN ( dg % nparts, nsaved_ffts_max ) - -! Let us make it even so it is easier to deal with in the double packing - IF ( dg % nparts > 1 .AND. nsaved_ffts < dg % nparts ) & - nsaved_ffts = ( nsaved_ffts / 2 ) * 2 - - ALLOCATE ( dvhartree ( 3, & - bounds_b ( 1, 1 ):bounds_b ( 2, 1 ), & - bounds_b ( 1, 2 ):bounds_b ( 2, 2 ), & - bounds_b ( 1, 3 ):bounds_b ( 2, 3 ) & - ), STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'dvhartree', 0 ) - - IF ( saved_ffts_singleprecision ) THEN - ALLOCATE ( rhos_r_save_sgl ( bounds_s ( 1, 1 ):bounds_s ( 2, 1 ), & - bounds_s ( 1, 2 ):bounds_s ( 2, 2 ), & - bounds_s ( 1, 3 ):bounds_s ( 2, 3 ), & - nsaved_ffts ), STAT = allocstatus ) - ELSE - ALLOCATE ( rhos_r_save_dbl ( bounds_s ( 1, 1 ):bounds_s ( 2, 1 ), & - bounds_s ( 1, 2 ):bounds_s ( 2, 2 ), & - bounds_s ( 1, 3 ):bounds_s ( 2, 3 ), & - nsaved_ffts ), STAT = allocstatus ) - END IF - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'rhos_r_save', 0 ) - - IF ( saved_ffts_singleprecision ) THEN - size_of_rhos_r_save = SIZE ( rhos_r_save_sgl ) * bytes_per_real - ELSE - size_of_rhos_r_save = SIZE ( rhos_r_save_dbl ) * bytes_per_real - END IF - - IF ( size_of_rhos_r_save /= previous_size_of_rhos_r_save ) THEN - IF ( size_of_rhos_r_save / 1024**2 > 4 ) THEN - WRITE ( 6, '( /, A, I4, A, / )' ) " DG| SIZE(rho) = ", & - size_of_rhos_r_save / 1024**2, " MB" - ELSE - WRITE ( 6, '( /, A, I4, A, / )' ) " DG| SIZE(rho) = ", & - size_of_rhos_r_save / 1024, " kB" - END IF - previous_size_of_rhos_r_save = size_of_rhos_r_save - END IF - - lb_pbc ( : ) = bounds_b ( 1, : ) + bounds_s ( 1, : ) - ub_pbc ( : ) = bounds_b ( 2, : ) + bounds_s ( 2, : ) + 2 - ALLOCATE ( pbc1_b ( lb_pbc ( 1 ) : ub_pbc ( 1 ) ), STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc1_b', 0 ) - ALLOCATE ( pbc2_b ( lb_pbc ( 2 ) : ub_pbc ( 2 ) ), STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc2_b', 0 ) - ALLOCATE ( pbc3_b ( lb_pbc ( 3 ) : ub_pbc ( 3 ) ), STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc3_b', 0 ) - - DO i = lb_pbc ( 1 ), ub_pbc ( 1 ) - IF ( i < bounds_b ( 1, 1 ) ) THEN - pbc1_b ( i ) = i + npts_b ( 1 ) - ELSE IF ( i > bounds_b ( 2, 1 ) ) THEN - pbc1_b ( i ) = i - npts_b ( 1 ) - ELSE - pbc1_b ( i ) = i - END IF - END DO - DO i = lb_pbc ( 2 ), ub_pbc ( 2 ) - IF ( i < bounds_b ( 1, 2 ) ) THEN - pbc2_b ( i ) = i + npts_b ( 2 ) - ELSE IF ( i > bounds_b ( 2, 2 ) ) THEN - pbc2_b ( i ) = i - npts_b ( 2 ) - ELSE - pbc2_b ( i ) = i - END IF - END DO - DO i = lb_pbc ( 3 ), ub_pbc ( 3 ) - IF ( i < bounds_b ( 1, 3 ) ) THEN - pbc3_b ( i ) = i + npts_b ( 3 ) - ELSE IF ( i > bounds_b ( 2, 3 ) ) THEN - pbc3_b ( i ) = i - npts_b ( 3 ) - ELSE - pbc3_b ( i ) = i - END IF - END DO - -!!------------- DENSITY CALCULATION ---------------- - -! initializing TOTAL rho_r - inv_fourpi_eps0 = 1.0_dbl / ( fourpi * ewald_param % eps0 ) - -!*apsi CALL coeff_allocate ( rho_r, grid_b, use_data = PW_COMPLEXDATA3D ) -!*apsi CALL coeff_zero ( rho_r ) - - rho0 => dg % dg_rho0 % density - -! initialize rho_r on big grid - CALL coeff_allocate ( rhob_r, grid_b, use_data = PW_REALDATA3D ) - CALL coeff_allocate ( rhos_r, grid_s, use_data = PW_COMPLEXDATA3D ) - CALL coeff_allocate ( rhos1_r, grid_s, use_data = PW_REALDATA3D ) - CALL coeff_allocate ( rhos2_r, grid_s, use_data = PW_REALDATA3D ) - - rho_b => rhob_r % pw % cr3d - rho_s => rhos_r % pw % cc3d - rhos1_ptr => rhos1_r % pw % cr3d - rhos2_ptr => rhos2_r % pw % cr3d - - lb_rhob = LBOUND ( rhob_r % pw % cr3d ) - - CALL coeff_zero ( rhob_r ) - -! Allocate the space for the structure factor - CALL structure_factor_allocate ( grid_s % bounds, dg % nparts, & - exp_igr, allocate_centre = .TRUE. ) - - IF (.NOT. ASSOCIATED ( dg % plist ) ) & - CALL stop_prg ( 'pme_evaluate', 'no charged particles') - - CALL timeset ( 'PME_DENSITY', 'I', ' ', handle2 ) - - p_idx = 1 - plist => dg % plist - DO - doublepack = ASSOCIATED ( plist % next ) - - r1 ( : ) = plist % r ( : ) - q1 = plist % charge - part1 = plist % particle_index - centre1 => exp_igr % centre ( :, part1 ) - ex1 => exp_igr % ex ( :, part1 ) - ey1 => exp_igr % ey ( :, part1 ) - ez1 => exp_igr % ez ( :, part1 ) - IF ( doublepack ) THEN - plist => plist % next - r2 ( : ) = plist % r ( : ) - q2 = plist % charge - part2 = plist % particle_index - centre2 => exp_igr % centre ( :, part2 ) - ex2 => exp_igr % ex ( :, part2 ) - ey2 => exp_igr % ey ( :, part2 ) - ez2 => exp_igr % ez ( :, part2 ) - END IF - - CALL timeset ( 'PME_GETSFAC', 'I', ' ', handle3 ) - CALL dg_get_strucfac ( box, r1, grid_s % npts, grid_b % npts, & - centre1, exp_igr % lb, ex1, ey1, ez1 ) - IF ( doublepack ) THEN - CALL dg_get_strucfac ( box, r2, grid_s % npts, grid_b % npts, & - centre2, exp_igr % lb, ex2, ey2, ez2 ) - END IF - CALL timestop ( 0.0_dbl, handle3 ) - - CALL timeset ( 'PME_GETPATCH', 'I', ' ', handle3 ) - IF ( doublepack ) THEN - CALL dg_get_2x_patch ( rho0, rhos_r, q1, q2, & - exp_igr % lb, ex1, ey1, ez1, ex2, ey2, ez2 ) - ELSE - CALL dg_get_1x_patch ( rho0, rhos_r, q1, & - exp_igr % lb, ex1, ey1, ez1 ) - END IF - CALL timestop ( 0.0_dbl, handle3 ) - - IF ( p_idx <= nsaved_ffts ) THEN - IF ( saved_ffts_singleprecision ) THEN - rhos_r_save_sgl ( :, :, :, p_idx ) = REAL ( rho_s ) - IF ( doublepack ) THEN - rhos_r_save_sgl ( :, :, :, p_idx + 1 ) = AIMAG ( rho_s ) - END IF - ELSE - rhos_r_save_dbl ( :, :, :, p_idx ) = REAL ( rho_s ) - IF ( doublepack ) THEN - rhos_r_save_dbl ( :, :, :, p_idx + 1 ) = AIMAG ( rho_s ) - END IF - END IF - END IF - - p_idx = p_idx + 2 - - rhos1_ptr = REAL ( rho_s ) - IF ( doublepack ) THEN - rhos2_ptr = AIMAG ( rho_s ) - END IF - - CALL timeset ( 'PME_SUMPATCH1', 'I', ' ', handle3 ) - CALL dg_sum_patch ( rhos1_ptr, rho_b, bounds_s, centre1, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) - IF ( doublepack ) THEN - CALL dg_sum_patch ( rhos2_ptr, rho_b, bounds_s, centre2, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) - END IF - CALL timestop ( 0.0_dbl, handle3 ) - - IF ( .NOT. ASSOCIATED ( plist % next ) ) THEN - EXIT - ELSE - plist => plist % next - END IF - END DO - -! Obtain total density on rho_r; not necessary in PME because rho_r and rhob_r -! can be the same... -!*apsi CALL dg_get_rho_tot ( rho_r, rhob_r ) - - CALL timestop ( 0.0_dbl, handle2 ) - -!*apsi CALL coeff_deallocate ( rhob_r ) - -! initialize the forces - -!!------------- ELECTROSTATIC CALCULATION ----------- - - DO i = 1, 3 - CALL coeff_allocate ( dphi_r ( i ), grid_b, use_data = PW_REALDATA3D ) - END DO - CALL coeff_allocate ( phi_r, grid_b, use_data = PW_REALDATA3D ) - - lb_dvhartree = LBOUND ( dphi_r ( 1 ) % pw % cr3d ) - - CALL timeset ( 'PME_POISSON', 'I', ' ', handle2 ) - -!*apsi CALL pw_poisson_solver ( rho_r, phi_r, dphi_r ) - CALL pw_poisson_solver ( rhob_r, phi_r, dphi_r ) - -! dvhartree ( :, :, :, 1 ) = dphi_r ( 1 ) % pw % cr3d -! dvhartree ( :, :, :, 2 ) = dphi_r ( 2 ) % pw % cr3d -! dvhartree ( :, :, :, 3 ) = dphi_r ( 3 ) % pw % cr3d - dvhartree ( 1, :, :, : ) = dphi_r ( 1 ) % pw % cr3d - dvhartree ( 2, :, :, : ) = dphi_r ( 2 ) % pw % cr3d - dvhartree ( 3, :, :, : ) = dphi_r ( 3 ) % pw % cr3d - -!*apsi vg_coulomb = 0.5_dbl * integral ( rho_r, phi_r ) * inv_fourpi_eps0 & -!*apsi / grid_b % vol - vg_coulomb = 0.5_dbl * integral ( rhob_r, phi_r ) * inv_fourpi_eps0 - - CALL timestop ( 0.0_dbl, handle2 ) - -!*apsi CALL coeff_deallocate ( rho_r ) - CALL coeff_deallocate ( rhob_r ) - CALL coeff_deallocate ( phi_r ) - - fg_coulomb = 0.0_dbl - - CALL timeset ( 'PME_FORCES', 'I', ' ', handle2 ) - - p_idx = 1 - plist => dg % plist - DO - doublepack = ASSOCIATED ( plist % next ) - - q1 = plist % charge - part1 = plist % particle_index - centre1 => exp_igr % centre ( :, part1 ) - ex1 => exp_igr % ex ( :, part1 ) - ey1 => exp_igr % ey ( :, part1 ) - ez1 => exp_igr % ez ( :, part1 ) - IF ( doublepack ) THEN - plist => plist % next - q2 = plist % charge - part2 = plist % particle_index - centre2 => exp_igr % centre ( :, part2 ) - ex2 => exp_igr % ex ( :, part2 ) - ey2 => exp_igr % ey ( :, part2 ) - ez2 => exp_igr % ez ( :, part2 ) - END IF - -! Either fetch the densities from memory ... - IF ( p_idx <= nsaved_ffts ) THEN - IF ( saved_ffts_singleprecision ) THEN - rhos1_ptr = rhos_r_save_sgl ( :, :, :, p_idx ) - IF ( doublepack ) THEN - rhos2_ptr = rhos_r_save_sgl ( :, :, :, p_idx + 1 ) - END IF - ELSE - rhos1_ptr = rhos_r_save_dbl ( :, :, :, p_idx ) - IF ( doublepack ) THEN - rhos2_ptr = rhos_r_save_dbl ( :, :, :, p_idx + 1 ) - END IF - END IF - - ELSE -! ... they have to be calculated - IF ( doublepack ) THEN - CALL dg_get_2x_patch ( rho0, rhos_r, q1, q2, & - exp_igr % lb, ex1, ey1, ez1, ex2, ey2, ez2 ) - ELSE - CALL dg_get_1x_patch ( rho0, rhos_r, q1, & - exp_igr % lb, ex1, ey1, ez1 ) - END IF - - rhos1_ptr = REAL ( rho_s ) - IF ( doublepack ) THEN - rhos2_ptr = AIMAG ( rho_s ) - END IF - END IF - - p_idx = p_idx + 2 - - CALL timeset ( 'PME_SUMPATCH2', 'I', ' ', handle3 ) - CALL dg_sum_patch_force ( rhos1_ptr, dvhartree, force, & - bounds_s, centre1, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_dvhartree ) - fg_coulomb ( :, part1 ) = fg_coulomb ( :, part1 ) & - - force ( : ) * rhos1_r % pw % pw_grid % dvol * inv_fourpi_eps0 - - IF ( doublepack ) THEN - CALL dg_sum_patch_force ( rhos2_ptr, dvhartree, force, & - bounds_s, centre2, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_dvhartree ) - fg_coulomb ( :, part2 ) = fg_coulomb ( :, part2 ) & - - force ( : ) * rhos2_r % pw % pw_grid % dvol * inv_fourpi_eps0 - END IF - CALL timestop ( 0.0_dbl, handle3 ) - - IF ( .NOT. ASSOCIATED ( plist % next ) ) THEN - EXIT - ELSE - plist => plist % next - END IF - END DO - - CALL timestop ( 0.0_dbl, handle2 ) - - DO i = 1, 3 - CALL coeff_deallocate ( dphi_r ( i ) ) - END DO - - CALL coeff_deallocate ( rhos2_r ) - CALL coeff_deallocate ( rhos1_r ) - CALL coeff_deallocate ( rhos_r ) - - CALL structure_factor_deallocate ( exp_igr ) - - DEALLOCATE ( dvhartree, STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'dvhartree' ) - - DEALLOCATE ( pbc1_b, STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc1_b' ) - DEALLOCATE ( pbc2_b, STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc2_b' ) - DEALLOCATE ( pbc3_b, STAT = allocstatus ) - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc3_b' ) - - IF ( saved_ffts_singleprecision ) THEN - DEALLOCATE ( rhos_r_save_sgl, STAT = allocstatus ) - ELSE - DEALLOCATE ( rhos_r_save_dbl, STAT = allocstatus ) - END IF - IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'rhos_r_save' ) - -! The contribution from the electro-statistics on the pressure tensor has -! not yet been implemented - pv_g = -1.0E+30_dbl - - CALL timestop ( 0.0_dbl, handle ) - -END SUBROUTINE pme_evaluate - -!****************************************************************************** - -END MODULE pme diff --git a/src/pw.h b/src/pw.h deleted file mode 100644 index 657ab1a..0000000 --- a/src/pw.h +++ /dev/null @@ -1,79 +0,0 @@ -#ifndef _PW_H -#define _PW_H - -#ifdef __cplusplus -namespace CP2K_NS { -#else -#include -#endif - - const int REALDATA1D = 301; - const int COMPLEXDATA1D = 302; - const int REALDATA3D = 303; - const int COMPLEXDATA3D = 304; - - const int NOSPACE = 371; - const int REALSPACE = 372; - const int RECIPROCALSPACE = 373; - - const int HALFSPACE = 211; - const int FULLSPACE = 212; - - - typedef struct map_pn { - int *pos; - int *neg; - } map_pn; - - typedef struct pw_grid_type { - int ngpts; // # grid points - int ngpts_cut; // # grid points within cutoff - int ndimension; // # of dimensions - int bounds[3][2]; // lower and upper bounds - int npts[3]; // # point in all directions - double dr[3]; // grid spacing - double dvol, vol; // volume element, volume - struct map_pn mapl, mapm, mapn; // mapping 1D => 3D - double **g; // grid point vectors - double *gsq; // squared vector lengths - int **g_hat; // grid point indices (Miller) - // int grid_kind // type of grid: equidistance, - // logarithmic, ... - int grid_span; // type of equidistance grid: - // is f^*(g) = f(-g) - - bool have_g0; // whether I have G = [0,0,0] - int first_gne0; // first g index /= 0 [1/2] - - int nglengths; // # different lengths/shells - double *glsq; // squared vector lengths - int *glidx; // index to the full arrays - } pw_grid_type; - - typedef struct pw_type { - double *cr; - double ***cr3d; - double *cc; - double ***cc3d; - pw_grid_type pw_grid; - int in_use; // Which data is used [r1d/c1d/r3d/c3d] - int in_space; // Real/Reciprocal space - - int group_id; // In which parallel group am I - bool group_head; // Whether I am the head of this group - int group_head_id; // The group id for the head of this group - } pw_type; - - typedef struct pw_grid_types { - int number; - } pw_grid_types; - - void pw_zero(pw_type); - void pw_allocate(pw_type, pw_grid_type, int); - void pw_deallocate(pw_type); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/pw_grid_types.c b/src/pw_grid_types.c deleted file mode 100644 index 6dbe3c1..0000000 --- a/src/pw_grid_types.c +++ /dev/null @@ -1,51 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE pw_grid_types - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: pw_grid_type, map_pn - PUBLIC :: HALFSPACE, FULLSPACE - - !! maps to positive and negative g-vectors - TYPE map_pn - INTEGER, DIMENSION ( : ), POINTER :: pos, neg - END TYPE map_pn - - !! all you always wanted to know about grids, but were... - TYPE pw_grid_type - INTEGER :: ngpts ! # grid points - INTEGER :: ngpts_cut ! # grid points within cutoff - INTEGER :: ndimension ! # of dimensions - INTEGER, DIMENSION ( 2, 3 ) :: bounds ! lower and upper bounds - INTEGER, DIMENSION ( 3 ) :: npts ! # point in all directions - REAL ( dbl ), DIMENSION ( 3 ) :: dr ! grid spacing - REAL ( dbl ) :: dvol, vol ! volume element, volume - TYPE ( map_pn ) :: mapl, mapm, mapn ! mapping 1D => 3D - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: g ! grid point vectors - REAL ( dbl ), DIMENSION ( : ), POINTER :: gsq ! squared vector lengths - INTEGER, DIMENSION ( :, : ), POINTER :: g_hat ! grid point indices (Miller) -! INTEGER :: grid_kind ! type of grid: equidistance, - ! logarithmic, ... - INTEGER :: grid_span ! type of equidistance grid: - ! is f^*(g) = f(-g) - - LOGICAL :: have_g0 ! whether I have G = [0,0,0] - INTEGER :: first_gne0 ! first g index /= 0 [1/2] - - INTEGER :: nglengths ! # different lengths/shells - REAL ( dbl ), DIMENSION ( : ), POINTER :: glsq ! squared vector lengths - INTEGER, DIMENSION ( : ), POINTER :: glidx ! index to the full arrays - - END TYPE pw_grid_type - -!! (only for reciprocal grid:) fill in half or full space - INTEGER, PARAMETER :: HALFSPACE = 211, FULLSPACE = 212 - -END MODULE pw_grid_types diff --git a/src/pw_grids.c b/src/pw_grids.c deleted file mode 100644 index ee34d04..0000000 --- a/src/pw_grids.c +++ /dev/null @@ -1,550 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -!! This module defines the grid data type and some basic operations on it -!! -!!@Author apsi -!!@Author Christopher Mundy - -MODULE pw_grids - - USE kinds, ONLY : dbl - USE mathconstants, ONLY : twopi - USE pw_grid_types, ONLY : pw_grid_type, map_pn, HALFSPACE, FULLSPACE - USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_prg - USE util, ONLY : dotprod_3d, sort - - IMPLICIT NONE - - PRIVATE - PUBLIC :: pw_grid_setup, pw_grid_change, pw_find_cutoff - -CONTAINS - -!****************************************************************************** - -SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff ) - - IMPLICIT NONE - -! Arguments - TYPE ( cell_type ), INTENT ( IN ) :: cell - TYPE ( pw_grid_type ), INTENT ( INOUT ) :: pw_grid - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: cutoff - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( cutoff ) & - .AND. SUM ( ABS ( pw_grid % bounds ( :, : ) ) ) == 0 ) THEN - CALL pw_grid_find_bounds ( pw_grid, cell, cutoff ) - ELSE - IF ( SUM ( ABS ( pw_grid % bounds ( :, : ) ) ) == 0 ) THEN - CALL stop_prg ( "grid_setup", & - "provide initial values for bounds yourself" ) - END IF - END IF - - pw_grid % npts ( : ) = & - pw_grid % bounds ( 2, : ) - pw_grid % bounds ( 1, : ) + 1 - - ! Find the number of grid points - CALL pw_grid_count ( cell, pw_grid, cutoff ) - - pw_grid % ngpts = PRODUCT ( pw_grid % npts ) - - IF ( PRESENT ( cutoff ) ) THEN - write ( 6, '( A, I8 )' ) "pw_grid_setup: #gpts = ", pw_grid % ngpts_cut - ELSE - write ( 6, '( A, I8 )' ) "pw_grid_setup: #gpts = ", pw_grid % ngpts - END IF - - ! Allocate the grid fields - CALL pw_grid_allocate ( pw_grid ) - - ! Fill in the grid structure - CALL pw_grid_assign ( cell, pw_grid, cutoff ) - - CALL pw_grid_sort ( pw_grid ) - - pw_grid % vol = ABS ( cell % deth ) - pw_grid % dvol = pw_grid % vol / REAL ( pw_grid % ngpts, dbl ) - pw_grid % dr ( : ) = SQRT ( SUM ( cell % hmat ( :, : ) ** 2, 1 ) ) & - / REAL ( pw_grid % npts ( : ), dbl ) - -END SUBROUTINE pw_grid_setup - -!****************************************************************************** - -SUBROUTINE pw_grid_count ( cell, pw_grid, cutoff ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: cutoff - TYPE ( cell_type ), INTENT ( IN ), TARGET :: cell - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - -! Locals - INTEGER :: gpt, l, m, n, n_upperlimit - REAL ( dbl ) :: length_x, length_y, length_z, length - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: h_inv - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - bounds => pw_grid % bounds - h_inv => cell % h_inv - - IF ( pw_grid % grid_span == HALFSPACE ) THEN - n_upperlimit = 0 - ELSE IF ( pw_grid % grid_span == FULLSPACE ) THEN - n_upperlimit = bounds ( 2, 3 ) - ELSE - CALL stop_prg ( "pw_grid_count", "no type set for the grid" ) - END IF - -! finds valid g-points within grid - gpt = 0 - DO n = bounds ( 1, 3 ), n_upperlimit - DO m = bounds ( 1, 2 ), bounds ( 2, 2 ) - DO l = bounds ( 1, 1 ), bounds ( 2, 1 ) - IF ( pw_grid % grid_span == HALFSPACE .AND. n == 0 ) THEN - IF ( ( m == 0 .AND. l > 0 ) .OR. ( m > 0 ) ) CYCLE - END IF - - IF ( PRESENT ( cutoff ) ) THEN - length_x & - = REAL(l,dbl) * h_inv(1,1) & - + REAL(m,dbl) * h_inv(2,1) & - + REAL(n,dbl) * h_inv(3,1) - length_y & - = REAL(l,dbl) * h_inv(1,2) & - + REAL(m,dbl) * h_inv(2,2) & - + REAL(n,dbl) * h_inv(3,2) - length_z & - = REAL(l,dbl) * h_inv(1,3) & - + REAL(m,dbl) * h_inv(2,3) & - + REAL(n,dbl) * h_inv(3,3) - - length = SQRT ( length_x ** 2 + length_y ** 2 + length_z ** 2 ) - length = twopi * length - - IF ( length <= cutoff ) THEN - gpt = gpt + 1 - END IF - ELSE - gpt = gpt + 1 - END IF - - END DO - END DO - END DO - -! number of g-vectors for grid - pw_grid % ngpts_cut = gpt - -END SUBROUTINE pw_grid_count - -!****************************************************************************** - -SUBROUTINE pw_grid_assign ( cell, pw_grid, cutoff ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: cutoff - TYPE ( cell_type ), INTENT ( IN ), OPTIONAL, TARGET :: cell - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - -! Locals - INTEGER :: gpt,l,m,n, n_upperlimit - REAL ( dbl ) :: length_x, length_y, length_z, length - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: h_inv - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - bounds => pw_grid % bounds - h_inv => cell % h_inv - - IF ( pw_grid % grid_span == HALFSPACE ) THEN - n_upperlimit = 0 - ELSE IF ( pw_grid % grid_span == FULLSPACE ) THEN - n_upperlimit = bounds ( 2, 3 ) - ELSE - CALL stop_prg ( "pw_grid_assign", "no type set for the grid" ) - END IF - -! finds valid g-points within grid - gpt = 0 - DO n = bounds ( 1, 3 ), n_upperlimit - DO m = bounds ( 1, 2 ), bounds ( 2, 2 ) - DO l = bounds ( 1, 1 ), bounds ( 2, 1 ) - IF ( pw_grid % grid_span == HALFSPACE .AND. n == 0 ) THEN - IF ( ( m == 0 .AND. l > 0 ) .OR. ( m > 0 ) ) CYCLE - END IF - - length_x & - = REAL(l,dbl) * h_inv(1,1) & - + REAL(m,dbl) * h_inv(2,1) & - + REAL(n,dbl) * h_inv(3,1) - length_y & - = REAL(l,dbl) * h_inv(1,2) & - + REAL(m,dbl) * h_inv(2,2) & - + REAL(n,dbl) * h_inv(3,2) - length_z & - = REAL(l,dbl) * h_inv(1,3) & - + REAL(m,dbl) * h_inv(2,3) & - + REAL(n,dbl) * h_inv(3,3) - - length = SQRT ( length_x ** 2 + length_y ** 2 + length_z ** 2 ) - length = twopi * length - - IF ( PRESENT ( cutoff ) ) THEN - IF ( length <= cutoff ) THEN - gpt = gpt + 1 - pw_grid % g ( 1, gpt ) = twopi * length_x - pw_grid % g ( 2, gpt ) = twopi * length_y - pw_grid % g ( 3, gpt ) = twopi * length_z - pw_grid % gsq ( gpt ) = length ** 2 - pw_grid % g_hat ( 1, gpt ) = l - pw_grid % g_hat ( 2, gpt ) = m - pw_grid % g_hat ( 3, gpt ) = n - END IF - ELSE - gpt = gpt + 1 - pw_grid % g ( 1, gpt ) = twopi * length_x - pw_grid % g ( 2, gpt ) = twopi * length_y - pw_grid % g ( 3, gpt ) = twopi * length_z - pw_grid % gsq ( gpt ) = length ** 2 - pw_grid % g_hat ( 1, gpt ) = l - pw_grid % g_hat ( 2, gpt ) = m - pw_grid % g_hat ( 3, gpt ) = n - END IF - - END DO - END DO - END DO - -! Check the number of g-vectors for grid - IF ( pw_grid % ngpts_cut /= gpt ) THEN - CALL stop_prg ( "pw_grid_assign", "error re-counting the vectors" ) - END IF - - pw_grid % have_g0 = .FALSE. - pw_grid % first_gne0 = 2 - DO gpt = 1, pw_grid % ngpts_cut - IF ( ALL ( pw_grid % g_hat ( :, gpt ) == 0 ) ) THEN - pw_grid % have_g0 = .TRUE. - pw_grid % first_gne0 = 1 - EXIT - END IF - END DO - - CALL pw_grid_set_maps ( pw_grid % g_hat, pw_grid % ngpts_cut, & - pw_grid % mapl, pw_grid % mapm, pw_grid % mapn, pw_grid % npts ) - -END SUBROUTINE pw_grid_assign - -!****************************************************************************** - -SUBROUTINE pw_grid_set_maps ( g_hat, ngpts_cut, mapl, mapm, mapn, npts ) - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: ngpts_cut - INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: g_hat - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - TYPE ( map_pn ), INTENT ( INOUT ) :: mapl - TYPE ( map_pn ), INTENT ( INOUT ) :: mapm - TYPE ( map_pn ), INTENT ( INOUT ) :: mapn - -! Locals - INTEGER :: l, m, n, gpt - -!------------------------------------------------------------------------------ - - DO gpt = 1, ngpts_cut - l = g_hat ( 1, gpt ) - m = g_hat ( 2, gpt ) - n = g_hat ( 3, gpt ) - IF ( l < 0 ) THEN - mapl % pos ( g_hat ( 1, gpt ) ) = g_hat ( 1, gpt ) + npts ( 1 ) - ELSE - mapl % pos ( g_hat ( 1, gpt ) ) = g_hat ( 1, gpt ) - END IF - IF ( m < 0 ) THEN - mapm % pos ( g_hat ( 2, gpt ) ) = g_hat ( 2, gpt ) + npts ( 2 ) - ELSE - mapm % pos ( g_hat ( 2, gpt ) ) = g_hat ( 2, gpt ) - END IF - IF ( n < 0 ) THEN - mapn % pos ( g_hat ( 3, gpt ) ) = g_hat ( 3, gpt ) + npts ( 3 ) - ELSE - mapn % pos ( g_hat ( 3, gpt ) ) = g_hat ( 3, gpt ) - END IF - -! Generating the maps to the full 3-d space - - IF ( l <= 0 ) THEN - mapl % neg ( g_hat ( 1, gpt ) ) = - g_hat ( 1, gpt ) - ELSE - mapl % neg ( g_hat ( 1, gpt ) ) = npts ( 1 ) - g_hat ( 1, gpt ) - END IF - IF ( m <= 0 ) THEN - mapm % neg ( g_hat ( 2, gpt ) ) = - g_hat ( 2, gpt ) - ELSE - mapm % neg ( g_hat ( 2, gpt ) ) = npts ( 2 ) - g_hat ( 2, gpt ) - END IF - IF ( n <= 0 ) THEN - mapn % neg ( g_hat ( 3, gpt ) ) = - g_hat ( 3, gpt ) - ELSE - mapn % neg ( g_hat ( 3, gpt ) ) = npts ( 3 ) - g_hat ( 3, gpt ) - END IF - END DO - -END SUBROUTINE pw_grid_set_maps - -!****************************************************************************** - -SUBROUTINE pw_grid_find_bounds ( pw_grid, cell, cutoff ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - REAL ( dbl ), INTENT ( IN ) :: cutoff - TYPE ( cell_type ), INTENT ( IN ), TARGET :: cell - -! Locals - INTEGER :: l, m, n, test_max = 50 - REAL ( dbl ) :: length_x, length_y, length_z, length - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: h_inv - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - bounds => pw_grid % bounds - h_inv => cell % h_inv - - bounds ( :, : ) = 0 - -! finds valid g-points within grid - DO n = 0, +test_max - DO m = -test_max, +test_max - DO l = -test_max, +test_max - length_x & - = REAL(l,dbl) * h_inv(1,1) & - + REAL(m,dbl) * h_inv(2,1) & - + REAL(n,dbl) * h_inv(3,1) - length_y & - = REAL(l,dbl) * h_inv(1,2) & - + REAL(m,dbl) * h_inv(2,2) & - + REAL(n,dbl) * h_inv(3,2) - length_z & - = REAL(l,dbl) * h_inv(1,3) & - + REAL(m,dbl) * h_inv(2,3) & - + REAL(n,dbl) * h_inv(3,3) - - length = SQRT ( length_x ** 2 + length_y ** 2 + length_z ** 2 ) - length = twopi * length - - IF ( length <= cutoff ) THEN - bounds ( 2, 1 ) = MAX ( bounds ( 2, 1 ), l ) - bounds ( 2, 2 ) = MAX ( bounds ( 2, 2 ), m ) - bounds ( 2, 3 ) = MAX ( bounds ( 2, 3 ), n ) - END IF - - END DO - END DO - END DO - - IF ( bounds ( 2, 1 ) == test_max .OR. & - bounds ( 2, 2 ) == test_max .OR. & - bounds ( 2, 3 ) == test_max ) THEN - WRITE ( 6, * ) "grid_find_bounds: WARNING" - WRITE ( 6, * ) " initial bounds maybe too small:" - WRITE ( 6, * ) bounds ( 2, : ), test_max - END IF - - write(6,*) "apsi: automatic grid bounds ", bounds(2,:) - - bounds ( 1, : ) = - bounds ( 2, : ) - -END SUBROUTINE pw_grid_find_bounds - -!**************************************************************************** - -SUBROUTINE pw_grid_allocate ( pw_grid ) - IMPLICIT NONE - -! Argument - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - -! Locals - INTEGER, POINTER :: ngpts_cut - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - ngpts_cut => pw_grid % ngpts_cut - bounds => pw_grid % bounds - - ALLOCATE ( pw_grid % g ( 3, ngpts_cut ) ) - ALLOCATE ( pw_grid % gsq ( ngpts_cut ) ) - ALLOCATE ( pw_grid % g_hat ( 3, ngpts_cut ) ) - ALLOCATE ( pw_grid % mapl % pos ( bounds ( 1, 1 ):bounds ( 2, 1 ) ) ) - ALLOCATE ( pw_grid % mapl % neg ( bounds ( 1, 1 ):bounds ( 2, 1 ) ) ) - ALLOCATE ( pw_grid % mapm % pos ( bounds ( 1, 2 ):bounds ( 2, 2 ) ) ) - ALLOCATE ( pw_grid % mapm % neg ( bounds ( 1, 2 ):bounds ( 2, 2 ) ) ) - ALLOCATE ( pw_grid % mapn % pos ( bounds ( 1, 3 ):bounds ( 2, 3 ) ) ) - ALLOCATE ( pw_grid % mapn % neg ( bounds ( 1, 3 ):bounds ( 2, 3 ) ) ) - -END SUBROUTINE pw_grid_allocate - -!**************************************************************************** - -SUBROUTINE pw_grid_sort ( pw_grid ) - - IMPLICIT NONE - -! Argument - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - -! Locals - INTEGER :: gpt, gpt_curr, gpt_tmp, int_tmp ( 3 ) - INTEGER :: idx ( SIZE ( pw_grid % gsq ) ) - REAL ( dbl ) :: real_tmp ( 3 ) - -!------------------------------------------------------------------------------ - - IF ( .NOT. ASSOCIATED ( pw_grid % gsq ) ) THEN - CALL stop_prg ( "pw_grid_sort", & - "works currently only if lenghts are filled" ) - END IF - - CALL sort ( pw_grid % gsq, pw_grid % ngpts_cut, idx ) - - DO gpt = 1, pw_grid % ngpts_cut - 1 - gpt_curr = gpt - - DO - IF ( idx ( gpt_curr ) == gpt ) EXIT - - real_tmp ( : ) = pw_grid % g ( :, gpt_curr ) - pw_grid % g ( :, gpt_curr ) = pw_grid % g ( :, idx ( gpt_curr ) ) - pw_grid % g ( :, idx ( gpt_curr ) ) = real_tmp ( : ) - - int_tmp ( : ) = pw_grid % g_hat ( :, gpt_curr ) - pw_grid % g_hat ( :, gpt_curr ) & - = pw_grid % g_hat ( :, idx ( gpt_curr ) ) - pw_grid % g_hat ( :, idx ( gpt_curr ) ) = int_tmp ( : ) - - gpt_tmp = gpt_curr - gpt_curr = idx ( gpt_curr ) - idx ( gpt_tmp ) = gpt_tmp - - IF ( idx ( gpt_curr ) == gpt ) then - idx ( gpt_curr ) = gpt_curr - EXIT - END IF - END DO - END DO - -END SUBROUTINE pw_grid_sort - -!**************************************************************************** - -SUBROUTINE pw_grid_change ( cell, pw_grid ) - IMPLICIT NONE - -! Argument - TYPE ( cell_type ), INTENT ( IN ), TARGET :: cell - TYPE ( pw_grid_type ), INTENT ( INOUT ), TARGET :: pw_grid - -! Locals - INTEGER :: gpt, l, m, n - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: h_inv - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: g - -!------------------------------------------------------------------------------ - - h_inv => cell % h_inv - g => pw_grid % g - - DO gpt = 1, pw_grid % ngpts_cut - l = pw_grid % g_hat ( 1, gpt ) - m = pw_grid % g_hat ( 2, gpt ) - n = pw_grid % g_hat ( 3, gpt ) - - g ( 1, gpt ) & - = REAL(l,dbl) * h_inv(1,1) & - + REAL(m,dbl) * h_inv(2,1) & - + REAL(n,dbl) * h_inv(3,1) - g ( 2, gpt ) & - = REAL(l,dbl) * h_inv(1,2) & - + REAL(m,dbl) * h_inv(2,2) & - + REAL(n,dbl) * h_inv(3,2) - g ( 3, gpt ) & - = REAL(l,dbl) * h_inv(1,3) & - + REAL(m,dbl) * h_inv(2,3) & - + REAL(n,dbl) * h_inv(3,3) - - IF ( ASSOCIATED ( pw_grid % gsq ) ) & - pw_grid % gsq ( gpt ) = SUM ( g ( :, gpt ) ** 2 ) - END DO - -END SUBROUTINE pw_grid_change - -!**************************************************************************** - -SUBROUTINE pw_find_cutoff ( npts, box, cutoff ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( OUT ) :: cutoff - -! Locals - INTEGER :: i - REAL ( dbl ) :: gdum ( 3 ), length, gcut - -!------------------------------------------------------------------------------ - -! compute 2*pi*h_inv^t*g where g = (npts[1],0,0) - gdum ( : ) = twopi * box % h_inv ( 1, : ) & - * REAL ( npts ( 1 ), dbl ) / 2.0_dbl -!*apsi:old * REAL ( npts ( 1 ) - 1, dbl ) / 2.0_dbl - length = SQRT ( dotprod_3d ( gdum, gdum ) ) - gcut = length - -! compute 2*pi*h_inv^t*g where g = (0,npts[2],0) - gdum ( : ) = twopi * box % h_inv ( 2, : ) & - * REAL ( npts ( 2 ), dbl ) / 2.0_dbl -!*apsi:old * REAL ( npts ( 2 ) - 1, dbl ) / 2.0_dbl - length = SQRT ( dotprod_3d ( gdum, gdum ) ) - gcut = MIN ( gcut, length ) - -! compute 2*pi*h_inv^t*g where g = (0,0,npts[3]) - gdum ( : ) = twopi * box % h_inv ( 3, : ) & - * REAL ( npts ( 3 ), dbl ) / 2.0_dbl -!*apsi:old * REAL ( npts ( 3 ) - 1, dbl ) / 2.0_dbl - length = SQRT ( dotprod_3d ( gdum, gdum ) ) - gcut = MIN ( gcut, length ) - -! Because there is a HUGE OZONE hole over FINLAND that -! effects SOME co-workers...We subtract epsilon. - - cutoff = gcut - 1.0E-5_dbl -!*apsi:old cutoff = gcut + 1e-5_dbl - -END SUBROUTINE pw_find_cutoff - -!****************************************************************************** - -END MODULE pw_grids diff --git a/src/pw_types.cpp b/src/pw_types.cpp deleted file mode 100644 index 836c6c6..0000000 --- a/src/pw_types.cpp +++ /dev/null @@ -1,67 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include -#include - -#include "pw.h" - -using namespace CP2K_NS; - -void pw_allocate(pw_type &pw, pw_grid_type &pw_grid, int use_data) { - - int *bounds; - - pw.in_use = use_data; - pw.pw_grid = pw_grid; - pw.in_space = NOSPACE; - bounds = pw.pw_grid->bounds[0]; - - pw.cr = nullptr; - pw.cc = nullptr; - pw.cr3d = nullptr; - pw.cc3d = nullptr; - - if (use_data == REALDATA1D) { - pw.cr = new double[pw.pw_grid->ngpts_cut]; - } else if (use_data == COMPLEXDATA1D) { - pw.cc = new std::complex [pw.pw_grid->ngpts_cut]; - } else if (use_data == REALDATA3D) { - pw.cr3d = new double[bounds[1] - bounds[0] + 1][bounds[3] - bounds[2] + 1][bounds[5] - bounds[4] + 1]; - } else if (use_data == COMPLEXDATA3D) { - pw.cc3d = new std::complex [bounds[1] - bounds[0] + 1][bounds[3] - bounds[2] + 1][bounds[5] - bounds[4] + 1]; - } else { - stop_prg("pw_allocate", "no possible data field"); - } -} - -void pw_deallocate(pw_type pw) { - - if (pw.in_use == REALDATA1D) { - delete pw.cr; - } else if (pw.in_use == COMPLEXDATA1D) { - delete pw.cc; - } else if (pw.in_use == REALDATA3D) { - delete pw.cr3d; - } else if (pw.in_use == COMPLEXDATA3D) { - delete pw.cc3d; - } else { - stop_prg("pw_deallocate", "no possible data field"); - } -} - -void pw_zero(pw_type pw) { - if (pw.in_use == REALDATA1D) { - pw.cr[0] = 0.0; - } else if (pw.in_use == COMPLEXDATA1D) { - pw.cc[0] = 0.0; - } else if (pw.in_use == REALDATA3D) { - pw.cr3d[0][0][0].push_back(0.0); - } else if (pw.in_use == COMPLEXDATA3D) { - pw.cc3d[0][0][0].push_back(0.0); - } else { - stop_prg("pw_zero", "no possible data field"); - } -} \ No newline at end of file diff --git a/src/pws.c b/src/pws.c deleted file mode 100644 index aae4014..0000000 --- a/src/pws.c +++ /dev/null @@ -1,885 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE pws - - USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_deallocate, & - SQUARE, SQUAREROOT - USE fft_tools, ONLY : fft3d => fft_wrap, & - FWFFTu => FWFFT, BWFFTu => BWFFT, FWFFTw => FWFFT, BWFFTw => BWFFT - USE kinds, ONLY : dbl - USE mathconstants, ONLY : fourpi - USE mp, ONLY : mp_sum - USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE - USE pw_types, ONLY : pw_type, pw_allocate, pw_deallocate, & - REALDATA1D, COMPLEXDATA1D, REALDATA3D, COMPLEXDATA3D - USE stop_program, ONLY : stop_prg - USE util, ONLY : dotprod_3d - - IMPLICIT NONE - - PRIVATE - PUBLIC :: pw_poisson_solver, pw_kinetic_evaluate - PUBLIC :: pw_integral_a, pw_integral_ab, pw_h_psi, fft_wrap - - INTERFACE fft_wrap - MODULE PROCEDURE fft_wrap_c1c2, fft_wrap_c1pw2, & - fft_wrap_pw1c2, fft_wrap_pw1pw2 - END INTERFACE - -CONTAINS - -!****************************************************************************** - -#if defined ( __PGI ) -#define mp mpp -#endif - -!****************************************************************************** - -SUBROUTINE pw_poisson_solver ( n, vhartree, dvhartree ) - -!! obtains electrostatic potential and its derivatives with respect to r -!! from the density - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( IN ), TARGET :: n - TYPE ( coeff_type ), INTENT ( OUT ), OPTIONAL :: vhartree - TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), OPTIONAL :: dvhartree - -! Locals - INTEGER :: gpt, dir - REAL ( dbl ) :: gf - COMPLEX ( dbl ) :: i_cmplx - INTEGER :: lp, mp, np, ln, mn, nn - INTEGER, DIMENSION ( : ), POINTER :: ghat - - INTEGER, DIMENSION ( :, : ), POINTER :: g_hat - TYPE ( pw_grid_type ), POINTER :: pw_grid - TYPE ( pw_type ) :: rho_g, cfft - -!------------------------------------------------------------------------------ - - i_cmplx = ( 0._dbl, 1._dbl ) - - pw_grid => n % pw % pw_grid - g_hat => pw_grid % g_hat - - CALL pw_allocate ( rho_g, pw_grid, use_data = COMPLEXDATA3D ) - - CALL pw_allocate ( cfft, pw_grid, use_data = COMPLEXDATA3D ) - - CALL fft_wrap ( n, rho_g, dir = FWFFTu ) - - IF ( PRESENT ( vhartree ) ) THEN - cfft % cc3d = 0._dbl - - DO gpt = 1, pw_grid % ngpts_cut - - ! compute Green's function ''' - CALL pw_greens_function ( gf, pw_grid % g ( :, gpt ) ) - - ghat => g_hat ( :, gpt ) - - lp = pw_grid % mapl % pos ( ghat ( 1 ) ) - ln = pw_grid % mapl % neg ( ghat ( 1 ) ) - mp = pw_grid % mapm % pos ( ghat ( 2 ) ) - mn = pw_grid % mapm % neg ( ghat ( 2 ) ) - np = pw_grid % mapn % pos ( ghat ( 3 ) ) - nn = pw_grid % mapn % neg ( ghat ( 3 ) ) - - lp = lp + LBOUND ( cfft % cc3d, 1 ) - mp = mp + LBOUND ( cfft % cc3d, 2 ) - np = np + LBOUND ( cfft % cc3d, 3 ) - ln = ln + LBOUND ( cfft % cc3d, 1 ) - mn = mn + LBOUND ( cfft % cc3d, 2 ) - nn = nn + LBOUND ( cfft % cc3d, 3 ) - - cfft % cc3d ( lp, mp, np ) = gf * rho_g % cc3d ( lp, mp, np ) - cfft % cc3d ( ln, mn, nn ) = gf * rho_g % cc3d ( ln, mn, nn ) - END DO - -! get phi_r - CALL fft_wrap ( cfft, vhartree, dir = BWFFTu ) - END IF - -! multiply by the Green's function ''' - - IF ( PRESENT ( dvhartree ) ) THEN - DO dir = 1, 3 - cfft % cc3d = 0.0_dbl - - DO gpt = 1, pw_grid % ngpts_cut - - ! compute Green's function ''' - CALL pw_greens_function ( gf, pw_grid % g ( :, gpt ) ) - - ghat => g_hat ( :, gpt ) - - lp = pw_grid % mapl % pos ( ghat ( 1 ) ) - ln = pw_grid % mapl % neg ( ghat ( 1 ) ) - mp = pw_grid % mapm % pos ( ghat ( 2 ) ) - mn = pw_grid % mapm % neg ( ghat ( 2 ) ) - np = pw_grid % mapn % pos ( ghat ( 3 ) ) - nn = pw_grid % mapn % neg ( ghat ( 3 ) ) - - lp = lp + LBOUND ( cfft % cc3d, 1 ) - mp = mp + LBOUND ( cfft % cc3d, 2 ) - np = np + LBOUND ( cfft % cc3d, 3 ) - ln = ln + LBOUND ( cfft % cc3d, 1 ) - mn = mn + LBOUND ( cfft % cc3d, 2 ) - nn = nn + LBOUND ( cfft % cc3d, 3 ) - - cfft % cc3d ( lp, mp, np ) = & - i_cmplx * pw_grid % g ( dir, gpt ) * gf & - * rho_g % cc3d ( lp, mp, np ) - cfft % cc3d ( ln, mn, nn ) = & - - i_cmplx * pw_grid % g ( dir, gpt ) * gf & - * rho_g % cc3d ( ln, mn, nn ) - END DO - -! get derivative of phi_r - CALL fft_wrap ( cfft, dvhartree ( dir ), dir = BWFFTu ) - END DO - END IF - - CALL pw_deallocate ( cfft ) - - CALL pw_deallocate ( rho_g ) - -END SUBROUTINE pw_poisson_solver - -!****************************************************************************** - -SUBROUTINE pw_greens_function ( gf, g ) - IMPLICIT NONE - -! Arguments - REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: g - REAL ( dbl ), INTENT ( OUT ) :: gf - -! Locals - INTEGER :: dimensionality !TMPTMPTMP - REAL ( dbl ) :: g2 - -!------------------------------------------------------------------------------ - - dimensionality = SIZE ( g ) - - SELECT CASE ( dimensionality ) - CASE ( 3 ) ! 3-dim - g2 = dotprod_3d ( g, g ) - IF ( g2 > 1.0E-10_dbl ) THEN - gf = fourpi / g2 - ELSE - gf = 0.0_dbl - END IF - CASE ( 2 ) ! 2-dim - stop "greens_function, no 2-dim function implemented yet" - CASE ( 1 ) ! 1-dim - stop "greens_function, no 1-dim function implemented yet" - CASE ( 0 ) ! 0-dim = cluster - stop "greens_function, no 0-dim function implemented yet" - END SELECT - -END SUBROUTINE pw_greens_function - -!****************************************************************************** - -SUBROUTINE pw_allocate_coeff ( pw_out, pw_model, use_data ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( IN ), TARGET :: pw_model - TYPE ( pw_type ), INTENT ( OUT ) :: pw_out - INTEGER, INTENT ( IN ), OPTIONAL :: use_data - -! Locals - INTEGER, DIMENSION ( :, : ), POINTER :: bounds - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( use_data ) ) THEN - pw_out % in_use = use_data - ELSE - pw_out % in_use = pw_model % in_use - END IF - pw_out % pw_grid => pw_model % pw_grid - bounds => pw_model % pw_grid % bounds - - CALL pw_allocate ( pw_out, pw_out % pw_grid, use_data = use_data ) - -END SUBROUTINE pw_allocate_coeff - -!****************************************************************************** - -SUBROUTINE pw_deallocate_coeff ( pw ) - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( INOUT ) :: pw - -!------------------------------------------------------------------------------ - - IF ( pw % in_use == REALDATA1D ) THEN - DEALLOCATE ( pw % cr ) - ELSE IF ( pw % in_use == COMPLEXDATA1D ) THEN - DEALLOCATE ( pw % cc ) - ELSE IF ( pw % in_use == REALDATA3D ) THEN - DEALLOCATE ( pw % cr3d ) - ELSE IF ( pw % in_use == COMPLEXDATA3D ) THEN - DEALLOCATE ( pw % cc3d ) - ELSE - CALL stop_prg ( "pw_deallocate_coeff", "error de-allocating data" ) - END IF - -END SUBROUTINE pw_deallocate_coeff - -!****************************************************************************** - -SUBROUTINE fft_wrap_c1c2 ( c1, c2, dir, scale ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: c1 - TYPE ( coeff_type ), INTENT ( INOUT ), OPTIONAL, TARGET :: c2 - INTEGER, INTENT ( IN ), OPTIONAL :: dir - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER :: gpt, ghat ( 3 ) - INTEGER, POINTER :: bds ( :, : ) - COMPLEX ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: cfft - TYPE ( pw_type ), POINTER :: pw1, pw2 - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( c2 ) ) THEN - pw1 => c1 % pw - pw2 => c2 % pw - - IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - IF ( .NOT. PRESENT ( dir ) ) THEN - CALL stop_prg ( "fft_wrap_c1c2", & - "direction must be given in 3D => 3D transform" ) - ELSE - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, pw2 % cc3d, & - scale = scale ) - END IF - - ELSE IF ( pw1 % in_use == REALDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = pw1 % cr3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - CALL fft3d ( FWFFTu, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == REALDATA3D ) THEN - - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d - - CALL fft3d ( BWFFTu, pw1 % pw_grid % npts, cfft, scale = scale ) - pw2 % cr3d = REAL ( cfft ) - DEALLOCATE ( cfft ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = 0._dbl - - DO gpt = 1, pw1 % pw_grid % ngpts_cut - ghat = pw2 % pw_grid % g_hat ( :, gpt ) - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) -!TMPTMPTMP pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) -!TMPTMPTMP pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - END IF - END DO - - CALL fft3d ( BWFFTw, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - - bds => pw1 % pw_grid % bounds - ALLOCATE (cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3)) ) - cfft = pw1 % cc3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - - CALL fft3d ( FWFFTw, pw1 % pw_grid % npts, cfft, scale = scale ) - - DO gpt = 1, pw2 % pw_grid % ngpts_cut - ghat = pw1 % pw_grid % g_hat ( :, gpt ) - pw2 % cc ( gpt ) = cfft ( & - LBOUND ( cfft, 1 ) + pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( cfft, 2 ) + pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( cfft, 3 ) + pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) -!TMPTMPTMP pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & -!TMPTMPTMP pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & -!TMPTMPTMP pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - END DO - - DEALLOCATE ( cfft ) - - ELSE - CALL stop_prg ( "fft_wrap_c1c2", "no suitable FFT found" ) - END IF - ELSE - pw1 => c1 % pw - IF ( pw1 % in_use == COMPLEXDATA3D ) THEN - IF ( PRESENT ( dir ) ) THEN - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, scale = scale ) - ELSE - CALL stop_prg ( "fft_wrap_c1c2", & - "no direction specified for in-place FFT" ) - END IF - ELSE - CALL stop_prg ( "fft_wrap_c1c2", "wrong data type to be FFTed" ) - END IF - END IF - -END SUBROUTINE fft_wrap_c1c2 - -!****************************************************************************** - -SUBROUTINE fft_wrap_c1pw2 ( c1, pw2, dir, scale ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( IN ), TARGET :: c1 - TYPE ( pw_type ), INTENT ( INOUT ) :: pw2 - INTEGER, INTENT ( IN ), OPTIONAL :: dir - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER :: gpt, ghat ( 3 ) - INTEGER, POINTER :: bds ( :, : ) - COMPLEX ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: cfft - TYPE ( pw_type ), POINTER :: pw1 - -!------------------------------------------------------------------------------ - - pw1 => c1 % pw - - IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - IF ( .NOT. PRESENT ( dir ) ) THEN - CALL stop_prg ( "fft_wrap_c1pw2", & - "direction must be given in 3D => 3D transform" ) - ELSE - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, pw2 % cc3d, & - scale = scale ) - END IF - - ELSE IF ( pw1 % in_use == REALDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = pw1 % cr3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - CALL fft3d ( FWFFTu, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == REALDATA3D ) THEN - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d - CALL fft3d ( BWFFTu, pw1 % pw_grid % npts, cfft, scale = scale ) - pw2 % cr3d = REAL ( cfft ) - DEALLOCATE ( cfft ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = 0._dbl - - DO gpt = 1, pw1 % pw_grid % ngpts_cut - ghat = pw2 % pw_grid % g_hat ( :, gpt ) - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - !TMPTMPTMP pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - - IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - !TMPTMPTMP pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - END IF - END DO - - CALL fft3d ( BWFFTw, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - - CALL fft3d ( FWFFTw, pw1 % pw_grid % npts, cfft, scale = scale ) - - DO gpt = 1, pw2 % pw_grid % ngpts_cut - ghat = pw1 % pw_grid % g_hat ( :, gpt ) - pw2 % cc ( gpt ) = cfft ( & - LBOUND ( cfft, 1 ) + pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( cfft, 2 ) + pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( cfft, 3 ) + pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - !TMPTMPTMP pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - !TMPTMPTMP pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - !TMPTMPTMP pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - END DO - - DEALLOCATE ( cfft ) - - ELSE - CALL stop_prg ( "fft_wrap_c1pw2", "no suitable FFT found" ) - END IF - -END SUBROUTINE fft_wrap_c1pw2 - -!****************************************************************************** - -SUBROUTINE fft_wrap_pw1c2 ( pw1, c2, dir, scale ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( INOUT ), TARGET :: pw1 - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: c2 - INTEGER, INTENT ( IN ), OPTIONAL :: dir - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER :: gpt, ghat ( 3 ) - INTEGER, POINTER :: bds ( :, : ) - COMPLEX ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: cfft - TYPE ( pw_type ), POINTER :: pw2 - -!------------------------------------------------------------------------------ - - pw2 => c2 % pw - - IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - IF ( .NOT. PRESENT ( dir ) ) THEN - CALL stop_prg ( "fft_wrap_pw1c2", & - "direction must be given in 3D => 3D transform" ) - ELSE - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, pw2 % cc3d, & - scale = scale ) - END IF - - ELSE IF ( pw1 % in_use == REALDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = pw1 % cr3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - CALL fft3d ( FWFFTu, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == REALDATA3D ) THEN - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d - CALL fft3d ( BWFFTu, pw1 % pw_grid % npts, cfft, scale = scale ) - pw2 % cr3d = REAL ( cfft ) - DEALLOCATE ( cfft ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = 0._dbl - - DO gpt = 1, pw1 % pw_grid % ngpts_cut - ghat = pw2 % pw_grid % g_hat ( :, gpt ) - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - !TMPTMPTMP pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - !TMPTMPTMP pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - !TMPTMPTMP pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - END IF - END DO - - CALL fft3d ( BWFFTw, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - - CALL fft3d ( FWFFTw, pw1 % pw_grid % npts, cfft, scale = scale ) - - DO gpt = 1, pw2 % pw_grid % ngpts_cut - ghat = pw1 % pw_grid % g_hat ( :, gpt ) - pw2 % cc ( gpt ) = cfft ( & - LBOUND ( cfft, 1 ) + pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( cfft, 2 ) + pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( cfft, 3 ) + pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - !TMPTMPTMP pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - !TMPTMPTMP pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - !TMPTMPTMP pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - END DO - - DEALLOCATE ( cfft ) - - ELSE - CALL stop_prg ( "fft_wrap_pw1c2", "no suitable FFT found" ) - END IF - -END SUBROUTINE fft_wrap_pw1c2 - -!****************************************************************************** - -SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, dir, scale ) - - IMPLICIT NONE - -! Arguments - TYPE ( pw_type ), INTENT ( OUT ), TARGET :: pw1 - TYPE ( pw_type ), INTENT ( INOUT ), OPTIONAL, TARGET :: pw2 - INTEGER, INTENT ( IN ), OPTIONAL :: dir - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: scale - -! Locals - INTEGER :: gpt, ghat ( 3 ) - INTEGER, POINTER :: bds ( :, : ) - COMPLEX ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: cfft - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( pw2 ) ) THEN - - IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - IF ( .NOT. PRESENT ( dir ) ) THEN - CALL stop_prg ( "fft_wrap_pw1pw2", & - "direction must be given in 3D => 3D transform" ) - ELSE - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, pw2 % cc3d, & - scale = scale ) - END IF - - ELSE IF ( pw1 % in_use == REALDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = pw1 % cr3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - CALL fft3d ( FWFFTu, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == REALDATA3D ) THEN - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d - CALL fft3d ( BWFFTu, pw1 % pw_grid % npts, cfft, scale = scale ) - pw2 % cr3d = REAL ( cfft ) - DEALLOCATE ( cfft ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - - pw2 % cc3d = 0._dbl - - DO gpt = 1, pw1 % pw_grid % ngpts_cut - ghat = pw2 % pw_grid % g_hat ( :, gpt ) - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) -!TMPTMPTMP pw2 % pw_grid % mapl % pos ( ghat ( 1 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapm % pos ( ghat ( 2 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN - pw2 % cc3d ( & - LBOUND ( pw2 % cc3d, 1 ) + pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & - LBOUND ( pw2 % cc3d, 2 ) + pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & - LBOUND ( pw2 % cc3d, 3 ) + pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) -!TMPTMPTMP pw2 % pw_grid % mapl % neg ( ghat ( 1 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapm % neg ( ghat ( 2 ) ), & -!TMPTMPTMP pw2 % pw_grid % mapn % neg ( ghat ( 3 ) ) ) = pw1 % cc ( gpt ) - END IF - END DO - - CALL fft3d ( BWFFTw, pw2 % pw_grid % npts, pw2 % cc3d, scale = scale ) - - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - - bds => pw1 % pw_grid % bounds - ALLOCATE(cfft(bds(1,1):bds(2,1),bds(1,2):bds(2,2),bds(1,3):bds(2,3))) - cfft = pw1 % cc3d / REAL ( pw1 % pw_grid % ngpts, dbl ) - - CALL fft3d ( FWFFTw, pw1 % pw_grid % npts, cfft, scale = scale ) - - DO gpt = 1, pw2 % pw_grid % ngpts_cut - ghat = pw1 % pw_grid % g_hat ( :, gpt ) - pw2 % cc ( gpt ) = cfft ( & - LBOUND ( cfft, 1 ) + pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & - LBOUND ( cfft, 2 ) + pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & - LBOUND ( cfft, 3 ) + pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) -!TMPTMPTMP pw1 % pw_grid % mapl % pos ( ghat ( 1 ) ), & -!TMPTMPTMP pw1 % pw_grid % mapm % pos ( ghat ( 2 ) ), & -!TMPTMPTMP pw1 % pw_grid % mapn % pos ( ghat ( 3 ) ) ) - END DO - - DEALLOCATE ( cfft ) - - ELSE - CALL stop_prg ( "fft_wrap_pw1pw2", "no suitable FFT found" ) - END IF - - ELSE - IF ( pw1 % in_use == COMPLEXDATA3D ) THEN - IF ( PRESENT ( dir ) ) THEN - CALL fft3d ( dir, pw1 % pw_grid % npts, pw1 % cc3d, scale = scale ) - ELSE - CALL stop_prg ( "fft_wrap_pw1pw2", & - "no direction specified for in-place FFT" ) - END IF - ELSE - CALL stop_prg ( "fft_wrap_pw1pw2", "wrong data type to be FFTed" ) - END IF - END IF - -END SUBROUTINE fft_wrap_pw1pw2 - -!****************************************************************************** - -FUNCTION pw_integral_ab ( pw1, pw2, flag ) RESULT ( integral_value ) - - TYPE ( pw_type ), INTENT ( IN ) :: pw1, pw2 - INTEGER, INTENT ( IN ), OPTIONAL :: flag - - REAL ( dbl ) :: integral_value - -!------------------------------------------------------------------------------ - - IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D ) THEN - integral_value = SUM ( pw1 % cr3d ( :, :, : ) & - * pw2 % cr3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == REALDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - integral_value = SUM ( pw1 % cr3d ( :, :, : ) & - * pw2 % cc3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == REALDATA3D ) THEN - integral_value = SUM ( pw1 % cc3d ( :, :, : ) & - * pw2 % cr3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA3D & - .AND. pw2 % in_use == COMPLEXDATA3D ) THEN - integral_value = SUM ( CONJG ( pw1 % cc3d ( :, :, : ) ) & - * pw2 % cc3d ( :, :, : ) ) - - ELSE IF ( pw1 % in_use == REALDATA1D & - .AND. pw2 % in_use == REALDATA1D ) THEN - integral_value = SUM ( pw1 % cr ( : ) * pw2 % cr ( : ) ) - ELSE IF ( pw1 % in_use == REALDATA1D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - integral_value = SUM ( pw1 % cr ( : ) * pw2 % cc ( : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == REALDATA1D ) THEN - integral_value = SUM ( pw1 % cc ( : ) * pw2 % cr ( : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA1D & - .AND. pw2 % in_use == COMPLEXDATA1D ) THEN - integral_value = SUM ( CONJG ( pw1 % cc ( : ) ) * pw2 % cc ( : ) ) - ELSE - CALL stop_prg ( "integral_ab", "no possible data" ) - END IF - - IF ( pw1 % in_use == REALDATA3D .OR. pw1 % in_use == COMPLEXDATA3D ) THEN - integral_value = integral_value * pw1 % pw_grid % dvol - ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN - integral_value = integral_value - ELSE - CALL stop_prg ( "pw_integral_ab", "volume element not implemented" ) - END IF - - IF ( pw1 % group_id >= 0 ) CALL mp_sum ( integral_value, pw1 % group_id ) - -END FUNCTION pw_integral_ab - -!****************************************************************************** - -FUNCTION pw_integral_a ( pw1, flag ) RESULT ( integral_value ) - - TYPE ( pw_type ), INTENT ( IN ) :: pw1 - INTEGER, INTENT ( IN ), OPTIONAL :: flag - - REAL ( dbl ) :: integral_value - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( flag ) ) THEN - IF ( flag == SQUARE ) THEN - IF ( pw1 % in_use == REALDATA3D ) THEN - integral_value = SUM ( pw1 % cr3d ( :, :, : ) ** 2 ) - ELSE IF ( pw1 % in_use == COMPLEXDATA3D ) THEN - integral_value = SUM ( CONJG ( pw1 % cc3d ( :, :, : ) ) & - * pw1 % cc3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == REALDATA1D ) THEN - integral_value = SUM ( pw1 % cr ( : ) ** 2 ) - ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN - integral_value = SUM ( CONJG ( pw1 % cc ( : ) ) & - * pw1 % cc ( : ) ) - ELSE - CALL stop_prg ( "integral_aa", "no possible SQUARE data" ) - END IF - - ELSE IF ( flag == SQUAREROOT ) THEN - CALL stop_prg ( "integral_aa", "no SQUAREROOT defined" ) - END IF - - ELSE - IF ( pw1 % in_use == REALDATA3D ) THEN - integral_value = SUM ( pw1 % cr3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA3D ) THEN - integral_value = SUM ( pw1 % cc3d ( :, :, : ) ) - ELSE IF ( pw1 % in_use == REALDATA1D ) THEN - integral_value = SUM ( pw1 % cr ( : ) ) - ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN - integral_value = SUM ( pw1 % cc ( : ) ) - ELSE - CALL stop_prg ( "integral_aa", "no possible data" ) - END IF - END IF - - IF ( pw1 % in_use == REALDATA3D ) & - integral_value = integral_value * pw1 % pw_grid % dvol - - IF ( pw1 % group_id >= 0 ) CALL mp_sum ( integral_value, pw1 % group_id ) - -END FUNCTION pw_integral_a - -!****************************************************************************** - -SUBROUTINE pw_kinetic_evaluate ( psi, xkpt, ekinetic, kinetic_psi ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( IN ) :: psi - REAL ( dbl ), INTENT ( IN ) :: xkpt ( 3 ) - - REAL ( dbl ), INTENT ( OUT ) :: ekinetic - TYPE ( coeff_type ), INTENT ( INOUT ) :: kinetic_psi - -! Local - INTEGER :: gpt - -!------------------------------------------------------------------------------ - - IF ( psi % pw % in_use /= COMPLEXDATA1D ) THEN - CALL stop_prg ( "pw_calculate_kinetic", "wrong data in use" ) - END IF - - !OpenMP: parallel do - DO gpt = 1, psi % pw % pw_grid % ngpts_cut - kinetic_psi % pw % cc ( gpt ) = kinetic_psi % pw % cc ( gpt ) & - + 0.5_dbl & - * SUM ( ( psi % pw % pw_grid % g ( :, gpt ) + xkpt ( : ) ) ** 2 ) & - * psi % pw % cc ( gpt ) - END DO - - ekinetic = pw_integral_ab ( psi % pw, kinetic_psi % pw ) - -END SUBROUTINE pw_kinetic_evaluate - -!****************************************************************************** - -SUBROUTINE pw_h_psi ( psi_iks, xkpt, vloc, h_psi, psi_iks_r ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( IN ) :: psi_iks - TYPE ( coeff_type ), INTENT ( IN ), OPTIONAL :: psi_iks_r - TYPE ( coeff_type ), INTENT ( IN ) :: vloc - REAL ( dbl ), INTENT ( IN ) :: xkpt ( 3 ) - - TYPE ( coeff_type ), INTENT ( INOUT ) :: h_psi - -! Locals - INTEGER :: gpt, gpt2, i1, i2, i3, nhits !TMPTMPTMP - REAL ( dbl ) :: ekinetic !TMPTMPTMP -! COMPLEX ( dbl ) :: foo !TMPTMPTMP - TYPE ( pw_type ) :: cfft - -!------------------------------------------------------------------------------ - - CALL pw_allocate ( cfft, psi_iks % pw % pw_grid, & - use_data = COMPLEXDATA3D ) - -#if defined ( DEBUG ) - nhits = 0 - OPEN ( UNIT = 99, FILE = "psik", FORM = "FORMATTED" ) - DO gpt = 1, psi_iks % grid % ngpts - READ ( UNIT = 99, FMT = * ) i1, i2, i3, foo - DO gpt2 = 1, psi_iks % grid % ngpts - IF ( psi_iks % grid % g_hat ( 1, gpt2 ) == i1 .AND. & - psi_iks % grid % g_hat ( 2, gpt2 ) == i2 .AND. & - psi_iks % grid % g_hat ( 3, gpt2 ) == i3 ) THEN - psi_iks % cc ( gpt2 ) = foo - nhits = nhits + 1 - EXIT - END IF - END DO - END DO - CLOSE ( UNIT = 99 ) - WRITE ( 6, * ) "DDD: #hits = ", nhits -#endif - - IF ( PRESENT ( psi_iks_r ) ) THEN - cfft % cr3d = vloc % pw % cr3d * psi_iks_r % pw % cc3d - ELSE - CALL fft_wrap ( psi_iks, cfft ) - - cfft % cc3d = cfft % cc3d * vloc % pw % cr3d - END IF - - CALL fft_wrap ( cfft, h_psi ) - - !! This must be done after the local potential - CALL pw_kinetic_evaluate ( psi_iks, xkpt, ekinetic, h_psi ) - - CALL pw_deallocate ( cfft ) - -END SUBROUTINE pw_h_psi - -!****************************************************************************** - -END MODULE pws diff --git a/src/simulation.h b/src/simulation.h deleted file mode 100644 index f802964..0000000 --- a/src/simulation.h +++ /dev/null @@ -1,19 +0,0 @@ -#ifndef _SIMULATION_H -#define _SIMULATION_H - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct cell_type { - double hmat[3][3]; - double h_inv[3][3]; - double deth; - int perd[3]; - } cell_type; - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/simulation_cell.c b/src/simulation_cell.c deleted file mode 100644 index 6eabe27..0000000 --- a/src/simulation_cell.c +++ /dev/null @@ -1,141 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE simulation_cell - - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi - USE stop_program, ONLY : stop_prg - - IMPLICIT NONE - - PRIVATE - PUBLIC :: get_hinv, cell_type, pbc, get_cell_param - - TYPE cell_type - REAL ( dbl ), DIMENSION ( 3, 3 ) :: hmat - REAL ( dbl ), DIMENSION ( 3, 3 ) :: h_inv - REAL ( dbl ) :: deth - INTEGER :: perd ( 3 ) - END TYPE cell_type - -CONTAINS - -!****************************************************************************** - -SUBROUTINE get_hinv ( box ) - - IMPLICIT NONE - -! Arguments - TYPE ( cell_type ), INTENT ( INOUT ) :: box - -! Locals - REAL ( dbl ), DIMENSION ( 3, 3 ) :: hmat, hmati - REAL ( dbl ) :: odet - -!------------------------------------------------------------------------------ - - hmat = box % hmat - box % deth = & - hmat(1,1) * ( hmat(2,2)*hmat(3,3)-hmat(2,3)*hmat(3,2) ) + & - hmat(1,2) * ( hmat(2,3)*hmat(3,1)-hmat(2,1)*hmat(3,3) ) + & - hmat(1,3) * ( hmat(2,1)*hmat(3,2)-hmat(2,2)*hmat(3,1) ) - IF ( box % deth < 1.0E-10_dbl ) & - CALL stop_prg ( 'get_hinv', 'box determinant too small') - odet = 1.0_dbl / box % deth - hmati(1,1) = (hmat(2,2)*hmat(3,3)-hmat(2,3)*hmat(3,2))*odet - hmati(2,2) = (hmat(1,1)*hmat(3,3)-hmat(1,3)*hmat(3,1))*odet - hmati(3,3) = (hmat(1,1)*hmat(2,2)-hmat(1,2)*hmat(2,1))*odet - hmati(1,2) = (hmat(1,3)*hmat(3,2)-hmat(1,2)*hmat(3,3))*odet - hmati(2,1) = (hmat(3,1)*hmat(2,3)-hmat(2,1)*hmat(3,3))*odet - hmati(1,3) = (hmat(1,2)*hmat(2,3)-hmat(1,3)*hmat(2,2))*odet - hmati(3,1) = (hmat(2,1)*hmat(3,2)-hmat(3,1)*hmat(2,2))*odet - hmati(2,3) = (hmat(1,3)*hmat(2,1)-hmat(2,3)*hmat(1,1))*odet - hmati(3,2) = (hmat(3,1)*hmat(1,2)-hmat(3,2)*hmat(1,1))*odet - - box % h_inv = hmati - -END SUBROUTINE get_hinv - -!****************************************************************************** - -FUNCTION pbc ( rin, box, nl ) RESULT ( rout ) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: rout ( 3 ) - -! Arguments - TYPE ( cell_type ), INTENT ( IN ) :: box - REAL ( dbl ), INTENT ( IN ) :: rin ( 3 ) - INTEGER, INTENT ( IN ), OPTIONAL :: nl ( 3 ) - -! Locals - REAL ( dbl ) :: s ( 3 ) - -!------------------------------------------------------------------------------ - - s = MATMUL ( box % h_inv, rin ) - s = s - box % perd * NINT ( s ) - rout = MATMUL ( box % hmat, s ) - IF ( PRESENT ( nl ) ) THEN - s = REAL ( nl, dbl ) - rout = rout + MATMUL ( box % hmat, s ) - END IF - -END FUNCTION pbc - -!****************************************************************************** - -SUBROUTINE get_cell_param ( box, cell_length, cell_angle ) - - IMPLICIT NONE - -! Arguments - TYPE ( cell_type ), INTENT ( IN ), TARGET :: box - REAL ( dbl ), DIMENSION ( 3 ), INTENT ( OUT ) :: cell_length - REAL ( dbl ), DIMENSION ( 3 ), INTENT ( OUT ), OPTIONAL :: cell_angle - -! Locals - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: hmat - -!------------------------------------------------------------------------------ - - hmat => box % hmat - -! This code gets the cell parameters given the h-matrix: -! a - cell_length(1) = & - SQRT ( hmat(1,1)*hmat(1,1) + hmat(2,1)*hmat(2,1) + hmat(3,1)*hmat(3,1) ) -! b - cell_length(2) = & - SQRT ( hmat(1,2)*hmat(1,2) + hmat(2,2)*hmat(2,2) + hmat(3,2)*hmat(3,2) ) -! c - cell_length(3) = & - SQRT ( hmat(1,3)*hmat(1,3) + hmat(2,3)*hmat(2,3) + hmat(3,3)*hmat(3,3) ) - - IF ( PRESENT ( cell_angle ) ) THEN -! gamma - cell_angle(1) = ACOS ( & - ( hmat(1,1)*hmat(1,2) + hmat(2,1)*hmat(2,2) + hmat(3,1)*hmat(3,2) ) & - / ( cell_length(1)*cell_length(2) ) ) -! beta - cell_angle(2) = ACOS ( & - ( hmat(1,1)*hmat(1,3) + hmat(2,1)*hmat(2,3) + hmat(3,1)*hmat(3,3) ) & - / ( cell_length(1)*cell_length(3) ) ) -! alpha - cell_angle(3) = ACOS ( & - ( hmat(1,2)*hmat(1,3) + hmat(2,2)*hmat(2,3) + hmat(3,2)*hmat(3,3) ) & - / ( cell_length(2)*cell_length(3) ) ) - cell_angle = cell_angle * 180.0_dbl / pi - END IF - -END SUBROUTINE get_cell_param - -!****************************************************************************** - -END MODULE simulation_cell diff --git a/src/slater_koster.c b/src/slater_koster.c deleted file mode 100644 index cc0df7b..0000000 --- a/src/slater_koster.c +++ /dev/null @@ -1,123 +0,0 @@ -!------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!------------------------------------------------------------------------------! -!!> Calculation of two-center s-f Slater-Koster integrals -!! A.K. McMahan, Phys. Rev. B, 58, p4293 (1998) -!! -!! Sign convention: t(lp,lq)=(-1)**(lp+lq)*(lp m,lq m) -!! where (lp m,lq m) is the integral in the diatomic coordinate system -!! -!!< - MODULE slater_koster -!------------------------------------------------------------------------------! - USE kinds, ONLY : dbl - USE slater_koster_matr, ONLY : gmat, dgmat -! - IMPLICIT NONE -! - PRIVATE - PUBLIC :: m_integrals -! -!------------------------------------------------------------------------------! -! - CONTAINS -! -!------------------------------------------------------------------------------! - SUBROUTINE m_integrals(l1,l2,r,tll,hmm) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (IN) :: r(3) - REAL (dbl), INTENT (IN) :: tll(0:2*min(l1,l2)) - REAL (dbl), INTENT (OUT) :: hmm(0:2*l1,0:2*l2) - - REAL (dbl) :: gmu(0:6,0:6,0:3) - REAL (dbl) :: dll(0:6,0:6,0:6) - INTEGER :: m, m1, m2, mu, i - - IF (l1+l2==0) THEN - hmm(0,0) = tll(0) - ELSE IF (l1==0 .AND. l2==1) THEN - hmm(0,0) = tll(0)*r(3) - hmm(0,1) = tll(0)*r(1) - hmm(0,2) = tll(0)*r(2) - ELSE IF (l1==1 .AND. l2==0) THEN - hmm(0,0) = tll(0)*r(3) - hmm(1,0) = tll(0)*r(1) - hmm(2,0) = tll(0)*r(2) - ELSE IF (l1==1 .AND. l2==1) THEN - hmm(0,0) = tll(0)*r(3)*r(3) + tll(1)*(1._dbl-r(3)*r(3)) - hmm(1,0) = (tll(0)-tll(1))*r(3)*r(1) - hmm(2,0) = (tll(0)-tll(1))*r(3)*r(2) - hmm(0,1) = hmm(1,0) - hmm(0,2) = hmm(2,0) - hmm(1,1) = tll(0)*r(1)*r(1) + tll(1)*(1._dbl-r(1)*r(1)) - hmm(2,1) = (tll(0)-tll(1))*r(1)*r(2) - hmm(1,2) = hmm(2,1) - hmm(2,2) = tll(0)*r(2)*r(2) + tll(1)*(1._dbl-r(2)*r(2)) - ELSE - CALL gmat(l1,l2,r,gmu,dll) - mu = min(l1,l2) - m1 = 2*l1 - m2 = 2*l2 - hmm(0:m1,0:m2) = 0._dbl - DO i = 0, mu - hmm(0:m1,0:m2) = hmm(0:m1,0:m2) + gmu(0:m1,0:m2,i)*tll(i) - END DO - END IF - END SUBROUTINE m_integrals -!------------------------------------------------------------------------------! - SUBROUTINE dm_integrals(l1,l2,r,tllr,dtll,pmm,grad) - IMPLICIT NONE - INTEGER, INTENT (IN) :: l1, l2 - REAL (dbl), INTENT (IN) :: r(3) - REAL (dbl), INTENT (IN) :: tllr(0:2*min(l1,l2)) - REAL (dbl), INTENT (IN) :: dtll(0:2*min(l1,l2)) - REAL (dbl), INTENT (IN) :: pmm(0:2*l1,0:2*l2) - REAL (dbl), INTENT (OUT) :: grad(1:3) - - REAL (dbl) :: dgmu(0:6,0:6,0:3,1:3) - REAL (dbl) :: ddll(0:6,0:6,0:6,1:3) - REAL (dbl) :: hmm(0:6,0:6) - REAL (dbl) :: ph - INTEGER :: m, m1, m2, mu, i, j - - mu = min(l1,l2) - m1 = 2*l1 - m2 = 2*l2 - - CALL m_integrals(l1,l2,r,dtll,hmm(0:m1,0:m2)) - ph = trace_AB(hmm(0:m1,0:m2),pmm(0:m1,0:m2)) - grad = ph * r - - IF (l1+l2==0) THEN - ELSE - CALL dgmat(l1,l2,r,dgmu,ddll) - DO j = 1, 3 - hmm(0:m1,0:m2) = 0._dbl - DO i = 0, mu - hmm(0:m1,0:m2) = hmm(0:m1,0:m2) + dgmu(0:m1,0:m2,i,j)*tllr(i) - END DO - grad(j) = grad(j) + trace_AB(hmm(0:m1,0:m2),pmm(0:m1,0:m2)) - END DO - END IF - - END SUBROUTINE dm_integrals -!------------------------------------------------------------------------------! - FUNCTION trace_AB(A,B) RESULT(T) - IMPLICIT NONE - REAL(dbl), INTENT (IN) :: A(:,:), B(:,:) - REAL(dbl) :: T - INTEGER m, n, i - - m = SIZE(A(:,1)) - n = SIZE(A(1,:)) - T = 0._dbl - DO i = 1, m - T = T + dot_product(A(:,i),B(:,i)) - END DO - - END FUNCTION trace_AB -!------------------------------------------------------------------------------! - END MODULE slater_koster -!------------------------------------------------------------------------------! diff --git a/src/slater_koster.h b/src/slater_koster.h deleted file mode 100644 index 4217ee4..0000000 --- a/src/slater_koster.h +++ /dev/null @@ -1,36 +0,0 @@ -#ifndef _SLATER_KOSTER_H -#define _SLATER_KOSTER_H - -#ifdef __cplusplus -extern "C" { -#endif - -const double zero = 0.0; -const double one = 1.0; - -void sph(int l, double r[3], double gsl[7]); - -void dsph(int l, double r[3], double dgsl[7][3]); - -void out_prod(double mat[][3], double v1[], double v2[]); - -void out_dprod(double dmat[][3], double v1[], double v2[], double dv1[], - double dv2[]); - -double dpro(double g1[][7], double g2[][7], int l1, int l2); - -void m_integrals(); - -void gmat(int l1, int l2, double r[3], double gmu[7][7][4], double dll[7][7][7]); - -void dgmat(int l1, int l2, double r[3], double dgmu[7][7][4][3], double ddll[7][7][7][3]); - -void sk_test(); - -void dsk_test(); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/slater_koster_matr.c b/src/slater_koster_matr.c deleted file mode 100644 index 6c14142..0000000 --- a/src/slater_koster_matr.c +++ /dev/null @@ -1,1458 +0,0 @@ -/*----------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*----------------------------------------------------------------------------*/ -//> Calculation of two-center s-f Slater-Koster integrals -// A.K. McMahan, Phys. Rev. B, 58, p4293 (1998) -// -// Sign convention: t(lp,lq)=(-1)**(lp+lq)*(lp m,lq m) -// where (lp m,lq m) is the integral in the diatomic coordinate system -// -//< - -//#include -#include - -#include "slater_koster.h" - -void gmat(int l1, int l2, double r[3], double gmu[7][7][4], double dll[7][7][7]) { - int mu, mo, m1, m2, i; - double gsl[7][4]; - - mu = (l1 < l2) ? l1 : l2; - mo = (l1 > l2) ? l1 : l2; - m1 = 2 * l1; - m2 = 2 * l2; - - memset(gsl, 0, sizeof(gsl)); - for (i = 0; i <= mo; i++) { - sph(i, r, gsl[i]); - } - - memset(dll, 0, sizeof(dll)); - for (i = 0; i <= 2 * mo; i++) { - dll[i][i][0] = 1.0; - } - - if (l1 == 0) { - // s-l - for (i = 0; i <= m2; i++) { - gmu[0][i][0] = gsl[i][l2]; - } - } else if (l2 == 0) { - // l-s - for (i = 0; i <= m1; i++) { - gmu[i][0][0] = gsl[i][l1]; - } - } else { - switch (l1) { - case 1: - switch (l2) { - case 1: - // p-p - out_prod(&dll[0][2][2], &gsl[1], &gsl[1]); - memcpy(gmu[0][0], &dll[2][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], (-dll[2][0][2] + dll[2][0][0]), sizeof(gmu[0][1])); - break; - case 2: - // p-d - out_prod(&dll[0][4][3], gsl[1], gsl[2]); - set_mat(dll[0][4][1], r, 1); - memcpy(gmu[0][0], &dll[3][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -2.0 / sqrt(3.0) * &dll[3][0][3] + dll[3][0][1], sizeof(gmu[0][1])); - break; - case 3: - // p-f - out_prod(&dll[0][6][4], gsl[1], gsl[3]); - set_mat(dll[0][6][2], r, 2); - memcpy(gmu[0][0], dll[4][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -sqrt(1.5) * dll[4][0][4] + 0.5 * dll[4][0][2], sizeof(gmu[0][1])); - break; - } - break; - case 2: - switch (l2) { - case 1: - // d-p - out_prod(dll[0][2][3], gsl[2], gsl[1]); - set_mat(dll[0][2][1], r, 1); - memcpy(gmu[0][0], dll[3][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -2.0 / sqrt(3.0) * dll[3][0][3] + dll[3][0][1], sizeof(gmu[0][1])); - break; - case 2: - // d-d - out_prod(dll[0][4][4], gsl[2], gsl[2]); - set_mat(dll[0][4][2], r, 2); - memcpy(gmu[0][0], dll[4][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -4.0 / 3.0 * dll[4][0][4] + dll[4][0][2] + dll[4][0][0], sizeof(gmu[0][1])); - memcpy(gmu[0][2], 1.0 / 3.0 * dll[4][0][4] - dll[4][0][2], sizeof(gmu[0][2])); - break; - case 3: - // d-f - out_prod(dll[0][6][5], gsl[2], gsl[3]); - set_mat(dll[0][6][3], r, 3); - set_mat(dll[0][6][1], r, 1); - memcpy(gmu[0][0], dll[5][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -sqrt(2.0) * dll[5][0][5] + 0.5 * dll[5][0][3] + 0.5 * dll[5][0][1], sizeof(gmu[0][1])); - memcpy(gmu[0][2], sqrt(0.2) * dll[5][0][5] - sqrt(0.4) * dll[5][0][3], sizeof(gmu[0][2])); - break; - } - break; - case 3: - switch (l2) { - case 1: - // f-p - out_prod(dll[0][2][4], gsl[3], gsl[1]); - set_mat(dll[0][2][2], r, 2); - memcpy(gmu[0][0], dll[4][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -sqrt(1.5) * dll[4][0][4] + 0.5 * dll[4][0][2], sizeof(gmu[0][1])); - break; - case 2: - // f-d - out_prod(dll[0][4][5], gsl[3], gsl[2]); - set_mat(dll[0][4][3], r, 3); - set_mat(dll[0][4][1], r, 1); - memcpy(gmu[0][0], dll[5][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -sqrt(2.0) * dll[5][0][5] + 0.5 * dll[5][0][3] + 0.5 * dll[5][0][1], sizeof(gmu[0][1])); - memcpy(gmu[0][2], sqrt(0.2) * dll[5][0][5] - sqrt(0.4) * dll[5][0][3], sizeof(gmu[0][2])); - break; - case 3: - // f-f - out_prod(dll[0][6][6], gsl[3], gsl[3]); - set_mat(dll[0][6][4], r, 4); - set_mat(dll[0][6][2], r, 2); - memcpy(gmu[0][0], dll[6][0][0], sizeof(gmu[0][0])); - memcpy(gmu[0][1], -1.5 * dll[6][0][6] + 0.625 * dll[6][0][4] + 0.625 * dll[6][0][2] + 0.625 * dll[6][0][0], sizeof(gmu[0][1])); - memcpy(gmu[0][2], 0.6 * dll[6][0][6] - dll[6][0][4], sizeof(gmu[0][2])); - memcpy(gmu[0][3], -0.1 * dll[6][0][6] + 0.375 * dll[6][0][4] - 0.625 * dll[6][0][2] + 0.375 * dll[6][0][0], sizeof(gmu[0][3])); - break; - } - break; - } - } -} - -/*----------------------------------------------------------------------------*/ -void dgmat(int l1, int l2, double r[3], double dgmu[7][7][4][3], double ddll[7][7][7][3]) { - int mu, mo, m1, m2, i; - double gsl[7][4]; - double dgsl[7][4][3]; - - mu = (l1 < l2) ? l1 : l2; - mo = (l1 > l2) ? l1 : l2; - m1 = 2 * l1; - m2 = 2 * l2; - memset(gsl, 0, sizeof(gsl)); - memset(dgsl, 0, sizeof(dgsl)); - - for (i = 0; i <= mo; i++) { - sph(i, r, gsl[i]); - dsph(i, r, dgsl[i]); - } - - if (l1 == 0) { - // s-l - memcpy(dgmu[0][0], dgsl[l2], sizeof(dgmu[0][0])); - } else if (l2 == 0) { - // l-s - memcpy(dgmu[0][0], dgsl[l1], sizeof(dgmu[0][0])); - } else { - switch (l1) { - case 1: - switch (l2) { - case 1: - // p-p - out_dprod(ddll[0][0][2][0], gsl[1], gsl[1], dgsl[1][0], dgsl[1][0]); - out_dprod(ddll[0][0][2][1], gsl[1], gsl[1], dgsl[1][1], dgsl[1][1]); - out_dprod(ddll[0][0][2][2], gsl[1], gsl[1], dgsl[1][2], dgsl[1][2]); - memcpy(dgmu[0][0][0], ddll[0][0][2], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][2], sizeof(dgmu[0][0][1])); - break; - case 2: - // p-d - out_dprod(&ddll[0][0][3][0], gsl[1], gsl[2], dgsl[1][0], dgsl[2][0]); - out_dprod(&ddll[0][0][3][1], gsl[1], gsl[2], dgsl[1][1], dgsl[2][1]); - out_dprod(&ddll[0][0][3][2], gsl[1], gsl[2], dgsl[1][2], dgsl[2][2]); - set_dmat(ddll[0][0][1], r, 1); - memcpy(dgmu[0][0][0], ddll[0][0][3], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][3], sizeof(dgmu[0][0][1])); - break; - case 3: - // p-f - out_dprod(&ddll[0][0][4][0], gsl[1], gsl[3], dgsl[1][0], dgsl[3][0]); - out_dprod(&ddll[0][0][4][1], gsl[1], gsl[3], dgsl[1][1], dgsl[3][1]); - out_dprod(&ddll[0][0][4][2], gsl[1], gsl[3], dgsl[1][2], dgsl[3][2]); - set_dmat(ddll[0][0][2], r, 2); - memcpy(dgmu[0][0][0], ddll[0][0][4], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][4], sizeof(dgmu[0][0][1])); - break; - } - break; - case 2: - switch (l2) { - case 1: - // d-p - out_dprod(&ddll[0][0][3][0], &gsl[2], gsl[1], dgsl[2][0], dgsl[1][0]); - out_dprod(&ddll[0][0][3][1], gsl[2], gsl[1], dgsl[2][1], dgsl[1][1]); - out_dprod(&ddll[0][0][3][2], gsl[2], gsl[1], dgsl[2][2], dgsl[1][2]); - set_dmat(ddll[0][0][1], r, 1); - memcpy(dgmu[0][0][0], ddll[0][0][3], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][3], sizeof(dgmu[0][0][1])); - break; - case 2: - // d-d - out_dprod(&ddll[0][0][4][0], gsl[2], gsl[2], dgsl[2][0], dgsl[2][0]); - out_dprod(&ddll[0][0][4][1], gsl[2], gsl[2], dgsl[2][1], dgsl[2][1]); - out_dprod(&ddll[0][0][4][2], gsl[2], gsl[2], dgsl[2][2], dgsl[2][2]); - set_dmat(ddll[0][0][2], r, 2); - memcpy(dgmu[0][0][0], ddll[0][0][4], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][4], sizeof(dgmu[0][0][1])); - memcpy(dgmu[0][0][2], ddll[0][0][4], sizeof(dgmu[0][0][2])); - break; - case 3: - // d-f - out_dprod(&ddll[0][0][5][0], gsl[2], gsl[3], dgsl[2][0], dgsl[3][0]); - out_dprod(&ddll[0][0][5][1], gsl[2], gsl[3], dgsl[2][1], dgsl[3][1]); - out_dprod(&ddll[0][0][5][2], gsl[2], gsl[3], dgsl[2][2], dgsl[3][2]); - set_dmat(ddll[0][0][3], r, 3); - set_dmat(ddll[0][0][1], r, 1); - memcpy(dgmu[0][0][0], ddll[0][0][5], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][5], sizeof(dgmu[0][0][1])); - memcpy(dgmu[0][0][2], ddll[0][0][5], sizeof(dgmu[0][0][2])); - break; - } - break; - case 3: - switch (l2) { - case 1: - // f-p - out_dprod(&ddll[0][0][4][0], gsl[3], gsl[1], dgsl[3][0], dgsl[1][0]); - out_dprod(&ddll[0][0][4][1], gsl[3], gsl[1], dgsl[3][1], dgsl[1][1]); - out_dprod(&ddll[0][0][4][2], gsl[3], gsl[1], dgsl[3][2], dgsl[1][2]); - set_dmat(ddll[0][0][2], r, 2); - memcpy(dgmu[0][0][0], ddll[0][0][4], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][4], sizeof(dgmu[0][0][1])); - break; - case 2: - // f-d - out_dprod(&ddll[0][0][5][0], gsl[3], gsl[2], dgsl[3][0], dgsl[2][0]); - out_dprod(&ddll[0][0][5][1], gsl[3], gsl[2], dgsl[3][1], dgsl[2][1]); - out_dprod(&ddll[0][0][5][2], gsl[3], gsl[2], dgsl[3][2], dgsl[2][2]); - set_dmat(ddll[0][0][3], r, 3); - set_dmat(ddll[0][0][1], r, 1); - memcpy(dgmu[0][0][0], ddll[0][0][5], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][5], sizeof(dgmu[0][0][1])); - memcpy(dgmu[0][0][2], ddll[0][0][5], sizeof(dgmu[0][0][2])); - break; - case 3: - // f-f - out_dprod(&ddll[0][0][6][0], gsl[3], gsl[3], dgsl[3][0], dgsl[3][0]); - out_dprod(&ddll[0][0][6][1], gsl[3], gsl[3], dgsl[3][1], dgsl[3][1]); - out_dprod(&ddll[0][0][6][2], gsl[3], gsl[3], dgsl[3][2], dgsl[3][2]); - set_dmat(ddll[0][0][4], r, 4); - set_dmat(ddll[0][0][2], r, 2); - memcpy(dgmu[0][0][0], ddll[0][0][6], sizeof(dgmu[0][0][0])); - memcpy(dgmu[0][0][1], ddll[0][0][6], sizeof(dgmu[0][0][1])); - memcpy(dgmu[0][0][2], ddll[0][0][6], sizeof(dgmu[0][0][2])); - memcpy(dgmu[0][0][3], ddll[0][0][6], sizeof(dgmu[0][0][3])); - break; - } - break; - } - } -} -/*----------------------------------------------------------------------------*/ -void set_mat(double mat[][3], double r[3], int num) { - - int l1, l2; - const double s3 = 0.577350269189626; // sqrt(1.0/3.0) - double x, y, z, xx, yy, zz, xy, xz, yz; - - l1 = sizeof(mat) / sizeof(mat[0]); - l2 = sizeof(mat[0]) / sizeof(mat[0][0]); - x = r[0]; - y = r[1]; - z = r[2]; - - if (l1 == 5 && l2 == 3 && num == 1) { -// d1(d,p) - mat[0][0] = 2.0 * s3 * z; - mat[1][0] = x; - mat[2][0] = y; - mat[0][1] = -s3 * x; - mat[1][1] = z; - mat[3][1] = x; - mat[4][1] = y; - mat[0][2] = -s3 * y; - mat[2][2] = z; - mat[3][2] = -y; - mat[4][2] = x; - } else if (l1 == 3 && l2 == 5 && num == 1) { -// d1(p,d) - mat[0][0] = 2.0 * s3 * z; - mat[0][1] = x; - mat[0][2] = y; - mat[1][0] = -s3 * x; - mat[1][1] = z; - mat[1][3] = x; - mat[1][4] = y; - mat[2][0] = -s3 * y; - mat[2][2] = z; - mat[2][3] = -y; - mat[2][4] = x; - } else { - xx = x * x; - yy = y * y; - zz = z * z; - xy = x * y; - xz = x * z; - yz = y * z; - if (l1 == 5 && l2 == 5 && num == 2) { -// d2(d,d) - mat[0][0] = zz - 2.0/3.0; - mat[0][1] = s3*xz; - mat[0][2] = s3*yz; - mat[0][3] = -s3*(xx-yy); - mat[0][4] = -2.0*s3*xy; - mat[1][0] = mat[0][1]; - mat[2][0] = mat[0][2]; - mat[3][0] = mat[0][3]; - mat[4][0] = mat[0][4]; - mat[1][1] = -yy; - mat[1][2] = xy; - mat[1][3] = xz; - mat[1][4] = yz; - mat[2][1] = mat[1][2]; - mat[3][1] = mat[1][3]; - mat[4][1] = mat[1][4]; - mat[2][2] = -xx; - mat[2][3] = -yz; - mat[2][4] = xz; - mat[3][2] = mat[2][3]; - mat[4][2] = mat[2][4]; - mat[3][3] = -zz; - mat[3][4] = 0.0; - mat[4][3] = 0.0; - mat[4][4] = -zz; - } else if (l1 == 7 && l2 == 3 && num == 2) { -// d2(f,p) - mat[0][0] = sqrt(1.50)*(3.0*zz-1.0); - mat[0][1] = -sqrt(6.0)*xz; - mat[0][2] = -sqrt(6.0)*yz; - mat[1][0] = 4.0*xz; - mat[1][1] = 0.50*(5.0*zz-2.0*xx-1.0); - mat[1][2] = -xy; - mat[2][0] = 4.0*yz; - mat[2][1] = -xy; - mat[2][2] = 0.50*(5.0*zz-2.0*yy-1.0); - mat[3][0] = sqrt(2.50)*(xx-yy); - mat[3][1] = sqrt(10.0)*xz; - mat[3][2] = -sqrt(10.0)*yz; - mat[4][0] = sqrt(10.0)*xy; - mat[4][1] = sqrt(10.0)*yz; - mat[4][2] = sqrt(10.0)*xz; - mat[5][0] = 0.0; - mat[5][1] = sqrt(3.750)*(xx-yy); - mat[5][2] = -sqrt(15.0)*xy; - mat[6][0] = 0.0; - mat[6][1] = sqrt(15.0)*xy; - mat[6][2] = sqrt(3.750)*(xx-yy); - } else if (l1 == 3 && l2 == 7 && num == 2) { -// d2(p,f) - mat[0][0] = sqrt(1.50)*(3.0*zz-1.0); - mat[1][0] = -sqrt(6.0)*xz; - mat[2][0] = -sqrt(6.0)*yz; - mat[0][1] = 4.0*xz; - mat[1][1] = 0.50*(5.0*zz-2.0*xx-1.0); - mat[2][1] = -xy; - mat[0][2] = 4.0*yz; - mat[1][2] = -xy; - mat[2][2] = 0.50*(5.0*zz-2.0*yy-1.0); - mat[0][3] = sqrt(2.50)*(xx-yy); - mat[1][3] = sqrt(10.0)*xz; - mat[2][3] = -sqrt(10.0)*yz; - mat[0][4] = sqrt(10.0)*xy; - mat[1][4] = sqrt(10.0)*yz; - mat[2][4] = sqrt(10.0)*xz; - mat[0][5] = 0.0; - mat[1][5] = sqrt(3.750)*(xx-yy); - mat[2][5] = -sqrt(15.0)*xy; - mat[0][6] = 0.0; - mat[1][6] = sqrt(15.0)*xy; - mat[2][6] = sqrt(3.750)*(xx-yy); - } else if (l1 == 7 && l2 == 5 && num == 1) { -// d1(f,d) - mat[0][0] = sqrt(4.50)*z; - mat[0][1] = -sqrt(1.50)*x; - mat[0][2] = -sqrt(1.50)*y; - mat[0][3] = 0.0; - mat[0][4] = 0.0; - mat[1][0] = sqrt(3.0)*x; - mat[1][1] = 2.0*z; - mat[1][2] = 0.0; - mat[1][3] = -0.50*x; - mat[1][4] = -0.50*y; - mat[2][0] = sqrt(3.0)*y; - mat[2][1] = 0.0; - mat[2][2] = 2.0*z; - mat[2][3] = 0.50*y; - mat[2][4] = -0.50*x; - mat[3][0] = 0.0; - mat[3][1] = sqrt(2.50)*x; - mat[3][2] = -sqrt(2.50)*y; - mat[3][3] = sqrt(2.50)*z; - mat[3][4] = 0.0; - mat[4][0] = 0.0; - mat[4][1] = sqrt(2.50)*y; - mat[4][2] = sqrt(2.50)*x; - mat[4][3] = 0.0; - mat[4][4] = sqrt(2.50)*z; - mat[5][0] = 0.0; - mat[5][1] = 0.0; - mat[5][2] = 0.0; - mat[5][3] = sqrt(3.750)*x; - mat[5][4] = -sqrt(3.750)*y; - mat[6][0] = 0.0; - mat[6][1] = 0.0; - mat[6][2] = 0.0; - mat[6][3] = sqrt(3.750)*y; - mat[6][4] = sqrt(3.750)*x; - } else if (l1 == 5 && l2 == 7 && num == 1) { -// d1(d,f) - mat[0][0] = sqrt(4.50)*z; - mat[1][0] = -sqrt(1.50)*x; - mat[2][0] = -sqrt(1.50)*y; - mat[3][0] = 0.0; - mat[4][0] = 0.0; - mat[0][1] = sqrt(3.0)*x; - mat[1][1] = 2.0*z; - mat[2][1] = 0.0; - mat[3][1] = -0.50*x; - mat[4][1] = -0.50*y; - mat[0][2] = sqrt(3.0)*y; - mat[1][2] = 0.0; - mat[2][2] = 2.0*z; - mat[3][2] = 0.50*y; - mat[4][2] = -0.50*x; - mat[0][3] = 0.0; - mat[1][3] = sqrt(2.50)*x; - mat[2][3] = -sqrt(2.50)*y; - mat[3][3] = sqrt(2.50)*z; - mat[4][3] = 0.0; - mat[0][4] = 0.0; - mat[1][4] = sqrt(2.50)*y; - mat[2][4] = sqrt(2.50)*x; - mat[3][4] = 0.0; - mat[4][4] = sqrt(2.50)*z; - mat[0][5] = 0.0; - mat[1][5] = 0.0; - mat[2][5] = 0.0; - mat[3][5] = sqrt(3.750)*x; - mat[4][5] = -sqrt(3.750)*y; - mat[0][6] = 0.0; - mat[1][6] = 0.0; - mat[2][6] = 0.0; - mat[3][6] = sqrt(3.750)*y; - mat[4][6] = sqrt(3.750)*x; - } else if (l1 == 7 && l2 == 5 && num == 3) { -// d3(f,d) - mat[0][0] = sqrt(0.50)*(4.0*zz-3.0)*z; - mat[0][1] = sqrt(1.50)*x*zz; - mat[0][2] = sqrt(1.50)*y*zz; - mat[0][3] = -sqrt(6.0)*(xx-yy)*z; - mat[0][4] = -2.0*sqrt(6.0)*x*yz; - mat[1][0] = sqrt(0.750)*(3.0*zz-1.0)*x; - mat[1][1] = 0.50*(xx-5.0*yy)*z; - mat[1][2] = 3.0*x*yz; - mat[1][3] = (2.50*zz-xx+yy)*x; - mat[1][4] = 0.50*(5.0*zz-4.0*xx)*y; - mat[2][0] = sqrt(0.750)*(3.0*zz-1.0)*y; - mat[2][1] = 3.0*x*yz; - mat[2][2] = 0.50*(yy-5.0*xx)*z; - mat[2][3] = -(2.50*zz+xx-yy)*y; - mat[2][4] = 0.50*(5.0*zz-4.0*yy)*x; - mat[3][0] = 0.0; - mat[3][1] = sqrt(2.50)*(zz-2.0*yy)*x; - mat[3][2] = -sqrt(2.50)*(zz-2.0*xx)*y; - mat[3][3] = sqrt(2.50)*(1.0-2.0*zz)*z; - mat[3][4] = 0.0; - mat[4][0] = 0.0; - mat[4][1] = sqrt(2.50)*(1.0-2.0*yy)*y; - mat[4][2] = sqrt(2.50)*(1.0-2.0*xx)*x; - mat[4][3] = 0.0; - mat[4][4] = sqrt(2.50)*(1.0-2.0*zz)*z; - mat[5][0] = sqrt(1.250)*(3.0*yy-xx)*x; - mat[5][1] = sqrt(3.750)*(xx-yy)*z; - mat[5][2] = -sqrt(15.0)*x*yz; - mat[5][3] = -sqrt(3.750)*x*zz; - mat[5][4] = sqrt(3.750)*y*zz; - mat[6][0] = -sqrt(1.250)*(3.0*xx-yy)*y; - mat[6][1] = sqrt(15.0)*x*yz; - mat[6][2] = sqrt(3.750)*(xx-yy)*z; - mat[6][3] = -sqrt(3.750)*y*zz; - mat[6][4] = -sqrt(3.750)*x*zz; - } else if (l1 == 5 && l2 == 7 && num == 3) { -// d3(d,f) - mat[0][0] = sqrt(0.50)*(4.0*zz-3.0)*z; - mat[1][0] = sqrt(1.50)*x*zz; - mat[2][0] = sqrt(1.50)*y*zz; - mat[3][0] = -sqrt(6.0)*(xx-yy)*z; - mat[4][0] = -2.0*sqrt(6.0)*x*yz; - mat[0][1] = sqrt(0.750)*(3.0*zz-1.0)*x; - mat[1][1] = 0.50*(xx-5.0*yy)*z; - mat[2][1] = 3.0*x*yz; - mat[3][1] = (2.50*zz-xx+yy)*x; - mat[4][1] = 0.50*(5.0*zz-4.0*xx)*y; - mat[0][2] = sqrt(0.750)*(3.0*zz-1.0)*y; - mat[1][2] = 3.0*x*yz; - mat[2][2] = 0.50*(yy-5.0*xx)*z; - mat[3][2] = -(2.50*zz+xx-yy)*y; - mat[4][2] = 0.50*(5.0*zz-4.0*yy)*x; - mat[0][3] = 0.0; - mat[1][3] = sqrt(2.50)*(zz-2.0*yy)*x; - mat[2][3] = -sqrt(2.50)*(zz-2.0*xx)*y; - mat[3][3] = sqrt(2.50)*(1.0-2.0*zz)*z; - mat[4][3] = 0.0; - mat[0][4] = 0.0; - mat[1][4] = sqrt(2.50)*(1.0-2.0*yy)*y; - mat[2][4] = sqrt(2.50)*(1.0-2.0*xx)*x; - mat[3][4] = 0.0; - mat[4][4] = sqrt(2.50)*(1.0-2.0*zz)*z; - mat[0][5] = sqrt(1.250)*(3.0*yy-xx)*x; - mat[1][5] = sqrt(3.750)*(xx-yy)*z; - mat[2][5] = -sqrt(15.0)*x*yz; - mat[3][5] = -sqrt(3.750)*x*zz; - mat[4][5] = sqrt(3.750)*y*zz; - mat[0][6] = -sqrt(1.250)*(3.0*xx-yy)*y; - mat[1][6] = sqrt(15.0)*x*yz; - mat[2][6] = sqrt(3.750)*(xx-yy)*z; - mat[3][6] = -sqrt(3.750)*y*zz; - mat[4][6] = -sqrt(3.750)*x*zz; - } else if (l1 == 7 && l2 == 7 && num == 2) { -// d2(f,f) - mat[0][0] = 0.40*(3.0*zz-1.0); - mat[0][1] = sqrt(0.240)*xz; - mat[0][2] = sqrt(0.240)*yz; - mat[0][3] = -sqrt(0.60)*(xx-yy); - mat[0][4] = -sqrt(2.40)*xy; - mat[0][5] = 0.0; - mat[0][6] = 0.0; - mat[1][0] = mat[0][1]; - mat[2][0] = mat[0][2]; - mat[3][0] = mat[0][3]; - mat[4][0] = mat[0][4]; - mat[5][0] = mat[0][5]; - mat[6][0] = mat[0][6]; - mat[1][1] = 0.30*(1.0-4.0*yy+zz); - mat[1][2] = 1.20*xy; - mat[1][3] = sqrt(0.90)*xz; - mat[1][4] = sqrt(0.90)*yz; - mat[1][5] = -sqrt(0.150)*(xx-yy); - mat[1][6] = -sqrt(0.60)*xy; - mat[2][1] = mat[1][2]; - mat[3][1] = mat[1][3]; - mat[4][1] = mat[1][4]; - mat[5][1] = mat[1][5]; - mat[6][1] = mat[1][6]; - mat[2][2] = 0.30*(1.0-4.0*xx+zz); - mat[2][3] = -sqrt(0.90)*yz; - mat[2][4] = sqrt(0.90)*xz; - mat[2][5] = sqrt(0.60)*xy; - mat[2][6] = -sqrt(0.150)*(xx-yy); - mat[3][2] = mat[2][3]; - mat[4][2] = mat[2][4]; - mat[5][2] = mat[2][5]; - mat[6][2] = mat[2][6]; - mat[3][3] = 0.0; - mat[3][4] = 0.0; - mat[3][5] = sqrt(1.50)*xz; - mat[3][6] = sqrt(1.50)*yz; - mat[4][3] = mat[3][4]; - mat[5][3] = mat[3][5]; - mat[6][3] = mat[3][6]; - mat[4][4] = 0.0; - mat[4][5] = -sqrt(1.50)*yz; - mat[4][6] = sqrt(1.50)*xz; - mat[5][4] = mat[4][5]; - mat[6][4] = mat[4][6]; - mat[5][5] = -0.50*(3.0*zz-1.0); - mat[5][6] = 0.0; - mat[6][5] = 0.0; - mat[6][6] = -0.50*(3.0*zz-1.0); - } else if (l1 == 7 && l2 == 7 && num == 4) { -// d4(f,f) - mat[0][0] = 0.60*(5.0*zz-4.0)*zz; - mat[0][1] = sqrt(0.240)*(5.0*zz-2.0)*xz; - mat[0][2] = sqrt(0.240)*(5.0*zz-2.0)*yz; - mat[0][3] = -sqrt(0.60)*(xx-yy)*zz; - mat[0][4] = -sqrt(2.40)*xy*zz; - mat[0][5] = sqrt(3.60)*(3.0*yy-xx)*xz; - mat[0][6] = sqrt(3.60)*(yy-3.0*xx)*yz; - mat[1][0] = mat[0][1]; - mat[2][0] = mat[0][2]; - mat[3][0] = mat[0][3]; - mat[4][0] = mat[0][4]; - mat[5][0] = mat[0][5]; - mat[6][0] = mat[0][6]; - mat[1][1] = -0.40*xx - 0.50*(5.0*yy-3.0*xx)*zz; - mat[1][2] = 0.40*(10.0*zz-1.0)*xy; - mat[1][3] = sqrt(0.10)*(6.0*zz-8.0*yy-1.0)*xz; - mat[1][4] = sqrt(0.10)*(2.0*zz-8.0*yy+3.0)*yz; - mat[1][5] = sqrt(3.750)*(xx-yy-1.40*xx*xx+1.20*xx*yy+yy*yy); - mat[1][6] = sqrt(0.60)*(4.0*zz-4.0*xx+1.0)*xy; - mat[2][1] = mat[1][2]; - mat[3][1] = mat[1][3]; - mat[4][1] = mat[1][4]; - mat[5][1] = mat[1][5]; - mat[6][1] = mat[1][6]; - mat[2][2] = -0.40*yy - 0.50*(5.0*xx-3.0*yy)*zz; - mat[2][3] = -sqrt(0.10)*(6.0*zz-8.0*xx-1.0)*yz; - mat[2][4] = sqrt(0.10)*(2.0*zz-8.0*xx+3.0)*xz; - mat[2][5] = sqrt(0.60)*(4.0*yy-4.0*zz-1.0)*xy; - mat[2][6] = sqrt(3.750)*(xx-yy-xx*xx-1.20*xx*yy+1.40*yy*yy); - mat[3][2] = mat[2][3]; - mat[4][2] = mat[2][4]; - mat[5][2] = mat[2][5]; - mat[6][2] = mat[2][6]; - mat[3][3] = (2.0-3.0*zz)*zz - 4.0*xx*yy; - mat[3][4] = 2.0*(xx-yy)*xy; - mat[3][5] = -sqrt(1.50)*(2.0*zz-1.0)*xz; - mat[3][6] = -sqrt(1.50)*(2.0*zz-1.0)*yz; - mat[4][3] = mat[3][4]; - mat[5][3] = mat[3][5]; - mat[6][3] = mat[3][6]; - mat[4][4] = -(2.0*zz-1.0)*(2.0*zz-1.0) + 4.0*xx*yy; - mat[4][5] = sqrt(1.50)*(2.0*zz-1.0)*yz; - mat[4][6] = -sqrt(1.50)*(2.0*zz-1.0)*xz; - mat[5][4] = mat[4][5]; - mat[6][4] = mat[4][6]; - mat[5][5] = 1.50*(zz-1.0)*zz; - mat[5][6] = 0.0; - mat[6][5] = 0.0; - mat[6][6] = 1.50*(zz-1.0)*zz; - } - } -} -!------------------------------------------------------------------------------! - SUBROUTINE set_dmat(dmat,r,num) - IMPLICIT NONE - REAL (dbl), INTENT (IN) :: r(3) - INTEGER, INTENT (IN) :: num - REAL (dbl), INTENT (OUT) :: dmat(0:,0:,1:) - INTEGER :: l1, l2 - REAL (dbl), PARAMETER :: s3 = 0.5773502691896260 ! sqrt(1.0/3.0) - REAL (dbl) :: x, y, z, xx, yy, zz, xy, xz, yz - REAL (dbl) :: dc(0:6,0:6) - - l1 = size(dmat(:,0,1)) - l2 = size(dmat(0,:,1)) - x = r(1) - y = r(2) - z = r(3) - IF (l1 == 5 && l2 == 3 && num == 1) THEN -! d1(d,p) - dmat(0:4,0:2,1:3) = zero - dmat(1,0,1) = one - dmat(0,1,1) = -s3 - dmat(3,1,1) = one - dmat(4,2,1) = one - dmat(2,0,2) = one - dmat(0,2,2) = -s3 - dmat(3,2,2) = -one - dmat(4,1,2) = one - dmat(0,0,3) = 2.0*s3 - dmat(1,1,3) = one - dmat(2,2,3) = one - ELSE IF (l1 == 3 && l2 == 5 && num == 1) THEN -! d1(p,d) - dmat(0:2,0:4,1:3) = zero - dmat(0,1,1) = one - dmat(1,0,1) = -s3 - dmat(1,3,1) = one - dmat(2,4,1) = one - dmat(0,2,2) = one - dmat(2,0,2) = -s3 - dmat(2,3,2) = -one - dmat(1,4,2) = one - dmat(0,0,3) = 2.0*s3 - dmat(1,1,3) = one - dmat(2,2,3) = one - ELSEIF (l1 == 5 && l2 == 5 && num == 2) THEN -! d2(d,d) - dmat(0:4,0:4,1:3) = zero - dmat(0,1,1) = s3*z - dmat(0,3,1) = -2.0*s3*x - dmat(0,4,1) = -2.0*s3*y - dmat(1,0,1) = dmat(0,1,1) - dmat(3,0,1) = dmat(0,3,1) - dmat(4,0,1) = dmat(0,4,1) - dmat(1,2,1) = y - dmat(1,3,1) = z - dmat(2,1,1) = y - dmat(3,1,1) = z - dmat(2,2,1) = -2.0*x - dmat(2,4,1) = z - dmat(4,2,1) = z - dmat(0,2,2) = s3*z - dmat(0,3,2) = 2.0*s3*y - dmat(0,4,2) = -2.0*s3*x - dmat(2,0,2) = dmat(0,2,2) - dmat(3,0,2) = dmat(0,3,2) - dmat(4,0,2) = dmat(0,4,2) - dmat(1,1,2) = -2.0*y - dmat(1,2,2) = x - dmat(1,4,2) = z - dmat(2,1,2) = x - dmat(4,1,2) = z - dmat(2,3,2) = -z - dmat(3,2,2) = -z - dmat(0,0,3) = 2.0*z - dmat(0,1,3) = s3*x - dmat(0,2,3) = s3*y - dmat(1,0,3) = dmat(0,1,3) - dmat(2,0,3) = dmat(0,2,3) - dmat(1,3,3) = x - dmat(1,4,3) = y - dmat(3,1,3) = x - dmat(4,1,3) = y - dmat(2,3,3) = -y - dmat(2,4,3) = x - dmat(3,2,3) = -y - dmat(4,2,3) = x - dmat(3,3,3) = -2.0*z - dmat(4,4,3) = -2.0*z - ELSE IF (l1 == 7 && l2 == 3 && num == 2) THEN -! d2(f,p) - dmat(0,0,1) = zero - dmat(0,1,1) = -sqrt(6.0)*z - dmat(0,2,1) = zero - dmat(1,0,1) = 4.0*z - dmat(1,1,1) = -2.0*x - dmat(1,2,1) = -y - dmat(2,0,1) = zero - dmat(2,1,1) = -y - dmat(2,2,1) = zero - dmat(3,0,1) = 2.0*sqrt(2.50)*x - dmat(3,1,1) = sqrt(10.0)*z - dmat(3,2,1) = zero - dmat(4,0,1) = sqrt(10.0)*y - dmat(4,1,1) = zero - dmat(4,2,1) = sqrt(10.0)*z - dmat(5,0,1) = zero - dmat(5,1,1) = sqrt(15.0)*x - dmat(5,2,1) = -sqrt(15.0)*y - dmat(6,0,1) = zero - dmat(6,1,1) = sqrt(15.0)*y - dmat(6,2,1) = sqrt(15.0)*x - - dmat(0,0,2) = zero - dmat(0,1,2) = zero - dmat(0,2,2) = -sqrt(6.0)*z - dmat(1,0,2) = zero - dmat(1,1,2) = zero - dmat(1,2,2) = -x - dmat(2,0,2) = 4.0*z - dmat(2,1,2) = -x - dmat(2,2,2) = -2.0*y - dmat(3,0,2) = -2.0*sqrt(2.50)*y - dmat(3,1,2) = zero - dmat(3,2,2) = -sqrt(10.0)*z - dmat(4,0,2) = sqrt(10.0)*x - dmat(4,1,2) = sqrt(10.0)*z - dmat(4,2,2) = zero - dmat(5,0,2) = zero - dmat(5,1,2) = -sqrt(15.0)*y - dmat(5,2,2) = -sqrt(15.0)*x - dmat(6,0,2) = zero - dmat(6,1,2) = sqrt(15.0)*x - dmat(6,2,2) = -sqrt(15.0)*y - - dmat(0,0,3) = 6.0*sqrt(1.50)*z - dmat(0,1,3) = -sqrt(6.0)*x - dmat(0,2,3) = -sqrt(6.0)*y - dmat(1,0,3) = 4.0*x - dmat(1,1,3) = 5.0*z - dmat(1,2,3) = zero - dmat(2,0,3) = 4.0*y - dmat(2,1,3) = zero - dmat(2,2,3) = 5.0*z - dmat(3,0,3) = zero - dmat(3,1,3) = sqrt(10.0)*x - dmat(3,2,3) = -sqrt(10.0)*y - dmat(4,0,3) = zero - dmat(4,1,3) = sqrt(10.0)*y - dmat(4,2,3) = sqrt(10.0)*x - dmat(5,0,3) = zero - dmat(5,1,3) = zero - dmat(5,2,3) = zero - dmat(6,0,3) = zero - dmat(6,1,3) = zero - dmat(6,2,3) = zero - ELSE IF (l1 == 3 && l2 == 7 && num == 2) THEN -! d2(p,f) - dmat(0,0,1) = zero - dmat(1,0,1) = -sqrt(6.0)*z - dmat(2,0,1) = zero - dmat(0,1,1) = 4.0*z - dmat(1,1,1) = -2.0*x - dmat(2,1,1) = -y - dmat(0,2,1) = zero - dmat(1,2,1) = -y - dmat(2,2,1) = zero - dmat(0,3,1) = 2.0*sqrt(2.50)*x - dmat(1,3,1) = sqrt(10.0)*z - dmat(2,3,1) = zero - dmat(0,4,1) = sqrt(10.0)*y - dmat(1,4,1) = zero - dmat(2,4,1) = sqrt(10.0)*z - dmat(0,5,1) = zero - dmat(1,5,1) = sqrt(15.0)*x - dmat(2,5,1) = -sqrt(15.0)*y - dmat(0,6,1) = zero - dmat(1,6,1) = sqrt(15.0)*y - dmat(2,6,1) = sqrt(15.0)*x - - dmat(0,0,2) = zero - dmat(1,0,2) = zero - dmat(2,0,2) = -sqrt(6.0)*z - dmat(0,1,2) = zero - dmat(1,1,2) = zero - dmat(2,1,2) = -x - dmat(0,2,2) = 4.0*z - dmat(1,2,2) = -x - dmat(2,2,2) = -2.0*y - dmat(0,3,2) = -2.0*sqrt(2.50)*y - dmat(1,3,2) = zero - dmat(2,3,2) = -sqrt(10.0)*z - dmat(0,4,2) = sqrt(10.0)*x - dmat(1,4,2) = sqrt(10.0)*z - dmat(2,4,2) = zero - dmat(0,5,2) = zero - dmat(1,5,2) = -sqrt(15.0)*y - dmat(2,5,2) = -sqrt(15.0)*x - dmat(0,6,2) = zero - dmat(1,6,2) = sqrt(15.0)*x - dmat(2,6,2) = -sqrt(15.0)*y - - dmat(0,0,3) = 6.0*sqrt(1.50)*z - dmat(1,0,3) = -sqrt(6.0)*x - dmat(2,0,3) = -sqrt(6.0)*y - dmat(0,1,3) = 4.0*x - dmat(1,1,3) = 5.0*z - dmat(2,1,3) = zero - dmat(0,2,3) = 4.0*y - dmat(1,2,3) = zero - dmat(2,2,3) = 5.0*z - dmat(0,3,3) = zero - dmat(1,3,3) = sqrt(10.0)*x - dmat(2,3,3) = -sqrt(10.0)*y - dmat(0,4,3) = zero - dmat(1,4,3) = sqrt(10.0)*y - dmat(2,4,3) = sqrt(10.0)*x - dmat(0,5,3) = zero - dmat(1,5,3) = zero - dmat(2,5,3) = zero - dmat(0,6,3) = zero - dmat(1,6,3) = zero - dmat(2,6,3) = zero - ELSE IF (l1 == 7 && l2 == 5 && num == 1) THEN -! d1(f,d) - dmat(0:6,0:4,1:3) = zero - dmat(0,1,1) = -sqrt(1.50) - dmat(1,0,1) = sqrt(3.0) - dmat(1,3,1) = -0.50 - dmat(2,4,1) = -0.50 - dmat(3,1,1) = sqrt(2.50) - dmat(4,2,1) = sqrt(2.50) - dmat(5,3,1) = sqrt(3.750) - dmat(6,4,1) = sqrt(3.750) - - dmat(0,2,2) = -sqrt(1.50) - dmat(1,4,2) = -0.50 - dmat(2,0,2) = sqrt(3.0) - dmat(2,3,2) = 0.50 - dmat(3,2,2) = -sqrt(2.50) - dmat(4,1,2) = sqrt(2.50) - dmat(5,4,2) = -sqrt(3.750) - dmat(6,3,2) = sqrt(3.750) - - dmat(0,0,3) = sqrt(4.50) - dmat(1,1,3) = 2.0 - dmat(2,2,3) = 2.0 - dmat(3,3,3) = sqrt(2.50) - dmat(4,4,3) = sqrt(2.50) - ELSE IF (l1 == 5 && l2 == 7 && num == 1) THEN -! d1(d,f) - dmat(0:4,0:6,1:3) = zero - dmat(1,0,1) = -sqrt(1.50) - dmat(0,1,1) = sqrt(3.0) - dmat(3,1,1) = -0.50 - dmat(4,2,1) = -0.50 - dmat(1,3,1) = sqrt(2.50) - dmat(2,4,1) = sqrt(2.50) - dmat(3,5,1) = sqrt(3.750) - dmat(4,6,1) = sqrt(3.750) - - dmat(2,0,2) = -sqrt(1.50) - dmat(4,1,2) = -0.50 - dmat(0,2,2) = sqrt(3.0) - dmat(3,2,2) = 0.50 - dmat(2,3,2) = -sqrt(2.50) - dmat(1,4,2) = sqrt(2.50) - dmat(4,5,2) = -sqrt(3.750) - dmat(3,6,2) = sqrt(3.750) - - dmat(0,0,3) = sqrt(4.50) - dmat(1,1,3) = 2.0 - dmat(2,2,3) = 2.0 - dmat(3,3,3) = sqrt(2.50) - dmat(4,4,3) = sqrt(2.50) - ELSE IF (l1 == 7 && l2 == 5 && num == 3) THEN - xx = x*x - yy = y*y - zz = z*z - xy = x*y - xz = x*z - yz = y*z -! d3(f,d) - dmat(0,0,1) = zero - dmat(0,1,1) = sqrt(1.50)*zz - dmat(0,2,1) = zero - dmat(0,3,1) = -2.0*sqrt(6.0)*xz - dmat(0,4,1) = -2.0*sqrt(6.0)*yz - dmat(1,0,1) = sqrt(0.750)*(3.0*zz-1.0) - dmat(1,1,1) = xz - dmat(1,2,1) = 3.0*yz - dmat(1,3,1) = 2.50*zz-3.0*xx+yy - dmat(1,4,1) = -4.0*xy - dmat(2,0,1) = zero - dmat(2,1,1) = 3.0*yz - dmat(2,2,1) = -5.0*xz - dmat(2,3,1) = -2.0*xy - dmat(2,4,1) = 0.50*(5.0*zz-4.0*yy) - dmat(3,0,1) = zero - dmat(3,1,1) = sqrt(2.50)*(zz-2.0*yy) - dmat(3,2,1) = sqrt(2.50)*4.0*xy - dmat(3,3,1) = zero - dmat(3,4,1) = zero - dmat(4,0,1) = zero - dmat(4,1,1) = zero - dmat(4,2,1) = sqrt(2.50)*(1.0-6.0*xx) - dmat(4,3,1) = zero - dmat(4,4,1) = zero - dmat(5,0,1) = 3.0*sqrt(1.250)*(yy-xx) - dmat(5,1,1) = sqrt(15.0)*xz - dmat(5,2,1) = -sqrt(15.0)*yz - dmat(5,3,1) = -sqrt(3.750)*zz - dmat(5,4,1) = zero - dmat(6,0,1) = -sqrt(5.0)*3.0*xy - dmat(6,1,1) = sqrt(15.0)*yz - dmat(6,2,1) = sqrt(15.0)*xz - dmat(6,3,1) = zero - dmat(6,4,1) = -sqrt(3.750)*zz - - dmat(0,0,2) = zero - dmat(0,1,2) = zero - dmat(0,2,2) = sqrt(1.50)*zz - dmat(0,3,2) = 2.0*sqrt(6.0)*yz - dmat(0,4,2) = -2.0*sqrt(6.0)*xz - dmat(1,0,2) = zero - dmat(1,1,2) = -5.0*yz - dmat(1,2,2) = 3.0*xz - dmat(1,3,2) = 2.0*xy - dmat(1,4,2) = 0.50*(5.0*zz-4.0*xx) - dmat(2,0,2) = sqrt(0.750)*(3.0*zz-1.0) - dmat(2,1,2) = 3.0*xz - dmat(2,2,2) = yz - dmat(2,3,2) = -(2.50*zz+xx-3.0*yy) - dmat(2,4,2) = -4.0*xy - dmat(3,0,2) = zero - dmat(3,1,2) = -sqrt(2.50)*4.0*xy - dmat(3,2,2) = -sqrt(2.50)*(zz-2.0*xx) - dmat(3,3,2) = zero - dmat(3,4,2) = zero - dmat(4,0,2) = zero - dmat(4,1,2) = sqrt(2.50)*(1.0-6.0*yy) - dmat(4,2,2) = zero - dmat(4,3,2) = zero - dmat(4,4,2) = zero - dmat(5,0,2) = 3.0*sqrt(5.0)*xy - dmat(5,1,2) = -sqrt(15.0)*yz - dmat(5,2,2) = -sqrt(15.0)*xz - dmat(5,3,2) = zero - dmat(5,4,2) = sqrt(3.750)*zz - dmat(6,0,2) = -sqrt(1.250)*(3.0*xx-3.0*yy) - dmat(6,1,2) = sqrt(15.0)*xz - dmat(6,2,2) = -sqrt(15.0)*yz - dmat(6,3,2) = -sqrt(3.750)*zz - dmat(6,4,2) = zero - - dmat(0,0,3) = sqrt(0.50)*(12.0*zz-3.0) - dmat(0,1,3) = 2.0*sqrt(1.50)*xz - dmat(0,2,3) = 2.0*sqrt(1.50)*yz - dmat(0,3,3) = -sqrt(6.0)*(xx-yy) - dmat(0,4,3) = -2.0*sqrt(6.0)*xy - dmat(1,0,3) = 3.0*sqrt(3.0)*xz - dmat(1,1,3) = 0.50*(xx-5.0*yy) - dmat(1,2,3) = 3.0*xy - dmat(1,3,3) = 5.0*xz - dmat(1,4,3) = 5.0*yz - dmat(2,0,3) = 3.0*sqrt(3.0)*yz - dmat(2,1,3) = 3.0*xy - dmat(2,2,3) = 0.50*(yy-5.0*xx) - dmat(2,3,3) = -5.0*yz - dmat(2,4,3) = 5.0*xz - dmat(3,0,3) = zero - dmat(3,1,3) = 2.0*sqrt(2.50)*xz - dmat(3,2,3) = -2.0*sqrt(2.50)*yz - dmat(3,3,3) = sqrt(2.50)*(1.0-6.0*zz) - dmat(3,4,3) = zero - dmat(4,0,3) = zero - dmat(4,1,3) = zero - dmat(4,2,3) = zero - dmat(4,3,3) = zero - dmat(4,4,3) = sqrt(2.50)*(1.0-6.0*zz) - dmat(5,0,3) = zero - dmat(5,1,3) = sqrt(3.750)*(xx-yy) - dmat(5,2,3) = -sqrt(15.0)*xy - dmat(5,3,3) = -sqrt(15.0)*xz - dmat(5,4,3) = sqrt(15.0)*yz - dmat(6,0,3) = zero - dmat(6,1,3) = sqrt(15.0)*xy - dmat(6,2,3) = sqrt(3.750)*(xx-yy) - dmat(6,3,3) = -sqrt(15.0)*yz - dmat(6,4,3) = -sqrt(15.0)*xz - - ELSE IF (l1 == 5 && l2 == 7 && num == 3) THEN - xx = x*x - yy = y*y - zz = z*z - xy = x*y - xz = x*z - yz = y*z -! d3(d,f) - dmat(0,0,1) = zero - dmat(1,0,1) = sqrt(1.50)*zz - dmat(2,0,1) = zero - dmat(3,0,1) = -2.0*sqrt(6.0)*xz - dmat(4,0,1) = -2.0*sqrt(6.0)*yz - dmat(0,1,1) = sqrt(0.750)*(3.0*zz-1.0) - dmat(1,1,1) = xz - dmat(2,1,1) = 3.0*yz - dmat(3,1,1) = 2.50*zz-3.0*xx+yy - dmat(4,1,1) = -4.0*xy - dmat(0,2,1) = zero - dmat(1,2,1) = 3.0*yz - dmat(2,2,1) = -5.0*xz - dmat(3,2,1) = -2.0*xy - dmat(4,2,1) = 0.50*(5.0*zz-4.0*yy) - dmat(0,3,1) = zero - dmat(1,3,1) = sqrt(2.50)*(zz-2.0*yy) - dmat(2,3,1) = sqrt(2.50)*4.0*xy - dmat(3,3,1) = zero - dmat(4,3,1) = zero - dmat(0,4,1) = zero - dmat(1,4,1) = zero - dmat(2,4,1) = sqrt(2.50)*(1.0-6.0*xx) - dmat(3,4,1) = zero - dmat(4,4,1) = zero - dmat(0,5,1) = 3.0*sqrt(1.250)*(yy-xx) - dmat(1,5,1) = sqrt(15.0)*xz - dmat(2,5,1) = -sqrt(15.0)*yz - dmat(3,5,1) = -sqrt(3.750)*zz - dmat(4,5,1) = zero - dmat(0,6,1) = -sqrt(5.0)*3.0*xy - dmat(1,6,1) = sqrt(15.0)*yz - dmat(2,6,1) = sqrt(15.0)*xz - dmat(3,6,1) = zero - dmat(4,6,1) = -sqrt(3.750)*zz - - dmat(0,0,2) = zero - dmat(1,0,2) = zero - dmat(2,0,2) = sqrt(1.50)*zz - dmat(3,0,2) = 2.0*sqrt(6.0)*yz - dmat(4,0,2) = -2.0*sqrt(6.0)*xz - dmat(0,1,2) = zero - dmat(1,1,2) = -5.0*yz - dmat(2,1,2) = 3.0*xz - dmat(3,1,2) = 2.0*xy - dmat(4,1,2) = 0.50*(5.0*zz-4.0*xx) - dmat(0,2,2) = sqrt(0.750)*(3.0*zz-1.0) - dmat(1,2,2) = 3.0*xz - dmat(2,2,2) = yz - dmat(3,2,2) = -(2.50*zz+xx-3.0*yy) - dmat(4,2,2) = -4.0*xy - dmat(0,3,2) = zero - dmat(1,3,2) = -sqrt(2.50)*4.0*xy - dmat(2,3,2) = -sqrt(2.50)*(zz-2.0*xx) - dmat(3,3,2) = zero - dmat(4,3,2) = zero - dmat(0,4,2) = zero - dmat(1,4,2) = sqrt(2.50)*(1.0-6.0*yy) - dmat(2,4,2) = zero - dmat(3,4,2) = zero - dmat(4,4,2) = zero - dmat(0,5,2) = sqrt(5.0)*3.0*xy - dmat(1,5,2) = -sqrt(15.0)*yz - dmat(2,5,2) = -sqrt(15.0)*xz - dmat(3,5,2) = zero - dmat(4,5,2) = sqrt(3.750)*zz - dmat(0,6,2) = -sqrt(1.250)*(3.0*xx-3.0*yy) - dmat(1,6,2) = sqrt(15.0)*xz - dmat(2,6,2) = -sqrt(15.0)*yz - dmat(3,6,2) = -sqrt(3.750)*zz - dmat(4,6,2) = zero - - dmat(0,0,3) = sqrt(0.50)*(12.0*zz-3.0) - dmat(1,0,3) = 2.0*sqrt(1.50)*xz - dmat(2,0,3) = 2.0*sqrt(1.50)*yz - dmat(3,0,3) = -sqrt(6.0)*(xx-yy) - dmat(4,0,3) = -2.0*sqrt(6.0)*xy - dmat(0,1,3) = 3.0*sqrt(3.0)*xz - dmat(1,1,3) = 0.50*(xx-5.0*yy) - dmat(2,1,3) = 3.0*xy - dmat(3,1,3) = 5.0*xz - dmat(4,1,3) = 5.0*yz - dmat(0,2,3) = 3.0*sqrt(3.0)*yz - dmat(1,2,3) = 3.0*xy - dmat(2,2,3) = 0.50*(yy-5.0*xx) - dmat(3,2,3) = -5.0*yz - dmat(4,2,3) = 5.0*xz - dmat(0,3,3) = zero - dmat(1,3,3) = 2.0*sqrt(2.50)*xz - dmat(2,3,3) = -2.0*sqrt(2.50)*yz - dmat(3,3,3) = sqrt(2.50)*(1.0-6.0*zz) - dmat(4,3,3) = zero - dmat(0,4,3) = zero - dmat(1,4,3) = zero - dmat(2,4,3) = zero - dmat(3,4,3) = zero - dmat(4,4,3) = sqrt(2.50)*(1.0-6.0*zz) - dmat(0,5,3) = zero - dmat(1,5,3) = sqrt(3.750)*(xx-yy) - dmat(2,5,3) = -sqrt(15.0)*xy - dmat(3,5,3) = -sqrt(15.0)*xz - dmat(4,5,3) = sqrt(15.0)*yz - dmat(0,6,3) = zero - dmat(1,6,3) = sqrt(15.0)*xy - dmat(2,6,3) = sqrt(3.750)*(xx-yy) - dmat(3,6,3) = -sqrt(15.0)*yz - dmat(4,6,3) = -sqrt(15.0)*xz - ELSE IF (l1 == 7 && l2 == 7 && num == 2) THEN -! d2(f,f) - dmat(0,0,1) = zero - dmat(0,1,1) = sqrt(0.240)*z - dmat(0,2,1) = zero - dmat(0,3,1) = -2.0*sqrt(0.60)*x - dmat(0,4,1) = -sqrt(2.40)*y - dmat(0,5,1) = zero - dmat(0,6,1) = zero - dmat(1,0,1) = dmat(0,1,1) - dmat(2,0,1) = dmat(0,2,1) - dmat(3,0,1) = dmat(0,3,1) - dmat(4,0,1) = dmat(0,4,1) - dmat(5,0,1) = dmat(0,5,1) - dmat(6,0,1) = dmat(0,6,1) - dmat(1,1,1) = zero - dmat(1,2,1) = 1.20*y - dmat(1,3,1) = sqrt(0.90)*z - dmat(1,4,1) = zero - dmat(1,5,1) = -2.0*sqrt(0.150)*x - dmat(1,6,1) = -sqrt(0.60)*y - dmat(2,1,1) = dmat(1,2,1) - dmat(3,1,1) = dmat(1,3,1) - dmat(4,1,1) = dmat(1,4,1) - dmat(5,1,1) = dmat(1,5,1) - dmat(6,1,1) = dmat(1,6,1) - dmat(2,2,1) = -2.40*x - dmat(2,3,1) = zero - dmat(2,4,1) = sqrt(0.90)*z - dmat(2,5,1) = sqrt(0.60)*y - dmat(2,6,1) = -2.0*sqrt(0.150)*x - dmat(3,2,1) = dmat(2,3,1) - dmat(4,2,1) = dmat(2,4,1) - dmat(5,2,1) = dmat(2,5,1) - dmat(6,2,1) = dmat(2,6,1) - dmat(3,3,1) = zero - dmat(3,4,1) = zero - dmat(3,5,1) = sqrt(1.50)*z - dmat(3,6,1) = zero - dmat(4,3,1) = dmat(3,4,1) - dmat(5,3,1) = dmat(3,5,1) - dmat(6,3,1) = dmat(3,6,1) - dmat(4,4,1) = zero - dmat(4,5,1) = zero - dmat(4,6,1) = sqrt(1.50)*z - dmat(5,4,1) = dmat(4,5,1) - dmat(6,4,1) = dmat(4,6,1) - dmat(5,5,1) = zero - dmat(5,6,1) = zero - dmat(6,5,1) = zero - dmat(6,6,1) = zero - - dmat(0,0,2) = zero - dmat(0,1,2) = zero - dmat(0,2,2) = sqrt(0.240)*z - dmat(0,3,2) = 2.0*sqrt(0.60)*y - dmat(0,4,2) = -sqrt(2.40)*x - dmat(0,5,2) = zero - dmat(0,6,2) = zero - dmat(1,0,2) = dmat(0,1,2) - dmat(2,0,2) = dmat(0,2,2) - dmat(3,0,2) = dmat(0,3,2) - dmat(4,0,2) = dmat(0,4,2) - dmat(5,0,2) = dmat(0,5,2) - dmat(6,0,2) = dmat(0,6,2) - dmat(1,1,2) = -2.40*y - dmat(1,2,2) = 1.20*x - dmat(1,3,2) = zero - dmat(1,4,2) = sqrt(0.90)*z - dmat(1,5,2) = 2.0*sqrt(0.150)*y - dmat(1,6,2) = -sqrt(0.60)*x - dmat(2,1,2) = dmat(1,2,2) - dmat(3,1,2) = dmat(1,3,2) - dmat(4,1,2) = dmat(1,4,2) - dmat(5,1,2) = dmat(1,5,2) - dmat(6,1,2) = dmat(1,6,2) - dmat(2,2,2) = zero - dmat(2,3,2) = -sqrt(0.90)*z - dmat(2,4,2) = zero - dmat(2,5,2) = sqrt(0.60)*x - dmat(2,6,2) = 2.0*sqrt(0.150)*y - dmat(3,2,2) = dmat(2,3,2) - dmat(4,2,2) = dmat(2,4,2) - dmat(5,2,2) = dmat(2,5,2) - dmat(6,2,2) = dmat(2,6,2) - dmat(3,3,2) = zero - dmat(3,4,2) = zero - dmat(3,5,2) = zero - dmat(3,6,2) = sqrt(1.50)*z - dmat(4,3,2) = dmat(3,4,2) - dmat(5,3,2) = dmat(3,5,2) - dmat(6,3,2) = dmat(3,6,2) - dmat(4,4,2) = zero - dmat(4,5,2) = -sqrt(1.50)*z - dmat(4,6,2) = zero - dmat(5,4,2) = dmat(4,5,2) - dmat(6,4,2) = dmat(4,6,2) - dmat(5,5,2) = zero - dmat(5,6,2) = zero - dmat(6,5,2) = zero - dmat(6,6,2) = zero - - dmat(0,0,3) = 2.40*z - dmat(0,1,3) = sqrt(0.240)*x - dmat(0,2,3) = sqrt(0.240)*y - dmat(0,3,3) = zero - dmat(0,4,3) = zero - dmat(0,5,3) = zero - dmat(0,6,3) = zero - dmat(1,0,3) = dmat(0,1,3) - dmat(2,0,3) = dmat(0,2,3) - dmat(3,0,3) = dmat(0,3,3) - dmat(4,0,3) = dmat(0,4,3) - dmat(5,0,3) = dmat(0,5,3) - dmat(6,0,3) = dmat(0,6,3) - dmat(1,1,3) = 0.60*z - dmat(1,2,3) = zero - dmat(1,3,3) = sqrt(0.90)*x - dmat(1,4,3) = sqrt(0.90)*y - dmat(1,5,3) = zero - dmat(1,6,3) = zero - dmat(2,1,3) = dmat(1,2,3) - dmat(3,1,3) = dmat(1,3,3) - dmat(4,1,3) = dmat(1,4,3) - dmat(5,1,3) = dmat(1,5,3) - dmat(6,1,3) = dmat(1,6,3) - dmat(2,2,3) = 0.60*z - dmat(2,3,3) = -sqrt(0.90)*y - dmat(2,4,3) = sqrt(0.90)*x - dmat(2,5,3) = zero - dmat(2,6,3) = zero - dmat(3,2,3) = dmat(2,3,3) - dmat(4,2,3) = dmat(2,4,3) - dmat(5,2,3) = dmat(2,5,3) - dmat(6,2,3) = dmat(2,6,3) - dmat(3,3,3) = zero - dmat(3,4,3) = zero - dmat(3,5,3) = sqrt(1.50)*x - dmat(3,6,3) = sqrt(1.50)*y - dmat(4,3,3) = dmat(3,4,3) - dmat(5,3,3) = dmat(3,5,3) - dmat(6,3,3) = dmat(3,6,3) - dmat(4,4,3) = zero - dmat(4,5,3) = -sqrt(1.50)*y - dmat(4,6,3) = sqrt(1.50)*x - dmat(5,4,3) = dmat(4,5,3) - dmat(6,4,3) = dmat(4,6,3) - dmat(5,5,3) = -3.0*z - dmat(5,6,3) = zero - dmat(6,5,3) = zero - dmat(6,6,3) = -3.0*z - ELSE IF (l1 == 7 && l2 == 7 && num == 4) THEN - xx = x*x - yy = y*y - zz = z*z - xy = x*y - xz = x*z - yz = y*z -! d4(f,f) - dmat(0,0,1) = zero - dmat(0,1,1) = sqrt(0.240)*(5.0*zz-2.0)*z - dmat(0,2,1) = zero - dmat(0,3,1) = -sqrt(0.60)*2.0*x*zz - dmat(0,4,1) = -sqrt(2.40)*y*zz - dmat(0,5,1) = sqrt(3.60)*(3.0*yy-3.0*xx)*z - dmat(0,6,1) = -sqrt(3.60)*6.0*x*yz - dmat(1,0,1) = dmat(0,1,1) - dmat(2,0,1) = dmat(0,2,1) - dmat(3,0,1) = dmat(0,3,1) - dmat(4,0,1) = dmat(0,4,1) - dmat(5,0,1) = dmat(0,5,1) - dmat(6,0,1) = dmat(0,6,1) - dmat(1,1,1) = -0.80*x + 3.0*x*zz - dmat(1,2,1) = 0.40*(10.0*zz-1.0)*y - dmat(1,3,1) = sqrt(0.10)*(6.0*zz-8.0*yy-1.0)*z - dmat(1,4,1) = zero - dmat(1,5,1) = sqrt(3.750)*(2.0*x-5.60*x*xx+2.40*x*yy) - dmat(1,6,1) = sqrt(0.60)*(4.0*zz-12.0*xx+1.0)*y - dmat(2,1,1) = dmat(1,2,1) - dmat(3,1,1) = dmat(1,3,1) - dmat(4,1,1) = dmat(1,4,1) - dmat(5,1,1) = dmat(1,5,1) - dmat(6,1,1) = dmat(1,6,1) - dmat(2,2,1) = -5.0*x*zz - dmat(2,3,1) = sqrt(0.10)*16.0*x*yz - dmat(2,4,1) = sqrt(0.10)*(2.0*zz-24.0*xx+3.0)*z - dmat(2,5,1) = sqrt(0.60)*(4.0*yy-4.0*zz-1.0)*y - dmat(2,6,1) = sqrt(3.750)*(2.0*x-4.0*x*xx-2.40*x*yy) - dmat(3,2,1) = dmat(2,3,1) - dmat(4,2,1) = dmat(2,4,1) - dmat(5,2,1) = dmat(2,5,1) - dmat(6,2,1) = dmat(2,6,1) - dmat(3,3,1) = -8.0*x*yy - dmat(3,4,1) = 2.0*(3.0*xx-yy)*y - dmat(3,5,1) = -sqrt(1.50)*(2.0*zz-1.0)*z - dmat(3,6,1) = zero - dmat(4,3,1) = dmat(3,4,1) - dmat(5,3,1) = dmat(3,5,1) - dmat(6,3,1) = dmat(3,6,1) - dmat(4,4,1) = 8.0*x*yy - dmat(4,5,1) = zero - dmat(4,6,1) = -sqrt(1.50)*(2.0*zz-1.0)*z - dmat(5,4,1) = dmat(4,5,1) - dmat(6,4,1) = dmat(4,6,1) - dmat(5,5,1) = zero - dmat(5,6,1) = zero - dmat(6,5,1) = zero - dmat(6,6,1) = zero - - dmat(0,0,2) = zero - dmat(0,1,2) = zero - dmat(0,2,2) = sqrt(0.240)*(5.0*zz-2.0)*z - dmat(0,3,2) = sqrt(0.60)*2.0*y*zz - dmat(0,4,2) = -sqrt(2.40)*x*zz - dmat(0,5,2) = sqrt(3.60)*6.0*y*xz - dmat(0,6,2) = sqrt(3.60)*(3.0*yy-3.0*xx)*z - dmat(1,0,2) = dmat(0,1,2) - dmat(2,0,2) = dmat(0,2,2) - dmat(3,0,2) = dmat(0,3,2) - dmat(4,0,2) = dmat(0,4,2) - dmat(5,0,2) = dmat(0,5,2) - dmat(6,0,2) = dmat(0,6,2) - dmat(1,1,2) = -5.0*y*zz - dmat(1,2,2) = 0.40*(10.0*zz-1.0)*x - dmat(1,3,2) = sqrt(0.10)*(-16.0*y)*xz - dmat(1,4,2) = sqrt(0.10)*(2.0*zz-24.0*yy+3.0)*z - dmat(1,5,2) = sqrt(3.750)*(-2.0*y+2.40*xx*y+4.0*y*yy) - dmat(1,6,2) = sqrt(0.60)*(4.0*zz-4.0*xx+1.0)*x - dmat(2,1,2) = dmat(1,2,2) - dmat(3,1,2) = dmat(1,3,2) - dmat(4,1,2) = dmat(1,4,2) - dmat(5,1,2) = dmat(1,5,2) - dmat(6,1,2) = dmat(1,6,2) - dmat(2,2,2) = -0.80*y + 3.0*y*zz - dmat(2,3,2) = -sqrt(0.10)*(6.0*zz-8.0*xx-1.0)*z - dmat(2,4,2) = zero - dmat(2,5,2) = sqrt(0.60)*(12.0*yy-4.0*zz-1.0)*x - dmat(2,6,2) = sqrt(3.750)*(-2.0*y-2.40*xx*y+5.60*y*yy) - dmat(3,2,2) = dmat(2,3,2) - dmat(4,2,2) = dmat(2,4,2) - dmat(5,2,2) = dmat(2,5,2) - dmat(6,2,2) = dmat(2,6,2) - dmat(3,3,2) = -8.0*xx*y - dmat(3,4,2) = 2.0*(xx-3.0*yy)*x - dmat(3,5,2) = zero - dmat(3,6,2) = -sqrt(1.50)*(2.0*zz-1.0)*z - dmat(4,3,2) = dmat(3,4,2) - dmat(5,3,2) = dmat(3,5,2) - dmat(6,3,2) = dmat(3,6,2) - dmat(4,4,2) = 8.0*xx*y - dmat(4,5,2) = sqrt(1.50)*(2.0*zz-1.0)*z - dmat(4,6,2) = zero - dmat(5,4,2) = dmat(4,5,2) - dmat(6,4,2) = dmat(4,6,2) - dmat(5,5,2) = zero - dmat(5,6,2) = zero - dmat(6,5,2) = zero - dmat(6,6,2) = zero - - dmat(0,0,3) = 0.60*(20.0*zz-8.0)*z - dmat(0,1,3) = sqrt(0.240)*(15.0*zz-2.0)*x - dmat(0,2,3) = sqrt(0.240)*(15.0*zz-2.0)*y - dmat(0,3,3) = -sqrt(0.60)*(xx-yy)*2.0*z - dmat(0,4,3) = -sqrt(2.40)*xy*2.0*z - dmat(0,5,3) = sqrt(3.60)*(3.0*yy-xx)*x - dmat(0,6,3) = sqrt(3.60)*(yy-3.0*xx)*y - dmat(1,0,3) = dmat(0,1,3) - dmat(2,0,3) = dmat(0,2,3) - dmat(3,0,3) = dmat(0,3,3) - dmat(4,0,3) = dmat(0,4,3) - dmat(5,0,3) = dmat(0,5,3) - dmat(6,0,3) = dmat(0,6,3) - dmat(1,1,3) = -(5.0*yy-3.0*xx)*z - dmat(1,2,3) = 8.0*z*xy - dmat(1,3,3) = sqrt(0.10)*(18.0*zz-8.0*yy-1.0)*x - dmat(1,4,3) = sqrt(0.10)*(6.0*zz-8.0*yy+3.0)*y - dmat(1,5,3) = zero - dmat(1,6,3) = sqrt(0.60)*8.0*z*xy - dmat(2,1,3) = dmat(1,2,3) - dmat(3,1,3) = dmat(1,3,3) - dmat(4,1,3) = dmat(1,4,3) - dmat(5,1,3) = dmat(1,5,3) - dmat(6,1,3) = dmat(1,6,3) - dmat(2,2,3) = -(5.0*xx-3.0*yy)*z - dmat(2,3,3) = -sqrt(0.10)*(18.0*zz-8.0*xx-1.0)*y - dmat(2,4,3) = sqrt(0.10)*(6.0*zz-8.0*xx+3.0)*x - dmat(2,5,3) = sqrt(0.60)*(-8.0*z)*xy - dmat(2,6,3) = zero - dmat(3,2,3) = dmat(2,3,3) - dmat(4,2,3) = dmat(2,4,3) - dmat(5,2,3) = dmat(2,5,3) - dmat(6,2,3) = dmat(2,6,3) - dmat(3,3,3) = (4.0-12.0*zz)*z - dmat(3,4,3) = zero - dmat(3,5,3) = -sqrt(1.50)*(6.0*zz-1.0)*x - dmat(3,6,3) = -sqrt(1.50)*(6.0*zz-1.0)*y - dmat(4,3,3) = dmat(3,4,3) - dmat(5,3,3) = dmat(3,5,3) - dmat(6,3,3) = dmat(3,6,3) - dmat(4,4,3) = -2.0*(2.0*zz-1.0)*4.0*z - dmat(4,5,3) = sqrt(1.50)*(6.0*zz-1.0)*y - dmat(4,6,3) = -sqrt(1.50)*(6.0*zz-1.0)*x - dmat(5,4,3) = dmat(4,5,3) - dmat(6,4,3) = dmat(4,6,3) - dmat(5,5,3) = 1.50*(4.0*zz-2.0)*z - dmat(5,6,3) = zero - dmat(6,5,3) = zero - dmat(6,6,3) = 1.50*(4.0*zz-2.0)*z - END IF - dc(0:l1-1,0:l2-1) = r(1)*dmat(:,:,1) + r(2)*dmat(:,:,2) + & - r(3)*dmat(:,:,3) - dmat(:,:,1) = dmat(:,:,1) - r(1)*dc(0:l1-1,0:l2-1) - dmat(:,:,2) = dmat(:,:,2) - r(2)*dc(0:l1-1,0:l2-1) - dmat(:,:,3) = dmat(:,:,3) - r(3)*dc(0:l1-1,0:l2-1) - END SUBROUTINE set_dmat -!------------------------------------------------------------------------------! - END MODULE slater_koster_matr -!------------------------------------------------------------------------------! diff --git a/src/slater_koster_util.cpp b/src/slater_koster_util.cpp deleted file mode 100644 index 475008d..0000000 --- a/src/slater_koster_util.cpp +++ /dev/null @@ -1,161 +0,0 @@ -#include - -/*----------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*----------------------------------------------------------------------------*/ -// Some utility functions for the Slater-Koster Modules -// - -namespace slater_koster_util { - - // Spherical Harmonics up to f functions - // There is a factor sqrt(4*PI)/sqrt(2*l+1) omitted - void sph(int l, double r[3], double gsl[7]) { - const double sq3 = 1.732050807568877; // sqrt(3) - const double sq15 = 3.872983346207417; // sqrt(15) - const double sq38 = 0.612372435695794; // sqrt(0.375) - const double sq58 = 0.790569415042095; // sqrt(0.625) - - switch (l) { - case 0: - gsl[0] = 1.0; - break; - case 1: - gsl[0] = r[2]; - gsl[1] = r[0]; - gsl[2] = r[1]; - break; - case 2: - gsl[0] = 0.5 * (3.0 * r[2] * r[2] - 1.0); - gsl[1] = sq3 * r[0] * r[2]; - gsl[2] = sq3 * r[1] * r[2]; - gsl[3] = 0.5 * sq3 * (r[0] * r[0] - r[1] * r[1]); - gsl[4] = sq3 * r[0] * r[1]; - break; - case 3: - gsl[0] = 0.5 * (5.0 * r[2] * r[2] - 3.0) * r[2]; - gsl[1] = sq38 * (5.0 * r[2] * r[2] - 1.0) * r[0]; - gsl[2] = sq38 * (5.0 * r[2] * r[2] - 1.0) * r[1]; - gsl[3] = 0.5 * sq15 * (r[0] * r[0] - r[1] * r[1]) * r[2]; - gsl[4] = sq15 * r[0] * r[1] * r[2]; - gsl[5] = sq58 * (r[0] * r[0] - 3.0 * r[1] * r[1]) * r[0]; - gsl[6] = sq58 * (3.0 * r[0] * r[0] - r[1] * r[1]) * r[1]; - break; - } - } - - // Derivatives of Spherical Harmonics up to f functions - // There is a factor sqrt(4*PI)/sqrt(2*l+1)/R omitted - void dsph(int l, double r[3], double dgsl[7][3]) { - const double sq3 = 1.732050807568877; // sqrt(3) - const double sq15 = 3.872983346207417; // sqrt(15) - const double sq38 = 0.612372435695794; // sqrt(0.375) - const double sq58 = 0.790569415042095; // sqrt(0.625) - double dc[7]; - - switch (l) { - case 0: - dgsl[0][0] = 0.0; - dgsl[0][1] = 0.0; - dgsl[0][2] = 0.0; - break; - case 1: - dgsl[0][0] = 0.0; - dgsl[0][1] = 1.0; - dgsl[0][2] = 0.0; - dgsl[1][0] = 0.0; - dgsl[1][1] = 0.0; - dgsl[1][2] = 0.0; - dgsl[2][0] = 0.0; - dgsl[2][1] = 0.0; - dgsl[2][2] = 1.0; - break; - case 2: - dgsl[0][0] = 0.0; - dgsl[0][1] = sq3 * r[2]; - dgsl[0][2] = 0.0; - dgsl[1][0] = 0.0; - dgsl[1][1] = 0.0; - dgsl[1][2] = -sq3 * r[2]; - dgsl[2][0] = sq3 * r[2]; - dgsl[2][1] = sq3 * r[0]; - dgsl[2][2] = sq3 * r[1]; - dgsl[3][0] = sq3 * r[0]; - dgsl[3][1] = -sq3 * r[2]; - dgsl[3][2] = sq3 * r[1]; - dgsl[4][0] = sq3 * r[1]; - dgsl[4][1] = sq3 * r[2]; - dgsl[4][2] = sq3 * r[0]; - break; - case 3: - dgsl[0][0] = 0.0; - dgsl[0][1] = sq38 * (5.0 * r[2] * r[2] - 1.0); - dgsl[0][2] = 0.0; - dgsl[1][0] = 0.0; - dgsl[1][1] = 0.0; - dgsl[1][2] = -sq38 * (5.0 * r[2] * r[2] - 1.0); - dgsl[2][0] = sq38 * (5.0 * r[2] * r[2] - 1.0); - dgsl[2][1] = sq38 * (5.0 * r[0] * r[2]); - dgsl[2][2] = sq38 * (5.0 * r[1] * r[2]); - dgsl[3][0] = sq15 * r[0] * r[2]; - dgsl[3][1] = -sq15 * r[2] * r[2] + sq15 * r[0] * r[0]; - dgsl[3][2] = sq15 * r[1] * r[2]; - dgsl[4][0] = sq15 * r[1] * r[2]; - dgsl[4][1] = sq15 * r[2] * r[2] - sq15 * r[1] * r[1]; - dgsl[4][2] = -sq15 * r[0] * r[2]; - dgsl[5][0] = 3.0 * sq58 * (r[0] * r[0] - r[1] * r[1]); - dgsl[5][1] = -6.0 * sq58 * r[0] * r[1]; - dgsl[5][2] = 0.0; - dgsl[6][0] = 6.0 * sq58 * r[0] * r[1]; - dgsl[6][1] = 3.0 * sq58 * (r[1] * r[1] - r[0] * r[0]); - dgsl[6][2] = 0.0; - break; - } - - for (int i = 0; i <= 2 * l; i++) { - dc[i] = r[0] * dgsl[i][0] + r[1] * dgsl[i][1] + r[2] * dgsl[i][2]; - dgsl[i][0] -= r[0] * dc[i]; - dgsl[i][1] -= r[1] * dc[i]; - dgsl[i][2] -= r[2] * dc[i]; - } - } - - // Compute the outer product of two vectors - void out_prod(double mat[][3], double v1[], double v2[]) { - int n1 = sizeof(v1) / sizeof(v1[0]); - int n2 = sizeof(v2) / sizeof(v2[0]); - - for (int j = 0; j < n2; j++) { - for (int i = 0; i < n1; i++) { - mat[i][j] = v1[i] * v2[j]; - } - } - } - - // Compute the outer product of two vectors with their derivatives - void out_dprod(double dmat[][3], double v1[], double v2[], double dv1[], double dv2[]) { - int n1 = sizeof(v1) / sizeof(v1[0]); - int n2 = sizeof(v2) / sizeof(v2[0]); - - for (int j = 0; j < n2; j++) { - for (int i = 0; i < n1; i++) { - dmat[i][j] = dv1[i] * v2[j] + v1[i] * dv2[j]; - } - } - } - - // Compute the dot product of two matrices - double dpro(double g1[][7], double g2[][7], int l1, int l2) { - double dpro = 0.0; - - for (int i = 0; i <= 2 * l2; i++) { - for (int j = 0; j <= 2 * l1; j++) { - dpro += g1[j][i] * g2[j][i]; - } - } - - return dpro; - } - -} // namespace slater_koster_util diff --git a/src/splines.c b/src/splines.c deleted file mode 100644 index 06a880d..0000000 --- a/src/splines.c +++ /dev/null @@ -1,545 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE splines - -! routines for handling splines -! init_splinexy: allocates x and y vectors for splines -! init_spline: generate table for spline (allocate spl%y2) -! spline: return value of spline for given abscissa (optional:also y1) -! spline_1: return value of 1. derivative of spline for given abscissa -! spline_int: return value of integral on given interval of spline -! kill_spline: destructor ( spl%x,y und/oder spl%y2) - -! NB: splines are always ``natural splines'', i.e. values of first -! derivative at the end-points cannot be specified -!-----------------------------------------------------------------------------! - - USE kinds, ONLY : dbl - USE stop_program, ONLY : stop_prg, stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: spline_data, init_splinexy, init_spline, spline, spline_1, & - spline_int, kill_spline, splineh - - TYPE spline_data - REAL ( dbl ), POINTER :: x ( : ), y ( : ) - REAL ( dbl ), POINTER :: y2 ( : ) - INTEGER :: n, pos - REAL ( dbl ) :: h, invh, h26, h16 - END TYPE spline_data - -CONTAINS - -!****************************************************************************** - -SUBROUTINE init_splinexy ( spl, nn ) - - IMPLICIT NONE - -! Arguments - TYPE ( spline_data ), INTENT ( INOUT ) :: spl - INTEGER, INTENT ( IN ) :: nn - -! Locals - INTEGER :: err - -!------------------------------------------------------------------------------ - - spl % n = nn - IF ( ASSOCIATED ( spl % x ) ) THEN - DEALLOCATE ( spl % x, STAT = err ) - IF ( err /= 0 ) CALL stop_memory ( 'init_splinexy', 'spl%x') - NULLIFY ( spl % x ) - END IF - IF ( ASSOCIATED ( spl % y ) ) THEN - DEALLOCATE ( spl % y, STAT = err ) - IF ( err /= 0 ) CALL stop_memory ( 'init_splinexy', 'spl%y') - NULLIFY ( spl % y ) - END IF - - ALLOCATE ( spl % x ( 1:nn ), STAT = err ) - IF ( err /= 0 ) CALL stop_memory ( 'init_splinexy', 'spl%x', nn ) - - ALLOCATE ( spl%y(1:nn), STAT = err ) - IF ( err /= 0 ) CALL stop_memory ( 'init_splinexy', 'spl%y', nn) - -END SUBROUTINE init_splinexy - -!****************************************************************************** - -! endpt: 's': regular spacing -! 'l': left; 'r': right; 'b': both = specify 1-deriv for -! which endpoints - -SUBROUTINE init_spline ( spl, endpt, y1a, y1b ) - - IMPLICIT NONE - -! Arguments - TYPE (spline_data), INTENT ( INOUT ) :: spl - CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: endpt - REAL ( dbl ), INTENT ( IN ), OPTIONAL :: y1a, y1b - -! Locals - INTEGER :: err, i, k - REAL ( dbl ) :: p, qn, sig, un, y1l, y1r - REAL ( dbl ), POINTER :: ww ( : ) - CHARACTER ( LEN = 8 ) :: ep - LOGICAL :: reg, lep, rep - -!------------------------------------------------------------------------------ - - IF ( .NOT. PRESENT ( endpt ) ) THEN - ep = '' - ELSE - ep = endpt - END IF - - reg = (scan(ep,'sS')>0) - lep = (scan(ep,'lL')>0) .OR. (scan(ep,'bB')>0) - rep = (scan(ep,'rR')>0) .OR. (scan(ep,'bB')>0) - IF (lep) y1l = y1a - IF (rep .AND. .NOT. lep) y1r = y1a - IF (rep .AND. lep) y1r = y1b - IF ((lep .OR. rep) .AND. .NOT. PRESENT ( y1a)) & - CALL stop_prg ( 'init_spline','first deriv. at end-point missing') - IF (lep .AND. rep .AND. .NOT. PRESENT ( y1b)) CALL stop_prg( & - 'init_spline','first deriv. at end-point missing') - - spl%pos = 1 - IF ( ASSOCIATED ( spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'init_spline','spl%y2') - NULLIFY (spl%y2) - END IF - ALLOCATE (spl%y2(1:spl%n),STAT=err) - IF ( err /= 0 ) CALL stop_memory ( 'init_spline', 'spl%y2', spl % n ) - ALLOCATE (ww(1:spl%n),STAT=err) - IF ( err /= 0 ) CALL stop_memory ( 'init_spline', 'ww', spl % n ) - - IF (lep) THEN - spl%y2(1) = -0.5_dbl - ww(1) = ( 3.0_dbl & - /(spl%x(2)-spl%x(1)))*((spl%y(2)-spl%y(1))/(spl%x(2)-spl% & - x(1))-y1l) - ELSE - spl%y2(1) = 0 - ww(1) = 0.0_dbl - END IF - - DO i = 2, spl%n - 1 - sig = (spl%x(i)-spl%x(i-1))/(spl%x(i+1)-spl%x(i-1)) - p = sig*spl%y2(i-1) + 2.0_dbl - spl%y2(i) = (sig-1.)/p - ww(i) = (6.0_dbl*((spl%y(i+1)-spl%y(i))/(spl%x(i+1)-spl%x(i))-(spl%y(i)- & - spl%y(i-1))/(spl%x(i)-spl%x(i-1)))/(spl%x(i+ & - 1)-spl%x(i-1))-sig*ww(i-1))/p - END DO - - IF ( rep ) THEN - qn = 0.5_dbl - un = ( 3.0_dbl & - /(spl%x(spl%n)-spl%x(spl%n-1)))*(y1r-(spl%y(spl%n)-spl%y(spl & - %n-1))/(spl%x(spl%n)-spl%x(spl%n-1))) - ELSE - qn = 0 - un = 0 - END IF - - spl%y2(spl%n) = (un-qn*ww(spl%n-1))/(qn*spl%y2(spl%n-1)+1.) - DO k = spl%n - 1, 1, -1 - spl%y2(k) = spl%y2(k)*spl%y2(k+1) + ww(k) - END DO - - DEALLOCATE (ww,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'init_spline','ww') - - IF (reg) THEN - spl%h = (spl%x(spl%n)-spl%x(1))/(spl%n-1.) - spl%h16 = spl%h/6. - spl%h26 = spl%h**2/6. - spl%invh = 1/spl%h - ELSE - spl%h = 0 - spl%invh = 0 - END IF - -END SUBROUTINE init_spline - -!****************************************************************************** - -FUNCTION interv ( spl, xx ) - - IMPLICIT NONE - -! Arguments - TYPE ( spline_data ), INTENT ( IN ) :: spl - REAL ( dbl ), INTENT ( IN ) :: xx - -! Locals - INTEGER :: interv - INTEGER :: khi, klo, i, p, n, k - -!------------------------------------------------------------------------------ - - IF (spl%h /= 0 ) THEN - i = (xx-spl%x(1))*spl%invh + 1 - IF (i<1 .OR. i>spl%n) CALL stop_prg ( 'interv', & - 'illegal x-value passed to interv') - interv = i - RETURN - END IF - - p = spl%pos - IF (p>=spl%n) p = spl%n/2 - i = 0 - n = spl%n - -! check if interval is close to previous interval - IF ( xx < spl % x ( p + 1 ) ) THEN - IF ( xx >= spl % x ( p ) ) THEN - i = spl%pos - ELSE IF ( p > 1 .AND. xx >= spl % x ( p - 1 ) ) THEN - i = p - 1 - ELSE - klo = 1 - khi = p + 1 - END IF - ELSE IF ( p + 2 <= n .AND. xx < spl % x ( p + 2 ) ) THEN - i = p + 1 - ELSE - klo = p + 1 - khi = n - END IF - - IF ( i == 0 ) THEN ! perform binary search - IF ( xx < spl % x ( 1 ) .OR. xx > spl % x ( n ) ) & - CALL stop_prg ( 'interv', 'xx value out of spline-range' ) - DO WHILE ( khi - klo > 1 ) - k = ( khi + klo ) / 2 - IF ( spl % x ( k ) > xx ) THEN - khi = k - ELSE - klo = k - END IF - END DO - i = klo - END IF - - interv = i - -END FUNCTION interv - -!****************************************************************************** - -FUNCTION spline_slow ( spl, xx, y1 ) - - IMPLICIT NONE - -! Arguments - TYPE (spline_data), INTENT ( INOUT ) :: spl - REAL ( dbl ), INTENT ( IN ) :: xx - REAL ( dbl ), INTENT ( OUT ), OPTIONAL :: y1 - -! Locals - REAL ( dbl ) :: spline_slow - INTEGER :: khi, klo - REAL ( dbl ) :: a, b, h, invh - -!------------------------------------------------------------------------------ - - spl%pos = interv(spl,xx) - klo = spl%pos - khi = spl%pos + 1 - - IF (spl%h /= 0 ) THEN - h = spl%h - invh = spl%invh - ELSE - h = spl%x(khi) - spl%x(klo) - invh = spl%invh - IF ( h == 0.0_dbl ) CALL stop_prg ( 'spline', 'bad spl%x input' ) - END IF - - a = (spl%x(khi)-xx)*invh - b = 1 - a - spline_slow = a*spl%y(klo) + b*spl%y(khi) + ((a**3-a)*spl%y2(klo)+(b** & - 3-b)*spl%y2(khi))*(h**2)/6.0_dbl - IF ( PRESENT ( y1 ) ) y1 = (spl%y(khi)-spl%y(klo))*invh + & - ((1.0_dbl-3*a**2)*spl%y2(klo)+(3*b**2-1.0_dbl)*spl%y2(khi))*h/6.0_dbl - -END FUNCTION spline_slow - -!****************************************************************************** - -FUNCTION spline ( spl, xx, y1 ) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: spline - -! Arguments - TYPE ( spline_data ), INTENT ( INOUT ) :: spl - REAL ( dbl ), INTENT ( IN ) :: xx - REAL ( dbl ), INTENT ( OUT ), OPTIONAL :: y1 - -! Locals - INTEGER :: khi, klo, i - REAL ( dbl ) :: a, b, h, invh, t, ylo, yhi, y2lo, y2hi, d, d0 - -!------------------------------------------------------------------------------ - - h = spl % h - invh = spl%invh - IF (h /= 0 ) THEN -! d=xx-spl%x(1); i=INT(d*spl%invh); d0=REAL(i)*h; i=i+1 - i = (xx-spl%x(1))*invh + 1 - IF (i<1 .OR. i>spl%n) CALL stop_prg ( 'spline','illegal x-value') - ELSE - i = interv(spl,xx) - spl%pos = 1 - END IF - - a = (spl%x(i+1)-xx)*invh - b = 1 - a - t = -a*b -! b=(d-d0)*invh; a=1-b; t=-a*b - ylo = spl%y(i) - yhi = spl%y(i+1) - y2lo = spl%y2(i) - y2hi = spl%y2(i+1) - spline = a*ylo + b*yhi + ((a+1)*y2lo+(b+1)*y2hi)*t*spl%h26 - IF ( PRESENT ( y1)) y1 = (yhi-ylo)*invh + ((1.-3*a*a)*y2lo+(3*b*b-1.)* & - y2hi)*spl%h16 - -END FUNCTION spline - -!****************************************************************************** - -FUNCTION splineh ( spl, xx, y1 ) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: splineh - -! Arguments - TYPE (spline_data), INTENT ( IN ) :: spl - REAL ( dbl ), INTENT ( IN ) :: xx - REAL ( dbl ), INTENT ( OUT ) :: y1 - -! Locals - INTEGER :: khi, klo, i - REAL ( dbl ) :: a, b, h, invh, t, ylo, yhi, y2lo, y2hi, d, d0 - -!------------------------------------------------------------------------------ - -! fast spline for pair potentials without checks - h = spl%h - invh = spl%invh - d=xx-spl%x(1); i=INT(d*spl%invh); d0=REAL(i)*h; i=i+1 - i = (xx-spl%x(1))*invh + 1 - - a = (spl%x(i+1)-xx)*invh - b = 1 - a - t = -a*b -! b=(d-d0)*invh; a=1-b; t=-a*b - ylo = spl%y(i) - yhi = spl%y(i+1) - y2lo = spl%y2(i) - y2hi = spl%y2(i+1) - splineh = a*ylo + b*yhi + ((a+1)*y2lo+(b+1)*y2hi)*t*spl%h26 - y1 = (yhi-ylo)*invh + ((1.-3*a*a)*y2lo+(3*b*b-1.)*y2hi)*spl%h16 - -END FUNCTION splineh - -!****************************************************************************** - -FUNCTION spline_1 ( spl, xx ) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: spline_1 - -! Arguments - TYPE ( spline_data ), INTENT ( INOUT ) :: spl - REAL ( dbl ), INTENT ( IN ) :: xx - -! Locals - INTEGER :: khi, klo - REAL ( dbl ) :: a, b, h - -!------------------------------------------------------------------------------ - - spl % pos = interv ( spl, xx ) - klo = spl % pos - khi = spl % pos + 1 - - h = spl % x ( khi ) - spl % x ( klo ) - IF ( h == 0.0_dbl ) CALL stop_prg ( 'spline', 'bad spl%x input' ) - a = ( spl % x ( khi ) - xx ) / h - b = 1.0_dbl - a - spline_1 = ( spl%y(khi)-spl%y(klo) ) / h & - + ( ( 1.0_dbl - 3.0_dbl * a ** 2 ) * spl % y2(klo) & - + ( 3.0_dbl * b ** 2 - 1.0_dbl ) * spl % y2(khi) ) * h / 6.0_dbl - -END FUNCTION spline_1 - -!****************************************************************************** - -FUNCTION stamm ( spl, p, x ) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: stamm - -! Arguments - TYPE (spline_data), INTENT ( IN ) :: spl - INTEGER, INTENT ( IN ) :: p - REAL ( dbl ), INTENT ( IN ) :: x - -! Locals - REAL ( dbl ) :: a, b, aa, bb, h - -!------------------------------------------------------------------------------ - - h = spl%x(p+1) - spl%x(p) - b = (x-spl%x(p))/h - a = 1 - b - aa = a**2 - bb = b**2 - stamm = 0.5*h*(bb*spl%y(p+1)-aa*spl%y(p)) + h**3/12.*(aa*(1-0.5*aa)* & - spl%y2(p)-bb*(1-0.5*bb)*spl%y2(p+1)) - -END FUNCTION stamm - -!****************************************************************************** - -FUNCTION spline_int(spl,x0,x1) - - IMPLICIT NONE - -! Return value - REAL ( dbl ) :: spline_int - -! Arguments - TYPE (spline_data), INTENT ( INOUT ) :: spl - REAL ( dbl ), INTENT ( IN ) :: x0, x1 - -! Local - INTEGER :: j, pa, pb - REAL ( dbl ) :: h, vorz, xa, xb, i1, i2 - -!------------------------------------------------------------------------------ - - vorz = 1.0_dbl - xa = MIN ( x0, x1 ) - xb = MAX ( x0, x1 ) - IF ( x0 > x1 ) vorz = -1.0_dbl - IF ( xa < spl % x ( 1 ) .OR. xb > spl % x ( spl % n ) ) & - CALL stop_prg ( 'spline_int', 'illegal integration range' ) - - pa = interv ( spl, xa ) - pb = interv ( spl, xb ) - - IF ( pa == pb ) THEN - spline_int = vorz * ( stamm(spl,pa,xb) - stamm(spl,pa,xa) ) - RETURN - END IF - - i1 = 0 - i2 = 0 - DO j = pa + 1, pb - 1 - h = spl%x(j+1) - spl%x(j) - i1 = i1 + h*(spl%y(j)+spl%y(j+1)) - i2 = i2 + h**3*(spl%y2(j)+spl%y2(j+1)) - END DO - h = spl%x(pa+1) - spl%x(pa) - i1 = i1 + h*spl%y(pa+1) - i2 = i2 + h**3*spl%y2(pa+1) - h = spl%x(pb+1) - spl%x(pb) - i1 = i1 + h*spl%y(pb) - i2 = i2 + h**3*spl%y2(pb) - - spline_int = vorz*(i1/2.-i2/24.+stamm(spl,pb,xb)-stamm(spl,pa,xa)) - -END FUNCTION spline_int - -!****************************************************************************** - -! deallocate splines -! what=='a' or not present: deallocate all (spl%x, spl%y, spl%y2) -! what=='d': deallocate only data (spl%x, spl%y) -! what=='2': deallocate only table of 2. derivatives (spl%y2) - -SUBROUTINE kill_spline ( spl, what ) - - IMPLICIT NONE - -! Arguments - TYPE ( spline_data ), INTENT ( INOUT ) :: spl - CHARACTER, INTENT ( IN ), OPTIONAL :: what - -! Locals - CHARACTER :: w - INTEGER :: err - -!------------------------------------------------------------------------------ - - IF ( PRESENT ( what ) ) THEN - w = what - ELSE - w = 'a' - END IF - - SELECT CASE ( w ) - CASE ( 'd', 'D' ) - IF ( ASSOCIATED ( spl%x)) THEN - DEALLOCATE (spl%x,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%x' ) - NULLIFY (spl%x) - END IF - IF ( ASSOCIATED ( spl%y)) THEN - DEALLOCATE (spl%y,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%y' ) - NULLIFY (spl%y) - END IF - - CASE ( '2') - IF ( ASSOCIATED ( spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%y2' ) - NULLIFY (spl%y2) - END IF - - CASE ( 'a', 'A' ) - IF ( ASSOCIATED ( spl%x)) THEN - DEALLOCATE (spl%x,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%x' ) - NULLIFY (spl%x) - END IF - IF ( ASSOCIATED ( spl%y)) THEN - DEALLOCATE (spl%y,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%y' ) - NULLIFY (spl%y) - END IF - IF ( ASSOCIATED ( spl%y2)) THEN - DEALLOCATE (spl%y2,STAT=err) - IF (err /= 0 ) CALL stop_memory ( 'kill_spline', 'spl%y2' ) - NULLIFY (spl%y2) - END IF - END SELECT - -END SUBROUTINE kill_spline - -!****************************************************************************** - -END MODULE splines diff --git a/src/stop.h b/src/stop.h deleted file mode 100644 index ba31a1c..0000000 --- a/src/stop.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef _STOP_H -#define _STOP_H - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - void set_stop(int); - void stop_prg(char *, char *, char *, char *, char *, char *); - void stop_allocate(char *, char *, int); - void stop_deallocate(); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/stop_program.cpp b/src/stop_program.cpp deleted file mode 100644 index fbdec3e..0000000 --- a/src/stop_program.cpp +++ /dev/null @@ -1,66 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include -#include - -int iw; - -// Initialise the output channel and the processor number -void set_stop(int output_channel) { - iw = output_channel; -} - -void stop_prg(std::string routine, std::string comment1, std::string comment2, - std::string comment3, std::string comment4, std::string comment5) { - int i; - char outline[50]; - - if (routine) { - i = routine.length(); - outline = routine.copy(); - std::cout << " Last routine executed " << outline << "\n"; - } - - if (comment1) { - i = comment1.length(); - outline = comment1.copy(); - std::cout << " Comment " << outline << "\n"; - } - - if (comment2) { - i = comment1.length(); - outline = comment2.copy(); - std::cout << " Comment " << outline << "\n"; - } - - if (comment3) { - i = comment1.length(); - outline = comment3.copy(); - std::cout << " Comment " << outline << "\n"; - } - - if (comment4) { - i = comment1.length(); - outline = comment4.copy(); - std::cout << " Comment " << outline << "\n"; - } - - if (comment5) { - i = comment1.length(); - outline = comment5.copy(); - std::cout << " Comment " << outline << "\n"; - } - - mp_stop(999); -} - -void stop_allocate(std::string routine, std::string array, int memory) { - char message_1[50], message_2[50]; - - if (memory == 0) { - std::cout << "Memory allocation for <" << array << "failed"; - } -} \ No newline at end of file diff --git a/src/string_utilities.c b/src/string_utilities.c deleted file mode 100644 index 9e9bc35..0000000 --- a/src/string_utilities.c +++ /dev/null @@ -1,209 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE string_utilities - -! Purpose: Utilities for string manipulations. - -! ***************************************************************************** - -! Index: - -! SUBROUTINE compress(string) -! SUBROUTINE uppercase(string) - -! ***************************************************************************** - - IMPLICIT NONE - - PRIVATE - - PUBLIC :: compress,uppercase,xstring,str_search,str_comp,make_tuple - -! ***************************************************************************** - -CONTAINS - -! ***************************************************************************** - -! Purpose: Eliminate multiple space characters in a string. -! History: - Creation (23.06.1998, Matthias Krack) - -SUBROUTINE compress ( string ) - - IMPLICIT NONE - - CHARACTER ( LEN = * ), INTENT ( INOUT ) :: string - -! Locals - - INTEGER :: i, z - -!------------------------------------------------------------------------------ - - z = 1 - - DO i=1,LEN_TRIM(string) - IF (z == 1) THEN - IF (string(i:i) /= " ") THEN - string(z:z) = string(i:i) - z = z + 1 - END IF - ELSE - IF ((string(i:i) /= " ").OR.(string(z-1:z-1) /= " ")) THEN - string(z:z) = string(i:i) - z = z + 1 - END IF - END IF - END DO - - string(z:) = "" - -END SUBROUTINE compress - -!****************************************************************************** - -! Purpose: Convert all lower case characters in a string to upper case. -! History: - Creation (22.06.1998, Matthias Krack) - -SUBROUTINE uppercase ( string ) - - IMPLICIT NONE - - CHARACTER ( LEN = * ), INTENT ( INOUT ) :: string - -! Locals - INTEGER :: i, iascii - -!------------------------------------------------------------------------------ - - DO i = 1, LEN_TRIM ( string ) - iascii = ICHAR ( string (i:i) ) - IF ( ( iascii >= 97 ) .AND. ( iascii <= 122 ) ) THEN - string ( i:i ) = CHAR ( iascii - 32 ) - END IF - END DO - -END SUBROUTINE uppercase - -!****************************************************************************** - -SUBROUTINE xstring(string,ia,ib) - - IMPLICIT NONE - - CHARACTER ( LEN = * ), INTENT ( IN ) :: string - INTEGER, INTENT ( OUT ) :: ia, ib - -!------------------------------------------------------------------------------ - - ia = 1 - ib = len_trim(string) - IF (ib>0) THEN - DO WHILE (string(ia:ia)==' ') - ia = ia + 1 - END DO - END IF - -END SUBROUTINE xstring - -!****************************************************************************** - -SUBROUTINE make_tuple(int,nt,na,tuple) - IMPLICIT NONE - INTEGER, INTENT ( IN ) :: int ( :, : ), nt, na - INTEGER :: i, nm - CHARACTER ( LEN = * ), INTENT ( OUT ) :: tuple ( : ) - - nm = maxval(int(1:nt,1:na)) - SELECT CASE (nt) - CASE DEFAULT - STOP 'make_tuple: case not programmed' - CASE (1) - IF (nm<100) THEN - DO i = 1, na - WRITE (tuple(i),'(A,I2,A )' ) '[', int(1,i), ']' - END DO - ELSE - DO i = 1, na - WRITE (tuple(i),'(A,I4,A )' ) '[', int(1,i), ']' - END DO - END IF - CASE (2) - IF (nm<100) THEN - DO i = 1, na - WRITE (tuple(i),'(A,I2,A,I2,A )' ) '[', int(1,i), '-', int(2,i), & - ']' - END DO - ELSE - DO i = 1, na - WRITE (tuple(i),'(A,I4,A,I4,A )' ) '[', int(1,i), '-', int(2,i), & - ']' - END DO - END IF - CASE (3) - IF (nm<100) THEN - DO i = 1, na - WRITE (tuple(i),'(A,I2,A,I2,A,I2,A )' ) '[', int(1,i), '-', & - int(2,i), '-', int(3,i), ']' - END DO - ELSE - DO i = 1, na - WRITE (tuple(i),'(A,I4,A,I4,A,I4,A )' ) '[', int(1,i), '-', & - int(2,i), '-', int(3,i), ']' - END DO - END IF - CASE (4) - IF (nm<100) THEN - DO i = 1, na - WRITE (tuple(i),'(A,I2,A,I2,A,I2,A,I2,A )' ) '[', int(1,i), '-', & - int(2,i), '-', int(3,i), '-', int(4,i), ']' - END DO - ELSE - DO i = 1, na - WRITE (tuple(i),'(A,I4,A,I4,A,I4,A,I4,A )' ) '[', int(1,i), '-', & - int(2,i), '-', int(3,i), '-', int(4,i), ']' - END DO - END IF - END SELECT - -END SUBROUTINE make_tuple - -!****************************************************************************** - -FUNCTION str_comp(str1,str2) RESULT (equal) - IMPLICIT NONE - CHARACTER ( LEN = * ), INTENT ( IN ) :: str1, str2 - LOGICAL equal - INTEGER :: i1, i2, j1, j2 - - i1 = 0 - i2 = 0 - j1 = 0 - j2 = 0 - CALL xstring(str1,i1,i2) - CALL xstring(str2,j1,j2) - equal = (str1(i1:i2)==str2(j1:j2)) -END FUNCTION str_comp - -!****************************************************************************** - -FUNCTION str_search(str1,n,str2) RESULT (pos) - CHARACTER ( LEN = * ), INTENT ( IN ) :: str1 ( : ), str2 - INTEGER, INTENT ( IN ) :: n - INTEGER :: pos, i - - pos = 0 - DO i = 1, n - IF (str_comp(str1(i),str2)) THEN - pos = i - EXIT - END IF - END DO -END FUNCTION str_search - -!****************************************************************************** - -END MODULE string_utilities diff --git a/src/structure.h b/src/structure.h deleted file mode 100644 index 5b2049a..0000000 --- a/src/structure.h +++ /dev/null @@ -1,27 +0,0 @@ -#ifndef _STRUCTURE_H -#define _STRUCTURE_H - -#include "timings.h" -#include - -#ifdef __cplusplus -namespace CP2K_NS { -#endif - - typedef struct structure_factor_type { - double complex **ex, **ey, **ez; - int **centre; - int lb[3]; - } structure_factor_type; - - void structure_factor_deallocate(structure_factor_type); - void structure_factor_allocate(int*, int, structure_factor_type, bool); - - void structure_factor_evaluate(double*, int*, int*, double complex*, - double complex*, double complex*); - -#ifdef __cplusplus -} -#endif - -#endif \ No newline at end of file diff --git a/src/structure_factor_types.c b/src/structure_factor_types.c deleted file mode 100644 index be4bd17..0000000 --- a/src/structure_factor_types.c +++ /dev/null @@ -1,21 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE structure_factor_types - - USE kinds, ONLY : dbl - - IMPLICIT NONE - - PRIVATE - PUBLIC :: structure_factor_type - - TYPE structure_factor_type - COMPLEX ( dbl ), DIMENSION ( :, : ), POINTER :: ex, ey, ez - INTEGER, DIMENSION ( :, : ), POINTER :: centre - INTEGER :: lb ( 3 ) - END TYPE structure_factor_type - -END MODULE structure_factor_types diff --git a/src/structure_factors.c b/src/structure_factors.c deleted file mode 100644 index 00fb20c..0000000 --- a/src/structure_factors.c +++ /dev/null @@ -1,91 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include -#include - -void structure_factor_deallocate(structure_factor_type exp_igr) { - - free(exp_igr.ex); - free(exp_igr.ey); - free(exp_igr.ez); - if (exp_igr.centre != NULL) { - free(exp_igr.centre); - } - -} - -void structure_factor_allocate(int *bds, int nparts, structure_factor_type exp_igr, bool allocate_centre) { - - int isos; - - exp_igr.ex = (double complex *)malloc((bds[1][1] - bds[2][1] + 1) * nparts * sizeof(double complex)); - - - exp_igr.ey = (double complex *)malloc((bds[1][2] - bds[2][2] + 1) * nparts * sizeof(double complex)); - - exp_igr.ez = (double complex *)malloc((bds[1][3] - bds[2][3] + 1) * nparts * sizeof(double complex)); - - exp_igr.centre = NULL; - - - exp_igr.lb[0] = 0; - exp_igr.lb[1] = 0; - exp_igr.lb[2] = 0; - - if (allocate_centre) { - exp_igr.centre = (double *)malloc(3 * nparts * sizeof(double)); - } - -} - -void structure_factor_evaluate(double *delta, int *npts, int *lb, double complex *ex, - double complex *ey, double complex *ez) { - - double vec[3]; - double complex fp, fm; - int l0, m0, n0, j, l1, m1, n1; - - l0 = lb[0]; - l1 = lb[1]; - m0 = lb[2]; - m1 = lb[3]; - n0 = lb[4]; - n1 = lb[5]; - - // delta is in scaled coordinates - vec[0] = twopi * (delta[0] + 0.5); - vec[1] = twopi * (delta[1] + 0.5); - vec[2] = twopi * (delta[2] + 0.5); - - ex[l0] = 1.0; - ey[m0] = 1.0; - ez[n0] = 1.0; - ex[l1] = 1.0; - ey[m1] = 1.0; - ez[n1] = 1.0; - - fp = cos(vec[0]) - I * sin(vec[0]); - fm = conj(fp); - for (j = 0; j >= -l0; j--) { - ex[j + l0] = ex[j + l0 - 1] * fp; - ex[-j + l1] = ex[-j + l1 + 1] * fm; - } - - fp = cos(vec[1]) - I * sin(vec[1]); - fm = conj(fp); - for (j = 0; j >= -m0; j--) { - ey[j + m0] = ey[j + m0 - 1] * fp; - ey[-j + m1] = ey[-j + m1 + 1] * fm; - } - - fp = cos(vec[2]) - I * sin(vec[2]); - fm = conj(fp); - for (j = 0; j >= -n0; j--) { - ez[j + n0] = ez[j + n0 - 1] * fp; - ez[-j + n1] = ez[-j + n1 + 1] * fm; - } - -} diff --git a/src/structure_types.c b/src/structure_types.c deleted file mode 100644 index d2875cf..0000000 --- a/src/structure_types.c +++ /dev/null @@ -1,28 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE structure_types - - USE kinds, ONLY : dbl - USE molecule_types, ONLY : molecule_structure_type, particle_node_type - USE particle_types, ONLY : particle_type - USE simulation_cell, ONLY : cell_type - - IMPLICIT NONE - - PRIVATE - PUBLIC :: structure_type - PUBLIC :: cell_type, particle_type, particle_node_type - PUBLIC :: molecule_structure_type - - TYPE structure_type - CHARACTER ( LEN = 30 ) :: name - TYPE (cell_type ) :: box - TYPE (particle_type ), POINTER :: part ( : ) - TYPE (particle_node_type ), POINTER :: pnode ( : ) - TYPE (molecule_structure_type ), POINTER :: molecule ( : ) - END TYPE structure_type - -END MODULE structure_types diff --git a/src/tbmd.c b/src/tbmd.c deleted file mode 100644 index 9c15525..0000000 --- a/src/tbmd.c +++ /dev/null @@ -1,323 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE tbmd - - USE kinds, ONLY : dbl - USE tbmd_global, ONLY : tbmdpar - USE tbmd_input, ONLY : read_tbmd_section, read_tb_hamiltonian, & - read_tb_hopping_elements - USE tbmd_debug, ONLY : debug_control - USE mathconstants, ONLY : zero - USE timings, ONLY : timeset, timestop - USE header, ONLY : tbmd_header - USE ewalds, ONLY : ewald_print, ewald_correction - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE input_types, ONLY : setup_parameters_type - USE molecule_input, ONLY : read_molecule_section, read_setup_section - USE molecule_types, ONLY : molecule_type, intra_parameters_type - USE particle_types, ONLY : particle_prop_type, particle_type - USE pair_potential, ONLY : get_potrange, potentialparm_type, & - potential_f, spline_nonbond_control - USE force_fields, ONLY : read_force_field_section - USE atoms_input, ONLY : read_coord_vel, system_type - USE md, ONLY : read_md_section, simulation_parameters_type, & - initialize_velocities, thermodynamic_type, mdio_parameters_type - USE unit, ONLY : unit_convert_type, set_units - USE structure_types, ONLY : structure_type - USE convert_units, ONLY : convert - USE simulation_cell, ONLY : cell_type, get_hinv - USE stop_program, ONLY : stop_memory - USE integrator, ONLY : velocity_verlet, force, set_energy_parm, energy - USE initialize_particle_types, ONLY : initialize_particle_type - USE initialize_extended_types, ONLY : initialize_extended_type - USE initialize_molecule_types, ONLY : initialize_molecule_type - USE nose, ONLY : extended_parameters_type - USE util, ONLY : close_unit, get_share - USE linklist_control, ONLY : set_ll_parm - USE dump, ONLY : dump_variables - - IMPLICIT NONE - - PRIVATE - PUBLIC :: tbmd_main - - TYPE ( mdio_parameters_type ) :: mdio - -CONTAINS - -!-----------------------------------------------------------------------------! -! TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD ! -!-----------------------------------------------------------------------------! - -SUBROUTINE tbmd_main - - IMPLICIT NONE - -! Locals - REAL (dbl) :: cons - REAL (dbl), DIMENSION(:,:), ALLOCATABLE :: rcut - INTEGER :: handle, itimes, isos - INTEGER :: iat, jat - CHARACTER ( LEN = 20 ), POINTER :: atom_names ( : ) - CHARACTER ( LEN = 20 ) :: set_fn -! - TYPE (potentialparm_type), POINTER :: potparm ( :, : ) - TYPE (particle_prop_type), POINTER :: pstat ( : ) - TYPE (molecule_type), POINTER :: mol_setup ( : ) - TYPE (unit_convert_type) :: units - TYPE (simulation_parameters_type) :: simpar - TYPE (structure_type) :: struc - TYPE (extended_parameters_type) :: nhcp - TYPE (thermodynamic_type) :: thermo - TYPE (system_type) :: ainp - TYPE (ewald_parameters_type) :: ewald_param - TYPE (setup_parameters_type) :: setup - TYPE (intra_parameters_type) :: intra_param - -!------------------------------------------------------------------------------ -! - CALL timeset ( 'TBMD', 'I', ' ', handle ) -! - IF ( tbmdpar % ionode ) CALL tbmd_header ( tbmdpar % scr ) -! -!..read tbmd section -! - CALL read_tbmd_section ( setup, ewald_param, tbmdpar ) -! -! read from the setup and molecule section of *.set -! - set_fn = setup % set_file_name - - CALL read_setup_section(mol_setup,set_fn,tbmdpar) - - CALL read_molecule_section(mol_setup,set_fn,tbmdpar) -! -! read pair potential information -! - CALL read_force_field_section ( setup, mol_setup, set_fn, & - intra_param, potparm, atom_names, pstat, tbmdpar ) -! -!..read Hamiltonian section -! - CALL read_tb_hamiltonian ( setup, atom_names, tbmdpar ) - CALL read_tb_hopping_elements ( setup, atom_names, tbmdpar ) -! -!..read the input of the molecular dynamics section -! - CALL read_md_section(simpar,tbmdpar,mdio) - simpar % program = 'TBMD' -! -!..read atomic coordinates, velocities (optional) and the simulation box - ainp % rtype = simpar % read_type - CALL read_coord_vel ( ainp, setup % input_file_name, tbmdpar ) -! -!..initialize box, perd - struc % box % hmat = ainp % box - struc % box % perd = setup % perd - - CALL get_hinv ( struc % box ) -! -!..initialize working units - CALL set_units ( setup % unit_type, units ) - - CALL set_energy_parm ( units % pconv, units % econv, units % l_label, & - units % vol_label, units % e_label, units % pres_label, & - units % temp_label, units % angl_label ) -! -!..allocate memory for atoms and molecules - CALL allocmem ( ainp, mol_setup, struc ) -! -!..initialize particle_type - CALL initialize_particle_type ( atom_names, simpar, mol_setup, & - ainp, pstat, struc % part ) -! -!..convert the units - CALL convert ( units = units, simpar = simpar, & - part = struc % part, pstat = pstat, box = struc % box, & - potparm = potparm, intra_param = intra_param, & - ewald_param = ewald_param ) -! -!..initialize molecule_type - CALL initialize_molecule_type ( mol_setup, intra_param, struc % pnode, & - struc % part, struc % molecule, tbmdpar ) -! -!..initialize extended_parameters_type and get number of degrees of freedom - CALL initialize_extended_type ( struc % box, simpar, & - struc % molecule, mol_setup, nhcp, tbmdpar ) -! -! initialize velocities if needed - IF ( simpar % read_type == 'POS' ) THEN - CALL initialize_velocities ( simpar, struc % part, tbmdpar ) - END IF -! -!...initialize splines -! - potparm ( :, : ) % energy_cutoff = 0.0_dbl - potparm ( :, : ) % e_cutoff_coul = 0.0_dbl - CALL spline_nonbond_control ( potparm, pstat, 5000, ewald_param ) -! -!..set linklist control parameters - ALLOCATE ( rcut ( setup % natom_type, setup % natom_type ), STAT = isos ) - IF ( isos /=0 ) CALL stop_memory ( 'tbmd', 'rcut' , 0) - - rcut ( :, : ) = potparm ( :, : ) % rcutsq - - CALL set_ll_parm ( tbmdpar, simpar % verlet_skin, & - setup % natom_type, rcut, simpar % n_cell ) - - CALL set_ll_parm ( tbmdpar, printlevel = tbmdpar % print_level, & - ltype = 'NONBOND' ) - - DEALLOCATE ( rcut, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'tbmd', 'rcut' ) -! -!..deallocate arrays needed for atom input - IF ( ASSOCIATED ( ainp % c ) ) THEN - DEALLOCATE ( ainp % c, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'tbmd', 'ainp%c' ) - END IF - - IF ( ASSOCIATED ( ainp % v ) ) THEN - DEALLOCATE (ainp % v, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'tbmd', 'ainp%v' ) - END IF -! - IF ( setup % run_type == 'DEBUG' ) THEN - -!..debug the forces - CALL debug_control( tbmdpar, ewald_param, struc%part, struc%pnode, & - struc%molecule, struc%box, thermo, potparm, simpar % ensemble ) - - ELSE -! -!..MD - itimes = 0 - CALL force ( struc, potparm, thermo, simpar, ewald_param ) - IF ( tbmdpar % ionode .AND. ewald_param % ewald_type /= 'NONE' ) & - CALL ewald_print( tbmdpar % scr, thermo, struc % box, & - units % e_label ) - CALL energy ( itimes, cons, simpar, struc, thermo, nhcp ) - - DO itimes = 1, simpar%nsteps - CALL velocity_verlet ( itimes, cons, simpar, potparm,thermo, & - struc, ewald_param, nhcp ) - IF ( MOD ( itimes, mdio % idump ) == 0 ) & - CALL dump_variables ( struc, mdio % dump_file_name, tbmdpar ) - END DO - - CALL dump_variables ( struc, mdio % dump_file_name, tbmdpar ) - IF (tbmdpar % ionode) CALL close_unit(10,99) - - END IF - -!..deallocate memory for atoms and molecules - CALL deallocmem ( struc ) - - CALL timestop ( zero, handle ) - -END SUBROUTINE tbmd_main - -!-----------------------------------------------------------------------------! -! TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD TBMD ! -!-----------------------------------------------------------------------------! - - SUBROUTINE allocmem ( ainp, mol_setup, struc ) - IMPLICIT NONE - -! Arguments - TYPE(molecule_type), DIMENSION(:), INTENT(IN) :: mol_setup - TYPE(structure_type), INTENT(INOUT) :: struc - TYPE(system_type), INTENT(IN) :: ainp - -! Locals - INTEGER :: natoms, nnodes, nmol, nmoltype, ios, iat, i, scr - -!------------------------------------------------------------------------------ - - struc % name = 'TBMD MOLECULAR SYSTEM' - IF ( tbmdpar % num_pe == 1 ) THEN - - natoms = SIZE ( ainp % c ( 1, : ) ) - ALLOCATE ( struc % part ( 1 : natoms ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd', 'part', natoms ) - ALLOCATE ( struc % pnode ( 1 :natoms ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd', 'pnode' , natoms ) - nmol = SUM ( mol_setup ( : ) % num_mol ) - - ALLOCATE ( struc % molecule ( 1 : nmol ), STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd', 'molecule' , nmol ) - - IF ( tbmdpar % ionode .AND. tbmdpar % print_level > 3 ) THEN - scr = tbmdpar % scr - WRITE ( scr, '( A )' ) - WRITE (scr,'(A,T71,I10)') ' TBMD| Number of allocated particles ', & - natoms - WRITE (scr,'(A,T71,I10)') & - ' TBMD| Number of allocated particle nodes ', natoms - WRITE ( scr, '( A, T71, I10 )' ) & - ' TBMD| Number of allocated molecules ', nmol - WRITE ( scr, '( A )' ) - END IF - ELSE -! -!..replicated data - - natoms = size(ainp%c(1,:)) - ALLOCATE (struc%part(1:natoms),STAT=ios) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd', 'part' , natoms ) - nmoltype = SIZE ( mol_setup ) - nmol = 0 - nnodes = 0 - DO i = 1, nmoltype - nmol = nmol + get_share ( mol_setup ( i ) % num_mol, & - tbmdpar % num_pe, tbmdpar % mepos ) - nnodes = nnodes + nmol*mol_setup(i) %molpar%natom - END DO - - ALLOCATE (struc%molecule(1:nmol),STAT=ios) - IF (ios/=0) CALL stop_memory('tbmd','molecule',nmol) - ALLOCATE (struc%pnode(1:nnodes),STAT=ios) - IF (ios/=0) CALL stop_memory('tbmd','pnode',nnodes) - - IF ( tbmdpar%ionode .AND. tbmdpar%print_level>3) THEN - WRITE ( scr, '( A )' ) - WRITE (scr,'(A,T71,I10)') ' TBMD| Number of allocated particles ' & - , natoms - WRITE (scr,'(A,T71,I10)') & - ' TBMD| Number of allocated particle nodes ', nnodes - WRITE (scr,'(A,I5,T71,I10)') & - ' TBMD| Number of allocated molecules on processor ', & - tbmdpar % mepos, nmol - WRITE ( scr, '( A )' ) - END IF - - END IF - - END SUBROUTINE allocmem - -!****************************************************************************** - - SUBROUTINE deallocmem ( struc ) - IMPLICIT NONE - -! Arguments - TYPE ( structure_type ), INTENT ( INOUT ) :: struc - -! Locals - INTEGER :: ios - - DEALLOCATE ( struc % part, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd','part' ) - DEALLOCATE ( struc % pnode, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd','pnode' ) - DEALLOCATE ( struc % molecule, STAT = ios ) - IF ( ios /= 0 ) CALL stop_memory ( 'tbmd','molecule' ) - - END SUBROUTINE deallocmem - -!****************************************************************************** - -END MODULE tbmd diff --git a/src/tbmd_debug.c b/src/tbmd_debug.c deleted file mode 100644 index 269d27a..0000000 --- a/src/tbmd_debug.c +++ /dev/null @@ -1,282 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE tbmd_debug - - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type - USE particle_types, ONLY : particle_type - USE pair_potential, ONLY : potentialparm_type, ener_coul - USE tbmd_force, ONLY : force_control, debug_variables_type - USE fist_force_numer, ONLY : force_nonbond_numer, force_recip_numer, & - ptens_numer, pvg_numer, potential_g_numer, de_g_numer, & - energy_recip_numer - USE linklists, ONLY : dist_constraints, g3x3_constraints - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_setup - USE simulation_cell, ONLY : cell_type - USE stop_program, ONLY : stop_memory - - IMPLICIT NONE - - PRIVATE - PUBLIC :: debug_control - -CONTAINS - -!****************************************************************************** - -! Routine to execute numerical tests for debugging - -SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, & - thermo, potparm, ensemble ) - - IMPLICIT NONE - -! Arguments - TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - TYPE ( particle_type ), INTENT ( INOUT ), DIMENSION ( : ) :: part - TYPE ( particle_node_type ), INTENT ( INOUT ), DIMENSION ( : ) :: pnode - TYPE ( potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm - TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule - TYPE ( cell_type ), INTENT ( INOUT ) :: box - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble - -! Locals - TYPE ( debug_variables_type ) :: dbg - TYPE ( pw_grid_type ) :: pw_grid - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff - INTEGER :: iflag, i, natoms, isos, iatom, iw, ir - INTEGER, DIMENSION ( 2 ) :: dum - REAL ( dbl ) :: delta, energy_numer - REAL ( dbl ) :: e_numer, pv_test ( 3, 3 ) - REAL ( dbl ) :: err1, numer, denom1, vec ( 3 ), e_bc, e_real, energy_tot - REAL ( dbl ) :: denom2, err2 - REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_bc, f_real - -!------------------------------------------------------------------------------ - - iw = globenv % scr - ir = 5 - WRITE ( iw, '( 16x,A )' ) & - '***************************************************' - WRITE ( iw, '( 16x,A )' ) ' BEGIN DEBUG' - WRITE ( iw, '( 16x,A )' ) & - '***************************************************' - -! allocating all arrays involved with debug - natoms = SIZE ( pnode ) - IF ( .NOT. ALLOCATED ( diff ) ) ALLOCATE ( diff ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "diff", 3 * natoms ) - IF ( .NOT. ALLOCATED ( rel ) ) ALLOCATE ( rel ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "rel", 3 * natoms ) - IF ( .NOT. ALLOCATED ( f_numer ) ) & - ALLOCATE ( f_numer ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_numer", 3 * natoms ) - ALLOCATE ( dbg % f_nonbond ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( "debug_control", "f_nonbond", 3 * natoms ) - ALLOCATE ( dbg % f_g ( 3, natoms ), STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( "debug_control", "f_g", 3 * natoms ) - -! call to analytical nonbond force routine: - CALL force_control ( molecule, pnode, part, box, thermo, & - potparm, ewald_param, ensemble, globenv, dbg ) - -! Debug real-space nonbond - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR REAL SPACE NON-BOND (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN - -! get numerical force for the nonbond - WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL force_nonbond_numer ( pnode, box, potparm, delta, f_numer, & - energy_numer ) - WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND NUMER ENERGY = ', & - energy_numer - WRITE ( iw, '( A, T61, E20.14 )' ) ' NON BOND ANAL ENERGY = ', & - dbg % pot_nonbond - -! computing the absolute value of the differences in the forces - diff = ABS ( dbg % f_nonbond - f_numer ) - rel = diff / dbg % f_nonbond - -! find the maximum difference and the relative and absolute errors. - WRITE ( iw, '( A, T61, E20.14 )' ) & - ' MAXIMUM ABSOLUTE ERROR = ', MAXVAL ( diff ) - WRITE ( iw, '( A, T61, E20.14 )' ) & - ' MAXIMUM RELATIVE ERROR = ', MAXVAL ( rel ) - -! write out the particle number and forces of -! the max absolute and relative error - dum = MAXLOC ( diff ) - WRITE ( iw, '( A, T71, I10 )' ) & - ' NON BOND PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) - WRITE ( iw, '( A, T21, 3G20.14 )' ) & - ' F ANAL NONBOND =', dbg % f_nonbond ( :, dum ( 2 ) ) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F NUMR NONBOND =', f_numer ( :, dum ( 2 ) ) - - dum = MAXLOC ( rel ) - WRITE ( iw, '( A,T71,I10 )' ) & - ' NON BOND PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F ANAL NONBOND =', dbg % f_nonbond ( :, dum ( 2 ) ) - WRITE ( iw, '( A,T21,3G20.14 )' ) & - ' F NUMR NONBOND =', f_numer ( :, dum ( 2 ) ) - END IF - -! Debug g-space -! IF ( ewald_param % ewald_type /= 'NONE' ) THEN -! WRITE ( iw, '( A )' ) ' DO YOU WANT TO DEBUG YOUR G-SPACE (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! CALL pw_grid_setup ( box, pw_grid, ewald_param % gmax ) -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A, T71, I10 )' ) 'TOTAL NUMBER OF G-VECTORS= ', & -! pw_grid % ngpts_cut -! WRITE ( iw, '( A, T71, F10.4 )' ) 'ALPHA= ', & -! ewald_param % alpha -! CALL energy_recip_numer ( pnode, box, potparm, pw_grid, & -! energy_numer, pw_grid % ngpts_cut ) -! WRITE ( iw, '( A, T61, G20.14 )' ) 'G-SPACE ANAL ENERGY = ', & -! dbg % pot_g -! WRITE ( iw, '( A, T61, G20.14 )' ) & -! 'G-SPACE NUMERICAL ENERGY = ', energy_numer -! END IF -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE FORCES (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A, T71, F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta -! END IF -! -! CALL force_recip_numer ( pnode, box, potparm, gvec, delta, f_numer ) -! -! computing the absolute value of the differences in the forces -! diff = ABS ( dbg % f_g - f_numer ) -! rel = diff / dbg % f_g -! -! find the maximum difference and the relative and absolute errors. -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM ABSOLUTE ERROR = ', maxval(diff) -! WRITE ( iw, '( A,T61,G20.14 )' ) & -! 'MAXIMUM RELATIVE ERROR = ', maxval(rel) -! -! write out the particle number and forces of -! the max absolute and relative error -! dum = MAXLOC ( diff ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! ' PARTICLE WITH MAX ABSOLUTE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! -! dum = MAXLOC ( rel ) -! WRITE ( iw, '( A,T71,I10 )' ) & -! 'PARTICLE WITH MAX RELATIVE ERROR IS ', dum(2) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_ANAL G-SPACE =', & -! dbg % f_g(:,dum(2)) -! WRITE ( iw, '( A,T21,3G20.14 )' ) ' F_NUMR G-SPACE =', & -! f_numer(:,dum(2)) -! END IF -! -! WRITE ( iw, '( A )' ) & -! ' DO YOU WANT TO DEBUG YOUR G-SPACE VIRIAL (1=yes)?' -! READ ( ir, * ) iflag -! IF ( iflag == 1 ) THEN -! -! get numerical virial -! WRITE ( iw, '( A )' ) ' ENTER A DELTA LESS THAN 1' -! READ ( ir, * ) delta -! IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN -! delta = 1.0E-5_dbl -! WRITE ( iw, '( A,T71,F10.6 )' ) & -! ' DELTA (changed to default) = ', delta -! ELSE -! WRITE ( iw, '( A,T71,F10.6 )' ) ' DELTA = ', delta -! END IF -! CALL pvg_numer ( pnode, box, potparm, gvec, pv_test, delta ) -! -! writing out the virials -! WRITE ( iw, '( A )' ) ' PV G-SPACE NUMERICAL' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) -! END DO -! WRITE ( iw, '( A )' ) ' PV G-SPACE' -! DO i = 1, 3 -! WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_g(i,:) -! END DO -! END IF -! END IF -! END IF -! -! Debug real-space virial - WRITE ( iw, '( A )' ) & - ' DO YOU WANT TO DEBUG YOUR NON BOND (REAL SPACE) VIRIAL (1=yes)?' - READ ( ir, * ) iflag - IF ( iflag == 1 ) THEN -! -! get numerical virial - WRITE ( iw, '( A )' ) 'ENTER A DELTA LESS THAN 1' - READ ( ir, * ) delta - IF ( delta >= 1.0_dbl .OR. delta <= 0.0_dbl ) THEN - delta = 1.0E-5_dbl - WRITE ( iw, '( A, T71, F10.6 )' ) & - ' DELTA (changed to default) = ', delta - ELSE - WRITE ( iw, '( A, T71, F10.6 )' ) ' DELTA = ', delta - END IF - CALL ptens_numer ( pnode, box, potparm, pv_test, delta ) -! -! writing out the virials - WRITE ( iw, '( A )' ) ' PV NUMERICAL' - DO i = 1, 3 - WRITE ( iw, '( T21,3G20.14 )' ) pv_test(i,:) - END DO - WRITE ( iw, '( A )' ) ' PV NONBOND' - DO i = 1, 3 - WRITE ( iw, '( T21,3G20.14 )' ) dbg % pv_nonbond(i,:) - END DO - END IF - - WRITE ( iw, '( )' ) - WRITE ( iw, '( 16x, A )' ) & - '***************************************************' - WRITE ( iw, '( 16x, A )' ) & - '* END DEBUG *' - WRITE ( iw, '( 16x, A )' ) & - '***************************************************' -END SUBROUTINE debug_control - -!****************************************************************************** - -END MODULE tbmd_debug diff --git a/src/tbmd_force.c b/src/tbmd_force.c deleted file mode 100644 index f404a90..0000000 --- a/src/tbmd_force.c +++ /dev/null @@ -1,255 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C ) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! -MODULE tbmd_force - - USE dg_types, ONLY : dg_type - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE ewalds, ONLY : ewald_gaussian, ewald_initialize - USE fist_nonbond_force, ONLY : force_nonbond - USE global_types, ONLY : global_environment_type - USE kinds, ONLY : dbl - USE linklist_control, ONLY : list_control - USE mathconstants, ONLY : pi, zero - USE md, ONLY : thermodynamic_type - USE molecule_types, ONLY : molecule_structure_type, particle_node_type, & - linklist_neighbor, linklist_exclusion, linklist_bonds, linklist_bends - USE mp, ONLY : mp_sum - USE pair_potential, ONLY : potentialparm_type - USE particle_types, ONLY : particle_type - USE pme, ONLY: pme_evaluate - USE pw_grid_types, ONLY : pw_grid_type - USE pw_grids, ONLY : pw_grid_change - USE simulation_cell, ONLY : cell_type, get_hinv - USE stop_program, ONLY : stop_prg, stop_memory - USE timings, ONLY : timeset, timestop - - PRIVATE - PUBLIC :: force_control, debug_variables_type - - TYPE debug_variables_type - REAL ( dbl ) :: pot_nonbond, pot_g - REAL ( dbl ), DIMENSION ( :, : ), POINTER :: f_nonbond, f_g - REAL ( dbl ), DIMENSION ( 3, 3 ) :: pv_nonbond, pv_g - END TYPE debug_variables_type - -CONTAINS - -!****************************************************************************** - -!! Calculates the total potential energy, total force, and the -!! total pressure tensor from the potentials - -SUBROUTINE force_control ( molecule, pnode, part, box, thermo, & - potparm, ewald_param, ensemble, fc_global, debug ) - - IMPLICIT NONE - -! Arguments - TYPE ( particle_type ), DIMENSION ( : ), INTENT ( INOUT ) :: part - TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode - TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule - TYPE ( cell_type ), INTENT ( INOUT ) :: box - TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo - TYPE ( potentialparm_type ), DIMENSION ( :,: ), INTENT ( IN ) :: potparm - TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param - CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble - TYPE ( global_environment_type ), INTENT ( IN ) :: fc_global - TYPE ( debug_variables_type ), INTENT ( OUT ), OPTIONAL :: debug - -! Locals - INTEGER :: id, i, natoms, nnodes, handle, isos - REAL ( dbl ) :: pot_nonbond, vg_coulomb - REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE, SAVE :: f_nonbond - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_nonbond - REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE :: fg_coulomb - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_g, ident - REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_bc - TYPE ( pw_grid_type ), SAVE :: grid_s, grid_b, grid_ewald - TYPE ( dg_type ), SAVE :: dg - LOGICAL :: first_time - -!------------------------------------------------------------------------------ - - CALL timeset ( 'FORCE','I',' ',handle ) - - nnodes = SIZE ( pnode ) - natoms = SIZE ( part ) - isos = 0 - first_time = .NOT. ALLOCATED ( f_nonbond ) - IF ( .NOT. ALLOCATED ( f_nonbond ) ) & - ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_control', 'f_nonbond', 3 * natoms ) - -! initialize ewalds - IF ( first_time ) THEN - SELECT CASE ( ewald_param % ewald_type ) - CASE ( 'EWALD_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - ewald_grid = grid_ewald ) - CASE ( 'PME_GAUSS' ) - CALL ewald_initialize ( dg, part, pnode, fc_global % group, & - ewald_param, box, thermo, fc_global % scr, & - pme_small_grid = grid_s, pme_big_grid = grid_b ) - END SELECT - END IF - -! reinitialize the gspace for the new box - SELECT CASE ( ensemble ( 1:3 ) ) - CASE ( 'NPT' ) - CALL get_hinv ( box ) - - SELECT CASE ( ewald_param % ewald_type ) - CASE ( 'EWALD_GAUSS' ) - CALL pw_grid_change ( box, grid_s ) - CASE ( 'PME_GAUSS' ) - CALL stop_prg ( 'force_control', & - 'constant pressure with PME not implemented' ) - END SELECT - END SELECT - -! -! first check with list_control to update neighbor lists -! - CALL list_control ( pnode, part, box ) -! -! initial force, energy and pressure tensor arrays -! - DO i = 1, natoms - part ( i ) % f ( 1 ) = 0.0_dbl - part ( i ) % f ( 2 ) = 0.0_dbl - part ( i ) % f ( 3 ) = 0.0_dbl - END DO - thermo % pot = 0.0_dbl - thermo % pv = 0.0_dbl -! -! get real-space non-bonded forces: -! - f_nonbond = zero - CALL force_nonbond ( ewald_param,pnode,box,potparm, & - pot_nonbond,f_nonbond,pv_nonbond ) -! -! get g-space non-bonded forces: -! - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - IF ( .NOT. ALLOCATED ( fg_coulomb ) ) & - ALLOCATE ( fg_coulomb ( 3,nnodes ), STAT=isos ) - IF ( isos /= 0 ) & - CALL stop_memory ( 'force_control', 'fg_coulomb', 3 * nnodes ) - -! compute g-space part of the ewald sum - SELECT CASE ( ewald_param % ewald_type ) - - CASE ( "EWALD_GAUSS" ) - CALL ewald_gaussian ( dg, ewald_param, fg_coulomb, vg_coulomb, & - pv_g, pnode, box ) - - CASE ( "PME_GAUSS" ) - CALL pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, & - grid_s, grid_b, ewald_param ) - - CASE DEFAULT - CALL stop_prg ( "force_control", "illegal value of ewald_type:", & - ewald_param % ewald_type ) - END SELECT - END IF -! -! add up all the potential energies -! - IF ( ewald_param % ewald_type == 'NONE' ) THEN - thermo % pot = pot_nonbond -#if defined ( __parallel ) - CALL mp_sum ( thermo % pot,fc_global % group ) -#endif - ELSE - thermo % pot = pot_nonbond + thermo % e_bonded - thermo % gspace = vg_coulomb -#if defined ( __parallel ) - CALL mp_sum ( thermo % pot,fc_global % group ) - CALL mp_sum ( thermo % e_bonded,fc_global % group ) -#endif -! e_self and e_neut are already summed over all processors -! vg_coulomb is not calculated in parallel - thermo % pot = thermo % pot + thermo % e_self + thermo % e_neut/box % deth - thermo % pot = thermo % pot + vg_coulomb - END IF - -! add up all the forces -! nonbonded forces might be claculated for atoms not on this node -! ewald forces are strictly local -> sum only over pnode - DO i = 1, natoms - part ( i ) % f ( 1 ) = part ( i ) % f ( 1 ) + f_nonbond ( 1, i ) - part ( i ) % f ( 2 ) = part ( i ) % f ( 2 ) + f_nonbond ( 2, i ) - part ( i ) % f ( 3 ) = part ( i ) % f ( 3 ) + f_nonbond ( 3, i ) - END DO - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - DO i = 1, nnodes - pnode ( i ) % p % f ( 1 ) = pnode ( i ) % p % f ( 1 ) & - + fg_coulomb ( 1, i ) - pnode ( i ) % p % f ( 2 ) = pnode ( i ) % p % f ( 2 ) & - + fg_coulomb ( 2, i ) - pnode ( i ) % p % f ( 3 ) = pnode ( i ) % p % f ( 3 ) & - + fg_coulomb ( 3, i ) - END DO - END IF - -! add up all the pressure tensors - IF ( ewald_param % ewald_type == 'NONE' ) THEN - thermo % pv = pv_nonbond -#if defined ( __parallel ) - CALL mp_sum ( thermo % pv, fc_global % group ) -#endif - ELSE - ident = 0.0_dbl - DO i = 1, 3 - ident ( i, i ) = 1.0_dbl - END DO - - thermo % pv = pv_nonbond + pv_bc -#if defined ( __parallel ) - CALL mp_sum ( thermo % pv,fc_global % group ) -#endif - - thermo % pv = thermo % pv + ident * thermo % e_neut / box % deth - thermo % pv = thermo % pv + pv_g - END IF - -! -! if we are doing debugging, check if variables are present and assign -! - IF ( PRESENT ( debug ) ) THEN - debug % pot_nonbond = pot_nonbond - debug % f_nonbond = f_nonbond - debug % pv_nonbond = pv_nonbond - IF ( ewald_param % ewald_type /= 'NONE' ) THEN - debug % pot_g = vg_coulomb - debug % f_g = fg_coulomb - debug % pv_g = pv_g - ELSE - debug % pot_g = 0.0_dbl - debug % f_g = 0.0_dbl - debug % pv_g = 0.0_dbl - END IF - END IF - -! deallocating all local variables - isos = 0 - IF ( ALLOCATED ( fg_coulomb ) ) DEALLOCATE ( fg_coulomb, STAT = isos ) - IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'fg_coulomb' ) - -#if defined ( __parallel ) - DO i = 1, natoms - CALL mp_sum ( part ( i ) % f, fc_global % group ) - END DO -#endif - - CALL timestop ( zero, handle ) - -END SUBROUTINE force_control - -!****************************************************************************** - -END MODULE tbmd_force diff --git a/src/tbmd_global.c b/src/tbmd_global.c deleted file mode 100644 index 3fee198..0000000 --- a/src/tbmd_global.c +++ /dev/null @@ -1,38 +0,0 @@ -!------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!------------------------------------------------------------------------------! -! -!! Definition of some global variables for the TBMD code - MODULE tbmd_global -! -!------------------------------------------------------------------------------! - USE kinds, ONLY : dbl - USE global_types, ONLY : global_environment_type - USE tbmd_types, ONLY : tbatom_param_type, tb_hopping_type -! - IMPLICIT NONE -! - PRIVATE - PUBLIC :: set_tbmd_global, tbmdpar, tbatom, tbhop -! - TYPE (global_environment_type) :: tbmdpar -! - TYPE (tbatom_param_type), DIMENSION (:), ALLOCATABLE :: tbatom - TYPE (tb_hopping_type), DIMENSION (:,:), ALLOCATABLE :: tbhop -! -!------------------------------------------------------------------------------! -! - CONTAINS -! -!------------------------------------------------------------------------------! - SUBROUTINE set_tbmd_global(glopar) - IMPLICIT NONE - TYPE (global_environment_type) :: glopar - - tbmdpar = glopar - END SUBROUTINE set_tbmd_global -!------------------------------------------------------------------------------! - END MODULE tbmd_global -!------------------------------------------------------------------------------! - diff --git a/src/tbmd_input.c b/src/tbmd_input.c deleted file mode 100644 index b823be4..0000000 --- a/src/tbmd_input.c +++ /dev/null @@ -1,466 +0,0 @@ -!------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!------------------------------------------------------------------------------! - MODULE tbmd_input -!------------------------------------------------------------------------------! - USE kinds, ONLY : dbl - USE tbmd_global, ONLY : tbatom, tbhop - USE stop_program, ONLY : stop_prg, stop_memory - USE util, ONLY : get_unit - USE string_utilities, ONLY : uppercase, xstring, & - str_search, str_comp, make_tuple - USE parser, ONLY : parser_init, parser_end, read_line, test_next, & - cfield, p_error, get_real, get_int, stop_parser - USE mp, ONLY : mp_bcast - USE ewald_parameters_types, ONLY : ewald_parameters_type - USE input_types, ONLY : setup_parameters_type - USE global_types, ONLY : global_environment_type - IMPLICIT NONE -! - PRIVATE - PUBLIC :: read_tbmd_section, read_tb_hamiltonian, & - read_tb_hopping_elements -! -!------------------------------------------------------------------------------! -! - CONTAINS -! -!!>----------------------------------------------------------------------------! -!! SECTION: &tbmd ... &end ! -!! ! -!! simulation [energy,md,debug] ! -!! units [atomic] ! -!! periodic [0,1][0,1][0,1] ! -!! set_file "filename" ! -!! input_file "filename" ! -!! ! -!!tmptmptmptmptmp (to be included)???? -!! symmetry [on,off] ! -!!<----------------------------------------------------------------------------! - -SUBROUTINE read_tbmd_section ( setup, ewald_param, tbmdpar ) - - IMPLICIT NONE - -! Arguments - TYPE(setup_parameters_type), INTENT(INOUT) :: setup - TYPE(ewald_parameters_type), INTENT(INOUT) :: ewald_param - TYPE(global_environment_type), INTENT(INOUT) :: tbmdpar - -! Locals - INTEGER :: ierror, ilen, ia, ie, i, j, n, iw, source, group - CHARACTER (len=20) :: string - CHARACTER (len=5) :: label, str2 - CHARACTER (len=3), PARAMETER :: yn(0:1) = (/ ' NO', 'YES'/) - -!------------------------------------------------------------------------------! -!..defaults - setup % run_type = 'ENERGY' - setup % unit_type = 'ATOMIC' - setup % perd = 1 - ewald_param % alpha = 0.4_dbl - ewald_param % gmax = 10 - ewald_param % ns_max = 10 - ewald_param % epsilon = 1.e-6_dbl - ewald_param % ewald_type = 'NONE' - CALL xstring(tbmdpar%project_name,ia,ie) - setup % set_file_name = tbmdpar%project_name(ia:ie) // '.set' - setup % input_file_name = tbmdpar%project_name(ia:ie) // '.dat' - - iw = tbmdpar % scr - -!..parse the input section - label = '&TBMD' - CALL parser_init(tbmdpar%input_file_name,label,ierror,tbmdpar) - IF (ierror/=0) THEN - IF (tbmdpar%ionode) & - WRITE (iw,'(a)') ' No input section &TBMD found ' - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 8 - CALL cfield(string,ilen) - CALL uppercase(string) - SELECT CASE (string) - CASE DEFAULT - CALL p_error() - CALL stop_parser('read_tbmd','unknown option') - CASE ('SIMULATI') - ilen = 20 - CALL cfield(setup%run_type,ilen) - CALL uppercase(setup%run_type) - CASE ('PRINTLEV') - tbmdpar%print_level = get_int() - CASE ('UNITS') - ilen = 20 - CALL cfield(setup%unit_type,ilen) - CALL uppercase(setup%unit_type) - CASE ('PERIODIC') - setup%perd(1) = get_int() - setup%perd(2) = get_int() - setup%perd(3) = get_int() - CASE ('SET_FILE') - ilen = 20 - CALL cfield(setup%set_file_name,ilen) - CASE ('INP_FILE') - ilen = 20 - CALL cfield(setup%input_file_name,ilen) - END SELECT - CALL read_line - END DO - END IF - CALL parser_end -!..end of parsing the input section -!..write some information to output - IF (tbmdpar%ionode) THEN - IF (tbmdpar%print_level>=0) THEN - WRITE (iw,'(A,T71,A)') ' TBMD| Run type ', adjustr(setup%run_type) - WRITE (iw,'(A,T71,A)') ' TBMD| Unit type ', adjustr(setup%unit_type) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in X direction ', & - yn(setup%perd(1)) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in Y direction ', & - yn(setup%perd(2)) - WRITE (iw,'(A,T78,A)') ' TBMD| Periodic in Z direction ', & - yn(setup%perd(3)) - WRITE (iw,'(A,T61,A)') ' TBMD| Set file name', & - adjustr(setup%set_file_name) - WRITE (iw,'(A,T61,A)') ' TBMD| Input file name', & - adjustr(setup%input_file_name) - WRITE (iw,'(A,T76,I5)') ' TBMD| Print level ', tbmdpar%print_level - WRITE (iw,*) - END IF - END IF - -END SUBROUTINE read_tbmd_section - -!------------------------------------------------------------------------------! - -SUBROUTINE read_tb_hamiltonian ( setup, atom_names, tbmdpar ) - - IMPLICIT NONE - -! Arguments - TYPE(setup_parameters_type), INTENT(INOUT) :: setup - TYPE(global_environment_type), INTENT(IN) :: tbmdpar - CHARACTER ( LEN = * ), INTENT(IN) :: atom_names ( : ) - -! Locals - INTEGER :: ierror, ilen, i, j, k, n, iw, source, group, iat, nt, ios, i1 - CHARACTER (len=20) :: string, at - CHARACTER (len=10) :: basis, atyp, ttyp - CHARACTER (len=5) :: label - CHARACTER (len=1), PARAMETER :: lq(0:3) = (/ 'S', 'P', 'D', 'F'/) - - iat = 0 - nt = setup%natom_type - ALLOCATE (tbatom(nt),STAT=ios) - IF (ios/=0) CALL stop_memory('read_tb_hamiltonian','tbatom',nt) -!..parse the input section &HAMILTONIAN - label = '&HAMILTONIAN' - CALL parser_init(setup%set_file_name,label,ierror,tbmdpar) - IF (ierror/=0) THEN - IF (tbmdpar%ionode) & - WRITE (tbmdpar%scr,'(a)') & - ' read_tb_hamiltonian| No input section &HAMILTONIAN found ' - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 6 - CALL cfield(string,ilen) - CALL uppercase ( string ) - SELECT CASE (string) - CASE ('TBATOM') - iat = iat + 1 - IF (iat>setup%natom_type) THEN - CALL stop_parser('read_tb_hamiltonian','Too many atoms') - END IF - ilen = 20 - CALL cfield(at,ilen) - i1 = str_search(atom_names,nt,at) - IF (i1==0) CALL stop_parser('read_tb_hamiltonian','atom not found') - tbatom(i1) %atom_name = at - tbatom(i1) %atomic_number = get_int() - tbatom(i1) %valence_charge = get_real() - ilen = 10 - CALL cfield(basis,ilen) - CALL set_basis(basis,tbatom(i1)%bsf) - DO i = 0, 3 - DO j = 1, tbatom(iat) %bsf(i) - tbatom(iat) %orbital_energy(i,j) = get_real() - END DO - END DO - END SELECT - CALL read_line - END DO - END IF - CALL parser_end -!..write some information to output - IF ( tbmdpar % ionode) THEN - iw = tbmdpar % scr - IF (tbmdpar%print_level>=0) THEN - WRITE (iw,'(A,T71,I10)') ' TBMD| Number of atom types ', & - setup%natom_type - WRITE (iw,'(A,T40,A,T55,A,T65,A,T75,A)') ' TBMD|', ' Atom type', & - ' Atomic# ', ' Charge ', ' Basis' - DO i = 1, setup%natom_type - WRITE (iw,'(A,T40,A,T57,I6,T67,F5.1,T71,A)') ' TBMD| ', & - adjustr(tbatom(i)%atom_name), tbatom(i) %atomic_number, & - tbatom(i) %valence_charge, adjustr(basis) - END DO - WRITE (iw,'(A,T40,A,T55,A,T66,A)') ' TBMD|', ' Atom type', & - ' Orbital ', ' Orbital energy' - DO i = 1, setup%natom_type - DO j = 0, 3 - DO k = 1, tbatom(i) %bsf(j) - WRITE (iw,'(A,T40,A,T62,A,T68,F10.6,A)') ' TBMD| ', & - adjustr(tbatom(i)%atom_name), lq(j), & - tbatom(i) %orbital_energy(j,k), ' eV' - END DO - END DO - END DO - WRITE (iw,*) - END IF - END IF - -END SUBROUTINE read_tb_hamiltonian - -!------------------------------------------------------------------------------! - -SUBROUTINE set_basis(basis,bsf) - IMPLICIT NONE - CHARACTER (len=*), INTENT (INOUT) :: basis - INTEGER, INTENT (OUT) :: bsf(0:3) - INTEGER :: ia, ie, i, lmax, lnew - - lmax = -1 - bsf = 0 - CALL xstring(basis,ia,ie) - CALL uppercase ( basis(ia:ie) ) - DO i = ia, ie - SELECT CASE (basis(i:i)) - CASE DEFAULT - CALL stop_parser('set_basis','angular momentum label not valid') - CASE ('S') - bsf(0) = bsf(0) + 1 - lnew = 0 - CASE ('P') - bsf(1) = bsf(1) + 1 - lnew = 1 - CASE ('D') - bsf(2) = bsf(2) + 1 - lnew = 2 - CASE ('F') - bsf(3) = bsf(3) + 1 - lnew = 3 - END SELECT - IF ( lnew < lmax ) THEN - CALL stop_parser('set_basis','shells have to be ordered') - ELSE - lmax = lnew - END IF - END DO -END SUBROUTINE set_basis - -!------------------------------------------------------------------------------! -SUBROUTINE read_tb_hopping_elements ( setup, atom_names, tbmdpar ) - - IMPLICIT NONE - -! Arguments - TYPE(setup_parameters_type), INTENT(INOUT) :: setup - TYPE(global_environment_type), INTENT(INOUT) :: tbmdpar - CHARACTER ( LEN = * ), INTENT(IN) :: atom_names ( : ) - - INTEGER :: ierror, ilen, i, j, k, l, n, iw, source, group, iat, ios - INTEGER :: l1, l2, k1, k2, kk, nk, lu, ku - CHARACTER (len=20) :: string - CHARACTER (len=10) :: itype, at1, at2 - CHARACTER (len=5) :: label - REAL (dbl) :: rc - - iat = setup%natom_type - ALLOCATE (tbhop(iat,iat),STAT=ios) - IF (ios/=0) CALL stop_memory('read_tb_hopping_elements', & - 'allocation of array tbhop failed',iat*iat) -!..calculate number of non-zero integrals - DO i = 1, iat - DO j = 1, iat - n = 0 - IF (i==j) THEN - DO k = 0, 3 - DO l = k, 3 - n = n + tbatom(i) %bsf(k)*tbatom(j) %bsf(l)*(k+1) - END DO - END DO - ELSE - DO k = 0, 3 - DO l = 0, 3 - n = n + tbatom(i) %bsf(k)*tbatom(j) %bsf(l)*(min(k,l)+1) - END DO - END DO - END IF - tbhop(i,j) %nint = n - ALLOCATE (tbhop(i,j)%lls(3,tbhop(i,j)%nint),STAT=ios) - IF (ios/=0) CALL stop_memory('read_tb_hopping_elements', & - 'allocation of array tbhop%lls failed',0) - tbhop(i,j) %rcutsq = 0._dbl - END DO - END DO - iw = tbmdpar%scr -!..parse the input section &HAMILTONIAN - label = '&HAMILTONIAN' - CALL parser_init(setup%set_file_name,label,ierror,tbmdpar) - IF (ierror/=0) THEN - IF (tbmdpar%ionode) WRITE (iw,'(a)') & - ' input_inter| No input section &HAMILTONIAN found ' - ELSE - CALL read_line - DO WHILE (test_next()/='X') - ilen = 5 - CALL cfield(string,ilen) - CALL uppercase ( string ) - SELECT CASE (string) - CASE ('TBHAM') - ilen = 10 - CALL cfield(itype,ilen) - CALL uppercase ( itype ) - IF (itype=='GOODWIN') THEN - CALL cfield(at1,ilen) - CALL cfield(at2,ilen) - i = str_search(atom_names,iat,at1) - j = str_search(atom_names,iat,at2) - IF (i==0 .OR. j==0) CALL stop_parser('read_tb_hopping_elements', & - 'atom type not known') - tbhop(i,j) %htype = itype - ALLOCATE (tbhop(i,j)%gsp(tbhop(i,j)%nint),STAT=ios) - IF (ios/=0) CALL stop_memory('read_tb_hopping_elements', & - 'allocation of array tbhop%gsp failed') - DO k = 1, tbhop(i,j) %nint - CALL read_line - CALL cfield(itype,ilen) - CALL set_int(itype,tbhop(i,j)%lls(1:3,k)) - tbhop(i,j) %gsp(k) %er0 = get_real() - tbhop(i,j) %gsp(k) %r0 = get_real() - tbhop(i,j) %gsp(k) %rt = get_real() - tbhop(i,j) %gsp(k) %na = get_real() - tbhop(i,j) %gsp(k) %nb = get_real() - tbhop(j,i) %gsp(k) = tbhop(i,j) %gsp(k) - END DO - ELSE IF (itype=='CUTOFF') THEN - ilen = 10 - CALL cfield(at1,ilen) - CALL cfield(at2,ilen) - rc = get_real() - i = str_search(atom_names,iat,at1) - j = str_search(atom_names,iat,at2) - IF (i==0 .OR. j==0) CALL stop_parser('read_tb_hopping_elements', & - 'atom type not known') - tbhop(i,j) %rcutsq = rc*rc - ELSE - CALL stop_parser('read_tb_hopping_elements','interaction type not known') - END IF - END SELECT - CALL read_line - END DO - END IF - CALL parser_end -!..check the ordering of the hamiltonian matrix eleements - DO i = 1, setup%natom_type - DO j = i, setup%natom_type - nk = 0 - DO l1 = 0, 3 - DO k1 = 1, tbatom(i) %bsf(l1) - lu = 0 - IF (i==j) lu = l1 - DO l2 = lu, 3 - ku = 1 - IF (i==j .AND. l1==l2) ku = k1 - DO k2 = ku, tbatom(j) %bsf(l2) - DO kk = 0, min(l1,l2) - nk = nk + 1 - IF (tbhop(i,j)%lls(1,nk)/=l1) & - CALL stop_prg('read_tb_hopping_elements', & - 'ordering of H matrix elements wrong') - IF (tbhop(i,j)%lls(2,nk)/=l2) & - CALL stop_prg('read_tb_hopping_elements', & - 'ordering of H matrix elements wrong') - IF (tbhop(i,j)%lls(3,nk)/=kk) & - CALL stop_prg('read_tb_hopping_elements', & - 'ordering of H matrix elements wrong') - END DO - END DO - END DO - END DO - END DO - END DO - END DO -!..write some information to output - IF (tbmdpar%ionode) THEN - IF (tbmdpar%print_level>=0) THEN - WRITE (iw,'(A)') ' TBMD| Hopping matrix element parameters' - DO i = 1, setup%natom_type - DO j = i, setup%natom_type - WRITE (iw,'(A,T40,A,T50,A,T71,A)') ' TBMD| ', & - adjustr(tbatom(i)%atom_name), adjustr(tbatom(j)%atom_name), & - adjustr(tbhop(i,j)%htype) - DO k = 1, tbhop(i,j) %nint - IF (tbhop(i,j)%htype=='GOODWIN') THEN - WRITE (iw, & - '(A,T20,3I1,T25,A,F10.5,T44,A,F10.5,T63,A,F11.5)') & - ' TBMD| ', tbhop(i,j) %lls(:,k), ' T0[eV]=', & - tbhop(i,j) %gsp(k) %er0, ' r0[A]=', & - tbhop(i,j) %gsp(k) %r0, ' rt[A]=', & - tbhop(i,j) %gsp(k) %rt - WRITE (iw,'(A,T47,A,F10.5,T66,A,F11.5)') ' TBMD| ', & - ' NA=', tbhop(i,j) %gsp(k) %na, ' NB=', & - tbhop(i,j) %gsp(k) %nb - ELSE - CALL stop_prg('read_tb_hopping_elements','unknown type') - END IF - END DO - END DO - END DO - DO i = 1, setup%natom_type - DO j = i, setup%natom_type - WRITE (iw,'(A,T40,A,T50,A,T71,F10.3)') & - ' TBMD| Cutoff distance [A] ', adjustr(tbatom(i)%atom_name), & - adjustr(tbatom(j)%atom_name), sqrt(tbhop(i,j)%rcutsq) - END DO - END DO - WRITE (iw,*) - END IF - END IF - -END SUBROUTINE read_tb_hopping_elements - -!------------------------------------------------------------------------------! - -SUBROUTINE set_int(itype,int) - IMPLICIT NONE - CHARACTER (len=*), INTENT (IN) :: itype - INTEGER, INTENT (OUT) :: int(1:3) - INTEGER :: ia, ie, i, j - - int = 0 - CALL xstring(itype,ia,ie) - IF (ie-ia+1/=3) call stop_parser('set_int','non valid integral label') - DO i = ia, ie - j = i - ia + 1 - SELECT CASE (itype(i:i)) - CASE DEFAULT - CASE ('S') - int(j) = 0 - CASE ('P') - int(j) = 1 - CASE ('D') - int(j) = 2 - CASE ('F') - int(j) = 3 - END SELECT - END DO -END SUBROUTINE set_int - -!------------------------------------------------------------------------------! -END MODULE tbmd_input -!------------------------------------------------------------------------------! diff --git a/src/tbmd_types.c b/src/tbmd_types.c deleted file mode 100644 index bf580a6..0000000 --- a/src/tbmd_types.c +++ /dev/null @@ -1,47 +0,0 @@ -!------------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!------------------------------------------------------------------------------! - MODULE tbmd_types -!------------------------------------------------------------------------------! - USE kinds, ONLY : dbl -! - IMPLICIT NONE -! - PRIVATE - PUBLIC :: tbatom_param_type, gsp_param_type, tb_hopping_type -! -!! Maximum number of orbitals of each l-quantum number - INTEGER, PARAMETER :: mx_orb = 3 -! - TYPE tbatom_param_type - CHARACTER (len=10) :: atom_name - INTEGER :: atomic_number - REAL (dbl) :: valence_charge - INTEGER :: natoms - INTEGER :: nbsf - INTEGER, DIMENSION (0:3) :: bsf - REAL (dbl), DIMENSION (0:3,1:mx_orb) :: orbital_energy - REAL (dbl), DIMENSION (:), POINTER :: h_diag - INTEGER, DIMENSION (:,:), POINTER :: spoint - END TYPE tbatom_param_type -! - TYPE gsp_param_type !Goodwin parameter set - REAL (dbl) :: er0 - REAL (dbl) :: r0, rt - REAL (dbl) :: na, nb - END TYPE gsp_param_type -! - TYPE tb_hopping_type - CHARACTER (len=10) :: htype - REAL (dbl) :: rcutsq - INTEGER :: nint - TYPE (gsp_param_type), POINTER :: gsp(:) - INTEGER, POINTER :: lls(:,:) - INTEGER, POINTER :: llpoint(:,:) - END TYPE tb_hopping_type -! -!------------------------------------------------------------------------------! - END MODULE tbmd_types -!------------------------------------------------------------------------------! - diff --git a/src/timesl.c b/src/timesl.c deleted file mode 100644 index 7209049..0000000 --- a/src/timesl.c +++ /dev/null @@ -1,53 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE timesl - - USE kinds, ONLY : dbl, sgl - USE machine, ONLY : m_cputime, m_walltime, m_datum - - PRIVATE - PUBLIC :: walltime, cputime, datum - -CONTAINS - -!****************************************************************************** - -FUNCTION cputime() RESULT ( ct ) - - IMPLICIT NONE - - REAL ( dbl ) :: ct - - ct = m_cputime() -END FUNCTION cputime - -!****************************************************************************** - -FUNCTION walltime() RESULT ( wt ) - - IMPLICIT NONE - - REAL ( dbl ) :: wt - - wt = m_walltime() - -END FUNCTION walltime - -!****************************************************************************** - -SUBROUTINE datum ( cal_date ) - - IMPLICIT NONE - - CHARACTER ( LEN = * ) :: cal_date - - CALL m_datum ( cal_date ) - -END SUBROUTINE datum - -!****************************************************************************** - -END MODULE timesl diff --git a/src/timings.c b/src/timings.c deleted file mode 100644 index b8202fb..0000000 --- a/src/timings.c +++ /dev/null @@ -1,208 +0,0 @@ -/*----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!----------------------------------------------------------------------------*/ - -MODULE timings - - USE kinds, ONLY : dbl - USE mathconstants, ONLY : zero - USE stop_program, ONLY : stop_prg - USE string_utilities, ONLY : xstring - USE timesl, ONLY : cputime, walltime - USE util, ONLY : sort - - PRIVATE - PUBLIC :: timeset, timestop, timeprint, stack_size, routine_stack - -!!subroutine calling stack - INTEGER, PARAMETER :: max_stack = 100 - INTEGER :: stack_size - CHARACTER ( LEN = 30 ) :: routine_stack ( max_stack ), routine_name - -!!subroutine timing and performance information - INTEGER, PARAMETER :: max_timer = 200 - - CHARACTER ( LEN = 30 ) :: clock_name ( max_timer ) - INTEGER :: routine_calls ( max_timer ) - INTEGER :: clock_status ( max_timer ) - REAL ( dbl ) :: clock_start ( max_timer ) - REAL ( dbl ) :: clock_accu ( max_timer ) - REAL ( dbl ) :: wallclock_start ( max_timer ) - REAL ( dbl ) :: wallclock_accu ( max_timer ) - INTEGER :: clock_type ( max_timer ) - REAL ( dbl ) :: perf_count ( max_timer ) - CHARACTER ( LEN = 10 ) :: perf_unit ( max_timer ) - INTEGER :: num_timer = 0 - -CONTAINS - -/*****************************************************************************/ - -void timeset(char *name, char ct, char *pu, int handle) { - int i; - -/*---------------------------------------------------------------------------*/ - // add name to subroutine stack - stack_size += 1; - routine_stack[stack_size] = name; - - // is this a new timer or has this routine been called before - handle = 0 - routine_name = name - DO i = 1, num_timer - IF ( routine_name == clock_name ( i ) ) handle = i - END DO - - IF ( handle == 0 ) THEN -!..new timer started - num_timer = num_timer + 1 - handle = num_timer - clock_name ( handle ) = routine_name - perf_unit ( handle ) = pu - IF ( ct == 'I' ) clock_type ( handle ) = 0 - IF ( ct == 'E' ) clock_type ( handle ) = 1 - clock_status ( handle ) = 0 - clock_accu ( handle ) = zero - wallclock_accu ( handle ) = zero - perf_count ( handle ) = zero - routine_calls ( handle ) = 0 - END IF - -!..start clock (if not yet started, i.e. recursive calls) - IF ( clock_status ( handle ) ==0 ) THEN - clock_start ( handle ) = cputime ( ) - wallclock_start ( handle ) = walltime ( ) - clock_status ( handle ) = 1 - END IF - - routine_calls ( handle ) = routine_calls ( handle ) + 1 - -} - -!****************************************************************************** - -SUBROUTINE timestop ( perf, handle ) - - IMPLICIT NONE - -! Arguments - REAL ( dbl ) :: perf - INTEGER :: handle - -! Locals - REAL ( dbl ) :: cpt, wt - INTEGER :: i - -!------------------------------------------------------------------------------ - - IF ( handle > num_timer ) THEN - CALL stop_prg ( 'timestop', 'handle > num_timer' ) - ELSE - cpt = cputime ( ) - clock_start ( handle ) - wt = walltime ( ) - wallclock_start ( handle ) - clock_accu ( handle ) = clock_accu ( handle ) + cpt - wallclock_accu ( handle ) = wallclock_accu ( handle ) + wt - clock_status ( handle ) = 0 - perf_count ( handle ) = perf_count ( handle ) + perf - - DO i = 1, num_timer - IF ( clock_status ( i ) == 1 .AND. clock_type ( i ) == 1 ) THEN - clock_start ( i ) = clock_start ( i ) + cpt - wallclock_start ( i ) = wallclock_start ( i ) + wt - END IF - END DO - -!..remove name from subroutine stack - stack_size = stack_size - 1 - END IF - -END SUBROUTINE timestop - -!****************************************************************************** - -SUBROUTINE timeprint ( iw, global_print_level ) - - IMPLICIT NONE - -! Arguments - INTEGER :: iw, global_print_level - -! Locals - INTEGER :: index ( max_timer ), i, j, ia, ie - REAL ( dbl ) :: maxtime, mintime, perf - CHARACTER ( LEN = 17 ) :: sname - CHARACTER ( LEN = 6 ) :: punit - CHARACTER ( LEN = 1 ) :: blank = ' ', ct ( 0 : 1 ) = (/ 'I', 'E' /) - -!------------------------------------------------------------------------------ - - IF ( num_timer > 0 .AND. global_print_level >= 0 ) THEN - - CALL sort ( clock_accu, num_timer, index ) - - maxtime = clock_accu ( index ( num_timer ) ) - - IF ( global_print_level > 10 ) THEN - mintime = zero - ELSE IF ( global_print_level > 5 ) THEN - mintime = maxtime * 0.002_dbl - ELSE - mintime = maxtime * 0.02_dbl - END IF - - WRITE ( iw, '( /, 1X, 79("-") )' ) - WRITE ( iw, '( " -", 77X, "-" )' ) - WRITE ( iw, '( " -", 32X, A, 32X, "-" )' ) ' T I M I N G ' - WRITE ( iw, '( " -", 77X, "-" )' ) - WRITE ( iw, '( 1X, 79("-"), / )' ) - WRITE ( iw, '( A, A, A )' ) ' SUBROUTINE', ' CALLS ', & - ' CPU TIME T PERFORMANCE ELAPSED TIME' - - DO i = num_timer, 1, -1 - - j = index ( i ) - IF ( clock_accu ( j ) > mintime ) THEN - - IF ( clock_accu ( i ) > zero ) THEN - perf = perf_count ( j ) / clock_accu ( i ) - ELSE - perf = zero - END IF - - sname = blank - ia = 0 - ie = 0 - CALL xstring ( clock_name ( j ), ia, ie ) - ie = min ( ia+16-1, ie ) - sname ( 1 : ie-ia+1 ) = clock_name ( j ) ( ia : ie ) - punit = blank - - CALL xstring ( perf_unit ( j ), ia, ie ) - - IF ( ia > ie ) THEN - punit = '--- ' - WRITE ( iw, & - '( 1X, A16, I7, F15.2, 1X, A1, 12X, 1X, A6, 5X, F15.2 )' ) & - sname, routine_calls ( j ), clock_accu ( i ), & - ct ( clock_type ( j ) ), punit, wallclock_accu ( j ) - ELSE - ie = MIN ( ia+6-1, ie ) - punit ( 6-ie+ia : 6 ) = perf_unit ( j ) ( ia : ie ) - WRITE ( iw, & - '( 1X, A16, I7, F15.2, 1X, A1, F12.2, 1X, A6, 5X, F15.2 )' & - ) & - sname, routine_calls ( j ), clock_accu ( i ), & - ct ( clock_type ( j ) ), perf, punit, wallclock_accu ( j ) - END IF - END IF - END DO - - WRITE ( iw, '( 1X, 79("-"), / )' ) - END IF - -END SUBROUTINE timeprint - -!****************************************************************************** - -END MODULE timings diff --git a/src/unit.c b/src/unit.c deleted file mode 100644 index e9885bf..0000000 --- a/src/unit.c +++ /dev/null @@ -1,86 +0,0 @@ -!-----------------------------------------------------------------------------! -! CP2K: A general program to perform molecular dynamics simulations ! -! Copyright (C) 2000 CP2K developers group ! -!-----------------------------------------------------------------------------! - -MODULE unit - - USE kinds, ONLY : dbl - USE mathconstants, ONLY : pi - USE physcon, ONLY : e_charge, angstrom, a_bohr, e_mass, joule, a_mass, & - boltzmann, massunit - USE stop_program, ONLY : stop_prg - - PRIVATE - PUBLIC :: set_units, unit_convert_type - - TYPE unit_convert_type - REAL ( dbl ) :: econv, mconv, lconv, tconv, pconv, eps0 - CHARACTER ( LEN = 10 ) :: e_label, l_label, vol_label, & - temp_label, pres_label,angl_label - END TYPE unit_convert_type - -CONTAINS - -!****************************************************************************** - -! routine which defines internal units and conversion factors -! Internal units for the code are as follows: -! mass is in amu; energy is in kelvin; length is in angstroms -! IT IS ASSUMED THAT -! input time is in femtoseconds; output pressure in bar -! mass is in amu ALWAYS - -SUBROUTINE set_units ( unit_char, units ) - - IMPLICIT NONE - -! Arguments - CHARACTER ( LEN = * ), INTENT ( IN ) :: unit_char - TYPE ( unit_convert_type ), INTENT ( OUT ) :: units - -!------------------------------------------------------------------------------ - - units % temp_label = '[K]' - units % pres_label = '[bar]' - units % angl_label = '[deg]' - - IF ( unit_char == 'KELVIN' ) THEN - -! mass is amu; energy is kelvin; length is angstroms - units % mconv = 1.0_dbl - units % econv = 1.0_dbl - units % lconv = 1.0_dbl - units % tconv = 1.0E-15_dbl * angstrom / a_bohr & - / ( SQRT ( a_mass / boltzmann ) ) - units % pconv = boltzmann * 1.0E+25_dbl - units % eps0 = boltzmann * a_bohr / ( angstrom * e_charge ** 2 ) - units % l_label = '[A]' - units % vol_label = '[A^3]' - units % e_label = '[K]' - -! gcunit is group code unit - - ELSE IF ( unit_char == 'GCUNIT' .OR. unit_char == 'ATOMIC' ) THEN - -! mass is amu; energy is hartree; length is bohr - units % mconv = massunit - units % econv = boltzmann / joule - units % lconv = 1.0E-10_dbl / a_bohr - units % tconv = 1.0E-15_dbl / ( a_bohr * SQRT ( e_mass / joule ) ) - units % pconv = joule / ( a_bohr ** 3 * 1.0E+05_dbl ) - units % eps0 = joule * a_bohr / e_charge ** 2 - units % l_label = '[bohr]' - units % vol_label = '[bohr^3]' - units % e_label = '[hartree]' - ELSE - - CALL stop_prg ( 'unit', 'unknown unit type' ) - - END IF - -END SUBROUTINE set_units - -!****************************************************************************** - -END MODULE unit diff --git a/src/util.c b/src/util.c deleted file mode 100644 index c23dd14..0000000 --- a/src/util.c +++ /dev/null @@ -1,610 +0,0 @@ -/*---------------------------------------------------------------------------*/ -/* CP2K: A general program to perform molecular dynamics simulations */ -/* Copyright (C) 2024 CP2K developers group */ -/*---------------------------------------------------------------------------*/ - -#include -#include - -#include "util.h" - -/*****************************************************************************/ - -void sort2(double *arr, int n, int index) { - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: n - REAL ( dbl ), INTENT ( INOUT ) :: arr(1:n) - INTEGER, INTENT ( OUT ) :: index(1:n) - -! Local - INTEGER, PARAMETER :: m = 7, nstack = 50 - INTEGER :: i, l, ib, ir, jstack, k, istack(1:nstack), itemp, j - REAL ( dbl ) :: a, temp - -!------------------------------------------------------------------------------ - - DO i = 1, n - index(i) = i - END DO - jstack = 0 - l = 1 - ir = n -1 IF (ir-larr(ir)) THEN - temp = arr(l+1) - arr(l+1) = arr(ir) - arr(ir) = temp - itemp = index(l+1) - index(l+1) = index(ir) - index(ir) = itemp - END IF - IF (arr(l)>arr(ir)) THEN - temp = arr(l) - arr(l) = arr(ir) - arr(ir) = temp - itemp = index(l) - index(l) = index(ir) - index(ir) = itemp - END IF - IF (arr(l+1)>arr(l)) THEN - temp = arr(l+1) - arr(l+1) = arr(l) - arr(l) = temp - itemp = index(l+1) - index(l+1) = index(l) - index(l) = itemp - END IF - i = l + 1 - j = ir - a = arr(l) - ib = index(l) -3 CONTINUE - i = i + 1 - IF (arr(i)a) GO TO 4 - IF (jnstack) STOP ' Nstack too small in sortr' - IF (ir-i+1>=j-l) THEN - istack(jstack) = ir - istack(jstack-1) = i - ir = j - 1 - ELSE - istack(jstack) = j - 1 - istack(jstack-1) = l - l = i - END IF - END IF - - GO TO 1 - -} - -!****************************************************************************** - -void sort2i( int *iarr, int n, int index) { - - IMPLICIT NONE - -! Arguments - INTEGER, INTENT ( IN ) :: n - INTEGER, INTENT ( INOUT ) :: iarr(1:n) - INTEGER, INTENT ( OUT ) :: index(1:n) - -! Locals - INTEGER, PARAMETER :: m = 7, nstack = 50 - INTEGER :: i, l, ib, ir, jstack, k, j - INTEGER :: a, temp, istack(1:nstack), itemp - -!------------------------------------------------------------------------------ - - DO i = 1, n - index(i) = i - END DO - jstack = 0 - l = 1 - ir = n -1 IF (ir-liarr(ir)) THEN - temp = iarr(l+1) - iarr(l+1) = iarr(ir) - iarr(ir) = temp - itemp = index(l+1) - index(l+1) = index(ir) - index(ir) = itemp - END IF - IF (iarr(l)>iarr(ir)) THEN - temp = iarr(l) - iarr(l) = iarr(ir) - iarr(ir) = temp - itemp = index(l) - index(l) = index(ir) - index(ir) = itemp - END IF - IF (iarr(l+1)>iarr(l)) THEN - temp = iarr(l+1) - iarr(l+1) = iarr(l) - iarr(l) = temp - itemp = index(l+1) - index(l+1) = index(l) - index(l) = itemp - END IF - i = l + 1 - j = ir - a = iarr(l) - ib = index(l) -3 CONTINUE - i = i + 1 - IF (iarr(i)a) GO TO 4 - IF (jnstack) STOP ' Nstack too small in sortr' - IF (ir-i+1>=j-l) THEN - istack(jstack) = ir - istack(jstack-1) = i - ir = j - 1 - ELSE - istack(jstack) = j - 1 - istack(jstack-1) = l - l = i - END IF - END IF - - GO TO 1 - -} - -!****************************************************************************** - -!!< from second edition of numerical recipes -!! call with negative idum to initialize -!!> then do not alter idum from successive calls - -double ran2(int idum, int icontrol) { - - double ret_val; - int im1, im2, imm1, ia1, ia2, iq1, iq2, ir1, ir2, ntab, ndiv; - double am, eps, rnmx; - - const double im1=2147483563; - const double im2=2147483399; - const double am=1./im1; - const double imm1=im1-1; - const double ia1=40014; - const double ia2=40692; - const double iq1=53668; - const double iq2=52774; - const double ir1=12211; - const double ir2=3791; - const double ntab=32; - const double ndiv=1+imm1/ntab; - const double eps=1.2E-7; - const double rnmx=1.-eps; - - int idum2 = 123456789; - int iy = 0; - int iounit = 10; - int j, k, iv[ntab]; - - for (j = 0; j < ntab; j++) { - iv[j] = 0.0; - } - -/*----------------------------------------------------------------------------- - -! -! if icontrol=0, generate a random number normally -! if icontrol=1, load old random number table, dont get a new # -! if icontrol=2, save current random number table and dont get a -! new random number -*/ - - if (!icontrol) { - if (idum<=0) { - idum = std::max(-idum,1); - idum2 = idum; - for (j = ntab + 8; j > 1; j--) { - k = idum/iq1; - idum = ia1*(idum-k*iq1) - k*ir1; - if (idum<0) idum += im1; - if (j <= ntab) iv[j] = idum; - } - iy = iv[0]; - } - k = idum/iq1; - idum = ia1*(idum-k*iq1); - if (idum < 0) idum += im1; - k = idum2/iq2; - idum2 = ia2*idum2-k*iq2; - if (idum2 < 0) idum2 += im2; - j = iy/ndiv; - iy = iv[j] - idum2; - iv[j] = idum; - if (iy < 1) iy += imm1; - ret_val = std::min(am*iy,rnmx); - } else if (icontrol == 1) { - fstream iounit("random.table"); - for (j = 0; j < ntab; j++) { - getline(iounit, iv[j]); - } - getline(iounit, iy); - getline(iounit, idum); - getline(iounit, idum2); - - iounit.close(); - - } else if (icontrol == 2) { - ifstream iounit("random.table"); - for (j = 0; j < ntab; j++) { - getline(iounit, iv[j]); - } - getline(iounit, iy); - getline(iounit, idum); - getline(iounit, idum2); - - iounit.close(); - } - - return ret_val; - -} - -!****************************************************************************** - -double gasdev(int idum) { - - double v1, v2, r, fac, gset, ret_val; - int iset = 0; - - -!------------------------------------------------------------------------------ - - if (iset = 0) { - while (r >= 1.0) { - v1 = 2.0*ran2[idum] - 1.00; - v2 = 2.0*ran2[idum] - 1.00; - r = v1*v1 + v2*v2; - } - fac = std::sqrt(-2.0*std::log(r)/r); - gset = v1*fac; - ret_val = v2*fac; - iset = 1; - } else { - ret_val = gset; - iset = 0; - } - - return ret_val; -} - - -!****************************************************************************** - -int get_unit() { - - FILE unit; - bool exists; - -!------------------------------------------------------------------------------ - - //..find a not associated unit - unit = 10; - - while (true) { - exists = false; - exists = unit.is_opened(); - if (!exists) return unit; - unit = unit + 1; - } -} - -!****************************************************************************** - -void close_unit(FILE u1, FILE u2) { - int iunit; - bool exists; - -!------------------------------------------------------------------------------ - -!..close all open units from u1 to u2 - for (iunit = u1; iunit< u2, iunit++) { - exists = false; - exists = iunit.is_opened(); - if (exists) iunit.close(); - } -} - - -!****************************************************************************** - -!..divide m entries into n parts, return size of part me - -int get_share(int m,int n,int me) { - - int nme; - - int nl, nu; - double part; - -!------------------------------------------------------------------------------ - - part = (double)m / (double)n; - nl = nint((float)me*part) + 1; - nu = nint(((float)me + 1.0) * part); - nl = std::max(1,nl); - nu = std::min(m,nu); - nme = nu - nl + 1; - nme = std::max(nme,0); - - return nme; -} - -!****************************************************************************** - -!..divide m entries into n parts, return size of part me - -int *get_limit(int m, int n, int me) { - int nlim[2]; - - int nl, nu; - double part; - -!------------------------------------------------------------------------------ - - part = (float)m/(float)n; - nl = nint((float)me*part) + 1; - nu = nint(float(me+1)*part) - nlim(1) = max(1,nl) - nlim(2) = min(m,nu) - -} - -!****************************************************************************** - -FUNCTION include_list(i,j) RESULT (doit) - - IMPLICIT NONE - -! Return value - LOGICAL :: doit - -! Arguments - INTEGER, INTENT ( IN ) :: i, j - -!------------------------------------------------------------------------------ - - IF ( i > j ) THEN - doit = mod(i+j,2) == 0 - ELSE IF (i -#include -#include - -#define CAPACITY 50000 // Size of the HashTable. - -unsigned long hash_function(char *str) -{ - unsigned long i = 0; - - for (int j = 0; str[j]; j++) - i += str[j]; - - return i % CAPACITY; -} - -// Defines the HashTable item. -typedef struct Ht_item -{ - char *key; - char *value; -} Ht_item; - -// Defines the LinkedList. -typedef struct LinkedList -{ - Ht_item *item; - LinkedList *next; -} LinkedList; - -// Defines the HashTable. -typedef struct HashTable -{ - // Contains an array of pointers to items. - Ht_item **items; - LinkedList **overflow_buckets; - int size; - int count; -} HashTable; - -LinkedList *allocate_list() -{ - // Allocates memory for a LinkedList pointer. - LinkedList *list = (LinkedList *)malloc(sizeof(LinkedList)); - return list; -} - -LinkedList *linkedlist_insert(LinkedList *list, Ht_item *item) -{ - // Inserts the item onto the LinkedList. - if (!list) - { - LinkedList *head = allocate_list(); - head->item = item; - head->next = NULL; - list = head; - return list; - } - else if (list->next == NULL) - { - LinkedList *node = allocate_list(); - node->item = item; - node->next = NULL; - list->next = node; - return list; - } - - LinkedList *temp = list; - - while (temp->next->next) - { - temp = temp->next; - } - - LinkedList *node = allocate_list(); - node->item = item; - node->next = NULL; - temp->next = node; - return list; -} - -Ht_item *linkedlist_remove(LinkedList *list) -{ - // Removes the head from the LinkedList. - // Returns the item of the popped element. - if (!list) - return NULL; - - if (!list->next) - return NULL; - - LinkedList *node = list->next; - LinkedList *temp = list; - temp->next = NULL; - list = node; - Ht_item *it = NULL; - memcpy(temp->item, it, sizeof(Ht_item)); - free(temp->item->key); - free(temp->item->value); - free(temp->item); - free(temp); - return it; -} - -void free_linkedlist(LinkedList *list) -{ - LinkedList *temp = list; - - while (list) - { - temp = list; - list = list->next; - free(temp->item->key); - free(temp->item->value); - free(temp->item); - free(temp); - } -} - -LinkedList **create_overflow_buckets(HashTable *table) -{ - // Create the overflow buckets; an array of LinkedLists. - LinkedList **buckets = (LinkedList **)calloc(table->size, sizeof(LinkedList *)); - - for (int i = 0; i < table->size; i++) - buckets[i] = NULL; - - return buckets; -} - -void free_overflow_buckets(HashTable *table) -{ - // Free all the overflow bucket lists. - LinkedList **buckets = table->overflow_buckets; - - for (int i = 0; i < table->size; i++) - free_linkedlist(buckets[i]); - - free(buckets); -} - -Ht_item *create_item(char *key, char *value) -{ - // Creates a pointer to a new HashTable item. - Ht_item *item = (Ht_item *)malloc(sizeof(Ht_item)); - item->key = (char *)malloc(strlen(key) + 1); - item->value = (char *)malloc(strlen(value) + 1); - strcpy(item->key, key); - strcpy(item->value, value); - return item; -} - -HashTable *create_table(int size) -{ - // Creates a new HashTable. - HashTable *table = (HashTable *)malloc(sizeof(HashTable)); - table->size = size; - table->count = 0; - table->items = (Ht_item **)calloc(table->size, sizeof(Ht_item *)); - - for (int i = 0; i < table->size; i++) - table->items[i] = NULL; - - table->overflow_buckets = create_overflow_buckets(table); - - return table; -} - -void free_item(Ht_item *item) -{ - // Frees an item. - free(item->key); - free(item->value); - free(item); -} - -void free_table(HashTable *table) -{ - // Frees the table. - for (int i = 0; i < table->size; i++) - { - Ht_item *item = table->items[i]; - - if (item != NULL) - free_item(item); - } - - // Free the overflow bucket lists and its items. - free_overflow_buckets(table); - free(table->items); - free(table); -} - -void handle_collision(HashTable *table, unsigned long index, Ht_item *item) -{ - LinkedList *head = table->overflow_buckets[index]; - - if (head == NULL) - { - // Creates the list. - head = allocate_list(); - head->item = item; - table->overflow_buckets[index] = head; - return; - } - else - { - // Insert to the list. - table->overflow_buckets[index] = linkedlist_insert(head, item); - return; - } -} - -void ht_insert(HashTable *table, char *key, char *value) -{ - // Creates the item. - Ht_item *item = create_item(key, value); - - // Computes the index. - int index = hash_function(key); - - Ht_item *current_item = table->items[index]; - - if (current_item == NULL) - { - // Key does not exist. - if (table->count == table->size) - { - // HashTable is full. - printf("Insert Error: Hash Table is full\n"); - free_item(item); - return; - } - - // Insert directly. - table->items[index] = item; - table->count++; - } - else - { - // Scenario 1: Update the value. - if (strcmp(current_item->key, key) == 0) - { - strcpy(table->items[index]->value, value); - return; - } - else - { - // Scenario 2: Handle the collision. - handle_collision(table, index, item); - return; - } - } -} - -char *ht_search(HashTable *table, char *key) -{ - // Searches for the key in the HashTable. - // Returns NULL if it doesn't exist. - int index = hash_function(key); - Ht_item *item = table->items[index]; - LinkedList *head = table->overflow_buckets[index]; - - // Provide only non-NULL values. - if (item != NULL) - { - if (strcmp(item->key, key) == 0) - return item->value; - - if (head == NULL) - return NULL; - - item = head->item; - head = head->next; - } - - return NULL; -} - -void ht_delete(HashTable *table, char *key) -{ - // Deletes an item from the table. - int index = hash_function(key); - Ht_item *item = table->items[index]; - LinkedList *head = table->overflow_buckets[index]; - - if (item == NULL) { - // Does not exist. - return; - } else { - if (head == NULL && strcmp(item->key, key) == 0) - { - // Collision chain does not exist. - // Remove the item. - // Set table index to NULL. - table->items[index] = NULL; - free_item(item); - table->count--; - return; - } else if (head != NULL) { - // Collision chain exists. - if (strcmp(item->key, key) == 0) - { - // Remove this item. - // Set the head of the list as the new item. - free_item(item); - LinkedList *node = head; - head = head->next; - node->next = NULL; - table->items[index] = create_item(node->item->key, node->item->value); - free_linkedlist(node); - table->overflow_buckets[index] = head; - return; - } - - LinkedList *curr = head; - LinkedList *prev = NULL; - - while (curr) { - if (strcmp(curr->item->key, key) == 0) { - if (prev == NULL) { - // First element of the chain. - // Remove the chain. - free_linkedlist(head); - table->overflow_buckets[index] = NULL; - return; - } else { - // This is somewhere in the chain. - prev->next = curr->next; - curr->next = NULL; - free_linkedlist(curr); - table->overflow_buckets[index] = head; - return; - } - } - - curr = curr->next; - prev = curr; - } - } - } -} - -void print_search(HashTable *table, char *key) -{ - char *val; - - if ((val = ht_search(table, key)) == NULL) - { - printf("Key:%s does not exist\n", key); - return; - } else { - printf("Key:%s, Value:%s\n", key, val); - } -} - -void print_table(HashTable *table) { - printf("\nHash Table\n-------------------\n"); - - for (int i = 0; i < table->size; i++) - { - if (table->items[i]) - { - printf("Index:%d, Key:%s, Value:%s\n", i, table->items[i]->key, table->items[i]->value); - } - } - - printf("-------------------\n\n"); -} - -int main() { - HashTable *ht = create_table(CAPACITY); - ht_insert(ht, (char *)"1", (char *)"First address"); - ht_insert(ht, (char *)"2", (char *)"Second address"); - ht_insert(ht, (char *)"Hel", (char *)"Third address"); - ht_insert(ht, (char *)"Cau", (char *)"Fourth address"); - print_search(ht, (char *)"1"); - print_search(ht, (char *)"2"); - print_search(ht, (char *)"3"); - print_search(ht, (char *)"Hel"); - print_search(ht, (char *)"Cau"); // Collision! - print_table(ht); - ht_delete(ht, (char *)"1"); - ht_delete(ht, (char *)"Cau"); - print_table(ht); - free_table(ht); - return 0; -} \ No newline at end of file diff --git a/tools/Makefile b/tools/Makefile deleted file mode 100644 index 4ad1f58..0000000 --- a/tools/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -.SUFFIXES: .o .c - -### Machine dependent ### - -CC = cc -LDR = cc - -CDEFS = -Dxxx -OPT = -O -BFLAGS = -CFLAGS = $(BFLAGS) $(OPT) $(CDEFS) -LFLAGS = $(BFLAGS) $(OPT) - -LIBS = -OBJECTS = forlex.o forpar.tab.o slist.o - -################################# - -PROG = forpar.x - -all: $(PROG) - -$(PROG): $(OBJECTS) - $(LDR) $(LFLAGS) -o $(PROG) $(OBJECTS) $(LIBS) - -%.o: %.c - $(CC) -c $(CFLAGS) $*.c - -clean: - rm -f *.o - -realclean: - rm -f $(PROG) *.o *~ diff --git a/tools/forlex.c b/tools/forlex.c deleted file mode 100644 index fbae2f2..0000000 --- a/tools/forlex.c +++ /dev/null @@ -1,3172 +0,0 @@ -#line 2 "forlex.c" -/* A lexical scanner generated by flex */ - -/* Scanner skeleton version: - * $Header$ - */ - -#define FLEX_SCANNER -#define YY_FLEX_MAJOR_VERSION 2 -#define YY_FLEX_MINOR_VERSION 5 - -#include - -/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ -#ifdef c_plusplus -#ifndef __cplusplus -#define __cplusplus -#endif -#endif - -#ifdef __cplusplus - -#include -#include - -/* Use prototypes in function declarations. */ -#define YY_USE_PROTOS - -/* The "const" storage-class-modifier is valid. */ -#define YY_USE_CONST - -#else /* ! __cplusplus */ - -#if __STDC__ - -#define YY_USE_PROTOS -#define YY_USE_CONST - -#endif /* __STDC__ */ -#endif /* ! __cplusplus */ - -#ifdef __TURBOC__ -#pragma warn - rch -#pragma warn - use -#include -#include -#define YY_USE_CONST -#define YY_USE_PROTOS -#endif - -#ifdef YY_USE_CONST -#define yyconst const -#else -#define yyconst -#endif - -#ifdef YY_USE_PROTOS -#define YY_PROTO(proto) proto -#else -#define YY_PROTO(proto) () -#endif - -/* Returned upon end-of-file. */ -#define YY_NULL 0 - -/* Promotes a possibly negative, possibly signed char to an unsigned - * integer for use as an array index. If the signed char is negative, - * we want to instead treat it as an 8-bit unsigned char, hence the - * double cast. - */ -#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) - -/* Enter a start condition. This macro really ought to take a parameter, - * but we do it the disgusting crufty way forced on us by the ()-less - * definition of BEGIN. - */ -#define BEGIN yy_start = 1 + 2 * - -/* Translate the current start state into a value that can be later handed - * to BEGIN to return to the state. The YYSTATE alias is for lex - * compatibility. - */ -#define YY_START ((yy_start - 1) / 2) -#define YYSTATE YY_START - -/* Action number for EOF rule of a given start state. */ -#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) - -/* Special action meaning "start processing a new file". */ -#define YY_NEW_FILE yyrestart(yyin) - -#define YY_END_OF_BUFFER_CHAR 0 - -/* Size of default input buffer. */ -#define YY_BUF_SIZE 16384 - -typedef struct yy_buffer_state *YY_BUFFER_STATE; - -extern int yyleng; -extern FILE *yyin, *yyout; - -#define EOB_ACT_CONTINUE_SCAN 0 -#define EOB_ACT_END_OF_FILE 1 -#define EOB_ACT_LAST_MATCH 2 - -/* The funky do-while in the following #define is used to turn the definition - * int a single C statement (which needs a semi-colon terminator). This - * avoids problems with code like: - * - * if ( condition_holds ) - * yyless( 5 ); - * else - * do_something_else(); - * - * Prior to using the do-while the compiler would get upset at the - * "else" because it interpreted the "if" statement as being all - * done when it reached the ';' after the yyless() call. - */ - -/* Return all but the first 'n' matched characters back to the input stream. */ - -#define yyless(n) \ - do \ - { \ - /* Undo effects of setting up yytext. */ \ - *yy_cp = yy_hold_char; \ - YY_RESTORE_YY_MORE_OFFSET \ - yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ - YY_DO_BEFORE_ACTION; /* set up yytext again */ \ - } \ - while ( 0 ) - -#define unput(c) yyunput( c, yytext_ptr ) - -/* The following is because we cannot portably get our hands on size_t - * (without autoconf's help, which isn't available because we want - * flex-generated scanners to compile on their own). - */ -typedef unsigned int yy_size_t; - - -struct yy_buffer_state - { - FILE *yy_input_file; - - char *yy_ch_buf; /* input buffer */ - char *yy_buf_pos; /* current position in input buffer */ - - /* Size of input buffer in bytes, not including room for EOB - * characters. - */ - yy_size_t yy_buf_size; - - /* Number of characters read into yy_ch_buf, not including EOB - * characters. - */ - int yy_n_chars; - - /* Whether we "own" the buffer - i.e., we know we created it, - * and can realloc() it to grow it, and should free() it to - * delete it. - */ - int yy_is_our_buffer; - - /* Whether this is an "interactive" input source; if so, and - * if we're using stdio for input, then we want to use getc() - * instead of fread(), to make sure we stop fetching input after - * each newline. - */ - int yy_is_interactive; - - /* Whether we're considered to be at the beginning of a line. - * If so, '^' rules will be active on the next match, otherwise - * not. - */ - int yy_at_bol; - - /* Whether to try to fill the input buffer when we reach the - * end of it. - */ - int yy_fill_buffer; - - int yy_buffer_status; -#define YY_BUFFER_NEW 0 -#define YY_BUFFER_NORMAL 1 - /* When an EOF's been seen but there's still some text to process - * then we mark the buffer as YY_EOF_PENDING, to indicate that we - * shouldn't try reading from the input source any more. We might - * still have a bunch of tokens to match, though, because of - * possible backing-up. - * - * When we actually see the EOF, we change the status to "new" - * (via yyrestart()), so that the user can continue scanning by - * just pointing yyin at a new input file. - */ -#define YY_BUFFER_EOF_PENDING 2 - }; - -static YY_BUFFER_STATE yy_current_buffer = 0; - -/* We provide macros for accessing buffer states in case in the - * future we want to put the buffer states in a more general - * "scanner state". - */ -#define YY_CURRENT_BUFFER yy_current_buffer - - -/* yy_hold_char holds the character lost when yytext is formed. */ -static char yy_hold_char; - -static int yy_n_chars; /* number of characters read into yy_ch_buf */ - - -int yyleng; - -/* Points to current character in buffer. */ -static char *yy_c_buf_p = (char *) 0; -static int yy_init = 1; /* whether we need to initialize */ -static int yy_start = 0; /* start state number */ - -/* Flag which is used to allow yywrap()'s to do buffer switches - * instead of setting up a fresh yyin. A bit of a hack ... - */ -static int yy_did_buffer_switch_on_eof; - -void yyrestart YY_PROTO(( FILE *input_file )); - -void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); -void yy_load_buffer_state YY_PROTO(( void )); -YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); -void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); -void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); -void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b )); -#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer ) - -YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size )); -YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *yy_str )); -YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len )); - -static void *yy_flex_alloc YY_PROTO(( yy_size_t )); -static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t )); -static void yy_flex_free YY_PROTO(( void * )); - -#define yy_new_buffer yy_create_buffer - -#define yy_set_interactive(is_interactive) \ - { \ - if ( ! yy_current_buffer ) \ - yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ - yy_current_buffer->yy_is_interactive = is_interactive; \ - } - -#define yy_set_bol(at_bol) \ - { \ - if ( ! yy_current_buffer ) \ - yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ - yy_current_buffer->yy_at_bol = at_bol; \ - } - -#define YY_AT_BOL() (yy_current_buffer->yy_at_bol) - - -#define YY_USES_REJECT -typedef unsigned char YY_CHAR; -FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; -typedef int yy_state_type; -extern char *yytext; -#define yytext_ptr yytext - -static yy_state_type yy_get_previous_state YY_PROTO(( void )); -static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); -static int yy_get_next_buffer YY_PROTO(( void )); -static void yy_fatal_error YY_PROTO(( yyconst char msg[] )); - -/* Done after the current pattern has been matched and before the - * corresponding action - sets up yytext. - */ -#define YY_DO_BEFORE_ACTION \ - yytext_ptr = yy_bp; \ - yyleng = (int) (yy_cp - yy_bp); \ - yy_hold_char = *yy_cp; \ - *yy_cp = '\0'; \ - yy_c_buf_p = yy_cp; - -#define YY_NUM_RULES 84 -#define YY_END_OF_BUFFER 85 -static yyconst short int yy_acclist[450] = - { 0, - 85, 83, 84, 2, 84, 75, 83, 84, 83, 84, - 83, 84, 83, 84, 80, 83, 84, 80, 83, 84, - 73, 83, 84, 72, 83, 84, 83, 84, 72, 83, - 84, 68, 83, 84, 80, 83, 84, 72, 83, 84, - 80, 83, 84, 72, 83, 84, 83, 84, 83, 84, - 83, 84, 83, 84, 83, 84, 83, 84, 83, 84, - 83, 84, 83, 84, 83, 84, 1, 2, 84, 83, - 84, 83, 84, 83, 84, 83, 84, 83, 84, 83, - 84, 83, 84, 83, 84, 83, 84, 83, 84, 75, - 83, 84, 56, 83, 84, 56, 83, 84, 56, 83, - - 84, 75, 83, 84, 33, 83, 84, 1, 2, 32, - 84, 33, 75, 83, 84, 33, 83, 84, 33, 83, - 84, 33, 80, 83, 84, 33, 80, 83, 84, 33, - 73, 83, 84, 33, 72, 83, 84, 33, 83, 84, - 33, 72, 83, 84, 33, 68, 83, 84, 33, 80, - 83, 84, 33, 72, 83, 84, 33, 80, 83, 84, - 33, 72, 83, 84, 33, 83, 84, 33, 83, 84, - 33, 83, 84, 33, 83, 84, 33, 83, 84, 33, - 83, 84, 33, 83, 84, 33, 83, 84, 33, 83, - 84, 33, 83, 84, 33, 83, 84, 83, 84, 2, - - 34, 84, 75, 83, 84, 83, 84, 83, 84, 80, - 83, 84, 80, 83, 84, 73, 83, 84, 72, 83, - 84, 83, 84, 72, 83, 84, 68, 83, 84, 80, - 83, 84, 72, 83, 84, 80, 83, 84, 72, 83, - 84, 1, 2, 34, 84, 80, 80, 80, 80, 69, - 69, 80, 78, 80, 74, 68, 79, 68, 68, 76, - 77, 56, 56, 56, 56, 32, 33, 33, 68, 33, - 68, 33, 33, 34, 80, 80, 80, 80, 69, 69, - 80, 78, 80, 74, 68, 79, 68, 68, 76, 77, - 78, 71, 79, 68, 68, 68, 68, 76, 77, 53, - - 57, 56, 56, 56, 33, 68, 78, 71, 79, 68, - 68, 68, 68, 76, 77, 81, 68, 54, 6, 8, - 57, 56, 56, 56, 33, 68, 81, 68, 81, 51, - 26, 10, 15, 56, 58, 56, 33, 68, 16, 81, - 70, 71, 55, 56, 58, 56, 33, 68, 70, 71, - 47, 41, 36, 52, 4, 4, 20, 41, 56, 56, - 50, 42, 12, 17, 9, 14, 21, 42, 3, 56, - 56,16443,16444,16445,16446,16447,16448,16449,16450,16466, - 46, 35, 49, 43, 7,16443,16444,16445,16446,16447, - 16448,16449,16450, 56,16443,16444,16445,16446,16447,16448, - - 16449,16450, 28, 45, 48, 40, 13, 27, 22, 19, - 40, 25,16443,16444,16445,16446,16447,16448,16449,16450, - 56,16451, 37, 5,16451,16451, 8252, 29, 8274, 44, - 16451, 8253, 8254, 8256, 8257, 8255, 8258, 38, 24, 8259, - 8251, 8251, 30, 18, 39, 31, 11, 23, 23 - } ; - -static yyconst short int yy_accept[712] = - { 0, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 2, 4, 6, 9, 11, 13, 15, 18, 21, - 24, 27, 29, 32, 35, 38, 41, 44, 47, 49, - 51, 53, 55, 57, 59, 61, 63, 65, 67, 70, - 72, 74, 76, 78, 80, 82, 84, 86, 88, 90, - 93, 96, 99, 102, 105, 108, 112, 116, 119, 122, - 126, 130, 134, 138, 141, 145, 149, 153, 157, 161, - 165, 168, 171, 174, 177, 180, 183, 186, 189, 192, - 195, 198, 200, 203, 206, 208, 210, 213, 216, 219, - 222, 224, 227, 230, 233, 236, 239, 242, 246, 246, - - 246, 247, 248, 248, 248, 249, 250, 250, 251, 251, - 251, 252, 253, 254, 255, 255, 255, 256, 257, 257, - 257, 257, 257, 258, 259, 260, 260, 260, 261, 262, - 262, 262, 262, 262, 262, 262, 262, 262, 262, 262, - 262, 262, 262, 262, 262, 262, 262, 262, 262, 262, - 262, 262, 262, 262, 262, 262, 262, 262, 262, 262, - 262, 262, 262, 262, 262, 262, 262, 263, 264, 265, - 266, 266, 267, 267, 268, 270, 272, 273, 274, 274, - 274, 274, 274, 274, 274, 274, 274, 274, 275, 275, - 276, 277, 277, 277, 278, 279, 279, 280, 280, 281, - - 282, 283, 284, 284, 284, 285, 286, 286, 286, 286, - 286, 287, 288, 289, 289, 289, 290, 291, 291, 292, - 292, 292, 293, 293, 293, 294, 295, 296, 297, 297, - 298, 299, 300, 300, 300, 300, 300, 300, 301, 301, - 301, 301, 301, 301, 301, 301, 301, 301, 301, 301, - 301, 301, 301, 301, 301, 301, 301, 301, 301, 301, - 301, 301, 301, 301, 301, 301, 301, 301, 301, 301, - 301, 301, 301, 301, 301, 302, 303, 304, 305, 307, - 307, 307, 307, 307, 307, 308, 308, 308, 309, 309, - 309, 310, 311, 312, 313, 313, 314, 315, 316, 316, - - 316, 317, 317, 317, 318, 318, 318, 318, 318, 318, - 318, 318, 318, 318, 319, 319, 319, 319, 319, 319, - 319, 319, 319, 319, 319, 319, 319, 319, 319, 320, - 320, 320, 320, 320, 320, 320, 320, 320, 320, 320, - 320, 320, 320, 320, 320, 321, 321, 321, 321, 322, - 323, 324, 325, 327, 327, 327, 327, 327, 327, 327, - 328, 328, 328, 329, 329, 330, 330, 330, 330, 330, - 330, 330, 330, 330, 330, 330, 330, 330, 330, 330, - 330, 330, 330, 331, 331, 331, 331, 331, 331, 331, - 331, 331, 331, 331, 331, 331, 331, 331, 331, 331, - - 331, 331, 331, 331, 331, 332, 333, 333, 334, 334, - 334, 334, 335, 335, 336, 337, 339, 339, 339, 339, - 339, 339, 339, 340, 341, 341, 341, 341, 341, 343, - 343, 343, 343, 343, 343, 343, 344, 344, 344, 344, - 344, 344, 344, 344, 344, 344, 344, 344, 344, 344, - 344, 344, 344, 344, 344, 344, 344, 344, 344, 344, - 344, 344, 344, 344, 344, 344, 344, 344, 344, 345, - 346, 347, 349, 349, 349, 349, 349, 349, 351, 351, - 351, 351, 351, 351, 351, 351, 352, 352, 352, 352, - 352, 352, 353, 354, 354, 354, 355, 355, 355, 355, - - 355, 355, 355, 355, 355, 355, 355, 355, 355, 356, - 357, 357, 357, 357, 359, 359, 359, 359, 360, 361, - 361, 361, 361, 361, 361, 361, 361, 361, 361, 361, - 361, 361, 361, 361, 362, 363, 363, 363, 363, 364, - 364, 364, 364, 364, 364, 365, 365, 366, 366, 367, - 367, 367, 369, 370, 370, 370, 370, 371, 380, 380, - 380, 380, 380, 380, 381, 381, 381, 381, 381, 382, - 383, 383, 384, 384, 385, 385, 385, 386, 386, 386, - 386, 386, 386, 386, 386, 386, 386, 386, 394, 395, - 403, 403, 403, 403, 404, 404, 404, 404, 405, 405, - - 405, 406, 407, 407, 408, 408, 409, 409, 409, 409, - 410, 410, 412, 413, 413, 421, 423, 423, 423, 423, - 423, 423, 423, 423, 423, 423, 423, 423, 423, 423, - 423, 423, 424, 424, 425, 425, 425, 425, 426, 427, - 427, 427, 427, 428, 428, 428, 428, 428, 428, 428, - 428, 428, 429, 430, 431, 431, 431, 431, 431, 431, - 431, 432, 432, 432, 432, 432, 432, 432, 433, 433, - 434, 434, 435, 435, 436, 436, 437, 437, 438, 438, - 438, 439, 439, 439, 440, 440, 440, 440, 441, 441, - 442, 442, 443, 444, 444, 444, 444, 445, 445, 445, - - 446, 446, 446, 447, 447, 447, 448, 448, 449, 450, - 450 - } ; - -static yyconst int yy_ec[256] = - { 0, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 3, 1, 4, 5, 1, 6, 1, 7, 8, - 9, 10, 11, 12, 11, 13, 14, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 16, 1, 17, - 18, 19, 1, 1, 21, 22, 23, 24, 25, 26, - 27, 28, 29, 30, 30, 31, 32, 33, 34, 35, - 36, 37, 38, 39, 40, 41, 30, 42, 43, 30, - 1, 1, 1, 1, 20, 1, 21, 22, 23, 24, - - 25, 26, 27, 28, 29, 30, 30, 31, 32, 33, - 34, 35, 36, 37, 38, 39, 40, 41, 30, 42, - 43, 30, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1 - } ; - -static yyconst int yy_meta[44] = - { 0, - 1, 2, 3, 4, 1, 5, 1, 1, 1, 1, - 1, 1, 1, 1, 6, 1, 1, 1, 1, 7, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 9, 8, 8, 8, 8, 9, 8, - 8, 8, 8 - } ; - -static yyconst short int yy_base[777] = - { 0, - 0, 42, 82, 1693, 123, 162, 42, 46, 204, 222, - 1694, 1696, 1696, 239, 1689, 1663, 1684, 43, 1687, 50, - 1696, 37, 124, 116, 52, 1671, 51, 1670, 1656, 1657, - 17, 1645, 1651, 21, 116, 1658, 114, 1661, 1696, 44, - 46, 101, 113, 1647, 1646, 222, 1654, 207, 1640, 249, - 255, 257, 261, 59, 1696, 1696, 207, 1673, 1669, 262, - 1672, 263, 1696, 253, 266, 275, 269, 1656, 279, 1655, - 253, 1638, 258, 1631, 213, 1636, 1629, 1643, 1627, 1623, - 1627, 1662, 1696, 299, 301, 312, 318, 275, 320, 1661, - 332, 374, 376, 377, 308, 379, 384, 1696, 0, 1633, - - 313, 1658, 321, 303, 315, 384, 1656, 1655, 1625, 1650, - 1649, 381, 1652, 1651, 382, 396, 1696, 389, 392, 395, - 402, 409, 1650, 404, 407, 1637, 140, 1648, 1647, 1618, - 1616, 1623, 1607, 1612, 387, 1605, 1604, 1605, 1612, 1611, - 1617, 1600, 1596, 1600, 1613, 1597, 1612, 401, 1592, 1606, - 1606, 1594, 391, 1601, 1603, 1589, 406, 401, 420, 1590, - 1599, 0, 1585, 409, 442, 1619, 443, 444, 448, 449, - 0, 1696, 0, 1696, 441, 444, 1606, 452, 1588, 1595, - 1585, 1578, 1579, 439, 1593, 1579, 1611, 1696, 0, 469, - 434, 473, 475, 483, 485, 487, 488, 491, 493, 494, - - 499, 503, 507, 509, 1610, 501, 505, 509, 514, 530, - 511, 521, 541, 566, 547, 535, 557, 1588, 1607, 470, - 525, 1696, 597, 598, 1606, 599, 1593, 0, 1592, 527, - 1603, 1602, 1570, 1578, 1599, 1576, 1577, 1696, 1559, 249, - 1569, 0, 1576, 1563, 1554, 1563, 1553, 1567, 1551, 1553, - 1562, 1551, 1552, 1547, 1563, 1552, 613, 1552, 527, 1553, - 1541, 1559, 1538, 1551, 1546, 1551, 1544, 1534, 1548, 0, - 1534, 1540, 1545, 1566, 614, 615, 619, 623, 621, 628, - 1545, 1542, 1529, 1540, 630, 637, 646, 1562, 638, 641, - 656, 648, 492, 681, 548, 659, 663, 668, 1532, 634, - - 1559, 712, 713, 0, 1538, 1527, 703, 1522, 1519, 1518, - 1523, 1526, 1520, 1696, 1521, 1513, 1530, 1521, 1518, 0, - 1523, 1513, 1521, 1524, 1513, 1522, 1511, 1516, 1696, 749, - 1507, 1496, 1509, 703, 1514, 1505, 1503, 1513, 1496, 1503, - 0, 0, 1494, 0, 1696, 1501, 1486, 1491, 672, 728, - 729, 736, 734, 741, 1488, 719, 1492, 745, 759, 761, - 756, 759, 0, 1485, 1521, 776, 542, 1502, 1484, 1481, - 1480, 1486, 1489, 0, 1478, 1483, 1482, 1489, 1488, 1473, - 1488, 1471, 1696, 1476, 1468, 1468, 1483, 1480, 1475, 1478, - 1469, 763, 1467, 1461, 1464, 1475, 1472, 1470, 1474, 1469, - - 1468, 1453, 1470, 1467, 1696, 1696, 1451, 1696, 1461, 774, - 1466, 777, 790, 1483, 794, 792, 801, 1445, 1444, 1454, - 1442, 805, 1696, 812, 796, 805, 1457, 810, 1696, 1441, - 1450, 1445, 1455, 1455, 1441, 1696, 0, 1436, 1452, 1433, - 1434, 1445, 0, 0, 1446, 1429, 0, 1428, 1424, 1432, - 1461, 1424, 1438, 1436, 1435, 1430, 1421, 1436, 1425, 1452, - 1415, 1428, 1420, 0, 1422, 1417, 783, 1410, 821, 1445, - 823, 821, 1414, 1424, 1411, 1405, 824, 1441, 1417, 1420, - 1406, 1416, 1401, 1406, 1403, 1696, 1406, 1403, 1408, 0, - 0, 1696, 1696, 1407, 1402, 1696, 1405, 0, 1391, 1393, - - 1406, 1386, 1388, 0, 1385, 0, 1400, 0, 1696, 1387, - 1396, 0, 0, 1696, 1379, 1387, 1384, 837, 845, 1394, - 1379, 1382, 1385, 851, 1391, 1379, 1372, 1376, 0, 0, - 1386, 0, 1371, 1696, 1696, 0, 1374, 1369, 1696, 0, - 1368, 1373, 1372, 1376, 1696, 1398, 1696, 1375, 1696, 1362, - 1361, 1696, 1696, 1372, 1371, 1358, 846, 853, 1355, 1359, - 0, 1321, 861, 0, 1282, 0, 1237, 1224, 1696, 1696, - 0, 1696, 0, 1696, 1107, 0, 1696, 1089, 0, 1088, - 1091, 1078, 0, 1074, 0, 0, 1074, 839, 863, 864, - 900, 1077, 1058, 1696, 1037, 1051, 1026, 1696, 1008, 994, - - 1696, 1696, 0, 1696, 998, 1696, 0, 997, 985, 1696, - 972, 1696, 1696, 902, 865, 868, 0, 919, 874, 829, - 872, 882, 898, 886, 863, 849, 0, 878, 0, 845, - 831, 1696, 829, 1696, 803, 786, 751, 884, 890, 891, - 939, 896, 1696, 898, 903, 912, 980, 981, 982, 727, - 708, 1696, 1696, 1696, 0, 700, 638, 0, 610, 603, - 905, 983, 984, 985, 989, 993, 994, 1696, 996, 1696, - 997, 1696, 1001, 1696, 1004, 1696, 1005, 1696, 0, 484, - 1696, 445, 424, 1696, 0, 371, 1006, 1696, 1008, 1696, - 1009, 1013, 1696, 369, 0, 291, 1696, 267, 0, 1696, - - 194, 134, 1696, 0, 127, 1696, 0, 0, 0, 1696, - 1022, 1031, 1040, 1044, 1051, 1060, 1069, 1078, 1087, 1091, - 1100, 1107, 1111, 1120, 1125, 1128, 1137, 1142, 1147, 1152, - 1157, 1162, 1167, 1172, 1177, 1182, 1187, 1192, 1197, 1202, - 1207, 1212, 1217, 1222, 1227, 1232, 1237, 1242, 1247, 1252, - 1257, 1262, 1271, 1276, 1281, 1286, 1291, 1296, 1301, 1306, - 1311, 1320, 1325, 1323, 1332, 1337, 1342, 1347, 1352, 1361, - 1366, 1371, 1376, 1381, 1379, 1383 - } ; - -static yyconst short int yy_def[777] = - { 0, - 710, 1, 710, 3, 1, 710, 1, 1, 711, 711, - 710, 710, 710, 710, 712, 710, 713, 710, 710, 710, - 710, 714, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 14, - 715, 715, 715, 14, 710, 710, 54, 712, 713, 710, - 710, 710, 710, 714, 710, 716, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 717, 710, 717, 718, 719, 717, 717, 717, 717, - 710, 717, 717, 717, 717, 717, 717, 710, 14, 710, - - 710, 710, 710, 710, 710, 710, 712, 710, 710, 713, - 710, 710, 710, 710, 710, 710, 710, 710, 714, 714, - 714, 710, 710, 710, 710, 720, 710, 710, 710, 710, - 710, 710, 710, 710, 721, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 721, 710, 710, 710, 710, 710, 710, 710, - 710, 50, 710, 710, 710, 722, 715, 715, 715, 715, - 54, 710, 57, 710, 710, 716, 720, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 717, 710, 84, 717, - 717, 717, 717, 717, 717, 718, 717, 719, 717, 717, - - 717, 717, 717, 717, 717, 717, 91, 91, 91, 717, - 717, 717, 717, 710, 717, 717, 717, 710, 710, 710, - 710, 710, 714, 714, 710, 710, 710, 723, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 724, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 725, - 710, 710, 710, 722, 726, 715, 715, 715, 716, 710, - 710, 710, 710, 710, 717, 717, 717, 717, 91, 91, - 717, 717, 717, 710, 717, 717, 717, 717, 710, 710, - - 710, 714, 714, 723, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 727, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 728, 729, 710, 730, 710, 710, 710, 710, 726, 715, - 715, 715, 716, 710, 710, 710, 710, 710, 717, 717, - 91, 91, 294, 710, 710, 714, 714, 710, 710, 710, - 710, 710, 710, 731, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 715, 710, 710, 715, 716, 710, 710, 710, 710, - 710, 710, 710, 717, 91, 91, 710, 714, 710, 710, - 710, 710, 710, 710, 710, 710, 732, 710, 710, 710, - 710, 710, 733, 734, 710, 710, 735, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 736, - 710, 710, 710, 737, 710, 710, 710, 710, 715, 710, - 715, 710, 710, 710, 710, 710, 91, 717, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 738, - 739, 710, 710, 710, 710, 710, 710, 740, 710, 710, - - 710, 710, 710, 741, 710, 742, 710, 743, 710, 710, - 710, 744, 745, 710, 710, 710, 710, 715, 715, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 746, 747, - 710, 748, 710, 710, 710, 749, 710, 710, 710, 750, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 715, 715, 710, 710, - 751, 710, 710, 752, 710, 753, 710, 710, 710, 710, - 754, 710, 755, 710, 710, 756, 710, 710, 757, 710, - 710, 710, 758, 710, 759, 760, 710, 710, 715, 710, - 761, 710, 710, 710, 710, 752, 710, 710, 710, 710, - - 710, 710, 762, 710, 710, 710, 763, 710, 710, 710, - 710, 710, 710, 710, 710, 715, 764, 764, 764, 764, - 764, 764, 764, 764, 710, 710, 765, 710, 766, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 767, 710, 710, 768, 710, 710, - 710, 710, 710, 710, 769, 641, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 770, 710, - 710, 710, 710, 710, 771, 710, 710, 710, 710, 710, - 769, 710, 710, 710, 772, 710, 710, 710, 773, 710, - - 710, 710, 710, 774, 710, 710, 775, 776, 776, 0, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710 - } ; - -static yyconst short int yy_nxt[1740] = - { 0, - 12, 13, 14, 15, 16, 12, 17, 18, 19, 20, - 21, 19, 22, 23, 24, 25, 26, 27, 28, 12, - 29, 12, 12, 30, 31, 32, 12, 12, 33, 12, - 12, 12, 12, 34, 35, 12, 36, 37, 38, 12, - 12, 12, 12, 39, 54, 112, 12, 39, 54, 132, - 12, 118, 115, 114, 114, 136, 113, 116, 133, 117, - 137, 171, 120, 710, 40, 41, 42, 128, 117, 129, - 43, 147, 44, 45, 131, 121, 46, 148, 47, 149, - 48, 49, 12, 13, 50, 15, 12, 12, 17, 18, - 19, 20, 21, 19, 22, 23, 24, 25, 26, 27, - - 28, 12, 51, 52, 52, 52, 52, 52, 52, 52, - 52, 52, 52, 52, 52, 53, 52, 52, 52, 52, - 52, 52, 52, 52, 52, 54, 122, 12, 124, 707, - 125, 150, 123, 151, 143, 126, 138, 117, 144, 127, - 127, 117, 133, 12, 152, 153, 12, 12, 12, 139, - 229, 12, 140, 145, 230, 141, 12, 12, 705, 12, - 12, 12, 55, 56, 57, 58, 55, 55, 59, 60, - 61, 62, 63, 61, 64, 65, 66, 67, 68, 69, - 70, 55, 55, 55, 71, 72, 73, 74, 55, 55, - 75, 55, 76, 55, 55, 55, 77, 55, 78, 79, - - 80, 81, 55, 55, 55, 83, 84, 85, 172, 173, - 86, 87, 88, 89, 90, 88, 91, 92, 93, 94, - 95, 96, 97, 98, 84, 85, 704, 146, 86, 87, - 88, 89, 90, 88, 91, 92, 93, 94, 95, 96, - 97, 99, 156, 100, 152, 182, 101, 102, 103, 160, - 102, 162, 104, 710, 105, 139, 106, 165, 157, 165, - 166, 158, 166, 165, 112, 115, 166, 118, 122, 163, - 116, 114, 117, 311, 123, 113, 188, 202, 120, 117, - 147, 114, 164, 117, 128, 312, 179, 175, 150, 176, - 180, 121, 168, 169, 177, 170, 117, 129, 178, 178, - - 188, 189, 188, 702, 197, 122, 190, 191, 192, 188, - 191, 123, 193, 188, 194, 112, 195, 114, 199, 188, - 200, 188, 203, 115, 701, 205, 113, 204, 116, 205, - 128, 201, 187, 188, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 187, 206, 187, 187, 187, - 187, 187, 207, 207, 207, 207, 207, 208, 207, 207, - 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, - 209, 207, 207, 207, 207, 188, 210, 188, 188, 202, - 188, 202, 211, 112, 115, 188, 114, 205, 212, 116, - 213, 205, 216, 699, 113, 214, 205, 217, 220, 215, - - 215, 205, 129, 118, 222, 221, 710, 222, 126, 710, - 698, 122, 127, 127, 222, 223, 710, 123, 226, 124, - 239, 125, 265, 126, 239, 240, 126, 127, 127, 259, - 127, 127, 253, 254, 263, 188, 202, 266, 224, 264, - 267, 272, 268, 273, 165, 165, 165, 166, 166, 166, - 165, 165, 696, 166, 166, 226, 175, 247, 279, 267, - 126, 268, 229, 177, 127, 127, 230, 178, 178, 695, - 188, 200, 220, 278, 188, 203, 188, 210, 277, 221, - 204, 276, 201, 211, 188, 202, 188, 202, 188, 188, - 197, 196, 188, 188, 188, 188, 200, 199, 216, 198, - - 188, 285, 188, 217, 188, 202, 293, 201, 188, 203, - 188, 286, 188, 291, 204, 206, 694, 288, 287, 187, - 214, 288, 188, 187, 215, 215, 288, 300, 187, 289, - 207, 188, 210, 301, 207, 292, 188, 297, 211, 207, - 214, 230, 188, 207, 215, 215, 126, 207, 188, 188, - 290, 334, 207, 212, 429, 213, 710, 295, 188, 298, - 214, 296, 296, 312, 215, 215, 187, 188, 187, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 187, 187, - 293, 187, 187, 187, 187, 187, 294, 294, 294, 294, - 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, - - 294, 294, 294, 294, 294, 294, 294, 294, 294, 222, - 222, 710, 710, 226, 329, 330, 165, 165, 126, 166, - 166, 165, 127, 127, 166, 165, 686, 302, 166, 329, - 354, 188, 285, 175, 685, 353, 300, 303, 188, 286, - 177, 331, 301, 350, 178, 178, 287, 188, 359, 188, - 288, 332, 187, 288, 360, 187, 331, 188, 291, 352, - 188, 351, 292, 207, 188, 297, 207, 214, 361, 188, - 298, 215, 215, 296, 165, 683, 207, 166, 214, 207, - 362, 187, 188, 187, 187, 187, 187, 187, 187, 187, - 187, 187, 187, 187, 187, 363, 187, 187, 187, 187, - - 363, 363, 363, 363, 363, 363, 363, 363, 363, 363, - 363, 363, 363, 363, 363, 363, 363, 363, 363, 363, - 363, 363, 363, 363, 222, 222, 710, 710, 370, 397, - 165, 413, 682, 166, 166, 375, 680, 367, 165, 398, - 371, 166, 329, 417, 414, 397, 175, 422, 416, 366, - 329, 392, 423, 177, 412, 398, 415, 178, 178, 679, - 188, 359, 188, 424, 329, 392, 418, 360, 288, 331, - 187, 288, 393, 187, 370, 660, 467, 331, 419, 165, - 393, 207, 166, 426, 207, 467, 371, 332, 222, 414, - 710, 331, 413, 425, 207, 166, 165, 207, 414, 166, - - 428, 332, 329, 417, 175, 414, 472, 422, 288, 469, - 187, 177, 423, 188, 424, 178, 178, 478, 659, 187, - 477, 207, 429, 165, 710, 165, 166, 658, 166, 331, - 207, 642, 471, 124, 207, 125, 478, 643, 187, 165, - 126, 615, 166, 207, 127, 127, 591, 165, 165, 207, - 166, 166, 518, 563, 564, 590, 519, 657, 166, 656, - 591, 557, 207, 563, 564, 165, 590, 615, 166, 166, - 639, 591, 591, 166, 642, 640, 642, 655, 589, 653, - 643, 558, 643, 644, 642, 645, 661, 651, 642, 646, - 643, 640, 639, 662, 643, 166, 650, 640, 642, 647, - - 667, 616, 618, 649, 643, 669, 668, 661, 663, 619, - 620, 670, 640, 621, 671, 648, 622, 623, 624, 617, - 672, 618, 617, 617, 617, 617, 617, 617, 619, 620, - 617, 617, 621, 617, 617, 622, 623, 624, 617, 664, - 638, 665, 664, 664, 664, 664, 664, 664, 664, 664, - 664, 664, 664, 664, 664, 664, 664, 664, 664, 666, - 666, 666, 666, 666, 666, 666, 666, 666, 666, 666, - 666, 666, 666, 666, 666, 666, 666, 666, 666, 666, - 666, 666, 673, 675, 677, 662, 687, 689, 674, 676, - 678, 691, 688, 690, 637, 691, 667, 692, 669, 671, - - 663, 692, 668, 673, 670, 672, 675, 677, 687, 674, - 689, 691, 676, 678, 688, 689, 690, 692, 636, 635, - 633, 690, 82, 82, 82, 82, 82, 82, 82, 82, - 82, 107, 631, 107, 107, 107, 107, 107, 107, 107, - 110, 630, 110, 110, 110, 110, 110, 110, 110, 119, - 629, 119, 119, 167, 628, 167, 167, 167, 167, 167, - 174, 627, 174, 174, 174, 174, 174, 174, 174, 187, - 187, 187, 187, 187, 187, 187, 187, 187, 196, 196, - 196, 196, 196, 196, 196, 196, 196, 198, 198, 198, - 198, 198, 198, 198, 198, 198, 228, 626, 228, 228, - - 238, 238, 238, 238, 238, 625, 614, 611, 238, 275, - 609, 608, 607, 605, 275, 275, 304, 304, 304, 304, - 314, 314, 314, 314, 314, 345, 345, 345, 345, 345, - 349, 603, 349, 349, 349, 349, 349, 383, 383, 383, - 383, 383, 405, 405, 405, 405, 405, 406, 406, 406, - 406, 406, 408, 408, 408, 408, 408, 436, 436, 436, - 436, 436, 486, 486, 486, 486, 486, 492, 492, 492, - 492, 492, 493, 493, 493, 493, 493, 496, 496, 496, - 496, 496, 509, 509, 509, 509, 509, 514, 514, 514, - 514, 514, 534, 534, 534, 534, 534, 535, 535, 535, - - 535, 535, 539, 539, 539, 539, 539, 545, 545, 545, - 545, 545, 547, 547, 547, 547, 547, 549, 549, 549, - 549, 549, 552, 552, 552, 552, 552, 553, 553, 553, - 553, 553, 569, 569, 569, 569, 569, 570, 570, 570, - 570, 570, 572, 572, 572, 572, 572, 574, 574, 574, - 574, 574, 577, 577, 577, 577, 577, 594, 594, 594, - 594, 594, 596, 600, 596, 599, 596, 596, 596, 596, - 596, 598, 598, 598, 598, 598, 601, 601, 601, 601, - 601, 602, 602, 602, 602, 602, 604, 604, 604, 604, - 604, 606, 606, 606, 606, 606, 610, 610, 610, 610, - - 610, 612, 612, 612, 612, 612, 613, 613, 613, 613, - 613, 617, 597, 617, 617, 617, 617, 617, 617, 617, - 632, 632, 632, 632, 632, 634, 634, 634, 634, 634, - 641, 641, 652, 652, 652, 652, 652, 654, 654, 654, - 654, 654, 681, 681, 681, 681, 681, 684, 684, 684, - 684, 684, 664, 595, 664, 664, 664, 664, 664, 664, - 664, 693, 693, 693, 693, 693, 697, 697, 697, 697, - 697, 700, 700, 700, 700, 700, 703, 703, 703, 703, - 703, 706, 706, 706, 706, 706, 708, 708, 709, 709, - 709, 709, 593, 592, 588, 587, 586, 585, 584, 583, - - 582, 581, 580, 579, 578, 576, 575, 573, 571, 568, - 567, 566, 565, 562, 561, 560, 559, 556, 555, 554, - 551, 550, 548, 546, 544, 543, 542, 541, 540, 538, - 537, 536, 533, 532, 531, 530, 529, 528, 527, 526, - 525, 524, 188, 523, 522, 521, 520, 470, 517, 516, - 515, 513, 512, 511, 510, 508, 507, 506, 505, 504, - 503, 502, 501, 500, 499, 498, 497, 495, 494, 491, - 490, 489, 488, 487, 485, 484, 483, 482, 481, 480, - 479, 476, 475, 474, 473, 470, 468, 466, 465, 464, - 463, 462, 461, 460, 459, 458, 457, 456, 455, 454, - - 453, 452, 451, 450, 449, 448, 447, 446, 445, 444, - 443, 442, 441, 440, 439, 438, 437, 435, 434, 433, - 432, 431, 430, 365, 427, 421, 420, 411, 410, 409, - 407, 404, 403, 402, 401, 400, 399, 396, 395, 394, - 391, 390, 389, 388, 387, 386, 385, 384, 382, 381, - 380, 379, 378, 377, 376, 375, 374, 373, 372, 369, - 368, 365, 364, 188, 358, 357, 356, 355, 274, 348, - 347, 346, 344, 343, 342, 341, 340, 339, 338, 337, - 336, 335, 333, 328, 327, 326, 325, 324, 323, 322, - 321, 320, 319, 318, 317, 316, 315, 313, 310, 309, - - 308, 307, 306, 305, 232, 231, 230, 227, 225, 219, - 299, 188, 188, 284, 283, 266, 282, 281, 280, 253, - 227, 274, 271, 270, 269, 262, 261, 260, 258, 257, - 256, 255, 252, 251, 250, 249, 248, 247, 246, 245, - 244, 243, 242, 241, 237, 236, 235, 234, 233, 232, - 231, 227, 225, 114, 219, 110, 111, 218, 107, 108, - 114, 109, 188, 188, 161, 186, 185, 184, 183, 154, - 181, 149, 117, 117, 114, 111, 108, 161, 159, 155, - 154, 146, 142, 135, 134, 131, 130, 117, 117, 114, - 111, 109, 108, 710, 39, 11, 710, 710, 710, 710, - - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710 - } ; - -static yyconst short int yy_chk[1740] = - { 0, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 7, 18, 7, 8, 8, 31, - 8, 22, 20, 27, 25, 34, 18, 20, 31, 20, - 34, 54, 22, 54, 2, 2, 2, 25, 27, 27, - 2, 40, 2, 2, 41, 22, 2, 40, 2, 41, - 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 5, 23, 5, 24, 705, - 24, 42, 23, 42, 37, 24, 35, 23, 37, 24, - 24, 23, 42, 5, 43, 43, 5, 5, 5, 35, - 127, 5, 35, 37, 127, 35, 5, 5, 702, 5, - 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, - - 6, 6, 6, 6, 6, 9, 9, 9, 57, 57, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 10, 10, 10, 701, 48, 10, 10, - 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 14, 46, 14, 75, 75, 14, 14, 14, 48, - 14, 50, 14, 50, 14, 46, 14, 51, 46, 52, - 51, 46, 52, 53, 60, 62, 53, 64, 65, 50, - 62, 67, 62, 240, 65, 60, 88, 88, 64, 65, - 71, 69, 50, 65, 67, 240, 71, 66, 73, 66, - 73, 64, 51, 53, 66, 53, 69, 69, 66, 66, - - 84, 84, 85, 698, 85, 104, 84, 84, 84, 95, - 84, 104, 84, 86, 84, 101, 84, 105, 86, 87, - 87, 89, 89, 103, 696, 95, 101, 89, 103, 89, - 105, 87, 91, 91, 91, 91, 91, 91, 91, 91, - 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - 91, 91, 91, 91, 91, 92, 92, 93, 94, 94, - 96, 96, 92, 112, 115, 97, 106, 92, 93, 115, - 93, 92, 94, 694, 112, 93, 96, 96, 116, 93, - - 93, 97, 106, 118, 119, 116, 119, 120, 118, 120, - 686, 122, 118, 118, 121, 120, 121, 122, 124, 125, - 135, 125, 158, 124, 153, 135, 125, 124, 124, 153, - 125, 125, 148, 148, 157, 191, 191, 158, 121, 157, - 159, 164, 159, 164, 165, 167, 168, 165, 167, 168, - 169, 170, 683, 169, 170, 175, 176, 159, 176, 184, - 175, 184, 178, 176, 175, 175, 178, 176, 176, 682, - 190, 190, 220, 170, 192, 192, 193, 193, 169, 220, - 192, 168, 190, 193, 194, 194, 195, 195, 196, 197, - 196, 197, 198, 293, 199, 200, 200, 198, 194, 199, - - 201, 201, 206, 195, 202, 202, 293, 200, 203, 203, - 204, 204, 211, 211, 203, 206, 680, 207, 204, 207, - 206, 208, 212, 208, 206, 206, 209, 221, 209, 208, - 207, 210, 210, 221, 208, 212, 216, 216, 210, 209, - 212, 230, 213, 207, 212, 212, 230, 208, 215, 295, - 209, 259, 209, 213, 367, 213, 367, 215, 217, 217, - 213, 215, 295, 259, 213, 213, 214, 214, 214, 214, - 214, 214, 214, 214, 214, 214, 214, 214, 214, 214, - 214, 214, 214, 214, 214, 214, 214, 214, 214, 214, - 214, 214, 214, 214, 214, 214, 214, 214, 214, 214, - - 214, 214, 214, 214, 214, 214, 214, 214, 214, 223, - 224, 223, 224, 226, 257, 257, 275, 276, 226, 275, - 276, 277, 226, 226, 277, 278, 660, 223, 278, 280, - 280, 285, 285, 279, 659, 279, 300, 224, 286, 286, - 279, 257, 300, 276, 279, 279, 286, 287, 287, 292, - 289, 257, 289, 290, 287, 290, 280, 291, 291, 278, - 296, 277, 292, 289, 297, 297, 290, 292, 289, 298, - 298, 292, 292, 296, 349, 657, 289, 349, 296, 290, - 290, 294, 294, 294, 294, 294, 294, 294, 294, 294, - 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, - - 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, - 294, 294, 294, 294, 294, 294, 294, 294, 294, 294, - 294, 294, 294, 294, 302, 303, 302, 303, 307, 334, - 350, 351, 656, 350, 351, 334, 651, 303, 352, 334, - 307, 352, 354, 354, 351, 356, 353, 358, 353, 302, - 330, 330, 358, 353, 350, 356, 352, 353, 353, 650, - 359, 359, 360, 360, 392, 392, 354, 359, 361, 354, - 361, 362, 354, 362, 330, 637, 410, 330, 354, 412, - 330, 361, 412, 362, 362, 467, 330, 330, 366, 410, - 366, 392, 413, 361, 361, 413, 415, 362, 467, 415, - - 366, 392, 417, 417, 416, 413, 416, 422, 425, 412, - 425, 416, 422, 424, 424, 416, 416, 426, 636, 426, - 425, 425, 428, 469, 428, 471, 469, 635, 471, 417, - 426, 620, 415, 472, 425, 472, 477, 620, 477, 518, - 472, 588, 518, 426, 472, 472, 588, 519, 557, 477, - 519, 557, 469, 524, 524, 558, 471, 633, 558, 631, - 558, 518, 477, 563, 563, 589, 590, 615, 589, 590, - 616, 590, 615, 616, 621, 616, 619, 630, 557, 628, - 621, 519, 619, 619, 622, 621, 638, 626, 624, 621, - 622, 638, 639, 640, 624, 639, 625, 639, 642, 622, - - 644, 589, 591, 624, 642, 645, 644, 661, 640, 591, - 591, 645, 661, 591, 646, 623, 591, 591, 591, 618, - 646, 618, 618, 618, 618, 618, 618, 618, 618, 618, - 618, 618, 618, 618, 618, 618, 618, 618, 618, 641, - 614, 641, 641, 641, 641, 641, 641, 641, 641, 641, - 641, 641, 641, 641, 641, 641, 641, 641, 641, 641, - 641, 641, 641, 641, 641, 641, 641, 641, 641, 641, - 641, 641, 641, 641, 641, 641, 641, 641, 641, 641, - 641, 641, 647, 648, 649, 662, 663, 664, 647, 648, - 649, 665, 663, 664, 611, 666, 667, 665, 669, 671, - - 662, 666, 667, 673, 669, 671, 675, 677, 687, 673, - 689, 691, 675, 677, 687, 692, 689, 691, 609, 608, - 605, 692, 711, 711, 711, 711, 711, 711, 711, 711, - 711, 712, 600, 712, 712, 712, 712, 712, 712, 712, - 713, 599, 713, 713, 713, 713, 713, 713, 713, 714, - 597, 714, 714, 715, 596, 715, 715, 715, 715, 715, - 716, 595, 716, 716, 716, 716, 716, 716, 716, 717, - 717, 717, 717, 717, 717, 717, 717, 717, 718, 718, - 718, 718, 718, 718, 718, 718, 718, 719, 719, 719, - 719, 719, 719, 719, 719, 719, 720, 593, 720, 720, - - 721, 721, 721, 721, 721, 592, 587, 584, 721, 722, - 582, 581, 580, 578, 722, 722, 723, 723, 723, 723, - 724, 724, 724, 724, 724, 725, 725, 725, 725, 725, - 726, 575, 726, 726, 726, 726, 726, 727, 727, 727, - 727, 727, 728, 728, 728, 728, 728, 729, 729, 729, - 729, 729, 730, 730, 730, 730, 730, 731, 731, 731, - 731, 731, 732, 732, 732, 732, 732, 733, 733, 733, - 733, 733, 734, 734, 734, 734, 734, 735, 735, 735, - 735, 735, 736, 736, 736, 736, 736, 737, 737, 737, - 737, 737, 738, 738, 738, 738, 738, 739, 739, 739, - - 739, 739, 740, 740, 740, 740, 740, 741, 741, 741, - 741, 741, 742, 742, 742, 742, 742, 743, 743, 743, - 743, 743, 744, 744, 744, 744, 744, 745, 745, 745, - 745, 745, 746, 746, 746, 746, 746, 747, 747, 747, - 747, 747, 748, 748, 748, 748, 748, 749, 749, 749, - 749, 749, 750, 750, 750, 750, 750, 751, 751, 751, - 751, 751, 752, 568, 752, 567, 752, 752, 752, 752, - 752, 753, 753, 753, 753, 753, 754, 754, 754, 754, - 754, 755, 755, 755, 755, 755, 756, 756, 756, 756, - 756, 757, 757, 757, 757, 757, 758, 758, 758, 758, - - 758, 759, 759, 759, 759, 759, 760, 760, 760, 760, - 760, 761, 565, 761, 761, 761, 761, 761, 761, 761, - 762, 762, 762, 762, 762, 763, 763, 763, 763, 763, - 764, 764, 765, 765, 765, 765, 765, 766, 766, 766, - 766, 766, 767, 767, 767, 767, 767, 768, 768, 768, - 768, 768, 769, 562, 769, 769, 769, 769, 769, 769, - 769, 770, 770, 770, 770, 770, 771, 771, 771, 771, - 771, 772, 772, 772, 772, 772, 773, 773, 773, 773, - 773, 774, 774, 774, 774, 774, 775, 775, 776, 776, - 776, 776, 560, 559, 556, 555, 554, 551, 550, 548, - - 546, 544, 543, 542, 541, 538, 537, 533, 531, 528, - 527, 526, 525, 523, 522, 521, 520, 517, 516, 515, - 511, 510, 507, 505, 503, 502, 501, 500, 499, 497, - 495, 494, 489, 488, 487, 485, 484, 483, 482, 481, - 480, 479, 478, 476, 475, 474, 473, 470, 468, 466, - 465, 463, 462, 461, 460, 459, 458, 457, 456, 455, - 454, 453, 452, 451, 450, 449, 448, 446, 445, 442, - 441, 440, 439, 438, 435, 434, 433, 432, 431, 430, - 427, 421, 420, 419, 418, 414, 411, 409, 407, 404, - 403, 402, 401, 400, 399, 398, 397, 396, 395, 394, - - 393, 391, 390, 389, 388, 387, 386, 385, 384, 382, - 381, 380, 379, 378, 377, 376, 375, 373, 372, 371, - 370, 369, 368, 365, 364, 357, 355, 348, 347, 346, - 343, 340, 339, 338, 337, 336, 335, 333, 332, 331, - 328, 327, 326, 325, 324, 323, 322, 321, 319, 318, - 317, 316, 315, 313, 312, 311, 310, 309, 308, 306, - 305, 301, 299, 288, 284, 283, 282, 281, 274, 273, - 272, 271, 269, 268, 267, 266, 265, 264, 263, 262, - 261, 260, 258, 256, 255, 254, 253, 252, 251, 250, - 249, 248, 247, 246, 245, 244, 243, 241, 239, 237, - - 236, 235, 234, 233, 232, 231, 229, 227, 225, 219, - 218, 205, 187, 186, 185, 183, 182, 181, 180, 179, - 177, 166, 163, 161, 160, 156, 155, 154, 152, 151, - 150, 149, 147, 146, 145, 144, 143, 142, 141, 140, - 139, 138, 137, 136, 134, 133, 132, 131, 130, 129, - 128, 126, 123, 114, 113, 111, 110, 109, 108, 107, - 102, 100, 90, 82, 81, 80, 79, 78, 77, 76, - 74, 72, 70, 68, 61, 59, 58, 49, 47, 45, - 44, 38, 36, 33, 32, 30, 29, 28, 26, 19, - 17, 16, 15, 11, 4, 710, 710, 710, 710, 710, - - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710, 710, - 710, 710, 710, 710, 710, 710, 710, 710, 710 - } ; - -static yy_state_type yy_state_buf[YY_BUF_SIZE + 2], *yy_state_ptr; -static char *yy_full_match; -static int yy_lp; -static int yy_looking_for_trail_begin = 0; -static int yy_full_lp; -static int *yy_full_state; -#define YY_TRAILING_MASK 0x2000 -#define YY_TRAILING_HEAD_MASK 0x4000 -#define REJECT \ -{ \ -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ \ -yy_cp = yy_full_match; /* restore poss. backed-over text */ \ -yy_lp = yy_full_lp; /* restore orig. accepting pos. */ \ -yy_state_ptr = yy_full_state; /* restore orig. state */ \ -yy_current_state = *yy_state_ptr; /* restore curr. state */ \ -++yy_lp; \ -goto find_rule; \ -} -#define yymore() yymore_used_but_not_detected -#define YY_MORE_ADJ 0 -#define YY_RESTORE_YY_MORE_OFFSET -char *yytext; -#line 1 "forlex.lex" -#define INITIAL 0 -/* the input routine wget() takes care of most skipping to be done - it garantees that each command will be on a single line ending - with '\n', without comments and repeated blanks, and that quotes - come in pairs -*/ -#define YY_STACK_USED 1 -#line 10 "forlex.lex" - -#define DEBUG -#undef DEBUG - -#define YYSTYPE char* -#define YY_INPUT(buf,result,max_size) { result=wget(buf,max_size); } - -extern int wws, submod, fixed, ext, lineno; -extern char line[], inpline[]; - -#define MAX_INCLUDE_DEPTH 10 -YY_BUFFER_STATE include_stack[MAX_INCLUDE_DEPTH]; -int include_stack_ptr = 0, nstrt=0; -void lexerr(char *meldung, ...); -void wdebug(char *meldung, ...); -void strt_ni(); -void mm(); -void un_strt(); -void zr_strt(); -void loc(char* s); - -#include "forpar.tab.h" -#include -#include -#include -#include /* needed for variable num. of parameters to w_fehler */ - -extern char stack[], *sp, *spmax; -char* push(char* s); -int getstr(char* str, char* lim); -int wget(char buf[],unsigned max_size); -char get1c(char* s); -void getid(char* s, char* id); -char c, wts[256], *pc; -int modsub=INITIAL; - -/* Start conditions: - INITIAL: reckognize keywords - NURID: do not reckognize keywords - M: in module after CONTAINS statement, beginning of line - MM: in module after CONTAINS statement, not at beginning of line -*/ -#define NURID 1 - -#define M 2 - -#define MM 3 - -#define SKIP 4 - -/* ws: at least one white-space, maybe more; ow: optional ws */ -/* id: identifier */ -/* cid: composite id = identifier of element of defined type */ -/* strc: string constant */ -/* logc: logical constant */ -/* realc: real constant */ -/* s: separate keywords */ -/* ope: any operator */ -#line 1125 "forlex.c" - -/* Macros after this point can all be overridden by user definitions in - * section 1. - */ - -#ifndef YY_SKIP_YYWRAP -#ifdef __cplusplus -extern "C" int yywrap YY_PROTO(( void )); -#else -extern int yywrap YY_PROTO(( void )); -#endif -#endif - -#ifndef YY_NO_UNPUT -static void yyunput YY_PROTO(( int c, char *buf_ptr )); -#endif - -#ifndef yytext_ptr -static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int )); -#endif - -#ifdef YY_NEED_STRLEN -static int yy_flex_strlen YY_PROTO(( yyconst char * )); -#endif - -#ifndef YY_NO_INPUT -#ifdef __cplusplus -static int yyinput YY_PROTO(( void )); -#else -static int input YY_PROTO(( void )); -#endif -#endif - -#if YY_STACK_USED -static int yy_start_stack_ptr = 0; -static int yy_start_stack_depth = 0; -static int *yy_start_stack = 0; -#ifndef YY_NO_PUSH_STATE -static void yy_push_state YY_PROTO(( int new_state )); -#endif -#ifndef YY_NO_POP_STATE -static void yy_pop_state YY_PROTO(( void )); -#endif -#ifndef YY_NO_TOP_STATE -static int yy_top_state YY_PROTO(( void )); -#endif - -#else -#define YY_NO_PUSH_STATE 1 -#define YY_NO_POP_STATE 1 -#define YY_NO_TOP_STATE 1 -#endif - -#ifdef YY_MALLOC_DECL -YY_MALLOC_DECL -#else -#if __STDC__ -#ifndef __cplusplus -#include -#endif -#else -/* Just try to get by without declaring the routines. This will fail - * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) - * or sizeof(void*) != sizeof(int). - */ -#endif -#endif - -/* Amount of stuff to slurp up with each read. */ -#ifndef YY_READ_BUF_SIZE -#define YY_READ_BUF_SIZE 8192 -#endif - -/* Copy whatever the last rule matched to the standard output. */ - -#ifndef ECHO -/* This used to be an fputs(), but since the string might contain NUL's, - * we now use fwrite(). - */ -#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) -#endif - -/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, - * is returned in "result". - */ -#ifndef YY_INPUT -#define YY_INPUT(buf,result,max_size) \ - if ( yy_current_buffer->yy_is_interactive ) \ - { \ - int c = '*', n; \ - for ( n = 0; n < max_size && \ - (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ - buf[n] = (char) c; \ - if ( c == '\n' ) \ - buf[n++] = (char) c; \ - if ( c == EOF && ferror( yyin ) ) \ - YY_FATAL_ERROR( "input in flex scanner failed" ); \ - result = n; \ - } \ - else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ - && ferror( yyin ) ) \ - YY_FATAL_ERROR( "input in flex scanner failed" ); -#endif - -/* No semi-colon after return; correct usage is to write "yyterminate();" - - * we don't want an extra ';' after the "return" because that will cause - * some compilers to complain about unreachable statements. - */ -#ifndef yyterminate -#define yyterminate() return YY_NULL -#endif - -/* Number of entries by which start-condition stack grows. */ -#ifndef YY_START_STACK_INCR -#define YY_START_STACK_INCR 25 -#endif - -/* Report a fatal error. */ -#ifndef YY_FATAL_ERROR -#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) -#endif - -/* Default declaration of generated scanner - a define so the user can - * easily add parameters. - */ -#ifndef YY_DECL -#define YY_DECL int yylex YY_PROTO(( void )) -#endif - -/* Code executed at the beginning of each rule, after yytext and yyleng - * have been set up. - */ -#ifndef YY_USER_ACTION -#define YY_USER_ACTION -#endif - -/* Code executed at the end of each rule. */ -#ifndef YY_BREAK -#define YY_BREAK break; -#endif - -#define YY_RULE_SETUP \ - if ( yyleng > 0 ) \ - yy_current_buffer->yy_at_bol = \ - (yytext[yyleng - 1] == '\n'); \ - YY_USER_ACTION - -YY_DECL - { - register yy_state_type yy_current_state; - register char *yy_cp, *yy_bp; - register int yy_act; - -#line 84 "forlex.lex" - - - yylval=NULL; - switch(wws){ - case 'n': strt_ni(); wws='p'; break; - case 'b': un_strt(); wws=0; break; - case 'p': /* do nothing */; break; - } - -#line 1289 "forlex.c" - - if ( yy_init ) - { - yy_init = 0; - -#ifdef YY_USER_INIT - YY_USER_INIT; -#endif - - if ( ! yy_start ) - yy_start = 1; /* first start state */ - - if ( ! yyin ) - yyin = stdin; - - if ( ! yyout ) - yyout = stdout; - - if ( ! yy_current_buffer ) - yy_current_buffer = - yy_create_buffer( yyin, YY_BUF_SIZE ); - - yy_load_buffer_state(); - } - - while ( 1 ) /* loops until end-of-file is reached */ - { - yy_cp = yy_c_buf_p; - - /* Support of yytext. */ - *yy_cp = yy_hold_char; - - /* yy_bp points to the position in yy_ch_buf of the start of - * the current run. - */ - yy_bp = yy_cp; - - yy_current_state = yy_start; - yy_current_state += YY_AT_BOL(); - yy_state_ptr = yy_state_buf; - *yy_state_ptr++ = yy_current_state; -yy_match: - do - { - register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; - while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) - { - yy_current_state = (int) yy_def[yy_current_state]; - if ( yy_current_state >= 711 ) - yy_c = yy_meta[(unsigned int) yy_c]; - } - yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; - *yy_state_ptr++ = yy_current_state; - ++yy_cp; - } - while ( yy_base[yy_current_state] != 1696 ); - -yy_find_action: - yy_current_state = *--yy_state_ptr; - yy_lp = yy_accept[yy_current_state]; -find_rule: /* we branch to this label when backing up */ - for ( ; ; ) /* until we find what rule we matched */ - { - if ( yy_lp && yy_lp < yy_accept[yy_current_state + 1] ) - { - yy_act = yy_acclist[yy_lp]; - if ( yy_act & YY_TRAILING_HEAD_MASK || - yy_looking_for_trail_begin ) - { - if ( yy_act == yy_looking_for_trail_begin ) - { - yy_looking_for_trail_begin = 0; - yy_act &= ~YY_TRAILING_HEAD_MASK; - break; - } - } - else if ( yy_act & YY_TRAILING_MASK ) - { - yy_looking_for_trail_begin = yy_act & ~YY_TRAILING_MASK; - yy_looking_for_trail_begin |= YY_TRAILING_HEAD_MASK; - } - else - { - yy_full_match = yy_cp; - yy_full_state = yy_state_ptr; - yy_full_lp = yy_lp; - break; - } - ++yy_lp; - goto find_rule; - } - --yy_cp; - yy_current_state = *--yy_state_ptr; - yy_lp = yy_accept[yy_current_state]; - } - - YY_DO_BEFORE_ACTION; - - -do_action: /* This label is used only to access EOF actions. */ - - - switch ( yy_act ) - { /* beginning of action switch */ -case 1: -YY_RULE_SETUP -#line 93 "forlex.lex" -{ /* empty: skip empty lines */ } - YY_BREAK -case 2: -YY_RULE_SETUP -#line 94 "forlex.lex" -{ zr_strt(); if( wws=='p' ); wws=0; - sp=stack; /* at end-of-command reset stack-pointer sp */ - return EOC; - } - YY_BREAK -case 3: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 99 "forlex.lex" -{ strt_ni(); return PROGRAM; } - YY_BREAK -case 4: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 100 "forlex.lex" -{ strt_ni(); return MODULE; } - YY_BREAK -case 5: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 10; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 101 "forlex.lex" -{ zr_strt(); BEGIN(INITIAL); - strt_ni(); submod=0; - return ENDMOD; } - YY_BREAK -case 6: -YY_RULE_SETUP -#line 104 "forlex.lex" -{ return END; } - YY_BREAK -case 7: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 105 "forlex.lex" -{ zr_strt(); BEGIN(M); return CONTAINS; } - YY_BREAK -case 8: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 3; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 106 "forlex.lex" -{ mm(); strt_ni(); return USE; } - YY_BREAK -case 9: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 107 "forlex.lex" -{ mm(); return INTEGER; } - YY_BREAK -case 10: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 4; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 108 "forlex.lex" -{ mm(); return REAL; } - YY_BREAK -case 11: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 16; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 109 "forlex.lex" -{ mm(); return DPREC; } - YY_BREAK -case 12: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 110 "forlex.lex" -{ mm(); return COMPLEX; } - YY_BREAK -case 13: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 111 "forlex.lex" -{ mm(); return CHARACTER; } - YY_BREAK -case 14: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 112 "forlex.lex" -{ mm(); return LOGICAL; } - YY_BREAK -case 15: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 4; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 113 "forlex.lex" -{ strt_ni(); return TYPE; } - YY_BREAK -case 16: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp -= 1; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 114 "forlex.lex" -{ mm(); strt_ni(); return TYPE; } - YY_BREAK -case 17: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp -= 1; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 115 "forlex.lex" -{ strt_ni(); return ENDTYPE; } - YY_BREAK -case 18: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 13; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 116 "forlex.lex" -{ mm(); return IMPLNONE; } - YY_BREAK -case 19: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 117 "forlex.lex" -{ strt_ni(); return PARAMETER; } - YY_BREAK -case 20: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 118 "forlex.lex" -{ strt_ni(); return PUBLIC; } - YY_BREAK -case 21: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 119 "forlex.lex" -{ strt_ni(); return PRIVATE; } - YY_BREAK -case 22: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 120 "forlex.lex" -{ mm(); strt_ni(); return INTERFACE; } - YY_BREAK -case 23: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 17; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 121 "forlex.lex" -{ strt_ni(); return MODPROC; } - YY_BREAK -case 24: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp -= 1; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 122 "forlex.lex" -{ mm(); strt_ni(); return ENDINTER; } - YY_BREAK -case 25: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 123 "forlex.lex" -{ mm(); return RECURSIVE; } - YY_BREAK -case 26: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 4; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 124 "forlex.lex" -{ mm(); return PURE; } - YY_BREAK -case 27: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 125 "forlex.lex" -{ mm(); return ELEMENTAL; } - YY_BREAK -case 28: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 127 "forlex.lex" -{ mm(); strt_ni(); return FUNCTION; } - YY_BREAK -case 29: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 10; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 128 "forlex.lex" -{ mm(); strt_ni(); return SUBROUTINE; } - YY_BREAK -case 30: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 12; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 129 "forlex.lex" -{ strt_ni(); return ENDFUN; } - YY_BREAK -case 31: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 14; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 130 "forlex.lex" -{ strt_ni(); return ENDSUB; } - YY_BREAK -case 32: -YY_RULE_SETUP -#line 131 "forlex.lex" -{ } /* skip empty line */ - YY_BREAK -case 33: -YY_RULE_SETUP -#line 132 "forlex.lex" -{ BEGIN(SKIP); } /* skip line */ - YY_BREAK -case 34: -YY_RULE_SETUP -#line 133 "forlex.lex" -{ BEGIN(M); } /* skip line */ - YY_BREAK -case 35: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 136 "forlex.lex" -{ mm(); strt_ni(); return FUNCTION; } - YY_BREAK -case 36: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 137 "forlex.lex" -{ strt_ni(); return RESULT; } - YY_BREAK -case 37: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 10; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 138 "forlex.lex" -{ mm(); strt_ni(); return SUBROUTINE; } - YY_BREAK -case 38: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 12; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 139 "forlex.lex" -{ strt_ni(); return ENDFUN; } - YY_BREAK -case 39: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 14; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 140 "forlex.lex" -{ strt_ni(); return ENDSUB; } - YY_BREAK -case 40: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 141 "forlex.lex" -{ return PARAMETER; } - YY_BREAK -case 41: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 142 "forlex.lex" -{ return PUBLIC; } - YY_BREAK -case 42: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 143 "forlex.lex" -{ return PRIVATE; } - YY_BREAK -case 43: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 144 "forlex.lex" -{ return SEQUENCE; } - YY_BREAK -case 44: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 11; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 145 "forlex.lex" -{ return ALLOCATABLE; } - YY_BREAK -case 45: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 146 "forlex.lex" -{ return DIMENSION; } - YY_BREAK -case 46: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 147 "forlex.lex" -{ return EXTERNAL; } - YY_BREAK -case 47: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 148 "forlex.lex" -{ return INTENT; } - YY_BREAK -case 48: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 9; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 149 "forlex.lex" -{ return INTRINSIC; } - YY_BREAK -case 49: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 8; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 150 "forlex.lex" -{ return OPTIONAL; } - YY_BREAK -case 50: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 7; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 151 "forlex.lex" -{ return POINTER; } - YY_BREAK -case 51: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 4; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 152 "forlex.lex" -{ return SAVE; } - YY_BREAK -case 52: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 6; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 153 "forlex.lex" -{ return TARGET; } - YY_BREAK -case 53: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 2; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 154 "forlex.lex" -{ return IN; } - YY_BREAK -case 54: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 3; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 155 "forlex.lex" -{ return OUT; } - YY_BREAK -case 55: -*yy_cp = yy_hold_char; /* undo effects of setting up yytext */ -yy_c_buf_p = yy_cp = yy_bp + 5; -YY_DO_BEFORE_ACTION; /* set up yytext again */ -YY_RULE_SETUP -#line 156 "forlex.lex" -{ return INOUT; } - YY_BREAK -case 56: -YY_RULE_SETUP -#line 162 "forlex.lex" -{ loc(yytext); yylval=push(yytext); return ID; } - YY_BREAK -case 57: -YY_RULE_SETUP -#line 163 "forlex.lex" -{ zapw(yytext); loc(yytext); yylval=push(yytext); return CID; } - YY_BREAK -case 58: -YY_RULE_SETUP -#line 164 "forlex.lex" -{ return ONLY; } - YY_BREAK -case 59: -YY_RULE_SETUP -#line 165 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 60: -YY_RULE_SETUP -#line 166 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 61: -YY_RULE_SETUP -#line 167 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 62: -YY_RULE_SETUP -#line 168 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 63: -YY_RULE_SETUP -#line 169 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 64: -YY_RULE_SETUP -#line 170 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 65: -YY_RULE_SETUP -#line 171 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 66: -YY_RULE_SETUP -#line 172 "forlex.lex" -{ return OPERATOR; } - YY_BREAK -case 67: -YY_RULE_SETUP -#line 173 "forlex.lex" -{ return ASSIGNMENT; } - YY_BREAK -case 68: -YY_RULE_SETUP -#line 175 "forlex.lex" -{ yylval=push(yytext); return REALC; /* real const */ } - YY_BREAK -case 69: -YY_RULE_SETUP -#line 176 "forlex.lex" -{ yylval=push(yytext); return STRC; /* string const */ } - YY_BREAK -case 70: -YY_RULE_SETUP -#line 177 "forlex.lex" -{ yylval=push(yytext); return LOGC; /* logical const */ } - YY_BREAK -case 71: -YY_RULE_SETUP -#line 178 "forlex.lex" -{ yylval=push(yytext); return DEFOPER ; /* operator */ } - YY_BREAK -case 72: -YY_RULE_SETUP -#line 179 "forlex.lex" -{ yylval=push(yytext); return OPER ; /* operator */ } - YY_BREAK -case 73: -YY_RULE_SETUP -#line 180 "forlex.lex" -{ return '*'; } - YY_BREAK -case 74: -YY_RULE_SETUP -#line 181 "forlex.lex" -{ yylval=push(yytext); return OPER ; } - YY_BREAK -case 75: -YY_RULE_SETUP -#line 182 "forlex.lex" -{ /* skip blanks */ } - YY_BREAK -case 76: -YY_RULE_SETUP -#line 183 "forlex.lex" -{ return DCOLON; } - YY_BREAK -case 77: -YY_RULE_SETUP -#line 184 "forlex.lex" -{ return POINT; } - YY_BREAK -case 78: -YY_RULE_SETUP -#line 185 "forlex.lex" -{ return ARRIN; } - YY_BREAK -case 79: -YY_RULE_SETUP -#line 186 "forlex.lex" -{ return ARROUT; } - YY_BREAK -case 80: -YY_RULE_SETUP -#line 187 "forlex.lex" -{ for( pc=yytext; *pc==' '; ++pc ); return *pc; } - YY_BREAK -case 81: -YY_RULE_SETUP -#line 188 "forlex.lex" -{ return ARBCHARLEN; } - YY_BREAK -case 82: -YY_RULE_SETUP -#line 190 "forlex.lex" -{ - if( getstr(wts,"\"\n")==EOF || input()!='"' ) - lexerr("illegal file-name \"%s\" in include",wts); - if ( include_stack_ptr >= MAX_INCLUDE_DEPTH ) - lexerr("Includes nested too deeply"); - getstr(NULL,"\n"); input(); /* skip to end of include command */ - include_stack[include_stack_ptr]=YY_CURRENT_BUFFER; - yyin=fopen( wts, "r" ); - include_stack_ptr++; - if( ! yyin ) lexerr("could not open file \"%s\"\n",wts); - yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE)); -} - YY_BREAK -case YY_STATE_EOF(INITIAL): -case YY_STATE_EOF(NURID): -case YY_STATE_EOF(M): -case YY_STATE_EOF(MM): -case YY_STATE_EOF(SKIP): -#line 202 "forlex.lex" -{ - if ( --include_stack_ptr < 0 ) yyterminate(); - else { - yy_delete_buffer(YY_CURRENT_BUFFER); - yy_switch_to_buffer(include_stack[include_stack_ptr]); - } -} - YY_BREAK -case 83: -YY_RULE_SETUP -#line 212 "forlex.lex" -{ yylval=push(yytext); - wdebug("UNKNOWN is >>>%s<<<, in line:\n \"%s\"",yylval,line); - return UNKNOWN; - } - YY_BREAK -case 84: -YY_RULE_SETUP -#line 217 "forlex.lex" -ECHO; - YY_BREAK -#line 1994 "forlex.c" - - case YY_END_OF_BUFFER: - { - /* Amount of text matched not including the EOB char. */ - int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1; - - /* Undo the effects of YY_DO_BEFORE_ACTION. */ - *yy_cp = yy_hold_char; - YY_RESTORE_YY_MORE_OFFSET - - if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) - { - /* We're scanning a new file or input source. It's - * possible that this happened because the user - * just pointed yyin at a new source and called - * yylex(). If so, then we have to assure - * consistency between yy_current_buffer and our - * globals. Here is the right place to do so, because - * this is the first action (other than possibly a - * back-up) that will match for the new input source. - */ - yy_n_chars = yy_current_buffer->yy_n_chars; - yy_current_buffer->yy_input_file = yyin; - yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; - } - - /* Note that here we test for yy_c_buf_p "<=" to the position - * of the first EOB in the buffer, since yy_c_buf_p will - * already have been incremented past the NUL character - * (since all states make transitions on EOB to the - * end-of-buffer state). Contrast this with the test - * in input(). - */ - if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) - { /* This was really a NUL. */ - yy_state_type yy_next_state; - - yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; - - yy_current_state = yy_get_previous_state(); - - /* Okay, we're now positioned to make the NUL - * transition. We couldn't have - * yy_get_previous_state() go ahead and do it - * for us because it doesn't know how to deal - * with the possibility of jamming (and we don't - * want to build jamming into it because then it - * will run more slowly). - */ - - yy_next_state = yy_try_NUL_trans( yy_current_state ); - - yy_bp = yytext_ptr + YY_MORE_ADJ; - - if ( yy_next_state ) - { - /* Consume the NUL. */ - yy_cp = ++yy_c_buf_p; - yy_current_state = yy_next_state; - goto yy_match; - } - - else - { - yy_cp = yy_c_buf_p; - goto yy_find_action; - } - } - - else switch ( yy_get_next_buffer() ) - { - case EOB_ACT_END_OF_FILE: - { - yy_did_buffer_switch_on_eof = 0; - - if ( yywrap() ) - { - /* Note: because we've taken care in - * yy_get_next_buffer() to have set up - * yytext, we can now set up - * yy_c_buf_p so that if some total - * hoser (like flex itself) wants to - * call the scanner after we return the - * YY_NULL, it'll still work - another - * YY_NULL will get returned. - */ - yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; - - yy_act = YY_STATE_EOF(YY_START); - goto do_action; - } - - else - { - if ( ! yy_did_buffer_switch_on_eof ) - YY_NEW_FILE; - } - break; - } - - case EOB_ACT_CONTINUE_SCAN: - yy_c_buf_p = - yytext_ptr + yy_amount_of_matched_text; - - yy_current_state = yy_get_previous_state(); - - yy_cp = yy_c_buf_p; - yy_bp = yytext_ptr + YY_MORE_ADJ; - goto yy_match; - - case EOB_ACT_LAST_MATCH: - yy_c_buf_p = - &yy_current_buffer->yy_ch_buf[yy_n_chars]; - - yy_current_state = yy_get_previous_state(); - - yy_cp = yy_c_buf_p; - yy_bp = yytext_ptr + YY_MORE_ADJ; - goto yy_find_action; - } - break; - } - - default: - YY_FATAL_ERROR( - "fatal flex scanner internal error--no action found" ); - } /* end of action switch */ - } /* end of scanning one token */ - } /* end of yylex */ - - -/* yy_get_next_buffer - try to read in a new buffer - * - * Returns a code representing an action: - * EOB_ACT_LAST_MATCH - - * EOB_ACT_CONTINUE_SCAN - continue scanning from current position - * EOB_ACT_END_OF_FILE - end of file - */ - -static int yy_get_next_buffer() - { - register char *dest = yy_current_buffer->yy_ch_buf; - register char *source = yytext_ptr; - register int number_to_move, i; - int ret_val; - - if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) - YY_FATAL_ERROR( - "fatal flex scanner internal error--end of buffer missed" ); - - if ( yy_current_buffer->yy_fill_buffer == 0 ) - { /* Don't try to fill the buffer, so this is an EOF. */ - if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) - { - /* We matched a single character, the EOB, so - * treat this as a final EOF. - */ - return EOB_ACT_END_OF_FILE; - } - - else - { - /* We matched some text prior to the EOB, first - * process it. - */ - return EOB_ACT_LAST_MATCH; - } - } - - /* Try to read more data. */ - - /* First move last chars to start of buffer. */ - number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1; - - for ( i = 0; i < number_to_move; ++i ) - *(dest++) = *(source++); - - if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) - /* don't do the read, it's not guaranteed to return an EOF, - * just force an EOF - */ - yy_current_buffer->yy_n_chars = yy_n_chars = 0; - - else - { - int num_to_read = - yy_current_buffer->yy_buf_size - number_to_move - 1; - - while ( num_to_read <= 0 ) - { /* Not enough room in the buffer - grow it. */ -#ifdef YY_USES_REJECT - YY_FATAL_ERROR( -"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); -#else - - /* just a shorter name for the current buffer */ - YY_BUFFER_STATE b = yy_current_buffer; - - int yy_c_buf_p_offset = - (int) (yy_c_buf_p - b->yy_ch_buf); - - if ( b->yy_is_our_buffer ) - { - int new_size = b->yy_buf_size * 2; - - if ( new_size <= 0 ) - b->yy_buf_size += b->yy_buf_size / 8; - else - b->yy_buf_size *= 2; - - b->yy_ch_buf = (char *) - /* Include room in for 2 EOB chars. */ - yy_flex_realloc( (void *) b->yy_ch_buf, - b->yy_buf_size + 2 ); - } - else - /* Can't grow it, we don't own it. */ - b->yy_ch_buf = 0; - - if ( ! b->yy_ch_buf ) - YY_FATAL_ERROR( - "fatal error - scanner input buffer overflow" ); - - yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; - - num_to_read = yy_current_buffer->yy_buf_size - - number_to_move - 1; -#endif - } - - if ( num_to_read > YY_READ_BUF_SIZE ) - num_to_read = YY_READ_BUF_SIZE; - - /* Read in more data. */ - YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), - yy_n_chars, num_to_read ); - - yy_current_buffer->yy_n_chars = yy_n_chars; - } - - if ( yy_n_chars == 0 ) - { - if ( number_to_move == YY_MORE_ADJ ) - { - ret_val = EOB_ACT_END_OF_FILE; - yyrestart( yyin ); - } - - else - { - ret_val = EOB_ACT_LAST_MATCH; - yy_current_buffer->yy_buffer_status = - YY_BUFFER_EOF_PENDING; - } - } - - else - ret_val = EOB_ACT_CONTINUE_SCAN; - - yy_n_chars += number_to_move; - yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; - yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; - - yytext_ptr = &yy_current_buffer->yy_ch_buf[0]; - - return ret_val; - } - - -/* yy_get_previous_state - get the state just before the EOB char was reached */ - -static yy_state_type yy_get_previous_state() - { - register yy_state_type yy_current_state; - register char *yy_cp; - - yy_current_state = yy_start; - yy_current_state += YY_AT_BOL(); - yy_state_ptr = yy_state_buf; - *yy_state_ptr++ = yy_current_state; - - for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) - { - register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); - while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) - { - yy_current_state = (int) yy_def[yy_current_state]; - if ( yy_current_state >= 711 ) - yy_c = yy_meta[(unsigned int) yy_c]; - } - yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; - *yy_state_ptr++ = yy_current_state; - } - - return yy_current_state; - } - - -/* yy_try_NUL_trans - try to make a transition on the NUL character - * - * synopsis - * next_state = yy_try_NUL_trans( current_state ); - */ - -#ifdef YY_USE_PROTOS -static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) -#else -static yy_state_type yy_try_NUL_trans( yy_current_state ) -yy_state_type yy_current_state; -#endif - { - register int yy_is_jam; - - register YY_CHAR yy_c = 1; - while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) - { - yy_current_state = (int) yy_def[yy_current_state]; - if ( yy_current_state >= 711 ) - yy_c = yy_meta[(unsigned int) yy_c]; - } - yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; - yy_is_jam = (yy_current_state == 710); - if ( ! yy_is_jam ) - *yy_state_ptr++ = yy_current_state; - - return yy_is_jam ? 0 : yy_current_state; - } - - -#ifndef YY_NO_UNPUT -#ifdef YY_USE_PROTOS -static void yyunput( int c, register char *yy_bp ) -#else -static void yyunput( c, yy_bp ) -int c; -register char *yy_bp; -#endif - { - register char *yy_cp = yy_c_buf_p; - - /* undo effects of setting up yytext */ - *yy_cp = yy_hold_char; - - if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) - { /* need to shift things up to make room */ - /* +2 for EOB chars. */ - register int number_to_move = yy_n_chars + 2; - register char *dest = &yy_current_buffer->yy_ch_buf[ - yy_current_buffer->yy_buf_size + 2]; - register char *source = - &yy_current_buffer->yy_ch_buf[number_to_move]; - - while ( source > yy_current_buffer->yy_ch_buf ) - *--dest = *--source; - - yy_cp += (int) (dest - source); - yy_bp += (int) (dest - source); - yy_current_buffer->yy_n_chars = - yy_n_chars = yy_current_buffer->yy_buf_size; - - if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) - YY_FATAL_ERROR( "flex scanner push-back overflow" ); - } - - *--yy_cp = (char) c; - - - yytext_ptr = yy_bp; - yy_hold_char = *yy_cp; - yy_c_buf_p = yy_cp; - } -#endif /* ifndef YY_NO_UNPUT */ - - -#ifdef __cplusplus -static int yyinput() -#else -static int input() -#endif - { - int c; - - *yy_c_buf_p = yy_hold_char; - - if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) - { - /* yy_c_buf_p now points to the character we want to return. - * If this occurs *before* the EOB characters, then it's a - * valid NUL; if not, then we've hit the end of the buffer. - */ - if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) - /* This was really a NUL. */ - *yy_c_buf_p = '\0'; - - else - { /* need more input */ - int offset = yy_c_buf_p - yytext_ptr; - ++yy_c_buf_p; - - switch ( yy_get_next_buffer() ) - { - case EOB_ACT_LAST_MATCH: - /* This happens because yy_g_n_b() - * sees that we've accumulated a - * token and flags that we need to - * try matching the token before - * proceeding. But for input(), - * there's no matching to consider. - * So convert the EOB_ACT_LAST_MATCH - * to EOB_ACT_END_OF_FILE. - */ - - /* Reset buffer status. */ - yyrestart( yyin ); - - /* fall through */ - - case EOB_ACT_END_OF_FILE: - { - if ( yywrap() ) - return EOF; - - if ( ! yy_did_buffer_switch_on_eof ) - YY_NEW_FILE; -#ifdef __cplusplus - return yyinput(); -#else - return input(); -#endif - } - - case EOB_ACT_CONTINUE_SCAN: - yy_c_buf_p = yytext_ptr + offset; - break; - } - } - } - - c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ - *yy_c_buf_p = '\0'; /* preserve yytext */ - yy_hold_char = *++yy_c_buf_p; - - yy_current_buffer->yy_at_bol = (c == '\n'); - - return c; - } - - -#ifdef YY_USE_PROTOS -void yyrestart( FILE *input_file ) -#else -void yyrestart( input_file ) -FILE *input_file; -#endif - { - if ( ! yy_current_buffer ) - yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); - - yy_init_buffer( yy_current_buffer, input_file ); - yy_load_buffer_state(); - } - - -#ifdef YY_USE_PROTOS -void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) -#else -void yy_switch_to_buffer( new_buffer ) -YY_BUFFER_STATE new_buffer; -#endif - { - if ( yy_current_buffer == new_buffer ) - return; - - if ( yy_current_buffer ) - { - /* Flush out information for old buffer. */ - *yy_c_buf_p = yy_hold_char; - yy_current_buffer->yy_buf_pos = yy_c_buf_p; - yy_current_buffer->yy_n_chars = yy_n_chars; - } - - yy_current_buffer = new_buffer; - yy_load_buffer_state(); - - /* We don't actually know whether we did this switch during - * EOF (yywrap()) processing, but the only time this flag - * is looked at is after yywrap() is called, so it's safe - * to go ahead and always set it. - */ - yy_did_buffer_switch_on_eof = 1; - } - - -#ifdef YY_USE_PROTOS -void yy_load_buffer_state( void ) -#else -void yy_load_buffer_state() -#endif - { - yy_n_chars = yy_current_buffer->yy_n_chars; - yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; - yyin = yy_current_buffer->yy_input_file; - yy_hold_char = *yy_c_buf_p; - } - - -#ifdef YY_USE_PROTOS -YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) -#else -YY_BUFFER_STATE yy_create_buffer( file, size ) -FILE *file; -int size; -#endif - { - YY_BUFFER_STATE b; - - b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); - if ( ! b ) - YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); - - b->yy_buf_size = size; - - /* yy_ch_buf has to be 2 characters longer than the size given because - * we need to put in 2 end-of-buffer characters. - */ - b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); - if ( ! b->yy_ch_buf ) - YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); - - b->yy_is_our_buffer = 1; - - yy_init_buffer( b, file ); - - return b; - } - - -#ifdef YY_USE_PROTOS -void yy_delete_buffer( YY_BUFFER_STATE b ) -#else -void yy_delete_buffer( b ) -YY_BUFFER_STATE b; -#endif - { - if ( ! b ) - return; - - if ( b == yy_current_buffer ) - yy_current_buffer = (YY_BUFFER_STATE) 0; - - if ( b->yy_is_our_buffer ) - yy_flex_free( (void *) b->yy_ch_buf ); - - yy_flex_free( (void *) b ); - } - - -#ifndef YY_ALWAYS_INTERACTIVE -#ifndef YY_NEVER_INTERACTIVE -extern int isatty YY_PROTO(( int )); -#endif -#endif - -#ifdef YY_USE_PROTOS -void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) -#else -void yy_init_buffer( b, file ) -YY_BUFFER_STATE b; -FILE *file; -#endif - - - { - yy_flush_buffer( b ); - - b->yy_input_file = file; - b->yy_fill_buffer = 1; - -#if YY_ALWAYS_INTERACTIVE - b->yy_is_interactive = 1; -#else -#if YY_NEVER_INTERACTIVE - b->yy_is_interactive = 0; -#else - b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; -#endif -#endif - } - - -#ifdef YY_USE_PROTOS -void yy_flush_buffer( YY_BUFFER_STATE b ) -#else -void yy_flush_buffer( b ) -YY_BUFFER_STATE b; -#endif - - { - if ( ! b ) - return; - - b->yy_n_chars = 0; - - /* We always need two end-of-buffer characters. The first causes - * a transition to the end-of-buffer state. The second causes - * a jam in that state. - */ - b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; - b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; - - b->yy_buf_pos = &b->yy_ch_buf[0]; - - b->yy_at_bol = 1; - b->yy_buffer_status = YY_BUFFER_NEW; - - if ( b == yy_current_buffer ) - yy_load_buffer_state(); - } - - -#ifndef YY_NO_SCAN_BUFFER -#ifdef YY_USE_PROTOS -YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size ) -#else -YY_BUFFER_STATE yy_scan_buffer( base, size ) -char *base; -yy_size_t size; -#endif - { - YY_BUFFER_STATE b; - - if ( size < 2 || - base[size-2] != YY_END_OF_BUFFER_CHAR || - base[size-1] != YY_END_OF_BUFFER_CHAR ) - /* They forgot to leave room for the EOB's. */ - return 0; - - b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); - if ( ! b ) - YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); - - b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ - b->yy_buf_pos = b->yy_ch_buf = base; - b->yy_is_our_buffer = 0; - b->yy_input_file = 0; - b->yy_n_chars = b->yy_buf_size; - b->yy_is_interactive = 0; - b->yy_at_bol = 1; - b->yy_fill_buffer = 0; - b->yy_buffer_status = YY_BUFFER_NEW; - - yy_switch_to_buffer( b ); - - return b; - } -#endif - - -#ifndef YY_NO_SCAN_STRING -#ifdef YY_USE_PROTOS -YY_BUFFER_STATE yy_scan_string( yyconst char *yy_str ) -#else -YY_BUFFER_STATE yy_scan_string( yy_str ) -yyconst char *yy_str; -#endif - { - int len; - for ( len = 0; yy_str[len]; ++len ) - ; - - return yy_scan_bytes( yy_str, len ); - } -#endif - - -#ifndef YY_NO_SCAN_BYTES -#ifdef YY_USE_PROTOS -YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len ) -#else -YY_BUFFER_STATE yy_scan_bytes( bytes, len ) -yyconst char *bytes; -int len; -#endif - { - YY_BUFFER_STATE b; - char *buf; - yy_size_t n; - int i; - - /* Get memory for full buffer, including space for trailing EOB's. */ - n = len + 2; - buf = (char *) yy_flex_alloc( n ); - if ( ! buf ) - YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); - - for ( i = 0; i < len; ++i ) - buf[i] = bytes[i]; - - buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR; - - b = yy_scan_buffer( buf, n ); - if ( ! b ) - YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); - - /* It's okay to grow etc. this buffer, and we should throw it - * away when we're done. - */ - b->yy_is_our_buffer = 1; - - return b; - } -#endif - - -#ifndef YY_NO_PUSH_STATE -#ifdef YY_USE_PROTOS -static void yy_push_state( int new_state ) -#else -static void yy_push_state( new_state ) -int new_state; -#endif - { - if ( yy_start_stack_ptr >= yy_start_stack_depth ) - { - yy_size_t new_size; - - yy_start_stack_depth += YY_START_STACK_INCR; - new_size = yy_start_stack_depth * sizeof( int ); - - if ( ! yy_start_stack ) - yy_start_stack = (int *) yy_flex_alloc( new_size ); - - else - yy_start_stack = (int *) yy_flex_realloc( - (void *) yy_start_stack, new_size ); - - if ( ! yy_start_stack ) - YY_FATAL_ERROR( - "out of memory expanding start-condition stack" ); - } - - yy_start_stack[yy_start_stack_ptr++] = YY_START; - - BEGIN(new_state); - } -#endif - - -#ifndef YY_NO_POP_STATE -static void yy_pop_state() - { - if ( --yy_start_stack_ptr < 0 ) - YY_FATAL_ERROR( "start-condition stack underflow" ); - - BEGIN(yy_start_stack[yy_start_stack_ptr]); - } -#endif - - -#ifndef YY_NO_TOP_STATE -static int yy_top_state() - { - return yy_start_stack[yy_start_stack_ptr - 1]; - } -#endif - -#ifndef YY_EXIT_FAILURE -#define YY_EXIT_FAILURE 2 -#endif - -#ifdef YY_USE_PROTOS -static void yy_fatal_error( yyconst char msg[] ) -#else -static void yy_fatal_error( msg ) -char msg[]; -#endif - { - (void) fprintf( stderr, "%s\n", msg ); - exit( YY_EXIT_FAILURE ); - } - - - -/* Redefine yyless() so it works in section 3 code. */ - -#undef yyless -#define yyless(n) \ - do \ - { \ - /* Undo effects of setting up yytext. */ \ - yytext[yyleng] = yy_hold_char; \ - yy_c_buf_p = yytext + n; \ - yy_hold_char = *yy_c_buf_p; \ - *yy_c_buf_p = '\0'; \ - yyleng = n; \ - } \ - while ( 0 ) - - -/* Internal utility routines. */ - -#ifndef yytext_ptr -#ifdef YY_USE_PROTOS -static void yy_flex_strncpy( char *s1, yyconst char *s2, int n ) -#else -static void yy_flex_strncpy( s1, s2, n ) -char *s1; -yyconst char *s2; -int n; -#endif - { - register int i; - for ( i = 0; i < n; ++i ) - s1[i] = s2[i]; - } -#endif - -#ifdef YY_NEED_STRLEN -#ifdef YY_USE_PROTOS -static int yy_flex_strlen( yyconst char *s ) -#else -static int yy_flex_strlen( s ) -yyconst char *s; -#endif - { - register int n; - for ( n = 0; s[n]; ++n ) - ; - - return n; - } -#endif - - -#ifdef YY_USE_PROTOS -static void *yy_flex_alloc( yy_size_t size ) -#else -static void *yy_flex_alloc( size ) -yy_size_t size; -#endif - { - return (void *) malloc( size ); - } - -#ifdef YY_USE_PROTOS -static void *yy_flex_realloc( void *ptr, yy_size_t size ) -#else -static void *yy_flex_realloc( ptr, size ) -void *ptr; -yy_size_t size; -#endif - { - /* The cast to (char *) in the following accommodates both - * implementations that use char* generic pointers, and those - * that use void* generic pointers. It works with the latter - * because both ANSI C and C++ allow castless assignment from - * any pointer type to void*, and deal with argument conversions - * as though doing an assignment. - */ - return (void *) realloc( (char *) ptr, size ); - } - -#ifdef YY_USE_PROTOS -static void yy_flex_free( void *ptr ) -#else -static void yy_flex_free( ptr ) -void *ptr; -#endif - { - free( ptr ); - } - -#if YY_MAIN -int main() - { - yylex(); - return 0; - } -#endif -#line 217 "forlex.lex" - - - -int yywrap(void){ return 1; } - -void lexerr(char *meldung, ...){ - va_list args; - - va_start(args,meldung); /* make args point to first argument of list */ - fprintf(stderr,"lexerr: error in line %d:\n",lineno); - vfprintf(stderr,meldung,args); - fprintf(stderr,"\n"); - va_end(args); /* clear-up arg-list */ - - exit(1); -} - - -void wdebug(char *meldung, ...){ - va_list args; -#ifdef DEBUG - va_start(args,meldung); /* make args point to first argument of list */ - vfprintf(stderr,meldung,args); - fprintf(stderr,"\n"); - va_end(args); /* clear-up arg-list */ -#endif - return; -} - - -int getc_safe(FILE *fp){ - static int eof=0; - int c; - if( eof ) return EOF; - c=getc(fp); - if( c==EOF ) eof=1; - return c; -} - - -int getcc(void){} -int getcs(void){} - - -/* get first non-blank char in s */ -char get1c(char* s){ - char* cp; - for( cp=yytext; *cp!=' '&&*cp!='\0'; ++cp ); - return *cp; -} - - -/* get identifier from s and put it in id */ -void getid(char* s, char* id){ - char* cp=s; - while(*cp && *cp!=' ') ++cp; - if( !isalpha(*cp) ) lexerr("illegal identifier in \"%s\"",s); - *s=*cp; - while( *cp && (isalnum(c)||c=='_') ) *++s=*++cp; - return; -} - - -/* reads string str from input until one of the chars in lim or EOF - is encountered - returns the last character encountered - if str==NULL skip characters instead of putting them in str; -*/ -int getstr(char* str, char* lim){ - int l,n,j,t,e; - char c; - - l=strlen(lim); n=0; - do { - c=t=input(); - for( j=0,e=0; j0 ) c=buf[n++]=' '; /* no tabs remain */ - } - else if( c=='!' || c=='\n' || c==';' ){ /* end command */ - if( pc==' ' || pc=='\n' ) --n; /* kill trailing whitespace */ - buf[n++]='\n'; - if( c!=';' ) c='\n'; /* ';' ends command, not line */ - ++p; - } - else if( c=='&' ){ /* continue line */ - c=*(skpws(p+1)); - if( c!='!' && c!='\n' ) lexerr( - "only comments or whitespace allowed after continuation mark (&)"); - do { /* skip inline-comments */ - if( (l=readzeile(inpline))==0 ) - lexerr("unexpected end of file after continuation mark (&)"); - } while( *(skpws(inpline))=='!' ); - p=skpws(inpline); c='\0'; - if( *p=='&' ) ++p; - } - else { buf[n++]=c; ++p; } - } - /* at this point p points to the next char to be read */ - if( c!='\0' ) pc=c; /* c=='\0' means no char added to buf */ - if( n>=max_size ) lexerr("OOOOPS... line to long (>=%d)",max_size); - } while( c!='\n' ); - - return n; -} - - -/* read a line of at most 72 chars, skip rest of line, return last char read */ -int rzeile(int r, char zeile[]){ - static int c='\0'; - int j; - - if( !r && *zeile ) return c; - for( j=0; j<72 && (c=getc(yyin))!=EOF && c!='\n'; ) zeile[j++]=c; - while( c!='\n' && c!=EOF ) c=getc(yyin); /* skip to end of line */ - zeile[j]='\0'; ++lineno; - - return c; -} - - -/* check if zeile is continuation line */ -int contline(char zeile[]){ - int j; - if( tolower(zeile[0])=='c' ) return 0; - if( strlen(zeile)<6 ) return 0; - for( j=0; j<6; ++j ) if( zeile[j]=='\t' ) return 0; - if( zeile[5]==' ' ) return 0; - return 1; -} - - -/* get a fixed-format command, skipping double blanks and comments - and joining lines */ -int getfixed(char buf[],unsigned max_size){ - static char zeile[73]=""; - int c,cc,n=0,pc=0,j; - int istr=0; - static int fine=0; - - cc=rzeile(0,zeile); /* read only if not already present */ - while( tolower(*zeile)=='c' ){ - do{ - cc=rzeile(1,zeile); - } while( contline(zeile) ); - } - if( *zeile=='\0' && cc==EOF ) return YY_NULL; - - j=0; - do{ - while( j0 && pc!=' ' ) buf[n++]=' '; } /* no tabs remain */ - else buf[n++]=c; - } - if( n>0 ) pc=buf[n-1]; - ++j; - } - cc=rzeile(1,zeile); j=6; - } while( contline(zeile) ); - buf[n++]='\n'; buf[n]='\0'; - if( n>max_size ) lexerr("OOOOPS... line to long (>%d)",max_size); - if( istr ) lexerr("line ended while reading string const"); - for( j=n-1; j>0 && buf[j]==' '; ){ buf[j]=buf[j+1]; buf[j+1]='\0'; --j,--n; } - return n; -} - - -/* wget: input routine: - get a command, skipping double blanks and comments and joining lines */ -int wget(char buf[],unsigned max_size){ - int j,n; - - switch( fixed ){ - case 0: n=getfree(buf,max_size); break; - case 1: n=getfixed(buf,max_size); break; - default: parerr("PANICO: wrong value of fixed in wget()"); - } - for( j=0; j0 && line[n-1]=='\n' ) line[n-1]='\0'; else line[n]='\0'; - wdebug("Read line: %s",buf); - - return n; -} - - -char* push(char* s){ - char* p=sp; - strcpy(sp,s); sp+=strlen(sp)+1; - if( sp>spmax ) spmax=sp; - return p; -} - - -void strt_ni(){ - yy_push_state(NURID); ++nstrt; - wdebug("strt_ni: state now is %d (n=%d)",YY_START,nstrt); -} - - -void mm(){ - if( !submod ) return; - if( ext ){ ext=0; BEGIN(M); } - yy_push_state(MM); ++nstrt; - wdebug("strt_ni(mm): state now is %d (n=%d)",YY_START,nstrt); -} - - -void un_strt(){ - while( nstrt>0 && yy_top_state()==YY_START){ yy_pop_state(); --nstrt;} - if( nstrt>0 ){ yy_pop_state(); --nstrt;} - wdebug("un_strt: state now is %d (n=%d)",YY_START,nstrt); -} - -void zr_strt(){ - wdebug("reset start-state stack"); - while(nstrt>0){ yy_pop_state(); --nstrt; } -} - -void loc(char* s){ while( *s && s ){ *s=tolower(*s); ++s; } } - -/* zap whitespace */ -int zapw(char* s){ - int j; - char* p; - for( p=s; *p!='\0'; ++p ){} -} - -/* -int yywrap(void){ return 1; } - - -int main(void){ - while( yylex()!=EOF ); -} -*/ diff --git a/tools/forpar.h b/tools/forpar.h deleted file mode 100644 index 9d1302f..0000000 --- a/tools/forpar.h +++ /dev/null @@ -1,47 +0,0 @@ -#include -#include -#include -#include /* needed for variable num. of parameters to w_fehler */ -#include "slist.h" /* sorted lists of char* */ -#if defined ( __DECC ) -#include -#endif - -#define YYSTYPE char* - -#define NI wws='n'; -#define YK wws='b'; - -int wws=0, fixed=0, chkint=0, ok=0, lineno=0, filedep=1; -int submod=1, cont=0, ext=1, internal=0, interf=0, wstat='\0'; - -int private=0, public=1; -int on=1; - -#define KB *1024 -#define MB *1048576 - -int indent=0, dind=2, nargbuf=-1, nfunname=-1; -slist *pub_l=NULL, *pri_l=NULL, *pl; -slist *use_l=NULL; -char stack[16 KB], *sp=stack, *spmax=stack; -char heap[64 KB], *hp=heap, *hpmax=heap; -char line[4 KB], inpline[16 KB], argbuf[3][4 KB], *args; -char modname[64], typename[64], intername[64]; /*module, type, interface name*/ -char proname[64], buffunname[3][64], *funname; /* program, funct-subroutine */ -char dimension[1 KB]=""; /* dimension of array */ -char semp[1]=""; -char *command; /* name of command (*argv[0]) */ -FILE *flout; -char fnin[256]="", fnout[256]="", fnold[256]="", path[256]=""; -char *pc; /* temporary pointer to char */ - -void parerr(char *meldung, ...); -void parwarn(char *meldung, ...); -char* find(char* pat,char* in); -char* present(char* tok, char* list, char* delim); -char* spr(int m, char* format,...); -void printw(int m, char* format,...); -int ispub(char* name); -int check_ext(int* c); -FILE *newfile(char *fnin, char *fnout, int open, int addpath); diff --git a/tools/forpar.tab.c b/tools/forpar.tab.c deleted file mode 100644 index 7b8f82f..0000000 --- a/tools/forpar.tab.c +++ /dev/null @@ -1,2518 +0,0 @@ - -/* A Bison parser, made from forpar.y - by GNU Bison version 1.25 - */ - -#define YYBISON 1 /* Identify Bison output. */ - -#define MODULE 258 -#define ENDMOD 259 -#define CONTAINS 260 -#define PROGRAM 261 -#define INTEGER 262 -#define REAL 263 -#define DPREC 264 -#define COMPLEX 265 -#define CHARACTER 266 -#define LOGICAL 267 -#define TYPE 268 -#define ENDTYPE 269 -#define USE 270 -#define ONLY 271 -#define OPERATOR 272 -#define ASSIGNMENT 273 -#define ID 274 -#define CID 275 -#define POINT 276 -#define ARBCHARLEN 277 -#define DCOLON 278 -#define ARRIN 279 -#define ARROUT 280 -#define IMPLICIT 281 -#define IMPLNONE 282 -#define PARAMETER 283 -#define OPER 284 -#define DEFOPER 285 -#define REALC 286 -#define STRC 287 -#define LOGC 288 -#define INTERFACE 289 -#define ENDINTER 290 -#define MODPROC 291 -#define RECURSIVE 292 -#define PURE 293 -#define ELEMENTAL 294 -#define FUNCTION 295 -#define RESULT 296 -#define ENDFUN 297 -#define SUBROUTINE 298 -#define ENDSUB 299 -#define END 300 -#define EOC 301 -#define UNKNOWN 302 -#define PUBLIC 303 -#define PRIVATE 304 -#define SEQUENCE 305 -#define ALLOCATABLE 306 -#define DIMENSION 307 -#define EXTERNAL 308 -#define INTENT 309 -#define IN 310 -#define OUT 311 -#define INOUT 312 -#define INTRINSIC 313 -#define OPTIONAL 314 -#define POINTER 315 -#define SAVE 316 -#define TARGET 317 -#define FORMAT 318 -#define ENTRY 319 -#define MODULSUB 320 - -#line 34 "forpar.y" - -#define YYDEBUG 1 -#undef YYDEBUG -#include "forpar.h" -extern FILE* yyin; -#ifndef YYSTYPE -#define YYSTYPE int -#endif -#include - -#ifndef __cplusplus -#ifndef __STDC__ -#define const -#endif -#endif - - - -#define YYFINAL 460 -#define YYFLAG -32768 -#define YYNTBASE 74 - -#define YYTRANSLATE(x) ((unsigned)(x) <= 320 ? yytranslate[x] : 221) - -static const char yytranslate[] = { 0, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 67, - 68, 73, 70, 66, 71, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 72, 2, 2, - 69, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 1, 2, 3, 4, 5, - 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, - 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, - 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, - 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, - 56, 57, 58, 59, 60, 61, 62, 63, 64, 65 -}; - -#if YYDEBUG != 0 -static const short yyprhs[] = { 0, - 0, 2, 4, 6, 8, 12, 14, 16, 19, 24, - 28, 32, 33, 36, 38, 39, 42, 43, 46, 51, - 52, 55, 57, 59, 63, 64, 66, 68, 72, 73, - 77, 81, 85, 87, 89, 91, 96, 98, 100, 102, - 104, 107, 108, 111, 117, 119, 123, 127, 129, 131, - 133, 135, 137, 140, 143, 145, 147, 152, 155, 159, - 163, 165, 167, 169, 171, 173, 177, 179, 183, 189, - 191, 193, 195, 197, 199, 201, 203, 205, 207, 209, - 211, 213, 218, 223, 224, 225, 234, 236, 238, 241, - 242, 245, 248, 251, 253, 256, 257, 263, 264, 265, - 266, 276, 278, 282, 283, 284, 291, 293, 296, 300, - 303, 308, 311, 316, 318, 322, 324, 328, 330, 334, - 336, 338, 343, 344, 346, 347, 352, 353, 359, 360, - 361, 362, 372, 374, 378, 383, 384, 387, 390, 395, - 399, 400, 404, 405, 408, 409, 411, 412, 416, 417, - 421, 422, 425, 426, 430, 431, 435, 436, 440, 445, - 446, 450, 456, 459, 460, 464, 470, 473, 475, 477, - 479, 481, 485, 487, 489, 491, 493, 494, 495, 502, - 504, 506, 508, 510, 512, 514, 516, 521, 523, 525, - 527, 531, 534, 537, 541, 543, 545, 547, 549, 553, - 557, 561, 565, 567, 570, 572, 574, 576, 578, 582, - 584, 588, 594, 600, 601, 604, 606, 607, 612, 613, - 619, 620, 621, 622, 632, 634, 638, 643, 644, 654, - 660, 662, 664, 666, 670, 672, 676, 677, 682, 683, - 685, 686, 690, 692, 696, 698, 700, 701, 703, 705, - 707, 709, 710, 712, 715, 716, 719, 722, 729, 736, - 742, 748, 749, 752, 754, 756, 758, 760, 764, 767, - 769, 771, 772, 774, 776, 779, 780, 782, 783, 785, - 787, 789, 792, 793 -}; - -static const short yyrhs[] = { 75, - 0, 77, 0, 78, 0, 76, 0, 6, 19, 46, - 0, 203, 0, 79, 0, 78, 79, 0, 80, 81, - 201, 220, 0, 3, 19, 46, 0, 83, 84, 85, - 0, 0, 82, 86, 0, 82, 0, 0, 84, 96, - 0, 0, 85, 111, 0, 15, 19, 89, 46, 0, - 0, 87, 88, 0, 86, 0, 92, 0, 66, 16, - 90, 0, 0, 91, 0, 94, 0, 91, 66, 94, - 0, 0, 92, 66, 93, 0, 19, 21, 19, 0, - 95, 21, 95, 0, 93, 0, 19, 0, 95, 0, - 17, 67, 110, 68, 0, 97, 0, 99, 0, 217, - 0, 218, 0, 27, 46, 0, 0, 98, 97, 0, - 28, 67, 100, 68, 46, 0, 101, 0, 100, 66, - 101, 0, 19, 69, 104, 0, 103, 0, 32, 0, - 33, 0, 109, 0, 31, 0, 70, 31, 0, 71, - 31, 0, 102, 0, 105, 0, 105, 67, 107, 68, - 0, 110, 104, 0, 104, 110, 104, 0, 67, 104, - 68, 0, 19, 0, 20, 0, 104, 0, 72, 0, - 106, 0, 107, 66, 106, 0, 104, 0, 108, 66, - 104, 0, 67, 103, 66, 103, 68, 0, 29, 0, - 30, 0, 73, 0, 113, 0, 168, 0, 138, 0, - 112, 0, 99, 0, 217, 0, 218, 0, 117, 0, - 118, 0, 114, 119, 121, 131, 0, 13, 216, 19, - 46, 0, 0, 0, 13, 66, 115, 164, 23, 116, - 19, 46, 0, 132, 0, 133, 0, 61, 46, 0, - 0, 119, 120, 0, 49, 46, 0, 50, 46, 0, - 122, 0, 121, 122, 0, 0, 150, 123, 216, 144, - 46, 0, 0, 0, 0, 150, 124, 66, 125, 127, - 23, 126, 144, 46, 0, 128, 0, 127, 66, 128, - 0, 0, 0, 52, 67, 129, 167, 130, 68, 0, - 60, 0, 14, 46, 0, 14, 19, 46, 0, 49, - 46, 0, 49, 216, 135, 46, 0, 48, 46, 0, - 48, 216, 134, 46, 0, 136, 0, 134, 66, 136, - 0, 136, 0, 0, 66, 136, 0, 136, 0, 135, - 66, 136, 0, 19, 0, 95, 0, 18, 67, 69, - 68, 0, 0, 136, 0, 0, 150, 139, 144, 46, - 0, 0, 150, 140, 23, 144, 46, 0, 0, 0, - 0, 150, 141, 66, 142, 160, 23, 143, 144, 46, - 0, 145, 0, 144, 66, 145, 0, 19, 148, 149, - 146, 0, 0, 69, 104, 0, 69, 147, 0, 21, - 19, 67, 68, 0, 24, 108, 25, 0, 0, 67, - 167, 68, 0, 0, 73, 104, 0, 0, 158, 0, - 0, 7, 151, 157, 0, 0, 8, 152, 157, 0, - 0, 9, 153, 0, 0, 10, 154, 157, 0, 0, - 11, 155, 158, 0, 0, 12, 156, 157, 0, 13, - 67, 19, 68, 0, 0, 67, 104, 68, 0, 67, - 19, 69, 104, 68, 0, 73, 31, 0, 0, 67, - 159, 68, 0, 67, 19, 69, 159, 68, 0, 73, - 104, 0, 22, 0, 73, 0, 104, 0, 161, 0, - 160, 66, 161, 0, 28, 0, 48, 0, 49, 0, - 51, 0, 0, 0, 52, 67, 162, 167, 163, 68, - 0, 53, 0, 164, 0, 58, 0, 59, 0, 60, - 0, 61, 0, 62, 0, 54, 67, 165, 68, 0, - 55, 0, 56, 0, 57, 0, 104, 72, 104, 0, - 104, 72, 0, 72, 104, 0, 104, 72, 73, 0, - 104, 0, 73, 0, 72, 0, 166, 0, 167, 66, - 166, 0, 169, 171, 170, 0, 34, 137, 46, 0, - 35, 137, 46, 0, 172, 0, 171, 172, 0, 173, - 0, 174, 0, 176, 0, 177, 0, 36, 175, 46, - 0, 19, 0, 175, 66, 19, 0, 188, 87, 98, - 178, 191, 0, 190, 87, 98, 178, 192, 0, 0, - 178, 179, 0, 180, 0, 0, 150, 181, 186, 46, - 0, 0, 150, 182, 23, 186, 46, 0, 0, 0, - 0, 150, 183, 66, 184, 160, 23, 185, 186, 46, - 0, 187, 0, 186, 66, 187, 0, 19, 148, 149, - 146, 0, 0, 200, 40, 19, 67, 196, 68, 189, - 195, 46, 0, 200, 43, 19, 197, 46, 0, 193, - 0, 194, 0, 45, 0, 42, 215, 46, 0, 45, - 0, 44, 215, 46, 0, 0, 41, 67, 19, 68, - 0, 0, 198, 0, 0, 67, 196, 68, 0, 199, - 0, 198, 66, 199, 0, 19, 0, 73, 0, 0, - 150, 0, 37, 0, 38, 0, 39, 0, 0, 202, - 0, 219, 203, 0, 0, 203, 205, 0, 203, 204, - 0, 188, 87, 98, 208, 213, 191, 0, 190, 87, - 98, 208, 213, 192, 0, 188, 87, 98, 208, 191, - 0, 190, 87, 98, 208, 192, 0, 0, 208, 209, - 0, 179, 0, 112, 0, 210, 0, 218, 0, 169, - 171, 170, 0, 219, 214, 0, 206, 0, 207, 0, - 0, 211, 0, 212, 0, 214, 212, 0, 0, 19, - 0, 0, 23, 0, 63, 0, 64, 0, 5, 46, - 0, 0, 4, 215, 46, 0 -}; - -#endif - -#if YYDEBUG != 0 -static const short yyrline[] = { 0, - 69, 70, 71, 74, 79, 87, 94, 95, 97, 100, - 107, 122, 123, 125, 128, 129, 131, 132, 135, 137, - 138, 140, 142, 143, 145, 146, 148, 149, 151, 152, - 154, 155, 158, 159, 160, 163, 167, 168, 169, 170, - 172, 175, 176, 178, 180, 181, 183, 185, 185, 185, - 185, 187, 187, 187, 189, 190, 192, 193, 194, 195, - 197, 197, 199, 200, 202, 203, 205, 206, 208, 210, - 211, 212, 216, 217, 218, 219, 220, 221, 222, 225, - 226, 241, 244, 247, 247, 247, 250, 251, 254, 257, - 258, 260, 261, 263, 264, 266, 266, 268, 268, 268, - 268, 271, 272, 274, 274, 274, 276, 279, 280, 285, - 286, 288, 289, 291, 292, 294, 295, 297, 298, 300, - 301, 302, 304, 305, 308, 308, 310, 310, 312, 312, - 312, 312, 315, 316, 318, 320, 321, 322, 323, 327, - 329, 330, 332, 333, 335, 336, 338, 338, 339, 339, - 340, 340, 341, 341, 342, 342, 343, 343, 344, 348, - 349, 350, 354, 359, 360, 361, 365, 366, 368, 369, - 371, 372, 374, 375, 376, 377, 378, 378, 378, 379, - 380, 381, 382, 383, 384, 385, 387, 389, 389, 389, - 391, 392, 393, 394, 395, 396, 397, 399, 400, 404, - 406, 415, 424, 425, 427, 428, 430, 431, 433, 435, - 436, 438, 440, 442, 443, 445, 448, 448, 450, 450, - 452, 452, 452, 452, 455, 456, 463, 471, 471, 485, - 497, 508, 519, 520, 522, 523, 525, 526, 528, 529, - 531, 532, 534, 535, 537, 538, 540, 541, 542, 543, - 544, 546, 547, 549, 551, 552, 553, 555, 557, 559, - 561, 563, 564, 566, 567, 568, 569, 571, 573, 575, - 576, 578, 579, 581, 582, 587, 588, 591, 592, 596, - 597, 600, 609, 612 -}; -#endif - - -#if YYDEBUG != 0 || defined (YYERROR_VERBOSE) - -static const char * const yytname[] = { "$","error","$undefined.","MODULE", -"ENDMOD","CONTAINS","PROGRAM","INTEGER","REAL","DPREC","COMPLEX","CHARACTER", -"LOGICAL","TYPE","ENDTYPE","USE","ONLY","OPERATOR","ASSIGNMENT","ID","CID","\"=>\"", -"\"*(*)\"","\"::\"","\"(/\"","\"/)\"","IMPLICIT","IMPLNONE","PARAMETER","OPER", -"DEFOPER","REALC","STRC","LOGC","INTERFACE","ENDINTER","MODPROC","RECURSIVE", -"PURE","ELEMENTAL","FUNCTION","RESULT","ENDFUN","SUBROUTINE","ENDSUB","END", -"EOC","UNKNOWN","PUBLIC","PRIVATE","SEQUENCE","ALLOCATABLE","DIMENSION","EXTERNAL", -"INTENT","IN","OUT","INOUT","INTRINSIC","OPTIONAL","POINTER","SAVE","TARGET", -"FORMAT","ENTRY","MODULSUB","','","'('","')'","'='","'+'","'-'","':'","'*'", -"unit","program","program_s","extfunsub","module_l","module","module_s","specpart", -"use_s_l","use_slp","implpart_l","declconstr_l","use_s","use_spl","use_sp","usearg", -"only_lo","only_l","crename_l","rename","only","opera","implpart","implicit_s", -"implicit_sl","parameter_s","nconstdef_l","nconstdef","const","srealc","expr", -"gid","arfun","arfun_l","expr_l","cmplxconst","oper","declconstr","specific_s", -"dertypedef","dertype_s","@1","@2","access_s","save_s","privseq_sl","privseq_s", -"componentdef_l","componentdef","@3","@4","@5","@6","coattrspec_l","coattrspec", -"@7","@8","endtype_s","private_s","public_s","pub_l","modent_l","modent","modent_o", -"typedecl_s","@9","@10","@11","@12","@13","entitydec_l","entitydec","init_o", -"arrinit","arrspec_o","lensel_o","typespec","@14","@15","@16","@17","@18","@19", -"kindsel","lensel","charlen","attrspec_l","attrspec","@20","@21","accessspec", -"intentspec","arrs","arrspec","interfaceblk","interface_s","endinter_s","interfacespec_l", -"interfacespec","interbody","modproc_s","procname_l","interfunspec","intersubspec", -"interspec_l","interspec","itspec","@22","@23","@24","@25","@26","interent_l", -"interent","function_s","@27","subroutine_s","endfun_s","endsub_s","endoffun", -"endofsub","result_o","dummyarg_lo","subargs_o","dummyarg_l","dummyarg","prefix", -"modsub_o","modsub","modulsub_l","modulfun","modulsub","fun","sub","modspec_l", -"modspec","modinter","internal","funsub","internal_o","funsub_l","id_o","dcol_o", -"format_s","entry_s","contain_s","endmod_s", NULL -}; -#endif - -static const short yyr1[] = { 0, - 74, 74, 74, 75, 76, 77, 78, 78, 79, 80, - 81, 82, 82, 83, 84, 84, 85, 85, 86, 87, - 87, 88, 89, 89, 90, 90, 91, 91, 92, 92, - 93, 93, 94, 94, 94, 95, 96, 96, 96, 96, - 97, 98, 98, 99, 100, 100, 101, 102, 102, 102, - 102, 103, 103, 103, 104, 104, 104, 104, 104, 104, - 105, 105, 106, 106, 107, 107, 108, 108, 109, 110, - 110, 110, 111, 111, 111, 111, 111, 111, 111, 112, - 112, 113, 114, 115, 116, 114, 117, 117, 118, 119, - 119, 120, 120, 121, 121, 123, 122, 124, 125, 126, - 122, 127, 127, 129, 130, 128, 128, 131, 131, 132, - 132, 133, 133, 134, 134, -1, -1, 135, 135, 136, - 136, 136, 137, 137, 139, 138, 140, 138, 141, 142, - 143, 138, 144, 144, 145, 146, 146, 146, 146, 147, - 148, 148, -1, -1, 149, 149, 151, 150, 152, 150, - 153, 150, 154, 150, 155, 150, 156, 150, 150, 157, - 157, 157, 157, 158, 158, 158, 158, 158, 159, 159, - 160, 160, 161, 161, 161, 161, 162, 163, 161, 161, - 161, 161, 161, 161, 161, 161, 164, 165, 165, 165, - 166, 166, 166, 166, 166, 166, 166, 167, 167, 168, - 169, 170, 171, 171, 172, 172, 173, 173, 174, 175, - 175, 176, 177, 178, 178, 179, 181, 180, 182, 180, - 183, 184, 185, 180, 186, 186, 187, 189, 188, 190, - 191, 192, 193, 193, 194, 194, 195, 195, 196, 196, - 197, 197, 198, 198, 199, 199, 200, 200, 200, 200, - 200, 201, 201, 202, 203, 203, 203, 204, 205, 206, - 207, 208, 208, 209, 209, 209, 209, 210, 211, 212, - 212, 213, 213, 214, 214, 215, 215, 216, 216, 217, - 218, 219, 219, 220 -}; - -static const short yyr2[] = { 0, - 1, 1, 1, 1, 3, 1, 1, 2, 4, 3, - 3, 0, 2, 1, 0, 2, 0, 2, 4, 0, - 2, 1, 1, 3, 0, 1, 1, 3, 0, 3, - 3, 3, 1, 1, 1, 4, 1, 1, 1, 1, - 2, 0, 2, 5, 1, 3, 3, 1, 1, 1, - 1, 1, 2, 2, 1, 1, 4, 2, 3, 3, - 1, 1, 1, 1, 1, 3, 1, 3, 5, 1, - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, - 1, 4, 4, 0, 0, 8, 1, 1, 2, 0, - 2, 2, 2, 1, 2, 0, 5, 0, 0, 0, - 9, 1, 3, 0, 0, 6, 1, 2, 3, 2, - 4, 2, 4, 1, 3, 1, 3, 1, 3, 1, - 1, 4, 0, 1, 0, 4, 0, 5, 0, 0, - 0, 9, 1, 3, 4, 0, 2, 2, 4, 3, - 0, 3, 0, 2, 0, 1, 0, 3, 0, 3, - 0, 2, 0, 3, 0, 3, 0, 3, 4, 0, - 3, 5, 2, 0, 3, 5, 2, 1, 1, 1, - 1, 3, 1, 1, 1, 1, 0, 0, 6, 1, - 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, - 3, 2, 2, 3, 1, 1, 1, 1, 3, 3, - 3, 3, 1, 2, 1, 1, 1, 1, 3, 1, - 3, 5, 5, 0, 2, 1, 0, 4, 0, 5, - 0, 0, 0, 9, 1, 3, 4, 0, 9, 5, - 1, 1, 1, 3, 1, 3, 0, 4, 0, 1, - 0, 3, 1, 3, 1, 1, 0, 1, 1, 1, - 1, 0, 1, 2, 0, 2, 2, 6, 6, 5, - 5, 0, 2, 1, 1, 1, 1, 3, 2, 1, - 1, 0, 1, 1, 2, 0, 1, 0, 1, 1, - 1, 2, 0, 3 -}; - -static const short yydefact[] = { 255, - 0, 0, 1, 4, 2, 3, 7, 12, 247, 0, - 0, 8, 283, 14, 15, 147, 149, 151, 153, 155, - 157, 0, 249, 250, 251, 248, 20, 20, 0, 257, - 256, 10, 5, 0, 0, 253, 255, 0, 13, 17, - 160, 160, 152, 160, 164, 160, 0, 42, 42, 0, - 0, 282, 276, 9, 247, 29, 0, 0, 280, 281, - 11, 16, 37, 38, 39, 40, 0, 0, 148, 150, - 154, 168, 0, 0, 156, 158, 0, 22, 21, 262, - 262, 0, 241, 277, 0, 0, 0, 23, 41, 0, - 278, 123, 278, 278, 0, 77, 18, 76, 73, 90, - 80, 81, 87, 88, 75, 125, 74, 247, 78, 79, - 61, 62, 70, 71, 52, 49, 50, 0, 0, 0, - 72, 55, 48, 0, 56, 51, 0, 163, 61, 72, - 170, 0, 61, 167, 159, 43, 283, 283, 239, 239, - 0, 284, 25, 19, 0, 0, 0, 45, 279, 84, - 0, 0, 0, 120, 121, 124, 0, 112, 0, 110, - 0, 89, 0, 0, 0, 0, 0, 247, 203, 205, - 206, 207, 208, 20, 20, 0, 48, 0, 53, 54, - 161, 0, 0, 58, 0, 165, 265, 217, 247, 264, - 216, 263, 266, 273, 0, 267, 247, 0, 245, 246, - 0, 240, 243, 0, 230, 34, 24, 26, 33, 27, - 35, 0, 30, 0, 0, 0, 0, 0, 0, 0, - 0, 201, 0, 114, 0, 118, 0, 0, 91, 0, - 94, 96, 141, 0, 133, 0, 130, 210, 0, 123, - 200, 204, 42, 42, 0, 0, 60, 59, 64, 63, - 65, 0, 0, 0, 0, 0, 247, 276, 233, 258, - 231, 20, 20, 270, 271, 274, 269, 276, 235, 259, - 232, 228, 0, 242, 0, 0, 0, 47, 46, 44, - 0, 0, 83, 0, 0, 113, 0, 111, 0, 92, - 93, 0, 95, 82, 278, 0, 0, 145, 126, 0, - 0, 0, 209, 0, 0, 214, 214, 162, 0, 0, - 57, 166, 141, 0, 225, 0, 222, 268, 0, 42, - 42, 275, 0, 237, 244, 31, 28, 32, 0, 85, - 36, 122, 115, 119, 0, 108, 0, 99, 197, 72, - 195, 198, 0, 136, 146, 134, 128, 173, 174, 175, - 176, 0, 180, 182, 183, 184, 185, 186, 0, 171, - 181, 211, 202, 0, 0, 69, 66, 145, 218, 0, - 0, 0, 234, 262, 262, 236, 0, 0, 188, 189, - 190, 0, 0, 109, 0, 0, 193, 192, 0, 142, - 0, 0, 135, 177, 131, 0, 215, 212, 213, 136, - 226, 220, 0, 0, 0, 0, 229, 187, 0, 97, - 0, 107, 0, 102, 72, 191, 199, 0, 0, 137, - 138, 0, 0, 172, 227, 223, 260, 261, 0, 86, - 104, 100, 0, 0, 67, 0, 178, 0, 0, 238, - 0, 0, 103, 139, 140, 0, 0, 132, 0, 105, - 0, 68, 179, 224, 0, 101, 106, 0, 0, 0 -}; - -static const short yydefgoto[] = { 458, - 3, 4, 5, 6, 7, 8, 13, 14, 15, 40, - 61, 78, 48, 79, 87, 207, 208, 88, 209, 210, - 155, 62, 136, 80, 64, 147, 148, 122, 123, 341, - 125, 251, 252, 436, 126, 127, 97, 187, 99, 100, - 218, 383, 101, 102, 163, 229, 230, 231, 295, 296, - 386, 442, 413, 414, 441, 455, 294, 103, 104, 223, - 225, 156, 157, 105, 164, 165, 166, 302, 423, 234, - 235, 393, 421, 298, 344, 26, 41, 42, 43, 44, - 45, 46, 69, 345, 132, 359, 360, 422, 447, 361, - 382, 342, 343, 107, 189, 241, 168, 169, 170, 171, - 239, 172, 173, 364, 190, 191, 254, 255, 256, 372, - 439, 314, 315, 174, 324, 175, 260, 270, 261, 271, - 378, 201, 141, 202, 203, 29, 35, 36, 9, 30, - 31, 264, 265, 137, 192, 193, 194, 266, 195, 267, - 85, 151, 65, 196, 197, 54 -}; - -static const short yypact[] = { 34, - 127, 131,-32768,-32768,-32768, 69,-32768,-32768, 468, 113, - 122,-32768, 37, 180,-32768,-32768,-32768,-32768,-32768,-32768, --32768, 145,-32768,-32768,-32768,-32768,-32768,-32768, 129,-32768, --32768,-32768,-32768, 171, 216,-32768,-32768, 226,-32768, 72, - 54, 54,-32768, 54, -4, 54, 234, 180, 180, 242, - 245,-32768, 255,-32768, 518, 219, 236, 228,-32768,-32768, - 174,-32768,-32768,-32768,-32768,-32768, 375, 271,-32768,-32768, --32768,-32768, 396, 420,-32768,-32768, 240,-32768,-32768, 296, - 296, 262, 275,-32768, 282, 327, 300, 281,-32768, 329, - 25, 188, 83, 97, 305,-32768,-32768,-32768,-32768,-32768, --32768,-32768,-32768,-32768,-32768, 29,-32768, 558,-32768,-32768, - 284,-32768,-32768,-32768,-32768,-32768,-32768, 420, 323, 325, --32768,-32768,-32768, 20, 288,-32768, 420,-32768, 295, 289, - 9, 297,-32768, 9,-32768,-32768, 19, 166, 6, 6, - 320,-32768, 260,-32768, 261, 298, 225,-32768,-32768,-32768, - 355, 309, 310,-32768,-32768,-32768, 332,-32768, 188,-32768, - 188,-32768, 154, 367, 364, 326, 370, 551,-32768,-32768, --32768,-32768,-32768,-32768,-32768, 420, 333, 28,-32768,-32768, --32768, 420, 14, 9, 441,-32768,-32768, 42, 558,-32768, --32768,-32768,-32768,-32768, 186,-32768, 565, 270,-32768,-32768, - 322, 343,-32768, 328,-32768, 372,-32768, 344,-32768,-32768, - 377, 372,-32768, 377, 420, 329, 345, 357, 366, 9, - 348,-32768, 59,-32768, 78,-32768, 368, 373,-32768, 423, --32768, 347, 353, 92,-32768, 367,-32768,-32768, 114, 188, --32768,-32768, 180, 180, 44, 71,-32768, 9,-32768, 9, --32768, 233, 376, 404, 415, 381, 551, 255,-32768,-32768, --32768,-32768,-32768,-32768,-32768,-32768, 508, 255,-32768,-32768, --32768,-32768, 6,-32768, 422, 260, 426, 9,-32768,-32768, - 387, 432,-32768, 388, 389,-32768, 188,-32768, 188,-32768, --32768, 111,-32768,-32768, 435, 393, 330, -4,-32768, 367, - 163, 258,-32768, 443, 418, 296, 296,-32768, 397, 14, --32768,-32768, 353, 167,-32768, 404,-32768,-32768, 436, 180, - 180,-32768, 437, 445,-32768,-32768,-32768,-32768, 212,-32768, --32768,-32768,-32768,-32768, 442,-32768, 367,-32768, 420, 256, - 60,-32768, 272, 2,-32768,-32768,-32768,-32768,-32768,-32768, --32768, 425,-32768,-32768,-32768,-32768,-32768,-32768, 47,-32768, --32768,-32768,-32768, 247, 181,-32768,-32768, -4,-32768, 404, - 175, 258,-32768, 296, 296,-32768, 433, 453,-32768,-32768, --32768, 421, 482,-32768, 178, 62, 9, 465, 330,-32768, - 483, 351,-32768,-32768,-32768, 258,-32768,-32768,-32768, 2, --32768,-32768, 53, 239, 324, 484,-32768,-32768, 458,-32768, - 446,-32768, 74,-32768, 273, 9,-32768, 456, 420, 9, --32768, 330, 367,-32768,-32768,-32768,-32768,-32768, 466,-32768, --32768,-32768, 62, 469, 9, 41, 444, 196, 404,-32768, - 330, 367,-32768,-32768,-32768, 420, 471,-32768, 217, 444, - 224, 9,-32768,-32768, 472,-32768,-32768, 509, 524,-32768 -}; - -static const short yypgoto[] = {-32768, --32768,-32768,-32768,-32768, 527,-32768,-32768,-32768,-32768,-32768, --32768, 528, -23,-32768,-32768,-32768,-32768,-32768, 398, 265, - -123,-32768, 504, -45, 488,-32768, 334,-32768, -107, -67, --32768, 243,-32768,-32768,-32768, -122,-32768, 491,-32768,-32768, --32768,-32768,-32768,-32768,-32768,-32768,-32768, 349,-32768,-32768, --32768,-32768,-32768, 121,-32768,-32768,-32768,-32768,-32768,-32768, --32768, -140, 340,-32768,-32768,-32768,-32768,-32768,-32768, -226, - 283, 182,-32768, 268, 223, -60,-32768,-32768,-32768,-32768, --32768,-32768, 190, 539, 400, 220, 197,-32768,-32768, 380, --32768, 210, -386,-32768, 540, 350, 411, -153,-32768,-32768, --32768,-32768,-32768, 299, -38,-32768,-32768,-32768,-32768,-32768, --32768, -302, 235, -1,-32768, 4, -329, -271,-32768,-32768, --32768, 470,-32768,-32768, 335,-32768,-32768,-32768, 572,-32768, --32768,-32768,-32768, -78,-32768,-32768,-32768, 346, 473,-32768, - -113, -77, 553, 70, 599,-32768 -}; - - -#define YYLAST 614 - - -static const short yytable[] = { 124, - 106, 182, 138, 81, 49, 131, 134, 27, 182, 301, - 177, 182, 28, 371, 242, 159, 161, 72, 224, 211, - 226, 214, 391, 34, 199, 16, 17, 18, 19, 20, - 21, 22, 133, 112, 398, 437, 1, 113, 114, 2, - -252, 34, 113, 114, 115, 116, 117, 149, 113, 114, - 178, -127, 92, 27, 450, 182, 113, 114, 28, 184, - -272, 182, 73, -272, -219, 445, 93, 94, 74, 395, - 392, 1, 113, 114, 427, 426, 188, 188, 200, 95, - 118, 121, 60, 119, 120, 249, 121, 181, 113, 114, - 150, 47, 121, 399, -129, 247, 432, 284, 57, 58, - 121, 115, 232, 242, 286, 149, 446, -221, 245, 66, - 385, 308, 396, 411, 248, 250, 121, 131, 396, 149, - 67, 412, 182, 288, 287, 182, 68, 182, 158, 335, - 110, 388, 121, 428, 59, 60, 449, 299, 309, 433, - 119, 120, 160, 289, 319, 10, 333, 278, 334, 11, - 243, 244, 211, 328, 323, 182, 336, 300, 32, 303, - 16, 17, 18, 19, 20, 21, 22, 33, 50, 232, - 34, 51, 16, 17, 18, 19, 20, 21, 22, 304, - 16, 17, 18, 19, 20, 21, 91, 16, 17, 18, - 19, 20, 21, 22, 38, 262, 438, 306, 307, 92, - 263, 58, 227, 228, 152, 153, 154, 92, 347, -272, - -272, 47, 369, 93, 94, 451, 52, 337, 182, 53, - 402, 93, 94, 410, 268, 269, 95, 258, 300, 60, - 259, 70, 370, 71, 95, 76, 59, 60, 320, 321, - 370, 448, 250, 300, 56, 16, 17, 18, 19, 20, - 21, 22, 77, 16, 17, 18, 19, 20, 21, 22, - 82, 300, 454, 83, 182, 262, 379, 380, 381, 456, - 263, 387, 92, 84, 374, 375, 152, 152, 206, 212, - 258, 89, 370, 259, 86, 348, 93, 94, 258, 300, - 216, 259, 217, 182, 90, 404, 405, 182, 310, 95, - 311, 128, 60, 188, 188, 349, 350, 135, 351, 352, - 353, 281, 182, 268, 269, 354, 355, 356, 357, 358, - 416, -196, 57, -196, 420, 397, 397, 142, 139, 182, - 16, 17, 18, 19, 20, 21, 22, 389, -194, 390, - -194, 140, 143, 188, 188, 144, 145, 146, 133, 112, - 162, 435, 176, 179, 183, 180, -169, 92, 113, 114, - 115, 116, 117, 185, 186, 205, 215, 268, 269, 133, - 112, 93, 94, 219, 419, 220, 221, 222, 452, 113, - 114, 115, 116, 117, 95, 233, 236, 60, 238, 272, - 280, 237, 275, 111, 112, 274, 118, 277, 246, 119, - 120, 339, 340, 113, 114, 115, 116, 117, 273, 276, - 281, 283, -98, 290, 129, 112, 285, 118, 291, 297, - 119, 120, 313, 121, 113, 114, 115, 116, 117, 16, - 17, 18, 19, 20, 21, 22, 292, 316, 133, 112, - 326, 118, 152, 312, 119, 120, 317, 121, 113, 114, - 115, 116, 117, 329, 330, 331, 332, 149, 338, 133, - 112, 362, 118, 363, 366, 119, 120, -6, 130, 113, - 114, 115, 116, 117, 16, 17, 18, 19, 20, 21, - 22, 373, 376, 133, 112, 377, 118, 384, 408, 119, - 120, 394, 121, 113, 114, 115, 116, 117, 407, 406, - 409, 418, 429, 430, 23, 24, 25, 118, 459, 389, - 119, 120, 431, 130, 16, 17, 18, 19, 20, 21, - 22, -254, 434, 460, 16, 17, 18, 19, 20, 21, - 22, 118, 12, 440, 119, 120, 444, 415, 453, 457, - 327, 39, 213, 63, 23, 24, 25, -247, 96, 279, - -247, 98, 367, 443, 23, 24, 25, 16, 17, 18, - 19, 20, 21, 22, 16, 17, 18, 19, 20, 21, - 22, 16, 17, 18, 19, 20, 21, 22, 293, 305, - 368, 425, 346, 75, 253, 240, 167, 23, 24, 25, - 400, 403, 424, 167, 23, 24, 25, 282, 417, 257, - 108, 23, 24, 25, 401, 365, 318, 325, 55, 204, - 198, 37, 322, 109 -}; - -static const short yycheck[] = { 67, - 61, 124, 81, 49, 28, 73, 74, 9, 131, 236, - 118, 134, 9, 316, 168, 93, 94, 22, 159, 143, - 161, 145, 21, 5, 19, 7, 8, 9, 10, 11, - 12, 13, 19, 20, 364, 422, 3, 29, 30, 6, - 4, 5, 29, 30, 31, 32, 33, 23, 29, 30, - 118, 23, 34, 55, 441, 178, 29, 30, 55, 127, - 42, 184, 67, 45, 23, 25, 48, 49, 73, 23, - 69, 3, 29, 30, 404, 23, 137, 138, 73, 61, - 67, 73, 64, 70, 71, 72, 73, 68, 29, 30, - 66, 67, 73, 365, 66, 68, 23, 220, 27, 28, - 73, 31, 163, 257, 46, 23, 66, 66, 176, 40, - 337, 68, 66, 52, 182, 183, 73, 185, 66, 23, - 67, 60, 245, 46, 66, 248, 73, 250, 46, 19, - 61, 72, 73, 405, 63, 64, 439, 46, 246, 66, - 70, 71, 46, 66, 258, 19, 287, 215, 289, 19, - 174, 175, 276, 277, 268, 278, 46, 66, 46, 46, - 7, 8, 9, 10, 11, 12, 13, 46, 40, 230, - 5, 43, 7, 8, 9, 10, 11, 12, 13, 66, - 7, 8, 9, 10, 11, 12, 13, 7, 8, 9, - 10, 11, 12, 13, 15, 197, 423, 243, 244, 34, - 197, 28, 49, 50, 17, 18, 19, 34, 46, 44, - 45, 67, 46, 48, 49, 442, 46, 295, 341, 4, - 46, 48, 49, 46, 44, 45, 61, 42, 66, 64, - 45, 42, 66, 44, 61, 46, 63, 64, 262, 263, - 66, 46, 310, 66, 19, 7, 8, 9, 10, 11, - 12, 13, 19, 7, 8, 9, 10, 11, 12, 13, - 19, 66, 46, 19, 387, 267, 55, 56, 57, 46, - 267, 339, 34, 19, 320, 321, 17, 17, 19, 19, - 42, 46, 66, 45, 66, 28, 48, 49, 42, 66, - 66, 45, 68, 416, 67, 374, 375, 420, 66, 61, - 68, 31, 64, 364, 365, 48, 49, 68, 51, 52, - 53, 54, 435, 44, 45, 58, 59, 60, 61, 62, - 388, 66, 27, 68, 392, 364, 365, 46, 67, 452, - 7, 8, 9, 10, 11, 12, 13, 66, 66, 68, - 68, 67, 16, 404, 405, 46, 66, 19, 19, 20, - 46, 419, 69, 31, 67, 31, 68, 34, 29, 30, - 31, 32, 33, 69, 68, 46, 69, 44, 45, 19, - 20, 48, 49, 19, 24, 67, 67, 46, 446, 29, - 30, 31, 32, 33, 61, 19, 23, 64, 19, 68, - 46, 66, 21, 19, 20, 68, 67, 21, 66, 70, - 71, 72, 73, 29, 30, 31, 32, 33, 66, 66, - 54, 46, 66, 46, 19, 20, 69, 67, 46, 67, - 70, 71, 19, 73, 29, 30, 31, 32, 33, 7, - 8, 9, 10, 11, 12, 13, 14, 23, 19, 20, - 19, 67, 17, 68, 70, 71, 66, 73, 29, 30, - 31, 32, 33, 67, 23, 68, 68, 23, 66, 19, - 20, 19, 67, 46, 68, 70, 71, 0, 73, 29, - 30, 31, 32, 33, 7, 8, 9, 10, 11, 12, - 13, 46, 46, 19, 20, 41, 67, 46, 68, 70, - 71, 67, 73, 29, 30, 31, 32, 33, 46, 67, - 19, 19, 19, 46, 37, 38, 39, 67, 0, 66, - 70, 71, 67, 73, 7, 8, 9, 10, 11, 12, - 13, 4, 67, 0, 7, 8, 9, 10, 11, 12, - 13, 67, 6, 68, 70, 71, 68, 73, 68, 68, - 276, 14, 145, 40, 37, 38, 39, 40, 61, 216, - 43, 61, 310, 433, 37, 38, 39, 7, 8, 9, - 10, 11, 12, 13, 7, 8, 9, 10, 11, 12, - 13, 7, 8, 9, 10, 11, 12, 13, 230, 240, - 313, 400, 300, 45, 185, 35, 36, 37, 38, 39, - 368, 372, 396, 36, 37, 38, 39, 218, 389, 189, - 61, 37, 38, 39, 370, 307, 257, 273, 37, 140, - 138, 13, 267, 61 -}; -/* -*-C-*- Note some compilers choke on comments on `#line' lines. */ -#line 3 "/usr/share/bison.simple" - -/* Skeleton output parser for bison, - Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -/* As a special exception, when this file is copied by Bison into a - Bison output file, you may use that output file without restriction. - This special exception was added by the Free Software Foundation - in version 1.24 of Bison. */ - -#ifndef alloca -#ifdef __GNUC__ -#define alloca __builtin_alloca -#else /* not GNU C. */ -#if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__) || defined (__sparc) || defined (__sgi) || defined (__alpha) -#include -#else /* not sparc */ -#if defined (MSDOS) && !defined (__TURBOC__) -#include -#else /* not MSDOS, or __TURBOC__ */ -#if defined(_AIX) -#include - #pragma alloca -#else /* not MSDOS, __TURBOC__, or _AIX */ -#if defined(_UNICOS) -#define alloca malloc -#else -#ifdef __hpux -#ifdef __cplusplus -extern "C" { -void *alloca (unsigned int); -}; -#else /* not __cplusplus */ -void *alloca (); -#endif /* not __cplusplus */ -#endif /* __hpux */ -#endif /* not _UNICOS */ -#endif /* not _AIX */ -#endif /* not MSDOS, or __TURBOC__ */ -#endif /* not sparc. */ -#endif /* not GNU C. */ -#endif /* alloca not defined. */ - -/* This is the parser code that is written into each bison parser - when the %semantic_parser declaration is not specified in the grammar. - It was written by Richard Stallman by simplifying the hairy parser - used when %semantic_parser is specified. */ - -/* Note: there must be only one dollar sign in this file. - It is replaced by the list of actions, each action - as one case of the switch. */ - -#define yyerrok (yyerrstatus = 0) -#define yyclearin (yychar = YYEMPTY) -#define YYEMPTY -2 -#define YYEOF 0 -#define YYACCEPT return(0) -#define YYABORT return(1) -#define YYERROR goto yyerrlab1 -/* Like YYERROR except do call yyerror. - This remains here temporarily to ease the - transition to the new meaning of YYERROR, for GCC. - Once GCC version 2 has supplanted version 1, this can go. */ -#define YYFAIL goto yyerrlab -#define YYRECOVERING() (!!yyerrstatus) -#define YYBACKUP(token, value) \ -do \ - if (yychar == YYEMPTY && yylen == 1) \ - { yychar = (token), yylval = (value); \ - yychar1 = YYTRANSLATE (yychar); \ - YYPOPSTACK; \ - goto yybackup; \ - } \ - else \ - { yyerror ("syntax error: cannot back up"); YYERROR; } \ -while (0) - -#define YYTERROR 1 -#define YYERRCODE 256 - -#ifndef YYPURE -#define YYLEX yylex() -#endif - -#ifdef YYPURE -#ifdef YYLSP_NEEDED -#ifdef YYLEX_PARAM -#define YYLEX yylex(&yylval, &yylloc, YYLEX_PARAM) -#else -#define YYLEX yylex(&yylval, &yylloc) -#endif -#else /* not YYLSP_NEEDED */ -#ifdef YYLEX_PARAM -#define YYLEX yylex(&yylval, YYLEX_PARAM) -#else -#define YYLEX yylex(&yylval) -#endif -#endif /* not YYLSP_NEEDED */ -#endif - -/* If nonreentrant, generate the variables here */ - -#ifndef YYPURE - -int yychar; /* the lookahead symbol */ -YYSTYPE yylval; /* the semantic value of the */ - /* lookahead symbol */ - -#ifdef YYLSP_NEEDED -YYLTYPE yylloc; /* location data for the lookahead */ - /* symbol */ -#endif - -int yynerrs; /* number of parse errors so far */ -#endif /* not YYPURE */ - -#if YYDEBUG != 0 -int yydebug; /* nonzero means print parse trace */ -/* Since this is uninitialized, it does not stop multiple parsers - from coexisting. */ -#endif - -/* YYINITDEPTH indicates the initial size of the parser's stacks */ - -#ifndef YYINITDEPTH -#define YYINITDEPTH 200 -#endif - -/* YYMAXDEPTH is the maximum size the stacks can grow to - (effective only if the built-in stack extension method is used). */ - -#if YYMAXDEPTH == 0 -#undef YYMAXDEPTH -#endif - -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 10000 -#endif - -#ifndef YYPARSE_RETURN_TYPE -#define YYPARSE_RETURN_TYPE int -#endif - -/* Prevent warning if -Wstrict-prototypes. */ -#ifdef __GNUC__ -YYPARSE_RETURN_TYPE yyparse (void); -#endif - -#if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ -#define __yy_memcpy(TO,FROM,COUNT) __builtin_memcpy(TO,FROM,COUNT) -#else /* not GNU C or C++ */ -#ifndef __cplusplus - -/* This is the most reliable way to avoid incompatibilities - in available built-in functions on various systems. */ -static void -__yy_memcpy (to, from, count) - char *to; - char *from; - int count; -{ - register char *f = from; - register char *t = to; - register int i = count; - - while (i-- > 0) - *t++ = *f++; -} - -#else /* __cplusplus */ - -/* This is the most reliable way to avoid incompatibilities - in available built-in functions on various systems. */ -static void -__yy_memcpy (char *to, char *from, int count) -{ - register char *f = from; - register char *t = to; - register int i = count; - - while (i-- > 0) - *t++ = *f++; -} - -#endif -#endif - -#line 196 "/usr/share/bison.simple" - -/* The user can define YYPARSE_PARAM as the name of an argument to be passed - into yyparse. The argument should have type void *. - It should actually point to an object. - Grammar actions can access the variable by casting it - to the proper pointer type. */ - -#ifdef YYPARSE_PARAM -#ifdef __cplusplus -#define YYPARSE_PARAM_ARG void *YYPARSE_PARAM -#define YYPARSE_PARAM_DECL -#else /* not __cplusplus */ -#define YYPARSE_PARAM_ARG YYPARSE_PARAM -#define YYPARSE_PARAM_DECL void *YYPARSE_PARAM; -#endif /* not __cplusplus */ -#else /* not YYPARSE_PARAM */ -#define YYPARSE_PARAM_ARG -#define YYPARSE_PARAM_DECL -#endif /* not YYPARSE_PARAM */ - -YYPARSE_RETURN_TYPE -yyparse(YYPARSE_PARAM_ARG) - YYPARSE_PARAM_DECL -{ - register int yystate; - register int yyn; - register short *yyssp; - register YYSTYPE *yyvsp; - int yyerrstatus; /* number of tokens to shift before error messages enabled */ - int yychar1 = 0; /* lookahead token as an internal (translated) token number */ - - short yyssa[YYINITDEPTH]; /* the state stack */ - YYSTYPE yyvsa[YYINITDEPTH]; /* the semantic value stack */ - - short *yyss = yyssa; /* refer to the stacks thru separate pointers */ - YYSTYPE *yyvs = yyvsa; /* to allow yyoverflow to reallocate them elsewhere */ - -#ifdef YYLSP_NEEDED - YYLTYPE yylsa[YYINITDEPTH]; /* the location stack */ - YYLTYPE *yyls = yylsa; - YYLTYPE *yylsp; - -#define YYPOPSTACK (yyvsp--, yyssp--, yylsp--) -#else -#define YYPOPSTACK (yyvsp--, yyssp--) -#endif - - int yystacksize = YYINITDEPTH; - -#ifdef YYPURE - int yychar; - YYSTYPE yylval; - int yynerrs; -#ifdef YYLSP_NEEDED - YYLTYPE yylloc; -#endif -#endif - - YYSTYPE yyval; /* the variable used to return */ - /* semantic values from the action */ - /* routines */ - - int yylen; - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Starting parse\n"); -#endif - - yystate = 0; - yyerrstatus = 0; - yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ - - /* Initialize stack pointers. - Waste one element of value and location stack - so that they stay on the same level as the state stack. - The wasted elements are never initialized. */ - - yyssp = yyss - 1; - yyvsp = yyvs; -#ifdef YYLSP_NEEDED - yylsp = yyls; -#endif - -/* Push a new state, which is found in yystate . */ -/* In all cases, when you get here, the value and location stacks - have just been pushed. so pushing a state here evens the stacks. */ -yynewstate: - - *++yyssp = yystate; - - if (yyssp >= yyss + yystacksize - 1) - { - /* Give user a chance to reallocate the stack */ - /* Use copies of these so that the &'s don't force the real ones into memory. */ - YYSTYPE *yyvs1 = yyvs; - short *yyss1 = yyss; -#ifdef YYLSP_NEEDED - YYLTYPE *yyls1 = yyls; -#endif - - /* Get the current used size of the three stacks, in elements. */ - int size = yyssp - yyss + 1; - -#ifdef yyoverflow - /* Each stack pointer address is followed by the size of - the data in use in that stack, in bytes. */ -#ifdef YYLSP_NEEDED - /* This used to be a conditional around just the two extra args, - but that might be undefined if yyoverflow is a macro. */ - yyoverflow("parser stack overflow", - &yyss1, size * sizeof (*yyssp), - &yyvs1, size * sizeof (*yyvsp), - &yyls1, size * sizeof (*yylsp), - &yystacksize); -#else - yyoverflow("parser stack overflow", - &yyss1, size * sizeof (*yyssp), - &yyvs1, size * sizeof (*yyvsp), - &yystacksize); -#endif - - yyss = yyss1; yyvs = yyvs1; -#ifdef YYLSP_NEEDED - yyls = yyls1; -#endif -#else /* no yyoverflow */ - /* Extend the stack our own way. */ - if (yystacksize >= YYMAXDEPTH) - { - yyerror("parser stack overflow"); - return 2; - } - yystacksize *= 2; - if (yystacksize > YYMAXDEPTH) - yystacksize = YYMAXDEPTH; - yyss = (short *) alloca (yystacksize * sizeof (*yyssp)); - __yy_memcpy ((char *)yyss, (char *)yyss1, size * sizeof (*yyssp)); - yyvs = (YYSTYPE *) alloca (yystacksize * sizeof (*yyvsp)); - __yy_memcpy ((char *)yyvs, (char *)yyvs1, size * sizeof (*yyvsp)); -#ifdef YYLSP_NEEDED - yyls = (YYLTYPE *) alloca (yystacksize * sizeof (*yylsp)); - __yy_memcpy ((char *)yyls, (char *)yyls1, size * sizeof (*yylsp)); -#endif -#endif /* no yyoverflow */ - - yyssp = yyss + size - 1; - yyvsp = yyvs + size - 1; -#ifdef YYLSP_NEEDED - yylsp = yyls + size - 1; -#endif - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Stack size increased to %d\n", yystacksize); -#endif - - if (yyssp >= yyss + yystacksize - 1) - YYABORT; - } - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Entering state %d\n", yystate); -#endif - - goto yybackup; - yybackup: - -/* Do appropriate processing given the current state. */ -/* Read a lookahead token if we need one and don't already have one. */ -/* yyresume: */ - - /* First try to decide what to do without reference to lookahead token. */ - - yyn = yypact[yystate]; - if (yyn == YYFLAG) - goto yydefault; - - /* Not known => get a lookahead token if don't already have one. */ - - /* yychar is either YYEMPTY or YYEOF - or a valid token in external form. */ - - if (yychar == YYEMPTY) - { -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Reading a token: "); -#endif - yychar = YYLEX; - } - - /* Convert token to internal form (in yychar1) for indexing tables with */ - - if (yychar <= 0) /* This means end of input. */ - { - yychar1 = 0; - yychar = YYEOF; /* Don't call YYLEX any more */ - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Now at end of input.\n"); -#endif - } - else - { - yychar1 = YYTRANSLATE(yychar); - -#if YYDEBUG != 0 - if (yydebug) - { - fprintf (stderr, "Next token is %d (%s", yychar, yytname[yychar1]); - /* Give the individual parser a way to print the precise meaning - of a token, for further debugging info. */ -#ifdef YYPRINT - YYPRINT (stderr, yychar, yylval); -#endif - fprintf (stderr, ")\n"); - } -#endif - } - - yyn += yychar1; - if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) - goto yydefault; - - yyn = yytable[yyn]; - - /* yyn is what to do for this token type in this state. - Negative => reduce, -yyn is rule number. - Positive => shift, yyn is new state. - New state is final state => don't bother to shift, - just return success. - 0, or most negative number => error. */ - - if (yyn < 0) - { - if (yyn == YYFLAG) - goto yyerrlab; - yyn = -yyn; - goto yyreduce; - } - else if (yyn == 0) - goto yyerrlab; - - if (yyn == YYFINAL) - YYACCEPT; - - /* Shift the lookahead token. */ - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Shifting token %d (%s), ", yychar, yytname[yychar1]); -#endif - - /* Discard the token being shifted unless it is eof. */ - if (yychar != YYEOF) - yychar = YYEMPTY; - - *++yyvsp = yylval; -#ifdef YYLSP_NEEDED - *++yylsp = yylloc; -#endif - - /* count tokens shifted since error; after three, turn off error status. */ - if (yyerrstatus) yyerrstatus--; - - yystate = yyn; - goto yynewstate; - -/* Do the default action for the current state. */ -yydefault: - - yyn = yydefact[yystate]; - if (yyn == 0) - goto yyerrlab; - -/* Do a reduction. yyn is the number of a rule to reduce with. */ -yyreduce: - yylen = yyr2[yyn]; - if (yylen > 0) - yyval = yyvsp[1-yylen]; /* implement default value of the action */ - -#if YYDEBUG != 0 - if (yydebug) - { - int i; - - fprintf (stderr, "Reducing via rule %d (line %d), ", - yyn, yyrline[yyn]); - - /* Print the symbols being reduced, and their result. */ - for (i = yyprhs[yyn]; yyrhs[i] > 0; i++) - fprintf (stderr, "%s ", yytname[yyrhs[i]]); - fprintf (stderr, " -> %s\n", yytname[yyr1[yyn]]); - } -#endif - - - switch (yyn) { - -case 4: -#line 74 "forpar.y" -{ parwarn("main program"); - ok=1; exit(0); - ; - break;} -case 5: -#line 79 "forpar.y" -{ strcpy(proname,yyvsp[-1]); wstat='p'; - if( !filedep ) flout=newfile(proname,fnout,1,1); - printw(-1,"PROGRAM %s\n\n",proname); - indent+=dind; - submod=public=private=ext=0; - if( !filedep ){ fclose(flout); flout=NULL; } - ; - break;} -case 6: -#line 87 "forpar.y" -{ - if( !filedep ) { - fclose(flout); flout=NULL; - if( chkint ) do_chkint(fnout,fnold); - } - ; - break;} -case 9: -#line 97 "forpar.y" -{ public=private=0; ; - break;} -case 10: -#line 100 "forpar.y" -{ strcpy(modname,yyvsp[-1]); wstat='m'; - if( !filedep ) flout=newfile(modname,fnout,1,1); - printw(-1,"MODULE: %s\n\n",modname); - indent+=dind; - submod=public=private=ext=0; - ; - break;} -case 11: -#line 108 "forpar.y" -{ printw(0,"\n"); - if( private ) printw(-1,"Private\n"); - if( public ) printw(-1,"Public\n"); - if( pub_l ) printw(-1,"Public:: "); - for( pl=pub_l; pl; pl=pl->nxt ) - printw(0,"%s %s",((pl==pub_l)? "" : ","), pl->ele); - if( pub_l ) printw(0,"\n"); - if( pri_l ) printw(-1,"Private:: "); - for( pl=pri_l; pl; pl=pl->nxt ) - printw(0,"%s %s",((pl==pri_l)? "" : ","), pl->ele); - if( pri_l ) printw(0,"\n"); - printw(0,"\n"); - ; - break;} -case 13: -#line 123 "forpar.y" -{ ins_lele(&use_l,yyvsp[0]); hp=heap; ; - break;} -case 14: -#line 125 "forpar.y" -{ for( pl=use_l; pl; pl=pl->nxt ) printw(0,pl->ele); - zap_lele(&use_l); ; - break;} -case 16: -#line 129 "forpar.y" -{ hp=heap; ; - break;} -case 18: -#line 132 "forpar.y" -{ hp=heap; ; - break;} -case 19: -#line 135 "forpar.y" -{ yyval=spr(-1,"Use %s%s\n",yyvsp[-2],yyvsp[-1]); ; - break;} -case 20: -#line 137 "forpar.y" -{ yyval=semp; ; - break;} -case 22: -#line 140 "forpar.y" -{ printw(0,yyvsp[0]); ; - break;} -case 24: -#line 143 "forpar.y" -{ yyval=spr(0,", Only: %s",yyvsp[0]); ; - break;} -case 25: -#line 145 "forpar.y" -{ yyval=semp; ; - break;} -case 27: -#line 148 "forpar.y" -{ yyval=spr(0,"%s",yyvsp[0]); ; - break;} -case 28: -#line 149 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 29: -#line 151 "forpar.y" -{ yyval=semp; ; - break;} -case 30: -#line 152 "forpar.y" -{ yyval=spr(0,", %s",yyvsp[0]); ; - break;} -case 31: -#line 154 "forpar.y" -{ yyval=spr(0,"%s=>%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 32: -#line 155 "forpar.y" -{ yyval=spr(0,"%s=>%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 36: -#line 163 "forpar.y" -{ yyval=spr(0,"Operator(%s)",yyvsp[-1]); ; - break;} -case 41: -#line 172 "forpar.y" -{ printw(-1,"Implicit None\n"); ; - break;} -case 42: -#line 175 "forpar.y" -{ yyval=semp; ; - break;} -case 44: -#line 178 "forpar.y" -{ printw(-1,"parameter\n"); ; - break;} -case 47: -#line 183 "forpar.y" -{ yyval=spr(0,"%s = %s",yyvsp[-2],yyvsp[0]); printw(-1,"%s\n",yyval); ; - break;} -case 56: -#line 190 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 57: -#line 192 "forpar.y" -{ yyval=spr(0,"%s(%s)",yyvsp[-3],yyvsp[-1]); ; - break;} -case 58: -#line 193 "forpar.y" -{ yyval=spr(0,"%s%s",yyvsp[-1],yyvsp[0]); ; - break;} -case 59: -#line 194 "forpar.y" -{ yyval=spr(0,"%s%s%s",yyvsp[-2],yyvsp[-1],yyvsp[0]); ; - break;} -case 60: -#line 195 "forpar.y" -{ yyval=spr(0,"(%s)",yyvsp[-1]); ; - break;} -case 63: -#line 199 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 64: -#line 200 "forpar.y" -{ yyval=":"; ; - break;} -case 66: -#line 203 "forpar.y" -{ yyval=spr(0,"%s,%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 67: -#line 205 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 68: -#line 206 "forpar.y" -{ yyval=spr(0,"%s,%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 69: -#line 208 "forpar.y" -{ yyval=spr(0,"(%s,%s)",yyvsp[-3],yyvsp[-1]); ; - break;} -case 72: -#line 212 "forpar.y" -{ yyval="*"; ; - break;} -case 83: -#line 245 "forpar.y" -{ strcpy(typename,yyvsp[-1]); printw(-1,"Type:: %s\n",yyvsp[-1]); - indent+=dind; ; - break;} -case 84: -#line 247 "forpar.y" -{YK; - break;} -case 85: -#line 247 "forpar.y" -{NI; - break;} -case 86: -#line 247 "forpar.y" -{ strcpy(typename,yyvsp[-1]); - printw(-1,"Type, %s:: %s\n",yyvsp[-4],yyvsp[-1]); indent+=dind; ; - break;} -case 89: -#line 254 "forpar.y" -{ printw(-1,"Save\n"); ; - break;} -case 90: -#line 257 "forpar.y" -{ yyval=semp; ; - break;} -case 92: -#line 260 "forpar.y" -{ yyval="Private"; ; - break;} -case 93: -#line 261 "forpar.y" -{ yyval="Sequence"; ; - break;} -case 96: -#line 266 "forpar.y" -{NI; - break;} -case 97: -#line 267 "forpar.y" -{ printw(-1,"%s:: %s\n",yyvsp[-4],yyvsp[-1]); ; - break;} -case 98: -#line 268 "forpar.y" -{NI; - break;} -case 99: -#line 268 "forpar.y" -{YK; - break;} -case 100: -#line 268 "forpar.y" -{NI; - break;} -case 101: -#line 268 "forpar.y" -{ - printw(-1,"%s, %s:: %s\n",yyvsp[-8],yyvsp[-4],yyvsp[-1]); ; - break;} -case 103: -#line 272 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 104: -#line 274 "forpar.y" -{NI; - break;} -case 105: -#line 274 "forpar.y" -{YK; - break;} -case 106: -#line 274 "forpar.y" -{ - yyval=spr(0,"Dimension(%s)",yyvsp[-2]); ; - break;} -case 107: -#line 276 "forpar.y" -{ yyval="Pointer"; ; - break;} -case 108: -#line 279 "forpar.y" -{ indent-=dind; printw(-1,"End Type %s\n",typename); ; - break;} -case 109: -#line 280 "forpar.y" -{ indent-=dind; printw(-1,"End Type %s\n",yyvsp[-1]); - if( strcmp(typename,yyvsp[-1])!=0 ) - parerr("type-name mismatch"); - ; - break;} -case 110: -#line 285 "forpar.y" -{ private=1; ; - break;} -case 111: -#line 286 "forpar.y" -{ ; - break;} -case 112: -#line 288 "forpar.y" -{ public=1; ; - break;} -case 113: -#line 289 "forpar.y" -{ ; - break;} -case 114: -#line 291 "forpar.y" -{ ins_lele(&pub_l,yyvsp[0]); ; - break;} -case 115: -#line 292 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ins_lele(&pub_l,yyvsp[0]); ; - break;} -case 116: -#line 294 "forpar.y" -{ ins_lele(&pri_l,yyvsp[0]); ; - break;} -case 117: -#line 295 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ins_lele(&pri_l,yyvsp[0]); ; - break;} -case 119: -#line 298 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 122: -#line 302 "forpar.y" -{ yyval=spr(0,"Assignment(=)",yyvsp[-1]); ; - break;} -case 123: -#line 304 "forpar.y" -{ yyval=semp; ; - break;} -case 125: -#line 308 "forpar.y" -{NI; - break;} -case 126: -#line 309 "forpar.y" -{ printw(-1,"%s:: %s\n",yyvsp[-3],yyvsp[-1]); ; - break;} -case 127: -#line 310 "forpar.y" -{NI; - break;} -case 128: -#line 311 "forpar.y" -{ printw(-1,"%s:: %s\n",yyvsp[-4],yyvsp[-1]); ; - break;} -case 129: -#line 312 "forpar.y" -{NI; - break;} -case 130: -#line 312 "forpar.y" -{YK; - break;} -case 131: -#line 312 "forpar.y" -{NI; - break;} -case 132: -#line 313 "forpar.y" -{ printw(-1,"%s, %s:: %s\n",yyvsp[-8],yyvsp[-4],yyvsp[-1]); ; - break;} -case 134: -#line 316 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 135: -#line 318 "forpar.y" -{ yyval=spr(0,"%s%s%s%s",yyvsp[-3],yyvsp[-2],yyvsp[-1],yyvsp[0]); ; - break;} -case 136: -#line 320 "forpar.y" -{ yyval=semp; ; - break;} -case 137: -#line 321 "forpar.y" -{ yyval=spr(0," = %s",yyvsp[0]); ; - break;} -case 138: -#line 322 "forpar.y" -{ yyval=spr(0," = %s",yyvsp[0]); ; - break;} -case 139: -#line 323 "forpar.y" -{ if( strcmp(yyvsp[-2],"null")!=0 ) yyerror("expecting NULL"); - yyval=spr(0,"=>NULL()"); - ; - break;} -case 140: -#line 327 "forpar.y" -{ yyval=spr(0,"(/ %s /)",yyvsp[-1]); ; - break;} -case 141: -#line 329 "forpar.y" -{ yyval=semp; ; - break;} -case 142: -#line 330 "forpar.y" -{ yyval=spr(0,"(%s)",yyvsp[-1]); ; - break;} -case 143: -#line 332 "forpar.y" -{ yyval=semp; ; - break;} -case 144: -#line 333 "forpar.y" -{ yyval=spr(0,"*%s",yyvsp[0]); ; - break;} -case 145: -#line 335 "forpar.y" -{ yyval=semp; ; - break;} -case 146: -#line 336 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 147: -#line 338 "forpar.y" -{NI; - break;} -case 148: -#line 338 "forpar.y" -{ yyval=spr(0,"Integer%s",yyvsp[0]); ; - break;} -case 149: -#line 339 "forpar.y" -{NI; - break;} -case 150: -#line 339 "forpar.y" -{ yyval=spr(0,"Real%s",yyvsp[0]); ; - break;} -case 151: -#line 340 "forpar.y" -{NI; - break;} -case 152: -#line 340 "forpar.y" -{ yyval="Double Precision"; ; - break;} -case 153: -#line 341 "forpar.y" -{NI; - break;} -case 154: -#line 341 "forpar.y" -{ yyval=spr(0,"Complex%s",yyvsp[0]); ; - break;} -case 155: -#line 342 "forpar.y" -{NI; - break;} -case 156: -#line 342 "forpar.y" -{ yyval=spr(0,"Character%s",yyvsp[0]); ; - break;} -case 157: -#line 343 "forpar.y" -{NI; - break;} -case 158: -#line 343 "forpar.y" -{ yyval=spr(0,"Logical%s",yyvsp[0]); ; - break;} -case 159: -#line 344 "forpar.y" -{ yyval=spr(0,"Type(%s)",yyvsp[-1]); ; - break;} -case 160: -#line 348 "forpar.y" -{ yyval=semp; ; - break;} -case 161: -#line 349 "forpar.y" -{ yyval=spr(0,"(Kind=%s)",yyvsp[-1]); ; - break;} -case 162: -#line 350 "forpar.y" -{ if( strcmp(yyvsp[-3],"kind")!=0 ) - yyerror("expecting \"Kind\"\n"); - yyval=spr(0,"(Kind=%s)",yyvsp[-1]); - ; - break;} -case 163: -#line 354 "forpar.y" -{ yyval=spr(0,"(Kind=%s)",yyvsp[0]); - for( pc=yyvsp[0]; *pc!='\0'; ++pc ) if( !isdigit(*pc) ) - parerr("\"Character*%s\" length-selector must be integer",yyvsp[0]); - ; - break;} -case 164: -#line 359 "forpar.y" -{ yyval=semp; ; - break;} -case 165: -#line 360 "forpar.y" -{ yyval=spr(0,"(Len=%s)",yyvsp[-1]); ; - break;} -case 166: -#line 361 "forpar.y" -{ if( strcmp(yyvsp[-3],"len")!=0 ) - yyerror("expecting \"Len\"\n"); - yyval=spr(0,"(Len=%s)",yyvsp[-1]); - ; - break;} -case 167: -#line 365 "forpar.y" -{ yyval=spr(0,"(Len=%s)",yyvsp[0]); ; - break;} -case 168: -#line 366 "forpar.y" -{ yyval="*(len=*)"; ; - break;} -case 169: -#line 368 "forpar.y" -{ yyval="*"; ; - break;} -case 170: -#line 369 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 172: -#line 372 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 173: -#line 374 "forpar.y" -{ yyval="Parameter"; ; - break;} -case 174: -#line 375 "forpar.y" -{ yyval="Public"; ; - break;} -case 175: -#line 376 "forpar.y" -{ yyval="Private"; ; - break;} -case 176: -#line 377 "forpar.y" -{ yyval="Allocatable"; ; - break;} -case 177: -#line 378 "forpar.y" -{NI; - break;} -case 178: -#line 378 "forpar.y" -{YK; - break;} -case 179: -#line 378 "forpar.y" -{ yyval=spr(0,"Dimension(%s)",yyvsp[-2]); ; - break;} -case 180: -#line 379 "forpar.y" -{ yyval="External"; ; - break;} -case 182: -#line 381 "forpar.y" -{ yyval="Intrinsic"; ; - break;} -case 183: -#line 382 "forpar.y" -{ yyval="Optional"; ; - break;} -case 184: -#line 383 "forpar.y" -{ yyval="Pointer"; ; - break;} -case 185: -#line 384 "forpar.y" -{ yyval="Save"; ; - break;} -case 186: -#line 385 "forpar.y" -{ yyval="Target"; ; - break;} -case 187: -#line 387 "forpar.y" -{ yyval=spr(0,"Intent (%s)",yyvsp[-1]); ; - break;} -case 188: -#line 389 "forpar.y" -{ yyval="IN"; ; - break;} -case 189: -#line 389 "forpar.y" -{ yyval="OUT"; ; - break;} -case 190: -#line 389 "forpar.y" -{ yyval="INOUT"; ; - break;} -case 191: -#line 391 "forpar.y" -{ yyval=spr(0,"%s:%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 192: -#line 392 "forpar.y" -{ yyval=spr(0,"%s:",yyvsp[-1]); ; - break;} -case 193: -#line 393 "forpar.y" -{ yyval=spr(0,":%s",yyvsp[0]); ; - break;} -case 194: -#line 394 "forpar.y" -{ yyval=spr(0,"%s:*",yyvsp[-2]); ; - break;} -case 195: -#line 395 "forpar.y" -{ yyval=spr(0,"%s",yyvsp[0]); ; - break;} -case 196: -#line 396 "forpar.y" -{ yyval=spr(0,"*"); ; - break;} -case 197: -#line 397 "forpar.y" -{ yyval=spr(0,":"); ; - break;} -case 199: -#line 400 "forpar.y" -{ yyval=spr(0,"%s,%s",yyvsp[-2],yyvsp[0]); ; - break;} -case 201: -#line 407 "forpar.y" -{ strcpy(intername,yyvsp[-1]); - if( !submod ){ printw(-1,"Interface"); - if( *yyvsp[-1] ) printw(0," %s",intername); printw(0,"\n"); - indent+=dind; - } - interf=1; - ; - break;} -case 202: -#line 416 "forpar.y" -{ if( !submod ){ indent-=dind; - printw(-1,"End Interface %s\n",intername); - } - if( *yyvsp[-1] && strcmp(intername,yyvsp[-1]) ) - parerr("Interface name mismatch"); - interf=0; - ; - break;} -case 209: -#line 433 "forpar.y" -{ printw(-1,"Module procedure %s\n",yyvsp[-1]); ; - break;} -case 211: -#line 436 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 217: -#line 448 "forpar.y" -{NI; - break;} -case 218: -#line 449 "forpar.y" -{ if( *yyvsp[-1] ) printw(-1,"%s:: %s\n",yyvsp[-3],yyvsp[-1]); ; - break;} -case 219: -#line 450 "forpar.y" -{NI; - break;} -case 220: -#line 451 "forpar.y" -{ if( *yyvsp[-1] ) printw(-1,"%s:: %s\n",yyvsp[-4],yyvsp[-1]); ; - break;} -case 221: -#line 452 "forpar.y" -{NI; - break;} -case 222: -#line 452 "forpar.y" -{YK; - break;} -case 223: -#line 452 "forpar.y" -{NI; - break;} -case 224: -#line 453 "forpar.y" -{ if( *yyvsp[-1] ) printw(-1,"%s, %s:: %s\n",yyvsp[-8],yyvsp[-4],yyvsp[-1]); ; - break;} -case 226: -#line 457 "forpar.y" -{ if( *yyvsp[0] ){ - if( *yyvsp[-2] ) yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); - else yyval=yyvsp[0]; - } else yyval=yyvsp[-2]; - ; - break;} -case 227: -#line 463 "forpar.y" -{ - if( present(yyvsp[-3],args,", ") ) yyval=spr(0,"%s%s%s%s",yyvsp[-3],yyvsp[-2],yyvsp[-1],yyvsp[0]); - else yyval=semp; - ; - break;} -case 228: -#line 471 "forpar.y" -{YK; - break;} -case 229: -#line 471 "forpar.y" -{ - check_ext(&wstat); - on=ispub(yyvsp[-6]); - funname=buffunname[++nfunname]; args=argbuf[++nargbuf]; - strcpy(funname,yyvsp[-6]); strcpy(args,yyvsp[-4]); - if( submod && interf ) - { printw(-1,"Interface\n"); indent+=dind; } - if( *yyvsp[-8] ) printw(-1,"%s ",yyvsp[-8]); else printw(-1,""); - printw(0,"Function %s(%s)",yyvsp[-6],yyvsp[-4]); strcat(args,", "); - if( *yyvsp[-1] ){ printw(0," Result(%s)",yyvsp[-1]); strcat(args,yyvsp[-1]); } - else strcat(args,yyvsp[-6]); - indent+=dind; printw(0,"\n"); - ; - break;} -case 230: -#line 485 "forpar.y" -{ - check_ext(&wstat); - on=ispub(yyvsp[-2]); - funname=buffunname[++nfunname]; args=argbuf[++nargbuf]; - strcpy(funname,yyvsp[-2]); strcpy(args,yyvsp[-1]); - if( submod && interf ) - { printw(-1,"Interface\n"); indent+=dind; } - if( *yyvsp[-4] ) printw(-1,"%s ",yyvsp[-4]); else printw(-1,""); - printw(0,"Subroutine %s(%s)",yyvsp[-2],yyvsp[-1]); - indent+=dind; printw(0,"\n"); - ; - break;} -case 231: -#line 498 "forpar.y" -{ indent-=dind; - if( *yyvsp[0] && strcmp(yyvsp[0],funname)!=0 ) - parerr("mismatching function name (%s<->%s)", - funname,yyvsp[0]); - printw(-1,"End Function %s\n",funname); - if( submod && interf ) - { indent-=dind; printw(-1,"End Interface\n"); } - funname=buffunname[--nfunname]; args=argbuf[--nargbuf]; - on=1; ; - break;} -case 232: -#line 509 "forpar.y" -{ indent-=dind; - if( *yyvsp[0] && strcmp(yyvsp[0],funname)!=0 ) - parerr("mismatching subroutine name (%s<->%s)", - funname,yyvsp[0]); - printw(-1,"End Subroutine %s\n",funname); - if( submod && interf ) - { indent-=dind; printw(-1,"End Interface\n"); } - funname=buffunname[--nfunname]; args=argbuf[--nargbuf]; - on=1; ; - break;} -case 233: -#line 519 "forpar.y" -{ yyval=semp; ; - break;} -case 234: -#line 520 "forpar.y" -{ yyval=yyvsp[-1]; ; - break;} -case 235: -#line 522 "forpar.y" -{ yyval=semp; ; - break;} -case 236: -#line 523 "forpar.y" -{ yyval=yyvsp[-1]; ; - break;} -case 237: -#line 525 "forpar.y" -{ yyval=semp; ; - break;} -case 238: -#line 526 "forpar.y" -{ yyval=spr(0,"%s",yyvsp[-1]); ; - break;} -case 239: -#line 528 "forpar.y" -{ yyval=semp; ; - break;} -case 241: -#line 531 "forpar.y" -{ yyval=semp; ; - break;} -case 242: -#line 532 "forpar.y" -{ yyval=yyvsp[-1]; ; - break;} -case 244: -#line 535 "forpar.y" -{ yyval=spr(0,"%s, %s",yyvsp[-2],yyvsp[0]); ; - break;} -case 246: -#line 538 "forpar.y" -{ yyval="*"; ; - break;} -case 247: -#line 540 "forpar.y" -{ yyval=semp; ; - break;} -case 249: -#line 542 "forpar.y" -{ yyval=spr(0,"Recursive"); ; - break;} -case 250: -#line 543 "forpar.y" -{ yyval=spr(0,"Pure"); ; - break;} -case 251: -#line 544 "forpar.y" -{ yyval=spr(0,"Elemental"); ; - break;} -case 255: -#line 551 "forpar.y" -{ yyval=semp; ; - break;} -case 256: -#line 552 "forpar.y" -{ hp=heap; ; - break;} -case 257: -#line 553 "forpar.y" -{ hp=heap; ; - break;} -case 269: -#line 573 "forpar.y" -{ internal=0; ; - break;} -case 276: -#line 587 "forpar.y" -{ yyval=semp; ; - break;} -case 277: -#line 588 "forpar.y" -{ yyval=yyvsp[0]; ; - break;} -case 278: -#line 591 "forpar.y" -{ yyval=semp; ; - break;} -case 279: -#line 592 "forpar.y" -{ yyval="::"; ; - break;} -case 282: -#line 601 "forpar.y" -{ if( submod ) internal=1; - else { - indent-=dind; printw(0,"\n"); - printw(-1,"!CONTAINS\n\n"); indent+=dind; - printw(0,"\n"); printw(-1,"Interface\n\n"); - indent+=dind; submod=cont=1; - } - ; - break;} -case 284: -#line 612 "forpar.y" -{ - if( *yyvsp[-1] && strcmp(yyvsp[-1],modname)!=0 ) - parerr("end module: non-matching name (\"%s <-> %s\")",modname,yyvsp[-1]); - if( cont ){ indent-=dind; printw(0,"\n"); printw(-1,"End Interface\n\n"); } - indent-=dind; printw(0,"\n"); printw(-1,"END MODULE %s\n",modname); - cont=ext=0; - if( indent!=0 ) parerr("problems in indentation (indent=%d)",indent); - if( !filedep ) { - fclose(flout); flout=NULL; - if( chkint ) do_chkint(fnout,fnold); - } -; - break;} -} - /* the action file gets copied in in place of this dollarsign */ -#line 498 "/usr/share/bison.simple" - - yyvsp -= yylen; - yyssp -= yylen; -#ifdef YYLSP_NEEDED - yylsp -= yylen; -#endif - -#if YYDEBUG != 0 - if (yydebug) - { - short *ssp1 = yyss - 1; - fprintf (stderr, "state stack now"); - while (ssp1 != yyssp) - fprintf (stderr, " %d", *++ssp1); - fprintf (stderr, "\n"); - } -#endif - - *++yyvsp = yyval; - -#ifdef YYLSP_NEEDED - yylsp++; - if (yylen == 0) - { - yylsp->first_line = yylloc.first_line; - yylsp->first_column = yylloc.first_column; - yylsp->last_line = (yylsp-1)->last_line; - yylsp->last_column = (yylsp-1)->last_column; - yylsp->text = 0; - } - else - { - yylsp->last_line = (yylsp+yylen-1)->last_line; - yylsp->last_column = (yylsp+yylen-1)->last_column; - } -#endif - - /* Now "shift" the result of the reduction. - Determine what state that goes to, - based on the state we popped back to - and the rule number reduced by. */ - - yyn = yyr1[yyn]; - - yystate = yypgoto[yyn - YYNTBASE] + *yyssp; - if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) - yystate = yytable[yystate]; - else - yystate = yydefgoto[yyn - YYNTBASE]; - - goto yynewstate; - -yyerrlab: /* here on detecting error */ - - if (! yyerrstatus) - /* If not already recovering from an error, report this error. */ - { - ++yynerrs; - -#ifdef YYERROR_VERBOSE - yyn = yypact[yystate]; - - if (yyn > YYFLAG && yyn < YYLAST) - { - int size = 0; - char *msg; - int x, count; - - count = 0; - /* Start X at -yyn if nec to avoid negative indexes in yycheck. */ - for (x = (yyn < 0 ? -yyn : 0); - x < (sizeof(yytname) / sizeof(char *)); x++) - if (yycheck[x + yyn] == x) - size += strlen(yytname[x]) + 15, count++; - msg = (char *) malloc(size + 15); - if (msg != 0) - { - strcpy(msg, "parse error"); - - if (count < 5) - { - count = 0; - for (x = (yyn < 0 ? -yyn : 0); - x < (sizeof(yytname) / sizeof(char *)); x++) - if (yycheck[x + yyn] == x) - { - strcat(msg, count == 0 ? ", expecting `" : " or `"); - strcat(msg, yytname[x]); - strcat(msg, "'"); - count++; - } - } - yyerror(msg); - free(msg); - } - else - yyerror ("parse error; also virtual memory exceeded"); - } - else -#endif /* YYERROR_VERBOSE */ - yyerror("parse error"); - } - - goto yyerrlab1; -yyerrlab1: /* here on error raised explicitly by an action */ - - if (yyerrstatus == 3) - { - /* if just tried and failed to reuse lookahead token after an error, discard it. */ - - /* return failure if at end of input */ - if (yychar == YYEOF) - YYABORT; - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Discarding token %d (%s).\n", yychar, yytname[yychar1]); -#endif - - yychar = YYEMPTY; - } - - /* Else will try to reuse lookahead token - after shifting the error token. */ - - yyerrstatus = 3; /* Each real token shifted decrements this */ - - goto yyerrhandle; - -yyerrdefault: /* current state does not do anything special for the error token. */ - -#if 0 - /* This is wrong; only states that explicitly want error tokens - should shift them. */ - yyn = yydefact[yystate]; /* If its default is to accept any token, ok. Otherwise pop it.*/ - if (yyn) goto yydefault; -#endif - -yyerrpop: /* pop the current state because it cannot handle the error token */ - - if (yyssp == yyss) YYABORT; - yyvsp--; - yystate = *--yyssp; -#ifdef YYLSP_NEEDED - yylsp--; -#endif - -#if YYDEBUG != 0 - if (yydebug) - { - short *ssp1 = yyss - 1; - fprintf (stderr, "Error: state stack now"); - while (ssp1 != yyssp) - fprintf (stderr, " %d", *++ssp1); - fprintf (stderr, "\n"); - } -#endif - -yyerrhandle: - - yyn = yypact[yystate]; - if (yyn == YYFLAG) - goto yyerrdefault; - - yyn += YYTERROR; - if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) - goto yyerrdefault; - - yyn = yytable[yyn]; - if (yyn < 0) - { - if (yyn == YYFLAG) - goto yyerrpop; - yyn = -yyn; - goto yyreduce; - } - else if (yyn == 0) - goto yyerrpop; - - if (yyn == YYFINAL) - YYACCEPT; - -#if YYDEBUG != 0 - if (yydebug) - fprintf(stderr, "Shifting error token, "); -#endif - - *++yyvsp = yylval; -#ifdef YYLSP_NEEDED - *++yylsp = yylloc; -#endif - - yystate = yyn; - goto yynewstate; -} -#line 627 "forpar.y" - - -int yyerror(char* s){ - fflush(stdout); - fprintf(stderr,"%s: %s\n",command,s); - fprintf(stderr," encountered error while reading line %d:\n \"%s\"\n", - lineno,line); - fflush(stderr); - exit(1); -} - -void init(){ - modname[0]='\0'; -} - - - -void parerr(char *meldung, ...){ - va_list args; - - va_start(args,meldung); /* make args point to first argument of list */ - fflush(stdout); - fprintf(stderr,"%s: ",command); - vfprintf(stderr,meldung,args); - fprintf(stderr,"\n"); - fflush(stderr); - va_end(args); /* clear-up arg-list */ - - exit(1); -} - - -void parwarn(char *meldung, ...){ - va_list args; - - va_start(args,meldung); fflush(stdout); - fprintf(stderr,"%s: ",command); - vfprintf(stderr,meldung,args); fprintf(stderr,"\n"); fflush(stderr); - va_end(args); /* clear-up arg-list */ -} - - -/* finds the first occurence of string pat in string in */ -char* find(char* pat,char* in){ - int lin=strlen(in), lp=strlen(pat),dl=lin-lp,j; - char *p=pat, *s; - for( s=in; s<=in+dl; ++s ){ - for( j=0; jhpmax ) hpmax=hp; - va_end(args); /* clear-up arg-list */ - return p; -} - - -void printw(int m, char* format,...){ - va_list args; - int j; - - if( !on ) return; - if( m==-1 ) m=indent; - va_start(args,format); - for( j=1; j<=m; ++j ) fprintf(flout," "); - vfprintf(flout,format,args); - - va_end(args); /* clear-up arg-list */ -} - - -int ispub(char* name){ - int on; - slist *pub=NULL,*pri=NULL; - if( internal ) return 0; - if( submod && interf ) /* function is passed as an argument */ - if( present(name,args,", ") ) return 1; else return 0; - if( public ) on=1; if( private ) on=0; - if( submod && private && (pub=find_lele(&pub_l,name)) ) on=1; - if( submod && public && (pri=find_lele(&pri_l,name)) ) on=0; - if( pub && pri ) - parerr("name \"%s\" appears in both PUBLIC and PRIVATE list",name); - return on; -} - - -/* truncate string s to remove dot-separated suffix (e.g. file.for -> file) */ -int delsuff(char* s){ - char *pc; - for( pc=s+strlen(s)-1; pc!=s && *pc!='.' && *pc!='/'; --pc ); - if( pc==s || *pc!='.' ) return 0; - *pc='\0'; - return 1; -} - - -int fex(char *n){ - FILE* fp; - if( !(fp=fopen(n,"r")) ) return 0; - fclose(fp); - return 1; -} - - -void clearup(void){ - if( chkint && !ok ){ - remove(fnout); remove(fnold); - parwarn("parsing of file %s FAILED\n",fnin); - } -} - - -/* remove path from filename (e.g.: /home/users/paperino/file.for -> file.for */ -char* base(char* name){ - char* p=name+strlen(name)-1; - if( *p=='/' && p>name ) --p; - while( p>name && *p!='/' ) --p; - if( *p=='/' ) ++p; - return p; -} - - -/* if file is external function file, open flout */ -int check_ext(int* c){ - if( *c=='\0' && !filedep ){ /* external funcs & subs */ - if( flout!=NULL ) fclose(flout); - flout=newfile(fnin,fnout,1,0); /* do not add path */ - *c='e'; - } -} - - -/* get the path of file, including trailing "/" (path is "" if not specified) - return length of path-string (0 if not specified) */ -int mydirname(char *file, char *path){ - char *p, *pp; - for( p=file+strlen(file)-1; *p!='/' && p>=file; --p ); - for( pp=file; pp<=p; ++pp,++path ) *path=*pp; *path='\0'; - return pp-file; -} - - -/* choose new filename; if it exists, move the old int-file - if moddep (i.e. !filedep), put path in front of fnout - NB: very dirty: fnin and fnout are passed, fnold and path are global -*/ -FILE *newfile(char *fnin, char *fnout, int open, int addpath){ - FILE *fl; - if( addpath ) strcpy(fnout,path); else *fnout='\0'; - strcat(fnout,fnin); delsuff(fnout); strcpy(fnold,fnout); - strcat(fnout,".int"); strcat(fnold,".oldint"); - remove(fnold); - if( fex(fnout) ) - rename(fnout,fnold); - if( open ){ - if( !(fl=fopen(fnout,"w")) ) - parerr("could not open file \"%s\" for writing\n",fnout); - return fl; - } - return NULL; -} - - -int do_chkint(char *fnout, char *fnold){ - char cmd[512]; - char *filemod[2]={"module" /* filedep==0 */ ,"file" /* filedep==0 */ }; - int cmp; - - sprintf(cmd,"cmp -s %s %s",fnout,fnold); - if( !fex(fnold) ) - parwarn("BUILT INTERFACE for %s %s\n",filemod[filedep],fnout); - else if( (cmp=system(cmd))==0 ){ - parwarn("Interface of %s \"%s\" has NOT CHANGED\n",filemod[filedep],fnout); - rename(fnold,fnout); - } else parwarn("Interface of %s \"%s\" DID CHANGE\n",filemod[filedep],fnout); - remove(fnold); -} - - -void prhelp(){ - printf("%s: create an interface for a fortran90 module\n",command); - printf(" usage is: %s [options] \n",command); - printf(" or: %s [options] -fix \n",command); - printf(" or: %s [options] -autofix \n",command); - printf(" options are:\n"); - printf(" -h|-?: print this help\n"); - printf(" -fix: specify that following files are in fixed format\n"); - printf(" -autofix: try to detect which files are fixed and wich are\n"); - printf(" free format\n"); - printf(" -o : specify file on which to write interface\n"); - printf(" -chkint: create interface and check if it has changed\n"); - printf(" -filedep: (default) filename of interface is chosen based \n"); - printf(" on name of file, not name of module\n"); - printf(" -moddep: filename of interface is chosen based on name of\n"); - printf(" module, not name of file\n"); - printf("\n"); - exit(1); - return; -} - - -int main(int argc, char* argv[]){ - slist *p; - -#ifdef YYDEBUG - yydebug=1; -#endif - - flout=stdout; - init(); /* set defaults */ - command=base(argv[0]); - - /* check options */ - while( argc>1 && **++argv=='-' ){ - --argc; - if( strcmp(*argv,"-?")==0 | strcmp(*argv,"-h")==0 ){ /* -?|-h print help */ - prhelp(); ++argv; --argc; - } else if( strcmp(*argv,"-o")==0 ){ /* -o : output to */ - strcpy(fnout,*++argv); --argc; - } else if( strcmp(*argv,"-fix")==0 ){ /* -fix: - parse fixed format file */ - fixed=1; - } else if( strcmp(*argv,"-chkint")==0 ){ /* -chkint: - handle interface files for dependencies */ - chkint=1; - } else if( strcmp(*argv,"-filedep")==0 ){ /* -filedep: - dependencies based on files (one .int file for each *.f) */ - filedep=1; - } else if( strcmp(*argv,"-moddep")==0 ){ /* -moddep: (default) - dependencies based on modules (one .int file for each module, - + one for the program) */ - filedep=0; - } else parerr("illegal option (\"%s\")\n",*argv); - } - if( argc>2 ) parerr("specify at most one argument\n"); - if( chkint && argc!=2 ) - parerr("with the \"-chkint\" option you MUST specify the input file\n"); - if( chkint && *fnout ) - parerr("with the \"-chkint\" option you CANNOT specify the output file\n"); - - if( argc==2 ){ strcpy(fnin,*argv); mydirname(fnin,path); } - - if( chkint ){ - atexit(clearup); - if( filedep ) flout=newfile(fnin,fnout,1,0); - } - - if( filedep && *fnout && !(flout=fopen(fnout,"w")) ) - parerr("could not open file \"%s\" for writing\n",fnout); - if( *fnin && !(yyin=fopen(fnin,"r")) ) - parerr("could not open file \"%s\" for reading\n",fnin); - - - - yyparse(); ok=1; - - - - if( *fnout && flout ) { fclose(flout); flout=NULL; } - if( chkint && filedep ) do_chkint(fnout,fnold); - - -#ifdef YYDEBUG - parwarn("MAX OCCUPANCY OF:\n"); - parwarn(" stack: %d bytes (=%.1f kb = %.1f Mb)\n", - (spmax-stack),(spmax-stack)/1024.,(spmax-stack)/1024./1024.); - parwarn(" heap: %d bytes (=%.1f kb = %.1f Mb)\n", - (hpmax-heap),(hpmax-heap)/1024.,(hpmax-heap)/1024./1024.); -#endif - -/* fprintf(stderr,"read %d lines\n",lineno); */ - - return 0; /* everything ok */ -} diff --git a/tools/forpar.tab.h b/tools/forpar.tab.h deleted file mode 100644 index a05f350..0000000 --- a/tools/forpar.tab.h +++ /dev/null @@ -1,69 +0,0 @@ -#ifndef YYSTYPE -#define YYSTYPE int -#endif -#define MODULE 258 -#define ENDMOD 259 -#define CONTAINS 260 -#define PROGRAM 261 -#define INTEGER 262 -#define REAL 263 -#define DPREC 264 -#define COMPLEX 265 -#define CHARACTER 266 -#define LOGICAL 267 -#define TYPE 268 -#define ENDTYPE 269 -#define USE 270 -#define ONLY 271 -#define OPERATOR 272 -#define ASSIGNMENT 273 -#define ID 274 -#define CID 275 -#define POINT 276 -#define ARBCHARLEN 277 -#define DCOLON 278 -#define ARRIN 279 -#define ARROUT 280 -#define IMPLICIT 281 -#define IMPLNONE 282 -#define PARAMETER 283 -#define OPER 284 -#define DEFOPER 285 -#define REALC 286 -#define STRC 287 -#define LOGC 288 -#define INTERFACE 289 -#define ENDINTER 290 -#define MODPROC 291 -#define RECURSIVE 292 -#define PURE 293 -#define ELEMENTAL 294 -#define FUNCTION 295 -#define RESULT 296 -#define ENDFUN 297 -#define SUBROUTINE 298 -#define ENDSUB 299 -#define END 300 -#define EOC 301 -#define UNKNOWN 302 -#define PUBLIC 303 -#define PRIVATE 304 -#define SEQUENCE 305 -#define ALLOCATABLE 306 -#define DIMENSION 307 -#define EXTERNAL 308 -#define INTENT 309 -#define IN 310 -#define OUT 311 -#define INOUT 312 -#define INTRINSIC 313 -#define OPTIONAL 314 -#define POINTER 315 -#define SAVE 316 -#define TARGET 317 -#define FORMAT 318 -#define ENTRY 319 -#define MODULSUB 320 - - -extern YYSTYPE yylval; diff --git a/tools/get_arch_code b/tools/get_arch_code deleted file mode 100755 index 39bda6e..0000000 --- a/tools/get_arch_code +++ /dev/null @@ -1,57 +0,0 @@ -#!/bin/ksh - -### Aliasing of commands ### - - alias echo="\echo" - -### No localization ### - - LANG=C - LC_MESSAGES=C - -### Load informations for system identification ### - - ostype=$(uname -s) - osversion=$(uname -v) - osrelease=$(uname -r) - machine=$(uname -m) - - platform="${ostype}-${osversion}-${osrelease}-${machine}" - - case $platform in - (AIX-*-*-*) - arch=$(lsattr -E -O -l proc0 | grep "enable" | cut -f2 -d":") - if [[ -n $arch ]]; then - PLATFORM="AIX-$arch" - else - PLATFORM="AIX" - fi;; - (IRIX-*-*-*) - PLATFORM="IRIX";; - (IRIX64-*-*-*) - PLATFORM="IRIX";; - (Linux-*-*-i686) - if [[ -n $PGI ]]; then - PLATFORM="Linux-i686-pgi" - elif [[ -d /usr/absoft ]]; then - PLATFORM="Linux-i686-absoft" - else - PLATFORM="Linux-i686" - fi;; - (Linux-*-*-ppc) - if [[ -n $PGI ]]; then - PLATFORM="Linux-ppc-pgi" - elif [[ -d /usr/absoft ]]; then - PLATFORM="Linux-ppc-absoft" - else - PLATFORM="Linux-ppc" - fi;; - (*-unicosmk-*-CRAY*T3E) - PLATFORM="CRAY-T3E";; - (*) - PLATFORM='unknown';; - esac - - echo ${PLATFORM} - -### End of procedure ### diff --git a/tools/sfmakedepend b/tools/sfmakedepend deleted file mode 100755 index 958f815..0000000 --- a/tools/sfmakedepend +++ /dev/null @@ -1,560 +0,0 @@ -#!/usr/local/bin/perl -# -# Usage: sfmakedepend [-s] [-e ext] [-f file] [-I incdir] -# [-m mod_ext] [-c] [-p] [-g] [-h] [-o obj_ext] -# [-a add_ext] file ... -# -# This is a makedepend script for Fortran, including Fortran 90. -# It searches for Fortran style includes, C preprocessor includes, -# and module dependencies to the extent that I understand them. -# -# Your files must have an extension listed in the @suffixes list -# below. You might also want to modify $compile_string if you use -# the -c or -p option. I call the compiler $(CFT) for historical -# reasons. -# -# The switch [-s] is for stupid Fortran compilers that don't know -# how to automatically send things through the C preprocessor. -# It is possible to force 'make' to invoke 'cpp' to create a .f -# file from a .F file (which has cpp directives), but make won't -# know that a .f file will depend on the files that the .F file -# included. This option will provide those dependencies. -# -# The [-e ext] switch is used with the [-s] switch for compilers -# which expect an extension other than .f on source files. For -# instance, for the Connection Machine one would use "-e fcm". -# -# The [-f file] switch is used to change the name of the current -# Makefile. -# -# The [-I incdir] option tells sfmakedepend to look in alternate -# directories for the include files. There can be several "-I dir" -# options used at once. The current directory is still searched -# first. -# -# The [-m mod_ext] option tells sfmakedepend what extension to -# use for Fortran 90 module files. The default for "use My_Mod" -# is to list the dependency as "my_mod.mod" since this is what -# NAG f90 and IBM xlf both use. Let me know if other compilers -# use a different filename for the module information. -# -# The [-c] option specifies that the Cray compiler is being used. -# This compiler requires a "-p file.o" option for each object file -# that contains a module used by your current source file. -# -# The [-p] option specifies that the Parasoft compiler is being used. -# This compiler requires a "-module file.o" option for each object file -# that contains a module used by your current source file. -# -# The [-g] option specifies that the SGI compiler is being used. -# This compiler names the module file in uppercase with the extension -# .kmo. -# -# The [-h] option specifies that the HP compiler is being used. -# This compiler names the module file in uppercase with the extension -# .mod (added by Patrick Jessee who also fixed an include bug). -# -# The [-o obj_ext] option tells sfmakedepend what extension to use for -# object files. The default is "o", but "obj", for instance, is -# appropriate on MS-DOG etc. This option was added by Dave Love. -# -# The [-a add_ext] option (also added by Dave Love) tells sfmakedepend -# to add targets with extension add_ext to the rules for object files. -# For instance, to operate with (f77) ftnchek .prj files, you could use -# `-a prj' to get rules like: -# foo.prj foo.o: ... -# -# The final arguments contain the list of source files to be -# searched for dependencies. -# -# EXAMPLE -# sfmakedepend -I /usr/local/include *.F -# -# NOTES -# This makedepend script is my first attempt at using perl 5 -# objects. Therefore, it may not be the best example of how -# to do this. Also, it requires perl 5 and will die if you -# to use it with an older perl. The latest version is -# available from: -# -# http://marine.rutgers.edu/po/perl.html -# ftp://ahab.rutgers.edu/pub/perl/sfmakedepend -# -# Fortran 90 introduces some interesting dependencies. Two -# compilers I have access to (NAG f90 and IBM xlf) produce a -# private "mod_name.mod" file if you define "module mod_name" -# in your code. This file is used by the compiler when you -# use the module as a consistency check (type-safe). On the -# other hand, the Cray and Parasoft compilers store the module -# information in the object file and then files which use the -# modules need to be compiled with extra flags pointing to the -# module object files. -# -# This script assumes that all the files using and defining -# modules are in the same directory and are all in the list of -# files to be searched. It seems that the industry has not -# settled on a practical way to deal with a separate modules -# directory, anyway. -# -# I sometimes include non-existent files as a compile time -# consistency check: -# -# #ifndef PLOTS -# #include "must_define_PLOTS" /* bogus include */ -# #endif -# -# This program warns about include files it can't find, but -# not if there is a "bogus" on the same line. -# -# * The f90 module dependencies can confuse some versions of -# make, especially of the System V variety. We use gnu -# make because it has no problems with these dependencies. -# -# BUGS -# It can sometimes produce duplicate dependencies. -# -# It treats C preprocessor includes the same as Fortran -# includes. This can add unnecessary dependencies if you -# use the -s flag and both kinds of includes. -# -# Please let me know if you find any others. -# Kate Hedstrom -# kate@ahab.rutgers.edu -# - -package source_file; - -# hashes containing names of included files, modules in files -%inc_files = (); -%main::mod_files = (); - -# Constructor -sub new { - my $type = shift; - my $filename = shift; - my $path = shift; - my $self = {}; - $self->{'source_file'} = $filename; - $self->{'filepath'} = $path; - $self->{'includes'} = {}; - $self->{'uses'} = {}; - $self->{'modules'} = {}; - bless $self; -} - -sub find_includes { - my $self = shift; - my $file = $self->{'filepath'}; - my($after, $filepath, $ref, $included, $use, $modname); - local(*FILE); - local($_); - - if (-f $file) { - open(FILE, $file) || warn "Can't open $file: $!\n"; - } elsif (-f "RCS/$file,v" || -f "$file,v" ) { - system("co $file"); - open(FILE, $file) || warn "Can't open $file: $!\n"; - $main::rcs{$file} = 1; - } else { - return; - } - while () { - $included = ""; - $use = ""; - # look for Fortran style includes - if (/^\s*include\s*['"]([^"']*)["']/i) { - $included = $1; - $after = $'; - # C preprocessor style includes - } elsif (/^#\s*include\s*["<]([^">]*)[">]/) { - $included = $1; - $after = $'; - # Fortran 90 "use" - } elsif (/^\s*use\s+(\w+)/i) { - $use = $1; -# Make the module name lowercase except for SGI & HP. -# May be compiler dependent!! - if ($main::sgi || $main::hp) { - $use = uc($use); - } else { - $use = lc($use); - } - $self->{'uses'}{$use} = 1; - # Fortran 90 module - } elsif (/^\s*module\s+(\w+)/i) { - $modname = $1; - if ($main::sgi || $main::hp) { - $modname = uc($modname); - } else { - $modname = lc($modname); - } - unless (lc($modname) eq "procedure") { - $main::mod_files{$modname} = $file; - $self->{'modules'}{$modname} = 1; - } - } - if ($included) { - if ( $inc_files{$included} ) { - $filepath = $inc_files{$included}{'filepath'}; - } else { - $filepath = &main::findfile($included); - $ref = new source_file($included, $filepath); - $inc_files{$included} = $ref; -# Search included file for includes - $ref->find_includes(); - } - if ( $filepath ) { - $self->{'includes'}{$included} = 1; - } else { - if ($after !~ /bogus/i) { - warn "Can't find file: $included\n"; - } - } - } - } - close FILE; -} - -sub print_includes { - my $self = shift; - my $target = shift; - my $len_sum = shift; - my($file, $ref); - my %printed = (); - - foreach $file (keys %{$self->{'includes'}}) { - next if $printed{$file}; - $ref = $inc_files{$file}; - my $len = length($ref->{'filepath'}) + 1; - if (($len_sum + $len > 80) && - (length($target) + 1 < $len_sum)) { - print "\n$target:"; - $len_sum = length($target) + 1; - } - print " " . $ref->{'filepath'}; - $printed{$file} = 1; - $len_sum += $len; - $len_sum = $ref->print_includes($target, $len_sum); - } - $len_sum; -} - -# return list of modules used by included files -sub inc_mods { - my $self = shift; - my($file, $ref, $mod, @sub_list); - my @list = (); - my %printed = (); - - foreach $mod (keys %{$self->{'uses'}}) { - push(@list, $mod); - } - - foreach $file (keys %{$self->{'includes'}}) { - next if $printed{$file}; - $ref = $inc_files{$file}; - $printed{$file} = 1; - @sub_list = $ref->inc_mods(); - @list = (@list, @sub_list); - } - @list; -} - -# filenames containing the list of modules used by file and all its includes -sub find_mods { - my $self = shift; - my($ref, $modname, $file, @list, $base); - my @module_files = (); - my @mod_list = (); - my @tmp_list = (); - -# find modules used by include files - if (%{$self->{'includes'}}) { - foreach $file (keys %{$self->{'includes'}}) { - $ref = $inc_files{$file}; - @list = $ref->inc_mods(); - @tmp_list = @mod_list; - @mod_list = (@tmp_list, @list); - } - } - -# add them to the uses list (hash ensures uniqueness) - foreach $modname (@mod_list) { - $self->{'uses'}{$modname} = 1; - } - -# now find the filename that contains the module information - foreach $modname (keys %{$self->{'uses'}}) { - if ($main::cray || $main::parasoft) { - if ($file = $main::mod_files{$modname}) { - $base = &main::basename($file, @main::suffixes); - $file = $base . "." . $main::obj_ext; - push(@module_files, $file); - } else { - warn "Don't know where module $modname lives.\n"; - } - } else { - $modname .= "." . $main::mod_ext; - push(@module_files, $modname); - } - } - sort(@module_files); -} - -sub print { - my $self = shift; - my $source = $self->{'source_file'}; - my $compile_string = "\t" . '$(CFT) $(FFLAGS) -c'; - my($base, $object, $modname, $flag, $target, $ftarget); - - $base = &main::basename($source, @main::suffixes); - $target = $base . "." . $main::obj_ext; - if ($main::stupid) { - $ftarget = $base . "." . $main::ext; - } - - if ($main::cray) { - $flag = " -p "; - } elsif ($main::parasoft) { - $flag = " -module "; - } - -# print out "include" dependencies - if (%{$self->{'includes'}}) { - my $len_sum = length($target) + 1; - if ($main::add_ext) { - $target .= " $base.$main::add_ext"; - $len_sum += length($base) + length($main::add_ext) + 2; - } - print "$target:"; - $self->print_includes($target, $len_sum); - print "\n"; - if ($main::stupid) { - $len_sum = length($ftarget) + 1; - print "$ftarget:"; - $self->print_includes($ftarget, $len_sum); - print "\n"; - } - } - -# clean out "use" of modules in own file - foreach $mod ( keys %{$self->{'uses'}} ) { - if ( ${$self->{'modules'}}{$mod} ) { - delete ${$self->{'uses'}}{$mod}; - } - } - -# print out "use" dependencies - if (%{$self->{'uses'}} || %{$self->{'includes'}}) { - @module_files = $self->find_mods(); - my $len_sum = length($target) + 1; - print "$target:"; - foreach $file (@module_files) { - my $len = length($file) + 1; - if (($len_sum + $len > 80) && - (length($target) + 1 < $len_sum)) { - print "\n$target:"; - $len_sum = length($target) + 1; - } - $len_sum += $len; - print " " . $file; - } - if ($main::need_f) { - my $len = length($ftarget) + 1; - if (($len_sum + $len > 80) && - (length($target) + 1 < $len_sum)) { - print "\n$target:"; - $len_sum = length($target) + 1; - } - print " " . $ftarget; - } - print "\n"; -# extra Cray / Parasoft stuff - if ($main::cray || $main::parasoft) { - print $compile_string; - foreach $file (@module_files) { - print $flag . $file; - } - if ($main::stupid) { - print " " . $ftarget . "\n"; - } else { - print " " . $source . "\n"; - } - } - } -} - - -# Start of main program -package main; - -if ($] < 5.000) { die "Need perl 5.000 or newer\n"; } -use File::Basename; -use Getopt::Long; -@suffixes = qw( .c .C .cc .cxx .cpp .f .F .fcm .FCM .f90 .F90 .for); - -GetOptions("s", "e=s", "f=s", "I=s@", "m=s", "c", "p", "g", "h", "o=s", "a=s") - || die "problem in GetOptions"; - -# For compilers that don't invoke cpp for you -if ($opt_s) { - $stupid = 1; -} -if ($opt_e) { - $ext = $opt_e; -} else { - $ext = "f"; -} - -# list of directories to search, starting with current directory -if (@opt_I) { - @incdirs = @opt_I; -} elsif (@opt_i) { - @incdirs = @opt_i; -} - -if ($opt_f) { - $mf = $opt_f; -} elsif (-f "makefile") { - $mf = 'makefile'; -} else { - $mf = 'Makefile'; -} -if ( !(-f $mf)) { - system "touch $mf"; -} - -# extension used for compiler's private module information -if ($opt_m) { - $mod_ext = $opt_m; -} else { - $mod_ext = 'mod'; -} - -if ($opt_c) { - $cray = 1; -} - -if ($opt_p) { - $parasoft = 1; -} - -if ($opt_g) { - $sgi = 1; - $mod_ext = 'kmo'; -} - -if ($opt_h) { - $hp = 1; -} - -# need to add some more dependencies so the .f file gets created -if ($stupid && ($cray || $parasoft)) { - $need_f = 1; -} - -if ($opt_c && $opt_p) { - die "Doesn't make sense to have both Cray and Parasoft options!"; -} - -# object file extension -if ($opt_o) { - $obj_ext = $opt_o; -} else { - $obj_ext = 'o'; -} - -# extension for additional targets (like .prj) -if ($opt_a) { - $add_ext = $opt_a; -} - -$mystring = '# DO NOT DELETE THIS LINE - used by make depend'; - - -# Search for the includes in all the files -foreach $file (@ARGV) { - $sources{$file} = new source_file($file, $file); - $sources{$file}->find_includes(); -} - -# Create new Makefile with new dependencies. - -open(MFILE, $mf) || die "can't read Makefile $mf: $!\n"; -open(NMFILE, "> Makefile.new") || die "can't write Makefile.new: $!\n"; -select(NMFILE); - -while () { - if (!/$mystring/) { - print; - } else { - last; - } -} - -print $mystring, "\n"; - -# Now print out include and use dependencies in sorted order. -foreach $target (sort keys(%sources)) { - $sources{$target}->print(); -} - -# print out module dependencies -if ( !( $cray || $parasoft) ) { - foreach $modname (sort keys(%mod_files)) { - ($name, $path, $suffix) = - &fileparse($sources{$mod_files{$modname}}->{'filepath'}, @suffixes); - $object = $path . "/" . $name . "." . $obj_ext; - print "$modname.$mod_ext: $object\n"; - } -} - -# Sort out the Makefiles - -rename($mf, "$mf.old") || warn "can't overwrite $mf.old: $!\n"; -rename('Makefile.new', $mf) || - warn "can't move Makefile.new to $mf: $!\n"; - -# Delete those RCS files we checked out -foreach $file (keys %rcs) { - unlink($file); -} - -# -# End of main -# - -sub findfile { -# Let's see if we can find the included file. Look in current -# directory first, then in directories from -I arguments. Finally, -# look for RCS files in current directory. - my $file = shift; - my($found, $i, $filepath); - - $found = 0; - - if ( -f $file ) { - $found = 1; - $file =~ s#^\./##; # convert ./foo.h to foo.h - return $file; - } - foreach $i (0 .. $#incdirs) { - $filepath = $incdirs[$i]."/".$file; - if ( -f $filepath ) { - $found = 1; - $filepath =~ s#^\./##; # convert ./foo.h to foo.h - return $filepath; - } - } -#see if it is a checked-in RCS file - if (-f "RCS/$file,v" || -f "$file,v" ) { - $found = 1; - system("co $file"); - $filepath = $file; - $rcs{$file} = 1; - } - if ( ! $found ) { - $filepath = ""; - } - $filepath; -} diff --git a/tools/slist.c b/tools/slist.c deleted file mode 100644 index 7870de4..0000000 --- a/tools/slist.c +++ /dev/null @@ -1,69 +0,0 @@ -#include -#include -#include -#include "slist.h" - - -/* finds element "newele" in list "list" (NULL: not in list) */ -slist* find_lele(slist **list, char* newele){ - slist *p; - int f; - - for( p=*list; p && (f=strcmp(newele,p->ele))>0; p=p->nxt ); - if( p && f!=0 ) p=NULL; - - return p; -} - - -/* delete element newele from list */ -void del_lele(slist **list, char* newele){ - slist *p,*pp; - int f; - - for( p=*list,pp=NULL; p && (f=strcmp(newele,p->ele))>0; pp=p,p=p->nxt ); - if( !p || f!=0 ) return; /* element not in list */ - if( pp ) - pp->nxt=p->nxt; /* remove element p from list */ - else - *list=p->nxt; - free( p->ele ); - free( p ); - - return; -} - - -/* delete and dellocate all elements from list */ -void zap_lele(slist **list){ - slist *p=*list,*pp=NULL; - - while( p ){ pp=p; p=p->nxt; free(pp); } - *list=NULL; - - return; -} - - -/* insert element "newele" into sorted list "list". - * "list" is entry-point of sorted list. - * pp and p point to the element before and after newele - */ -void ins_lele(slist **list, char* newele){ - slist *p,*pn,*pp; - int f; - char *s; - - for( p=*list,pp=NULL; p && (f=strcmp(newele,p->ele))>0; pp=p,p=p->nxt ); - if( p && f==0 ) return; /* newele already exists */ - if( !(pn=malloc(sizeof(slist))) ) - { fprintf(stderr,"malloc error in ins_lele (pn)\n"); exit(1); } - if( !pp ) /* put at head of list */ - { pn->nxt=*list; *list=pn; } - else /* insert pn between pp and p */ - { pn->nxt=p; pp->nxt=pn; } - if( !(s=malloc(strlen(newele)+1)) ) - { fprintf(stderr,"malloc error in ins_lele (s)\n"); exit(1); } - strcpy(s,newele); - pn->ele=s; -} diff --git a/tools/slist.h b/tools/slist.h deleted file mode 100644 index 2ce475d..0000000 --- a/tools/slist.h +++ /dev/null @@ -1,30 +0,0 @@ -typedef struct slist_s slist; - -struct slist_s { - char* ele; - slist *nxt; -}; - - - - -/* finds element "newele" in list "list" (NULL: not in list) */ -slist* find_lele(slist **list, char* newele); - - - -/* delete element newele from list */ -void del_lele(slist **list, char* newele); - - - -/* insert element "newele" into sorted list "list". - * "list" is entry-point of sorted list. - * pp and p point to the element before and after newele - */ -void ins_lele(slist **list, char* newele); - - - -/* delete and dellocate all elements from list */ -void zap_lele(slist **list);