Compare commits
No commits in common. "main" and "old_8f0c0cc" have entirely different histories.
main
...
old_8f0c0c
159 changed files with 37830 additions and 0 deletions
27
.gitignore
vendored
Normal file
27
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
/bin/
|
||||
/build/
|
||||
|
||||
### C ###
|
||||
# Prerequisites
|
||||
*.d
|
||||
|
||||
# Object files
|
||||
*.o
|
||||
*.ko
|
||||
*.obj
|
||||
*.elf
|
||||
|
||||
# Libraries
|
||||
*.lib
|
||||
*.a
|
||||
*.la
|
||||
*.lo
|
||||
|
||||
# Shared objects (inc. Windows DLLs)
|
||||
*.dll
|
||||
*.so
|
||||
*.so.*
|
||||
*.dylib
|
||||
.vscode
|
||||
|
||||
.DS_Store
|
||||
24
COPYRIGHT
Normal file
24
COPYRIGHT
Normal 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
86
INSTALL
Normal 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
|
||||
106
Makefile
Normal file
106
Makefile
Normal 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
19
README
Normal 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
|
||||
17
arch/AIX-POWER2.pdbg
Normal file
17
arch/AIX-POWER2.pdbg
Normal 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
15
arch/AIX-POWER2.popt
Normal 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
17
arch/AIX-POWER2.sdbg
Normal 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
15
arch/AIX-POWER2.sopt
Normal 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
30
arch/CRAY-T3E.pdbg
Normal 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
30
arch/CRAY-T3E.popt
Normal 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
30
arch/CRAY-T3E.sdbg
Normal 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
30
arch/CRAY-T3E.sopt
Normal 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
13
arch/DEC.sdbg
Normal 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
14
arch/DEC.sopt
Normal 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
14
arch/IRIX.pdbg
Normal 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
14
arch/IRIX.popt
Normal 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
14
arch/IRIX.sdbg
Normal 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
14
arch/IRIX.sopt
Normal 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
13
arch/Linux-i686-absoft.sdbg
Normal 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
13
arch/Linux-i686-absoft.sopt
Normal 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
13
arch/Linux-i686-pgi.sdbg
Normal 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
13
arch/Linux-i686-pgi.sopt
Normal 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
13
arch/Linux-ppc-absoft.sdbg
Normal 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
14
arch/Linux-ppc-absoft.sopt
Normal 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
124
doc/Makefile
Normal 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
21
src/MACHINEDEFS.DEC
Normal 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
27
src/MACHINEDEFS.IBM
Normal 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
21
src/MACHINEDEFS.PGI
Normal 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
22
src/MACHINEDEFS.SGI
Normal 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
21
src/MACHINEDEFS.T3E
Normal 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
55
src/Makefile
Normal 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
27
src/OBJECTDEFS
Normal 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
4
src/TODO
Normal 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
98
src/amoeba.cpp
Normal 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
10
src/amoeba.h
Normal 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
181
src/atoms_input.cpp
Normal 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
33
src/atoms_input.h
Normal 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
60
src/coefficient_types.cpp
Normal 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
28
src/coefficients.cpp
Normal 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
36
src/coefficients.h
Normal 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
9
src/complex.h
Normal 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
1475
src/constraint.c
Normal file
File diff suppressed because it is too large
Load diff
160
src/convert_units.c
Normal file
160
src/convert_units.c
Normal 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
65
src/cp2k.cpp
Normal 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
14
src/cp2k.h
Normal 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
89
src/cp2k_input.cpp
Normal 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
30
src/dg.h
Normal 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
148
src/dg_rho0s.c
Normal 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
25
src/dg_types.c
Normal 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
730
src/dgs.c
Normal 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
62
src/dump.c
Normal 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
303
src/eigenvalueproblems.c
Normal 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
120
src/environment.cpp
Normal 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
319
src/erf.c
Normal 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
348
src/erf_fn.c
Normal 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
23
src/ewald.h
Normal 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
26
src/ewald_parameters_types.c
Normal 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
330
src/ewalds.c
Normal 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
989
src/fft_tools.c
Normal 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
241
src/fist.cpp
Normal 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
452
src/fist_debug.c
Normal 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
279
src/fist_force.c
Normal 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
1322
src/fist_force_numer.c
Normal file
File diff suppressed because it is too large
Load diff
39
src/fist_global.c
Normal file
39
src/fist_global.c
Normal 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
167
src/fist_input.c
Normal 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
118
src/fist_intra_force.c
Normal 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
381
src/fist_nonbond_force.c
Normal 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
61
src/force_control.c
Normal 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
846
src/force_fields.c
Normal 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
1089
src/force_fit.c
Normal file
File diff suppressed because it is too large
Load diff
32
src/global_types.h
Normal file
32
src/global_types.h
Normal 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
119
src/header.c
Normal 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
21
src/header.h
Normal 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
111
src/initialize_ewalds.c
Normal 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
120
src/initialize_extended_types.c
Normal 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
140
src/initialize_molecule_types.c
Normal 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
81
src/initialize_particle_types.c
Normal 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
22
src/input_types.c
Normal 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
1099
src/integrator.c
Normal file
File diff suppressed because it is too large
Load diff
55
src/io_parameters.c
Normal file
55
src/io_parameters.c
Normal 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
65
src/kinds.cpp
Normal 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
122
src/lapack.c
Normal 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
32
src/linklist.h
Normal 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
412
src/linklist_cell_list.c
Normal 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
36
src/linklist_cell_types.c
Normal 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
242
src/linklist_control.c
Normal 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
222
src/linklist_utilities.c
Normal 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
303
src/linklist_verlet_list.c
Normal 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
692
src/linklists.c
Normal 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
34
src/machine.c
Normal 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
106
src/machine_absoft.c
Normal 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
118
src/machine_aix.c
Normal 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
135
src/machine_dec.c
Normal 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
104
src/machine_irix.c
Normal 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
135
src/machine_pgi.c
Normal 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
127
src/machine_t3e.c
Normal 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
71
src/mathconstants.c
Normal 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
|
||||
6
src/md.h
Normal file
6
src/md.h
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#ifndef _MD_H
|
||||
#define _MD_H
|
||||
|
||||
|
||||
|
||||
#endif
|
||||
183
src/mol_force.c
Normal file
183
src/mol_force.c
Normal file
|
|
@ -0,0 +1,183 @@
|
|||
!-----------------------------------------------------------------------------!
|
||||
! CP2K: A general program to perform molecular dynamics simulations !
|
||||
! Copyright (C) 2000 CP2K developers group !
|
||||
!-----------------------------------------------------------------------------!
|
||||
|
||||
MODULE mol_force
|
||||
|
||||
USE kinds, ONLY : dbl
|
||||
|
||||
PRIVATE
|
||||
PUBLIC :: force_bonds, force_bends, force_torsions
|
||||
PUBLIC :: get_pv_bond, get_pv_bend, get_pv_torsion
|
||||
|
||||
CONTAINS
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
! Computes the bonded force
|
||||
|
||||
SUBROUTINE force_bonds ( rij, r0, k, energy, fscalar )
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
! Arguments
|
||||
REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: rij
|
||||
REAL ( dbl ), INTENT ( IN ) :: r0, k
|
||||
REAL ( dbl ), INTENT ( OUT ) :: energy, fscalar
|
||||
|
||||
! Locals
|
||||
REAL ( dbl ) :: dij
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
|
||||
dij = SQRT ( DOT_PRODUCT ( rij, rij ) )
|
||||
energy = 0.5_dbl * k * ( dij - r0 ) ** 2
|
||||
fscalar = k * ( dij - r0 ) / dij
|
||||
|
||||
END SUBROUTINE force_bonds
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
SUBROUTINE force_bends ( b12, b32, d12, d32, id12, id32, dist, &
|
||||
theta, theta0, k, g1, g2, g3, energy, fscalar )
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
! Arguments
|
||||
REAL ( dbl ), INTENT ( IN ), DIMENSION ( : ) :: b12, b32
|
||||
REAL ( dbl ), INTENT ( OUT ), DIMENSION ( : ) :: g1, g2, g3
|
||||
REAL ( dbl ), INTENT ( IN ) :: d12, d32, id12, id32, dist, theta
|
||||
REAL ( dbl ), INTENT ( IN ) :: theta0, k
|
||||
REAL ( dbl ), INTENT ( OUT ) :: fscalar, energy
|
||||
|
||||
! Locals
|
||||
REAL ( dbl ) :: denom
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
|
||||
! define denom
|
||||
denom = id12*id12*id32*id32
|
||||
|
||||
! compute energy
|
||||
energy = 0.5_dbl * k * ( theta - theta0 ) ** 2
|
||||
|
||||
! compute fscalar
|
||||
fscalar = k*(theta-theta0)/sin(theta)
|
||||
|
||||
! compute the gradients
|
||||
g1 = (b32*d12*d32-dist*d32*id12*b12)*denom
|
||||
g2 = (-(b12+b32)*d12*d32+dist*(d32*id12*b12+id32*d12*b32))*denom
|
||||
g3 = (b12*d12*d32-dist*id32*d12*b32)*denom
|
||||
|
||||
END SUBROUTINE force_bends
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
SUBROUTINE force_torsions
|
||||
IMPLICIT NONE
|
||||
|
||||
STOP 1991
|
||||
END SUBROUTINE force_torsions
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
SUBROUTINE get_pv_bond(f1,f2,r1,r2,pvbond)
|
||||
IMPLICIT NONE
|
||||
REAL ( dbl ), DIMENSION (3), INTENT ( IN ) :: f1, f2, r1, r2
|
||||
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: pvbond
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
|
||||
! p(1,1)
|
||||
pvbond(1,1) = pvbond(1,1) + f1(1)*r1(1)
|
||||
pvbond(1,1) = pvbond(1,1) + f2(1)*r2(1)
|
||||
! p(1,2)
|
||||
pvbond(1,2) = pvbond(1,2) + f1(1)*r1(2)
|
||||
pvbond(1,2) = pvbond(1,2) + f2(1)*r2(2)
|
||||
! p(1,3)
|
||||
pvbond(1,3) = pvbond(1,3) + f1(1)*r1(3)
|
||||
pvbond(1,3) = pvbond(1,3) + f2(1)*r2(3)
|
||||
! p(2,1)
|
||||
pvbond(2,1) = pvbond(2,1) + f1(2)*r1(1)
|
||||
pvbond(2,1) = pvbond(2,1) + f2(2)*r2(1)
|
||||
! p(2,2)
|
||||
pvbond(2,2) = pvbond(2,2) + f1(2)*r1(2)
|
||||
pvbond(2,2) = pvbond(2,2) + f2(2)*r2(2)
|
||||
! p(2,3)
|
||||
pvbond(2,3) = pvbond(2,3) + f1(2)*r1(3)
|
||||
pvbond(2,3) = pvbond(2,3) + f2(2)*r2(3)
|
||||
! p(3,1)
|
||||
pvbond(3,1) = pvbond(3,1) + f1(3)*r1(1)
|
||||
pvbond(3,1) = pvbond(3,1) + f2(3)*r2(1)
|
||||
! p(3,2)
|
||||
pvbond(3,2) = pvbond(3,2) + f1(3)*r1(2)
|
||||
pvbond(3,2) = pvbond(3,2) + f2(3)*r2(2)
|
||||
! p(3,3)
|
||||
pvbond(3,3) = pvbond(3,3) + f1(3)*r1(3)
|
||||
pvbond(3,3) = pvbond(3,3) + f2(3)*r2(3)
|
||||
|
||||
END SUBROUTINE get_pv_bond
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
SUBROUTINE get_pv_bend(f1,f2,f3,r1,r2,r3,pvbend)
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
! Arguments
|
||||
REAL ( dbl ), DIMENSION (3), INTENT ( IN ) :: f1, f2, f3, r1, r2, r3
|
||||
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( INOUT ) :: pvbend
|
||||
|
||||
!------------------------------------------------------------------------------
|
||||
|
||||
!p(1,1)
|
||||
pvbend(1,1) = pvbend(1,1) + f1(1)*r1(1)
|
||||
pvbend(1,1) = pvbend(1,1) + f2(1)*r2(1)
|
||||
pvbend(1,1) = pvbend(1,1) + f3(1)*r3(1)
|
||||
!p(1,2)
|
||||
pvbend(1,2) = pvbend(1,2) + f1(1)*r1(2)
|
||||
pvbend(1,2) = pvbend(1,2) + f2(1)*r2(2)
|
||||
pvbend(1,2) = pvbend(1,2) + f3(1)*r3(2)
|
||||
!p(1,3)
|
||||
pvbend(1,3) = pvbend(1,3) + f1(1)*r1(3)
|
||||
pvbend(1,3) = pvbend(1,3) + f2(1)*r2(3)
|
||||
pvbend(1,3) = pvbend(1,3) + f3(1)*r3(3)
|
||||
!p(2,1)
|
||||
pvbend(2,1) = pvbend(2,1) + f1(2)*r1(1)
|
||||
pvbend(2,1) = pvbend(2,1) + f2(2)*r2(1)
|
||||
pvbend(2,1) = pvbend(2,1) + f3(2)*r3(1)
|
||||
!p(2,2)
|
||||
pvbend(2,2) = pvbend(2,2) + f1(2)*r1(2)
|
||||
pvbend(2,2) = pvbend(2,2) + f2(2)*r2(2)
|
||||
pvbend(2,2) = pvbend(2,2) + f3(2)*r3(2)
|
||||
!p(2,3)
|
||||
pvbend(2,3) = pvbend(2,3) + f1(2)*r1(3)
|
||||
pvbend(2,3) = pvbend(2,3) + f2(2)*r2(3)
|
||||
pvbend(2,3) = pvbend(2,3) + f3(2)*r3(3)
|
||||
!p(3,1)
|
||||
pvbend(3,1) = pvbend(3,1) + f1(3)*r1(1)
|
||||
pvbend(3,1) = pvbend(3,1) + f2(3)*r2(1)
|
||||
pvbend(3,1) = pvbend(3,1) + f3(3)*r3(1)
|
||||
!p(3,2)
|
||||
pvbend(3,2) = pvbend(3,2) + f1(3)*r1(2)
|
||||
pvbend(3,2) = pvbend(3,2) + f2(3)*r2(2)
|
||||
pvbend(3,2) = pvbend(3,2) + f3(3)*r3(2)
|
||||
!p(3,3)
|
||||
pvbend(3,3) = pvbend(3,3) + f1(3)*r1(3)
|
||||
pvbend(3,3) = pvbend(3,3) + f2(3)*r2(3)
|
||||
pvbend(3,3) = pvbend(3,3) + f3(3)*r3(3)
|
||||
|
||||
END SUBROUTINE get_pv_bend
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
SUBROUTINE get_pv_torsion()
|
||||
IMPLICIT NONE
|
||||
|
||||
STOP 1990
|
||||
END SUBROUTINE get_pv_torsion
|
||||
|
||||
!******************************************************************************
|
||||
|
||||
END MODULE mol_force
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue