aparler/cp2k-c
1
0
Fork 0
forked from comp-chem/cp2k-c
Code Pull requests Activity

Compare commits

base: aparler:main
Branches Tags
aparler:main
aparler:old_8f0c0cc
aparler:adam-apple
aparler:old_version_a1ba2989f
comp-chem:main
..
compare: aparler:old_8f0c0cc
Branches Tags
aparler:old_8f0c0cc
aparler:adam-apple
aparler:old_version_a1ba2989f
aparler:main
comp-chem:main

No commits in common. "main" and "old_8f0c0cc" have entirely different histories.
main ... old_8f0c0c

161 changed files with 37806 additions and 627 deletions
Download patch file Download diff file Expand all files Collapse all files

288
.gitignore vendored
View file

@ -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

24
COPYRIGHT Normal file
View file

@ -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

86
INSTALL Normal file
View file

@ -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

339
LICENSE
View file

@ -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.
<signature of Ty Coon>, 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.

106
Makefile Normal file
View file

@ -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)

19
README Normal file
View file

@ -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

3
README.md
View file

@ -1,3 +0,0 @@
# cp2k_to_c
Converting CP2K from fortran to C/C++

17
arch/AIX-POWER2.pdbg Normal file
View file

@ -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

15
arch/AIX-POWER2.popt Normal file
View file

@ -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

17
arch/AIX-POWER2.sdbg Normal file
View file

@ -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

15
arch/AIX-POWER2.sopt Normal file
View file

@ -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

30
arch/CRAY-T3E.pdbg Normal file
View file

@ -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

30
arch/CRAY-T3E.popt Normal file
View file

@ -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

30
arch/CRAY-T3E.sdbg Normal file
View file

@ -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

30
arch/CRAY-T3E.sopt Normal file
View file

@ -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

13
arch/DEC.sdbg Normal file
View file

@ -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

14
arch/DEC.sopt Normal file
View file

@ -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

14
arch/IRIX.pdbg Normal file
View file

@ -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

14
arch/IRIX.popt Normal file
View file

@ -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

14
arch/IRIX.sdbg Normal file
View file

@ -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

14
arch/IRIX.sopt Normal file
View file

@ -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

13
arch/Linux-i686-absoft.sdbg Normal file
View file

@ -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

13
arch/Linux-i686-absoft.sopt Normal file
View file

@ -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

13
arch/Linux-i686-pgi.sdbg Normal file
View file

@ -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

13
arch/Linux-i686-pgi.sopt Normal file
View file

@ -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

13
arch/Linux-ppc-absoft.sdbg Normal file
View file

@ -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

14
arch/Linux-ppc-absoft.sopt Normal file
View file

@ -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

124
doc/Makefile Normal file
View file

@ -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)

21
src/MACHINEDEFS.DEC Normal file
View file

@ -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

27
src/MACHINEDEFS.IBM Normal file
View file

@ -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

21
src/MACHINEDEFS.PGI Normal file
View file

@ -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

22
src/MACHINEDEFS.SGI Normal file
View file

@ -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

21
src/MACHINEDEFS.T3E Normal file
View file

@ -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

55
src/Makefile Normal file
View file

@ -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)

27
src/OBJECTDEFS Normal file
View file

@ -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

4
src/TODO Normal file
View file

@ -0,0 +1,4 @@
### I'm in the middle of editing nrutil.cpp
* "Funny" messages away - they are not funny!

98
src/amoeba.cpp Normal file
View file

@ -0,0 +1,98 @@
/*---------------------------------------------------------------------------*/
/* CP2K: A general program to perform molecular dynamics simulations */
/* Copyright (C) 2024 MPI fuer Festkoerperforschung, Stuttgart */
/*---------------------------------------------------------------------------*/
#include <cmath>
#include <vector>
#include <algorithm>
#include <functional>
#include "amoeba.h"
namespace amoeba {
/*----------------------------------------------------------------------------|
| NUMERICAL RECIPIES SUBROUTINE AMOEBA ADAPTED FOR USE IN CP2K |
|----------------------------------------------------------------------------*/
template<typename Func>
void amoeba_evaluate(std::vector<std::vector<double>>& p, std::vector<double>& y,
double ftol, double& rtol, Func func, int itmax) {
int ndim = p[0].size();
std::vector<double> 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<double> 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

10
src/amoeba.h Normal file
View file

@ -0,0 +1,10 @@
#ifndef _AMOEBA_H
#define _AMOEBA_H
#include <vector>
template<typename Func>
void amoeba_evaluate(std::vector<std::vector<double>>&, std::vector<double>&,
double, double&, Func, int);
#endif

181
src/atoms_input.cpp Normal file
View file

@ -0,0 +1,181 @@
#include <stdio.h>
#include <stdlib.h>
#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]);
}
}

33
src/atoms_input.h Normal file
View file

@ -0,0 +1,33 @@
#ifndef _ATOMS_INPUT_H
#define _ATOMS_INPUT_H
#ifdef __cplusplus
namespace CP2K_NS {
#include <string>
#include <vector>
#else
#include <stdbool.h>
#include <string.h>
#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<std::vector<double>>);
void print_cv(int, std::vector<std::vector<double>>, std::vector<std::vector<double>>);
#ifdef __cplusplus
}
#endif
#endif

60
src/coefficient_types.cpp Normal file
View file

@ -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");
}
}

28
src/coefficients.cpp Normal file
View file

@ -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;
}

36
src/coefficients.h Normal file
View file

@ -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

9
src/complex.h Normal file
View file

@ -0,0 +1,9 @@
#ifndef _COMPLEX_H
#define _COMPLEX_H
typedef struct complex {
double real;
double imag;
} complex;
#endif

1475
src/constraint.c Normal file
View file

