diff --git a/.gitignore b/.gitignore index da51fad..4f2d16b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,22 +1,5 @@ -# base directory structure -/exe/ -/lib/ -/obj/ /bin/ -/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 +/build/ ### C ### # Prerequisites @@ -28,15 +11,6 @@ *.obj *.elf -# Linker output -*.ilk -*.map -*.exp - -# Precompiled Headers -*.gch -*.pch - # Libraries *.lib *.a @@ -48,262 +22,6 @@ *.so *.so.* *.dylib +.vscode -# 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 +.DS_Store \ No newline at end of file diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..355cea6 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,24 @@ +!-----------------------------------------------------------------------------! +! ! +! 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 new file mode 100644 index 0000000..653a95b --- /dev/null +++ b/INSTALL @@ -0,0 +1,86 @@ + +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 deleted file mode 100644 index 1e79309..0000000 --- a/LICENSE +++ /dev/null @@ -1,339 +0,0 @@ - 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 new file mode 100644 index 0000000..031266f --- /dev/null +++ b/Makefile @@ -0,0 +1,106 @@ +.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 new file mode 100644 index 0000000..6787e35 --- /dev/null +++ b/README @@ -0,0 +1,19 @@ + +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 deleted file mode 100644 index af8aaff..0000000 --- a/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# cp2k_to_c - -Converting CP2K from fortran to C/C++ diff --git a/arch/AIX-POWER2.pdbg b/arch/AIX-POWER2.pdbg new file mode 100644 index 0000000..17ced63 --- /dev/null +++ b/arch/AIX-POWER2.pdbg @@ -0,0 +1,17 @@ +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 new file mode 100644 index 0000000..0a3141b --- /dev/null +++ b/arch/AIX-POWER2.popt @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000..153281a --- /dev/null +++ b/arch/AIX-POWER2.sdbg @@ -0,0 +1,17 @@ +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 new file mode 100644 index 0000000..b454a1c --- /dev/null +++ b/arch/AIX-POWER2.sopt @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000..41eb2fb --- /dev/null +++ b/arch/CRAY-T3E.pdbg @@ -0,0 +1,30 @@ +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 new file mode 100644 index 0000000..6289542 --- /dev/null +++ b/arch/CRAY-T3E.popt @@ -0,0 +1,30 @@ +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 new file mode 100644 index 0000000..a08b7c7 --- /dev/null +++ b/arch/CRAY-T3E.sdbg @@ -0,0 +1,30 @@ +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 new file mode 100644 index 0000000..b6c2c1b --- /dev/null +++ b/arch/CRAY-T3E.sopt @@ -0,0 +1,30 @@ +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 new file mode 100644 index 0000000..0f649a9 --- /dev/null +++ b/arch/DEC.sdbg @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..eafb288 --- /dev/null +++ b/arch/DEC.sopt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..9b5d345 --- /dev/null +++ b/arch/IRIX.pdbg @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..1f8bb99 --- /dev/null +++ b/arch/IRIX.popt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..deed62f --- /dev/null +++ b/arch/IRIX.sdbg @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..84e6e7f --- /dev/null +++ b/arch/IRIX.sopt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..bdf4d61 --- /dev/null +++ b/arch/Linux-i686-absoft.sdbg @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..dfb30d4 --- /dev/null +++ b/arch/Linux-i686-absoft.sopt @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..06811ab --- /dev/null +++ b/arch/Linux-i686-pgi.sdbg @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..9ea85f9 --- /dev/null +++ b/arch/Linux-i686-pgi.sopt @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..01bb7e8 --- /dev/null +++ b/arch/Linux-ppc-absoft.sdbg @@ -0,0 +1,13 @@ +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 new file mode 100644 index 0000000..d2626de --- /dev/null +++ b/arch/Linux-ppc-absoft.sopt @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..433b50f --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,124 @@ +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 new file mode 100644 index 0000000..2700a26 --- /dev/null +++ b/src/MACHINEDEFS.DEC @@ -0,0 +1,21 @@ +### 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 new file mode 100644 index 0000000..028e3a4 --- /dev/null +++ b/src/MACHINEDEFS.IBM @@ -0,0 +1,27 @@ +### 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 new file mode 100644 index 0000000..ec7472b --- /dev/null +++ b/src/MACHINEDEFS.PGI @@ -0,0 +1,21 @@ +### 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 new file mode 100644 index 0000000..b87804e --- /dev/null +++ b/src/MACHINEDEFS.SGI @@ -0,0 +1,22 @@ +### 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 new file mode 100644 index 0000000..3503140 --- /dev/null +++ b/src/MACHINEDEFS.T3E @@ -0,0 +1,21 @@ +### 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 new file mode 100644 index 0000000..db5fb3f --- /dev/null +++ b/src/Makefile @@ -0,0 +1,55 @@ +.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 new file mode 100644 index 0000000..1a2eb40 --- /dev/null +++ b/src/OBJECTDEFS @@ -0,0 +1,27 @@ +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 new file mode 100644 index 0000000..6c91931 --- /dev/null +++ b/src/TODO @@ -0,0 +1,4 @@ +### 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 new file mode 100644 index 0000000..488124b --- /dev/null +++ b/src/amoeba.cpp @@ -0,0 +1,98 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..9a33cfc --- /dev/null +++ b/src/amoeba.h @@ -0,0 +1,10 @@ +#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 new file mode 100644 index 0000000..18a8f82 --- /dev/null +++ b/src/atoms_input.cpp @@ -0,0 +1,181 @@ +#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 new file mode 100644 index 0000000..799a584 --- /dev/null +++ b/src/atoms_input.h @@ -0,0 +1,33 @@ +#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 new file mode 100644 index 0000000..ae31e90 --- /dev/null +++ b/src/coefficient_types.cpp @@ -0,0 +1,60 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..7efaece --- /dev/null +++ b/src/coefficients.cpp @@ -0,0 +1,28 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..34fb29e --- /dev/null +++ b/src/coefficients.h @@ -0,0 +1,36 @@ +#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 new file mode 100644 index 0000000..5940c86 --- /dev/null +++ b/src/complex.h @@ -0,0 +1,9 @@ +#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 new file mode 100644 index 0000000..cc0fe6b --- /dev/null +++ b/src/constraint.c @@ -0,0 +1,1475 @@ +/*-----------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..cdd9c3d --- /dev/null +++ b/src/convert_units.c @@ -0,0 +1,160 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..5d0ae20 --- /dev/null +++ b/src/cp2k.cpp @@ -0,0 +1,65 @@ +/*---------------------------------------------------------------------------*/ +/* */ +/* 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 new file mode 100644 index 0000000..6824c3a --- /dev/null +++ b/src/cp2k.h @@ -0,0 +1,14 @@ +#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 new file mode 100644 index 0000000..26ba387 --- /dev/null +++ b/src/cp2k_input.cpp @@ -0,0 +1,89 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..24d7113 --- /dev/null +++ b/src/dg.h @@ -0,0 +1,30 @@ +#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 new file mode 100644 index 0000000..d382835 --- /dev/null +++ b/src/dg_rho0s.c @@ -0,0 +1,148 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a6bd16c --- /dev/null +++ b/src/dg_types.c @@ -0,0 +1,25 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..7c579d8 --- /dev/null +++ b/src/dgs.c @@ -0,0 +1,730 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..014dd5e --- /dev/null +++ b/src/dump.c @@ -0,0 +1,62 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..26bb03c --- /dev/null +++ b/src/eigenvalueproblems.c @@ -0,0 +1,303 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..dce720e --- /dev/null +++ b/src/environment.cpp @@ -0,0 +1,120 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..2350fcc --- /dev/null +++ b/src/erf.c @@ -0,0 +1,319 @@ + +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 new file mode 100644 index 0000000..bb70632 --- /dev/null +++ b/src/erf_fn.c @@ -0,0 +1,348 @@ + +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 new file mode 100644 index 0000000..323510e --- /dev/null +++ b/src/ewald.h @@ -0,0 +1,23 @@ +#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 new file mode 100644 index 0000000..1f0f3b7 --- /dev/null +++ b/src/ewald_parameters_types.c @@ -0,0 +1,26 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..d2be584 --- /dev/null +++ b/src/ewalds.c @@ -0,0 +1,330 @@ +#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 new file mode 100644 index 0000000..4758052 --- /dev/null +++ b/src/fft_tools.c @@ -0,0 +1,989 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..8b53ccd --- /dev/null +++ b/src/fist.cpp @@ -0,0 +1,241 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..ab86f4a --- /dev/null +++ b/src/fist_debug.c @@ -0,0 +1,452 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..fd63f9e --- /dev/null +++ b/src/fist_force.c @@ -0,0 +1,279 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a538cbb --- /dev/null +++ b/src/fist_force_numer.c @@ -0,0 +1,1322 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..560c6cb --- /dev/null +++ b/src/fist_global.c @@ -0,0 +1,39 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..ff0327e --- /dev/null +++ b/src/fist_input.c @@ -0,0 +1,167 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..ad7edfe --- /dev/null +++ b/src/fist_intra_force.c @@ -0,0 +1,118 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..2215599 --- /dev/null +++ b/src/fist_nonbond_force.c @@ -0,0 +1,381 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..5a96156 --- /dev/null +++ b/src/force_control.c @@ -0,0 +1,61 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..17c8739 --- /dev/null +++ b/src/force_fields.c @@ -0,0 +1,846 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..5298a4f --- /dev/null +++ b/src/force_fit.c @@ -0,0 +1,1089 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..c49932b --- /dev/null +++ b/src/global_types.h @@ -0,0 +1,32 @@ +#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 new file mode 100644 index 0000000..2d2907f --- /dev/null +++ b/src/header.c @@ -0,0 +1,119 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..82c10f4 --- /dev/null +++ b/src/header.h @@ -0,0 +1,21 @@ +#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 new file mode 100644 index 0000000..ad834cc --- /dev/null +++ b/src/initialize_ewalds.c @@ -0,0 +1,111 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..de285fe --- /dev/null +++ b/src/initialize_extended_types.c @@ -0,0 +1,120 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..2c1bb39 --- /dev/null +++ b/src/initialize_molecule_types.c @@ -0,0 +1,140 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..c46c1e2 --- /dev/null +++ b/src/initialize_particle_types.c @@ -0,0 +1,81 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..caebd95 --- /dev/null +++ b/src/input_types.c @@ -0,0 +1,22 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a91e6e9 --- /dev/null +++ b/src/integrator.c @@ -0,0 +1,1099 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..1bf0407 --- /dev/null +++ b/src/io_parameters.c @@ -0,0 +1,55 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..6a033ab --- /dev/null +++ b/src/kinds.cpp @@ -0,0 +1,65 @@ +/* +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..58c2ded --- /dev/null +++ b/src/lapack.c @@ -0,0 +1,122 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..82a8790 --- /dev/null +++ b/src/linklist.h @@ -0,0 +1,32 @@ +#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 new file mode 100644 index 0000000..ae80516 --- /dev/null +++ b/src/linklist_cell_list.c @@ -0,0 +1,412 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..48670bd --- /dev/null +++ b/src/linklist_cell_types.c @@ -0,0 +1,36 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..6d30296 --- /dev/null +++ b/src/linklist_control.c @@ -0,0 +1,242 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..f6e67fc --- /dev/null +++ b/src/linklist_utilities.c @@ -0,0 +1,222 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a7dfabd --- /dev/null +++ b/src/linklist_verlet_list.c @@ -0,0 +1,303 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..4209b47 --- /dev/null +++ b/src/linklists.c @@ -0,0 +1,692 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..20b509c --- /dev/null +++ b/src/machine.c @@ -0,0 +1,34 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..4f83b1a --- /dev/null +++ b/src/machine_absoft.c @@ -0,0 +1,106 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..8d79105 --- /dev/null +++ b/src/machine_aix.c @@ -0,0 +1,118 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..f0211c9 --- /dev/null +++ b/src/machine_dec.c @@ -0,0 +1,135 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..efaa93d --- /dev/null +++ b/src/machine_irix.c @@ -0,0 +1,104 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..0cd5bed --- /dev/null +++ b/src/machine_pgi.c @@ -0,0 +1,135 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..590092e --- /dev/null +++ b/src/machine_t3e.c @@ -0,0 +1,127 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a71ca0e --- /dev/null +++ b/src/mathconstants.c @@ -0,0 +1,71 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..5b2eaef --- /dev/null +++ b/src/md.h @@ -0,0 +1,6 @@ +#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 new file mode 100644 index 0000000..62e9b99 --- /dev/null +++ b/src/mol_force.c @@ -0,0 +1,183 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..14db731 --- /dev/null +++ b/src/molecule.h @@ -0,0 +1,165 @@ +#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 new file mode 100644 index 0000000..3dfa995 --- /dev/null +++ b/src/molecule_input.c @@ -0,0 +1,615 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..ae6f8ff --- /dev/null +++ b/src/molecule_types.c @@ -0,0 +1,173 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..d1e4b83 --- /dev/null +++ b/src/mp.cpp @@ -0,0 +1,512 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..04d3e6b --- /dev/null +++ b/src/nhc.c @@ -0,0 +1,651 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..db50816 --- /dev/null +++ b/src/nose.c @@ -0,0 +1,831 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..42d5b68 --- /dev/null +++ b/src/nrutil.cpp @@ -0,0 +1,935 @@ +#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 new file mode 100644 index 0000000..6e00665 --- /dev/null +++ b/src/output_utilities.c @@ -0,0 +1,220 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..506ce46 --- /dev/null +++ b/src/pair_potential.c @@ -0,0 +1,298 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..1ea54a3 --- /dev/null +++ b/src/parallel.c @@ -0,0 +1,49 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..d0d3114 --- /dev/null +++ b/src/parallel_include.c @@ -0,0 +1,26 @@ +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 new file mode 100644 index 0000000..f2415dd --- /dev/null +++ b/src/parser.cpp @@ -0,0 +1,737 @@ +/*----------------------------------------------------------------------------| +| 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 new file mode 100644 index 0000000..d807080 --- /dev/null +++ b/src/particle.h @@ -0,0 +1,36 @@ +#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 new file mode 100644 index 0000000..7e8f045 --- /dev/null +++ b/src/particle_lists.c @@ -0,0 +1,81 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..946c95f --- /dev/null +++ b/src/particle_types.c @@ -0,0 +1,31 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..f75cb95 --- /dev/null +++ b/src/periodic_table.c @@ -0,0 +1,1232 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..39494ad --- /dev/null +++ b/src/physcon.c @@ -0,0 +1,221 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..a3912d3 --- /dev/null +++ b/src/pme.c @@ -0,0 +1,507 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..657ab1a --- /dev/null +++ b/src/pw.h @@ -0,0 +1,79 @@ +#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 new file mode 100644 index 0000000..6dbe3c1 --- /dev/null +++ b/src/pw_grid_types.c @@ -0,0 +1,51 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..ee34d04 --- /dev/null +++ b/src/pw_grids.c @@ -0,0 +1,550 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..836c6c6 --- /dev/null +++ b/src/pw_types.cpp @@ -0,0 +1,67 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..aae4014 --- /dev/null +++ b/src/pws.c @@ -0,0 +1,885 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..f802964 --- /dev/null +++ b/src/simulation.h @@ -0,0 +1,19 @@ +#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 new file mode 100644 index 0000000..6eabe27 --- /dev/null +++ b/src/simulation_cell.c @@ -0,0 +1,141 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..cc0df7b --- /dev/null +++ b/src/slater_koster.c @@ -0,0 +1,123 @@ +!------------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..4217ee4 --- /dev/null +++ b/src/slater_koster.h @@ -0,0 +1,36 @@ +#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 new file mode 100644 index 0000000..6c14142 --- /dev/null +++ b/src/slater_koster_matr.c @@ -0,0 +1,1458 @@ +/*----------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..475008d --- /dev/null +++ b/src/slater_koster_util.cpp @@ -0,0 +1,161 @@ +#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 new file mode 100644 index 0000000..06a880d --- /dev/null +++ b/src/splines.c @@ -0,0 +1,545 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..ba31a1c --- /dev/null +++ b/src/stop.h @@ -0,0 +1,16 @@ +#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 new file mode 100644 index 0000000..fbdec3e --- /dev/null +++ b/src/stop_program.cpp @@ -0,0 +1,66 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..9e9bc35 --- /dev/null +++ b/src/string_utilities.c @@ -0,0 +1,209 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..5b2049a --- /dev/null +++ b/src/structure.h @@ -0,0 +1,27 @@ +#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 new file mode 100644 index 0000000..be4bd17 --- /dev/null +++ b/src/structure_factor_types.c @@ -0,0 +1,21 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..00fb20c --- /dev/null +++ b/src/structure_factors.c @@ -0,0 +1,91 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..d2875cf --- /dev/null +++ b/src/structure_types.c @@ -0,0 +1,28 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..9c15525 --- /dev/null +++ b/src/tbmd.c @@ -0,0 +1,323 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..269d27a --- /dev/null +++ b/src/tbmd_debug.c @@ -0,0 +1,282 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..f404a90 --- /dev/null +++ b/src/tbmd_force.c @@ -0,0 +1,255 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..3fee198 --- /dev/null +++ b/src/tbmd_global.c @@ -0,0 +1,38 @@ +!------------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..b823be4 --- /dev/null +++ b/src/tbmd_input.c @@ -0,0 +1,466 @@ +!------------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..bf580a6 --- /dev/null +++ b/src/tbmd_types.c @@ -0,0 +1,47 @@ +!------------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..7209049 --- /dev/null +++ b/src/timesl.c @@ -0,0 +1,53 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..b8202fb --- /dev/null +++ b/src/timings.c @@ -0,0 +1,208 @@ +/*----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..e9885bf --- /dev/null +++ b/src/unit.c @@ -0,0 +1,86 @@ +!-----------------------------------------------------------------------------! +! 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 new file mode 100644 index 0000000..c23dd14 --- /dev/null +++ b/src/util.c @@ -0,0 +1,610 @@ +/*---------------------------------------------------------------------------*/ +/* 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 new file mode 100644 index 0000000..4ad1f58 --- /dev/null +++ b/tools/Makefile @@ -0,0 +1,33 @@ +.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 new file mode 100644 index 0000000..fbae2f2 --- /dev/null +++ b/tools/forlex.c @@ -0,0 +1,3172 @@ +#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 new file mode 100644 index 0000000..9d1302f --- /dev/null +++ b/tools/forpar.h @@ -0,0 +1,47 @@ +#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 new file mode 100644 index 0000000..7b8f82f --- /dev/null +++ b/tools/forpar.tab.c @@ -0,0 +1,2518 @@ + +/* 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 new file mode 100644 index 0000000..a05f350 --- /dev/null +++ b/tools/forpar.tab.h @@ -0,0 +1,69 @@ +#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 new file mode 100755 index 0000000..39bda6e --- /dev/null +++ b/tools/get_arch_code @@ -0,0 +1,57 @@ +#!/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 new file mode 100755 index 0000000..958f815 --- /dev/null +++ b/tools/sfmakedepend @@ -0,0 +1,560 @@ +#!/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 new file mode 100644 index 0000000..7870de4 --- /dev/null +++ b/tools/slist.c @@ -0,0 +1,69 @@ +#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 new file mode 100644 index 0000000..2ce475d --- /dev/null +++ b/tools/slist.h @@ -0,0 +1,30 @@ +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);