File diff suppressed because it is too large Load diff

160
src/convert_units.c Normal file
View file

@ -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

65
src/cp2k.cpp Normal file
View file

@ -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();
}

14
src/cp2k.h Normal file
View file

@ -0,0 +1,14 @@
#ifndef _LAMMPS_H
#define _LAMMPS_H
#ifdef __cplusplus
namespace CP2K_NS {
#endif
int cp2k(int, char **);
#ifdef __cplusplus
}
#endif
#endif

89
src/cp2k_input.cpp Normal file
View file

@ -0,0 +1,89 @@
/*---------------------------------------------------------------------------*/
/* CP2K: A general program to perform molecular dynamics simulations */
/* Copyright (C) 2024 CP2K developers group */
/*---------------------------------------------------------------------------*/
#include <string>
#include <iomanip>
#include <iostream>
#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;
}
}

30
src/dg.h Normal file
View file

@ -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

148
src/dg_rho0s.c Normal file
View file

@ -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

25
src/dg_types.c Normal file
View file

@ -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
!-----------------------------------------------------------------------------!

730
src/dgs.c Normal file
View file

@ -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

62
src/dump.c Normal file
View file

@ -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

303
src/eigenvalueproblems.c Normal file
View file

@ -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

120
src/environment.cpp Normal file
View file

@ -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 <string>
#include <iostream>
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")
}
}

319
src/erf.c Normal file
View file

@ -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

348
src/erf_fn.c Normal file
View file

@ -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

23
src/ewald.h Normal file
View file

@ -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

26
src/ewald_parameters_types.c Normal file
View file

@ -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

330
src/ewalds.c Normal file
View file

@ -0,0 +1,330 @@
#include <complex.h>
#include <malloc.h>
#include <math.h>
#include <string.h>
#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);
}
}

989
src/fft_tools.c Normal file
View file

@ -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

241
src/fist.cpp Normal file
View file

@ -0,0 +1,241 @@
/*---------------------------------------------------------------------------*/
/* CP2K: A general program to perform molecular dynamics simulations */
/* Copyright (C) 2024 CP2K developers group */
/*---------------------------------------------------------------------------*/
#include <vector>
#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<molecule_type> 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<std::vector<double>> rcut;
int handle, itimes, isos, para_comm_cart;
int iat, jat;
std::vector<std::string> 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<molecule_type> 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);
}

452
src/fist_debug.c Normal file
View file

@ -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

279
src/fist_force.c Normal file
View file

@ -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

1322
src/fist_force_numer.c Normal file
View file

File diff suppressed because it is too large Load diff

39
src/fist_global.c Normal file
View file

@ -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

167
src/fist_input.c Normal file
View file

@ -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

118
src/fist_intra_force.c Normal file
View file

@ -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

381
src/fist_nonbond_force.c Normal file
View file

@ -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

61
src/force_control.c Normal file
View file

@ -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

846
src/force_fields.c Normal file
View file

@ -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

1089
src/force_fit.c Normal file
View file

File diff suppressed because it is too large Load diff

32
src/global_types.h Normal file
View file

@ -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 <string>
#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

119
src/header.c Normal file
View file

@ -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");
}
/*****************************************************************************/

21
src/header.h Normal file
View file

@ -0,0 +1,21 @@
#ifndef _HEADER_H
#define _HEADER_H
// Secure block
#ifdef __cplusplus
extern "C" {
#endif
#include <stdio.h>
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

111
src/initialize_ewalds.c Normal file
View file

@ -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

120
src/initialize_extended_types.c Normal file
View file

@ -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

140
src/initialize_molecule_types.c Normal file
View file

@ -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

81
src/initialize_particle_types.c Normal file
View file

@ -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

22
src/input_types.c Normal file
View file

@ -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

1099
src/integrator.c Normal file
View file

File diff suppressed because it is too large Load diff

55
src/io_parameters.c Normal file
View file

@ -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

65
src/kinds.cpp Normal file
View file

@ -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 <limits>
#include <iostream>
namespace kinds {
const int dbl = std::numeric_limits<double>::max_digits10;
const int sgl = std::numeric_limits<float>::max_digits10;
const int qp = std::numeric_limits<long double>::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<double>::epsilon() << " Smallest positive number: "
<< std::numeric_limits<double>::min() << " Largest representable number: "
<< std::numeric_limits<double>::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<float>::epsilon() << " Smallest positive number: "
<< std::numeric_limits<float>::min() << " Largest representable number: "
<< std::numeric_limits<float>::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<int>::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;
}
}
//*****************************************************************************

122
src/lapack.c Normal file
View file

@ -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

32
src/linklist.h Normal file
View file

@ -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

412
src/linklist_cell_list.c Normal file
View file

@ -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

36
src/linklist_cell_types.c Normal file
View file

@ -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

242
src/linklist_control.c Normal file
View file

@ -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

222
src/linklist_utilities.c Normal file
View file

@ -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

303
src/linklist_verlet_list.c Normal file
View file

@ -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

692
src/linklists.c Normal file
View file

@ -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<jatom)) THEN
BIGIF: IF (jatom==ipart) THEN
match = .TRUE.
ELSE
ll_exclude => 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

34
src/machine.c Normal file
View file

@ -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

106
src/machine_absoft.c Normal file
View file

@ -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
!******************************************************************************

118
src/machine_aix.c Normal file
View file

@ -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
!******************************************************************************

135
src/machine_dec.c Normal file
View file

@ -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

104
src/machine_irix.c Normal file
View file

@ -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
!******************************************************************************

135
src/machine_pgi.c Normal file
View file

@ -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

127
src/machine_t3e.c Normal file
View file

@ -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

71
src/mathconstants.c Normal file
View file

@ -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

Some files were not shown because too many files have changed in this diff Show more