comp-chem/cp2k
1
0
Fork 0
mirror of https://github.com/cp2k/cp2k.git synced 2026-07-28 22:25:32 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions

update to version /06/25/2001

Browse source 
svn-origin-rev: 16
This commit is contained in:
Jürg Hutter 2001-06-26 18:44:55 +00:00
parent 3d17135eb4
commit a4df9f5ad8
85 changed files with 10600 additions and 3168 deletions
Download patch file Download diff file Expand all files Collapse all files

19
src/Makefile
View file

@ -1,11 +1,11 @@
.SUFFIXES: .F .d .o
CP2KHOME = $(HOME)/CP2K
CP2KHOME = $(HOME)/CP2K/
ARCH = $(shell $(CP2KHOME)/tools/get_arch_code)
VERSION = sdbg
SMAKE = gmake -r
VERSION = sopt
SMAKE = make -r
PMAKE = $(SMAKE) -j 1
LIB1 = fftsg
LIB1 = cp2klib
### Dependent variables ###
@ -54,11 +54,11 @@ include $(MACHINEDEFS)
OBJECTS = $(OBJECTS_GENERIC) $(OBJECTS_ARCHITECTURE)
LIB1_OBJECTS = ctrig.o fftpre.o fftrot.o fftstp.o mltfftsg.o
LIB1_OBJECTS = ctrig.o fftpre.o fftrot.o fftstp.o mltfftsg.o fast.o
DEPENDENCIES = $(OBJECTS:.o=.d)
LIBRARIES = $(LIBS) -L$(LIBDIR)/$(VERSION) -l$(LIB1)
LIBRARIES = -L$(LIBDIR)/$(VERSION) -l$(LIB1) $(LIBS)
### Slave rules ###
@ -79,18 +79,17 @@ $(PROG): $(OBJECTS)
%.d: %.F
$(CPP) $(CPPFLAGS) $< $*.f
-$(FORPAR) $*.f
$(FORPAR) $*.f
$(PERL) $(SFMAKEDEPEND) $*.d $*.f
rm -f $*.f $*.d.old
@rm -f $*.f $*.d.old
parallel_include.o: parallel_include.F
$(FC_fixed) -c $(FCFLAGS) $<
parallel_include.d: parallel_include.F
$(CPP) $(CPPFLAGS) $< $*.f
-$(FORPAR) -fix $*.f
$(PERL) $(SFMAKEDEPEND) $*.d $*.f
rm -f $*.f $*.d.old
@rm -f $*.f $*.d.old
clean:
rm -f *.o *.mod F*.f

2
src/Makefile.absoft
View file

@ -58,7 +58,7 @@ LIB1_OBJECTS = ctrig.o fftpre.o fftrot.o fftstp.o mltfftsg.o
DEPENDENCIES = $(OBJECTS:.o=.d)
LIBRARIES = $(LIBS) -L$(LIBDIR)/$(VERSION) -l$(LIB1)
LIBRARIES = -L$(LIBDIR)/$(VERSION) -l$(LIB1) $(LIBS)
### Slave rules ###

12
src/OBJECTDEFS
View file

@ -18,9 +18,11 @@ OBJECTS_GENERIC =\
cntl_input.o\
coefficient_types.o\
coefficients.o\
collocate_density.o\
constraint.o\
control_module.o\
convert_units.o\
core_energies.o\
core_hamiltonian.o\
cp2k.o\
cp2k_input.o\
@ -32,6 +34,7 @@ OBJECTS_GENERIC =\
dg_rho0s.o\
dg_types.o\
dgs.o\
diis.o\
dump.o\
eigenvalueproblems.o\
environment.o\
@ -48,7 +51,6 @@ OBJECTS_GENERIC =\
fist_debug.o\
fist_force.o\
fist_force_numer.o\
fist_input.o\
fist_intra_force.o\
fist_nonbond_force.o\
force_control.o\
@ -62,8 +64,10 @@ OBJECTS_GENERIC =\
initialize_extended_types.o\
initialize_molecule_types.o\
initialize_particle_types.o\
initialize_pimd_types.o \
input_types.o\
input_utilities.o\
integrate_potential.o\
integrator.o\
interactions.o\
k290.o\
@ -88,6 +92,7 @@ OBJECTS_GENERIC =\
memory_utilities.o\
message_passing.o\
method_specifications.o\
mo_types.o\
mol_force.o\
molecule_input.o\
molecule_types.o\
@ -120,12 +125,16 @@ OBJECTS_GENERIC =\
pw_types.o\
pw_xc.o\
pws.o\
qs_main.o\
qs_scf.o\
radial_grids.o\
radial_operators.o\
radial_poisson.o\
radial_solver.o\
radial_util.o\
read_pimd.o\
readin.o\
realspace_grid_types.o\
simulation_cell.o\
slater_koster.o\
slater_koster_matr.o\
@ -147,6 +156,7 @@ OBJECTS_GENERIC =\
termination.o\
timesl.o\
timings.o\
transformations.o \
unit.o\
util.o\
wf_types.o\

39
src/atomic_kinds.F
View file

@ -71,7 +71,9 @@ MODULE atomic_kinds
orb_basis_set_name,&
potential_name
CHARACTER(LEN=2) :: element_symbol
REAL(wp) :: alpha_erf,cerf,mass,&
REAL(wp) :: alpha_core_charge,&
ccore_charge,&
core_charge_radius,mass,&
prj_paw_radius
INTEGER :: natom,z,zeff
INTEGER, DIMENSION(:), POINTER :: atom_list,elec_conf
@ -96,14 +98,14 @@ MODULE atomic_kinds
! *** Public parameters ***
PUBLIC :: max_kind_label_length
PUBLIC :: max_basis_set_name_length,&
max_kind_label_length
! *** Public variables ***
PUBLIC :: all_potential_present,&
gth_potential_present,&
kind_info,&
max_basis_set_name_length,&
nkind
! *****************************************************************************
@ -223,7 +225,6 @@ CONTAINS
IF (SIZE(natom_of_kind) /= nkind) THEN
CALL stop_program(routine,"The first dimension of the argument "//&
"natom_of_kind has an invalid size")
CALL stop_program(routine,"")
END IF
IF (SIZE(atom_list,1) /= nkind) THEN
@ -465,20 +466,20 @@ CONTAINS
IF (apname == "ALL") THEN
CALL allocate_potential(kind_info(ikind)%all_potential)
CALL read_potential(kind_info(ikind)%element_symbol,apname,&
kind_info(ikind)%alpha_erf,&
kind_info(ikind)%alpha_core_charge,&
kind_info(ikind)%elec_conf,&
kind_info(ikind)%zeff,&
kind_info(ikind)%all_potential,&
globenv)
kind_info(ikind)%zeff = kind_info(ikind)%z
all_potential_present = .TRUE.
ELSE IF (apname == "GTH") THEN
CALL allocate_potential(kind_info(ikind)%gth_potential)
CALL read_potential(kind_info(ikind)%element_symbol,apname,&
kind_info(ikind)%alpha_erf,&
kind_info(ikind)%alpha_core_charge,&
kind_info(ikind)%elec_conf,&
kind_info(ikind)%zeff,&
kind_info(ikind)%gth_potential,&
globenv)
kind_info(ikind)%zeff = SUM(kind_info(ikind)%gth_potential%elec_conf)
gth_potential_present = .TRUE.
ELSE
CALL stop_program(routine,&
@ -490,8 +491,9 @@ CONTAINS
TRIM(globenv%input_file_name)//">")
END IF
kind_info(ikind)%cerf = REAL(kind_info(ikind)%zeff,wp)*&
(kind_info(ikind)%alpha_erf**2/pi)**1.5_wp
kind_info(ikind)%ccore_charge =&
REAL(kind_info(ikind)%zeff,wp)*&
SQRT((kind_info(ikind)%alpha_core_charge/pi)**3)
! *** Check the number of electrons ***
@ -536,7 +538,7 @@ CONTAINS
output_unit = globenv%scr
IF (globenv%print%basis_set.OR.globenv%print%potential) THEN
WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") "KIND INFORMATION"
WRITE (UNIT=output_unit,FMT="(/,/,T2,A)") "ATOMIC KIND INFORMATION"
END IF
DO ikind=1,nkind
@ -549,7 +551,8 @@ CONTAINS
IF (globenv%print%basis_set) THEN
WRITE (UNIT=output_unit,FMT="(/,T3,A)") "a) Basis set information"
WRITE (UNIT=output_unit,FMT="(/,T3,A)")&
"a) GTO basis set information"
WRITE (UNIT=output_unit,FMT="(/,T6,A)")&
"Orbital basis set name: "//TRIM(kind_info(ikind)%orb_basis_set_name)
@ -646,8 +649,8 @@ CONTAINS
" "//&
TRIM(kind_info(ikind)%all_potential%description(2))
WRITE (UNIT=output_unit,FMT="(/,T6,A,F12.6)")&
"Gaussian exponent of the nuclear charge distribution: ",&
kind_info(ikind)%alpha_erf**2
"Gaussian exponent of the core charge distribution: ",&
kind_info(ikind)%alpha_core_charge
WRITE (UNIT=output_unit,FMT="(/,T6,A,10I3)")&
"Electronic configuration (s p d ...):",&
kind_info(ikind)%elec_conf
@ -660,12 +663,12 @@ CONTAINS
" "//&
TRIM(kind_info(ikind)%gth_potential%description(3))
WRITE (UNIT=output_unit,FMT="(/,T6,A,F12.6)")&
"Gaussian exponent of the nuclear charge distribution: ",&
kind_info(ikind)%alpha_erf**2
"Gaussian exponent of the core charge distribution: ",&
kind_info(ikind)%alpha_core_charge
WRITE (UNIT=output_unit,FMT="(/,T6,A,10I3)")&
"Electronic configuration (s p d ...):",&
kind_info(ikind)%gth_potential%elec_conf
r = SQRT(0.5_wp)/kind_info(ikind)%alpha_erf
r = 1.0_wp/SQRT(2.0_wp*kind_info(ikind)%gth_potential%alpha_ppl)
WRITE (UNIT=output_unit,FMT="(/,T6,A,/,/,T8,A,/,T8,4F12.6)")&
"Parameters of the local part of the GTH pseudopotential:",&
" rloc C1 C2 C3 C4",&
@ -676,7 +679,7 @@ CONTAINS
"Parameters of the non-local part of the GTH pseudopotential:",&
" l r(l) h(i,j,l)"
DO l=0,kind_info(ikind)%gth_potential%lppnl
r = SQRT(0.5_wp/kind_info(ikind)%gth_potential%alpha_prj_ppnl(l))
r = SQRT(0.5_wp/kind_info(ikind)%gth_potential%alpha_ppnl(l))
WRITE (UNIT=output_unit,FMT="(T6,I2,F12.6,4F12.6)")&
l,r,(kind_info(ikind)%gth_potential%hprj_ppnl(1,j,l),&
j=1,kind_info(ikind)%gth_potential%nprj_ppnl(l))

32
src/atoms_input.F
View file

@ -144,13 +144,13 @@ SUBROUTINE read_coord_vel ( atype, filen, globenv )
CALL mp_bcast ( atype % ptype, source, allgrp )
CALL mp_bcast ( atype % rtype, source, allgrp )
CALL mp_bcast ( atype % n, source, allgrp )
IF ( .NOT. globenv % ionode ) THEN
IF ( .NOT. ASSOCIATED ( atype % c ) ) THEN
ALLOCATE ( atype % c(1:3,1:atype % n ), STAT = ios )
IF ( ios /= 0 ) CALL stop_memory ( 'ATOM', 'atype%c', 3 * atype % n )
END IF
CALL mp_bcast ( atype % c, source, allgrp )
IF ( atype % rtype == 'POSVEL' ) THEN
IF ( .NOT. globenv % ionode ) THEN
IF ( .NOT. ASSOCIATED ( atype % v ) ) THEN
ALLOCATE (atype % v(1:3,1:atype % n),STAT=ios)
IF ( ios /= 0 ) CALL stop_memory ( 'ATOM', 'atype%v', 3 * atype % n )
END IF
@ -257,9 +257,13 @@ SUBROUTINE read_file ( filen, atype )
OPEN ( iunit, file = filen )
READ ( iunit, * ) atype % n
ALLOCATE ( atype % c ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) CALL stop_memory ( 'ATOM', 'atype%c', 3 * atype % n )
NULLIFY ( atype % v )
IF (.NOT. ASSOCIATED (atype % c) ) THEN
ALLOCATE ( atype % c ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) CALL stop_memory ( 'ATOM', 'atype%c', 3 * atype % n )
NULLIFY ( atype % v )
ELSE IF (atype % n /= SIZE( atype % c, 2 ) ) THEN
CALL stop_program ( 'atoms_input','Inconsistent number of atoms' )
END IF
IF ( atype % rtype == 'INIT' ) THEN
DO i = 1, atype % n
@ -281,9 +285,11 @@ SUBROUTINE read_file ( filen, atype )
READ ( iunit, * ) atype % box_ref ( 2, 1:3 )
READ ( iunit, * ) atype % box_ref ( 3, 1:3 )
ELSE IF ( atype % rtype == 'POSVEL' ) THEN
ALLOCATE ( atype % v ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) &
CALL stop_memory ( 'ATOM', 'atype%v', 3 * atype % n )
IF (.NOT. ASSOCIATED (atype % v) ) THEN
ALLOCATE ( atype % v ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) &
CALL stop_memory ( 'ATOM', 'atype%v', 3 * atype % n )
END IF
DO i = 1, atype % n
READ ( iunit, * ) atype % c ( 1:3, i )
@ -299,9 +305,11 @@ SUBROUTINE read_file ( filen, atype )
READ ( iunit, * ) atype % v ( 1:3, i )
END DO
ELSE IF ( atype % rtype == 'ALL' ) THEN
ALLOCATE ( atype % v ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) &
CALL stop_memory ( 'ATOM', 'atype%v', 3 * atype % n )
IF (.NOT. ASSOCIATED (atype % v) ) THEN
ALLOCATE ( atype % v ( 1:3, 1:atype % n ), STAT = ios )
IF ( ios /= 0 ) &
CALL stop_memory ( 'ATOM', 'atype%v', 3 * atype % n )
END IF
DO i = 1, atype % n
READ ( iunit, * ) atype % c ( 1:3, i )
@ -396,6 +404,8 @@ SUBROUTINE read_file ( filen, atype )
CALL stop_program ( 'ATOM', 'this rtype not programmed' )
END IF
CLOSE ( iunit )
ELSE
CALL stop_program ( 'ATOM', 'No information on atoms found ' )

54
src/basis_set_types.F
View file

@ -60,7 +60,10 @@ MODULE basis_set_types
REAL(wp), DIMENSION(:,:,:), POINTER :: gcc
END TYPE gto_basis_set_type
INTEGER :: maxlcgf = 0
INTEGER :: maxco = 0,&
maxlcgf = 0,&
maxsgf = 0,&
maxsgf_set = 0
! *** Public subroutines ***
@ -77,7 +80,10 @@ MODULE basis_set_types
! *** Public variables ***
PUBLIC :: maxlcgf
PUBLIC :: maxco,&
maxlcgf,&
maxsgf,&
maxsgf_set
! *****************************************************************************
@ -483,8 +489,14 @@ CONTAINS
! ***************************************************************************
USE orbital_pointers, ONLY: ncoset
TYPE(gto_basis_set_type), POINTER :: gto_basis_set
! *** Local variables ***
INTEGER :: first_sgfa,iset,la_max,last_sgfa,npgfa,nsgfa,nshella
! ---------------------------------------------------------------------------
! *** Normalize the primitive Gaussian functions ***
@ -500,6 +512,21 @@ CONTAINS
CALL init_cphi_and_sphi(gto_basis_set)
! *** Update maximum numbers for work storage allocation ***
maxsgf = MAX(maxsgf,gto_basis_set%nsgf)
DO iset=1,gto_basis_set%nset
nshella = gto_basis_set%nshell(iset)
first_sgfa = gto_basis_set%first_sgf(1,iset)
last_sgfa = gto_basis_set%last_sgf(nshella,iset)
nsgfa = last_sgfa - first_sgfa + 1
maxsgf_set = MAX(maxsgf_set,nsgfa)
npgfa = gto_basis_set%npgf(iset)
la_max = gto_basis_set%lmax(iset)
maxco = MAX(maxco,npgfa*ncoset(la_max))
END DO
END SUBROUTINE init_orb_basis_set
! *****************************************************************************
@ -558,7 +585,7 @@ CONTAINS
start_input_session
USE memory_utilities, ONLY: reallocate
USE method_specifications, ONLY: maxder
USE orbital_pointers, ONLY: init_orbital_pointers,nco,ncoset,nso
USE orbital_pointers, ONLY: init_orbital_pointers,indco,nco,ncoset,nso
USE orbital_symbols, ONLY: cgf_symbol,sgf_symbol
USE string_utilities, ONLY: uppercase
USE termination, ONLY: stop_memory,stop_program
@ -578,7 +605,7 @@ CONTAINS
CHARACTER(LEN=240) :: line
CHARACTER(LEN=LEN(element_symbol)) :: symbol
INTEGER :: i,ipgf,iset,ishell,istat,lshell,lx,ly,lz,m,maxco,maxl,maxpgf,&
INTEGER :: i,ico,ipgf,iset,ishell,istat,lshell,m,maxco,maxl,maxpgf,&
maxshell,ncgf,ncgf_set,nmin,nset,nsgf
LOGICAL :: found
@ -756,16 +783,15 @@ CONTAINS
DO iset=1,nset
DO ishell=1,nshell(iset)
lshell = gto_basis_set%l(ishell,iset)
DO lx=lshell,0,-1
DO ly=lshell-lx,0,-1
lz = lshell - lx - ly
ncgf = ncgf + 1
gto_basis_set%lx(ncgf) = lx
gto_basis_set%ly(ncgf) = ly
gto_basis_set%lz(ncgf) = lz
gto_basis_set%cgf_symbol(ncgf) =&
cgf_symbol(n(ishell,iset),(/lx,ly,lz/))
END DO
DO ico=ncoset(lshell-1)+1,ncoset(lshell)
ncgf = ncgf + 1
gto_basis_set%lx(ncgf) = indco(1,ico)
gto_basis_set%ly(ncgf) = indco(2,ico)
gto_basis_set%lz(ncgf) = indco(3,ico)
gto_basis_set%cgf_symbol(ncgf) =&
cgf_symbol(n(ishell,iset),(/gto_basis_set%lx(ncgf),&
gto_basis_set%ly(ncgf),&
gto_basis_set%lz(ncgf)/))
END DO
DO m=-lshell,lshell
nsgf = nsgf + 1

21
src/cell_parameters.F
View file

@ -34,12 +34,15 @@ MODULE cell_parameters
USE kinds, ONLY: wp => dp
USE simulation_cell, ONLY: cell_type,get_hinv
IMPLICIT NONE
PRIVATE
TYPE(cell_type) :: cell
CHARACTER(LEN=8) :: unit_of_length_name = "BOHR"
REAL(wp) :: omega = 0.0_wp,&
REAL(wp) :: cutoff,omega = 0.0_wp,&
unit_of_length = 1.0_wp
LOGICAL :: scaled_coordinates = .FALSE.
@ -48,6 +51,8 @@ MODULE cell_parameters
! *** Public variables ***
PUBLIC :: abc,&
cell,&
cutoff,&
omega,&
scaled_coordinates,&
unit_of_length,&
@ -124,6 +129,9 @@ CONTAINS
CALL read_object(abc(1))
CALL read_object(abc(2))
CALL read_object(abc(3))
CASE ("CUTOFF")
CALL read_object(cutoff)
cutoff = 0.5_wp*cutoff
CASE ("UNIT")
CALL read_object(string)
SELECT CASE (TRIM(string))
@ -191,6 +199,13 @@ CONTAINS
END IF
END IF
cell%hmat(:,:) = 0.0_wp
cell%hmat(1,1) = abc(1)
cell%hmat(2,2) = abc(2)
cell%hmat(3,3) = abc(3)
CALL get_hinv(cell)
END SUBROUTINE read_cell_parameters
! *****************************************************************************
@ -208,9 +223,9 @@ CONTAINS
! ---------------------------------------------------------------------------
WRITE (lunit,"(/,/,T2,A,/)") "CELL PARAMETERS"
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/)") "CELL PARAMETERS"
WRITE (lunit,"(T3,A,T26,3F10.3,/,/,T3,A,T31,F15.3,A)")&
WRITE (UNIT=lunit,FMT="(T3,A,T26,3F10.3,/,/,T3,A,T31,F15.3,A)")&
"Cell size in "//TRIM(unit_of_length_name)//":",&
abc(:)/unit_of_length,&
"Cell volume in "//TRIM(unit_of_length_name)//"**3:",&

4
src/cntl_input.F
View file

@ -52,7 +52,7 @@ CONTAINS
!!I---------------------------------------------------------------------------I
!!I SECTION: &cntl ... &end I
!!I I
!!I simulation [md,debug] I
!!I simulation [md,pimd,debug] I
!!I printlevel globenv%print_level I
!!I units [kelvin,atomic] I
!!I periodic [0,1][0,1][0,1] I
@ -153,7 +153,7 @@ SUBROUTINE read_cntl_section ( setup, ewald_param, globenv )
! if no type specified, assume ewald
CASE ( 'EWALD_PA')
ewald_param % alpha = get_real()
SELECT CASE (ewald_param % ewald_type ( 1:3))
SELECT CASE (ewald_param % ewald_type )
CASE DEFAULT
ewald_param % gmax = get_int()
CASE ( 'PME')

6
src/coefficient_types.F
View file

@ -344,11 +344,7 @@ SUBROUTINE coeff_transform_c1c2 ( c1, c2, debug )
!..check if we are dealing with plane waves and call the correct routine
IF ( c1 % in_use == PLANEWAVES .AND. c2 % in_use == PLANEWAVES ) THEN
IF ( PRESENT ( debug ) ) THEN
CALL pw_fft_wrap ( c1 % pw, c2 % pw, debug )
ELSE
CALL pw_fft_wrap ( c1 % pw, c2 % pw )
END IF
CALL pw_fft_wrap ( c1 % pw, c2 % pw, debug )
ELSE
CALL stop_program ( "coeff_transform_c1c2", "not implemented")
END IF

14
src/coefficients.F
View file

@ -21,7 +21,7 @@ MODULE coefficients
USE coefficient_types, ONLY : coeff_type, PLANEWAVES
USE kinds, ONLY : dbl
USE pws, ONLY : pw_integral_a, pw_integral_ab
USE pws, ONLY : pw_integral_aa, pw_integral_ab
IMPLICIT NONE
@ -29,7 +29,7 @@ MODULE coefficients
PUBLIC :: integral
INTERFACE integral
MODULE PROCEDURE integral_a, integral_ab
MODULE PROCEDURE integral_aa, integral_ab
END INTERFACE
!!*****
@ -39,7 +39,7 @@ CONTAINS
!******************************************************************************
FUNCTION integral_a ( coeff, flag ) RESULT ( integral_value )
FUNCTION integral_aa ( coeff, flag ) RESULT ( integral_value )
TYPE ( coeff_type ), INTENT ( IN ) :: coeff
INTEGER, INTENT ( IN ), OPTIONAL :: flag
@ -49,12 +49,12 @@ FUNCTION integral_a ( coeff, flag ) RESULT ( integral_value )
!------------------------------------------------------------------------------
IF ( coeff % in_use == PLANEWAVES ) THEN
integral_value = pw_integral_a ( coeff % pw, flag )
integral_value = pw_integral_aa ( coeff % pw, flag )
ELSE
stop "integral_a, not defined"
stop "integral_aa, not defined"
END IF
END FUNCTION integral_a
END FUNCTION integral_aa
!******************************************************************************
@ -78,3 +78,5 @@ END FUNCTION integral_ab
!******************************************************************************
END MODULE coefficients
!******************************************************************************

703
src/collocate_density.F Normal file
View file

@ -0,0 +1,703 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/collocate_density [1.0] *
!!
!! NAME
!! collocate_density
!!
!! FUNCTION
!! Calculate the plane wave density by collocating the primitive Gaussian
!! functions (pgf).
!!
!! AUTHOR
!! Matthias Krack (03.04.2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE collocate_density
! *****************************************************************************
USE kinds, ONLY: wp => dp
USE atomic_kinds, ONLY: kind_info,nkind
USE atoms, ONLY: atom_info
USE basis_set_types, ONLY: gto_basis_set_type,maxco,maxsgf,maxsgf_set
USE coefficient_types, ONLY: coeff_type
USE interactions, ONLY: eps_rho_gspace,eps_rho_rspace,exp_radius
USE matrix_types, ONLY: get_block_node,&
real_matrix_set_type
USE memory_utilities, ONLY: reallocate
USE neighbor_list_types, ONLY: extract_neighbor_list,&
find_neighbor_list,&
first_neighbor_list,&
first_neighbor_node,&
get_neighbor_list,&
get_neighbor_node,&
neighbor_list_type,&
neighbor_node_type,&
next_neighbor_list,&
next_neighbor_node
USE nl, ONLY: orb_neighbor_list_set
USE orbital_pointers, ONLY: coset,indco,ncoset
USE pw_types, ONLY: pw_type
USE timings, ONLY: timeset,timestop
IMPLICIT NONE
PRIVATE
INTEGER :: npgf_product = 0
! *** Public subroutines ***
PUBLIC :: calculate_rho_core,&
calculate_rho_elec
! *** Public functions ***
PUBLIC :: calculate_total_rho
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE calculate_rho_core(rho,total_rho)
TYPE(coeff_type), INTENT(INOUT) :: rho
REAL(wp), INTENT(OUT) :: total_rho
! *** Local variables ***
REAL(wp) :: alpha
INTEGER :: handle,iatom,ikind
REAL(wp), DIMENSION(3) :: ra
REAL(wp), DIMENSION(1,1) :: pab
! ---------------------------------------------------------------------------
CALL timeset("calculate_rho_core","I","",handle)
DO ikind=1,nkind
pab(1,1) = kind_info(ikind)%ccore_charge
alpha = kind_info(ikind)%alpha_core_charge
DO iatom=1,kind_info(ikind)%natom
ra(:) = atom_info(kind_info(ikind)%atom_list(iatom))%r_pbc(:)
IF (ASSOCIATED(rho%pw%cc3d)) THEN
CALL collocate_pgf_product_gspace(0,alpha,0,0,0.0_wp,0,ra,&
(/0.0_wp,0.0_wp,0.0_wp/),&
0.0_wp,-1.0_wp,pab,rho%pw)
ELSE IF (ASSOCIATED(rho%pw%cr3d)) THEN
CALL collocate_pgf_product_rspace(0,alpha,0,0,0.0_wp,0,ra,&
(/0.0_wp,0.0_wp,0.0_wp/),&
0.0_wp,-1.0_wp,pab,rho%pw)
END IF
END DO
END DO
total_rho = calculate_total_rho(rho)
CALL timestop(0.0_wp,handle)
END SUBROUTINE calculate_rho_core
! *****************************************************************************
SUBROUTINE calculate_rho_elec(p,rho,total_rho,nproduct)
TYPE(real_matrix_set_type), INTENT(IN) :: p
TYPE(coeff_type), INTENT(INOUT) :: rho
REAL(wp), INTENT(OUT) :: total_rho
INTEGER, OPTIONAL, INTENT(OUT) :: nproduct
! *** Local variables ***
TYPE(gto_basis_set_type), POINTER :: basis_set_a,basis_set_b
TYPE(neighbor_list_type), POINTER :: orb_neighbor_list
REAL(wp) :: dab,scale,rab2,radius_kind_a,radius_kind_b,radius_set_a,&
radius_set_b
INTEGER :: first_isgf,first_jpgf,first_jset,first_jsgf,first_sgfa,&
first_sgfb,handle,iatom,ikind,ineighbor,ipgf,iset,isgf,isgfa,&
isgfb,ishell,istat,jatom,jkind,jneighbor,jpgf,jset,jsgf,&
jshell,la_max,la_min,last_sgfa,last_sgfb,lb_max,lb_min,&
na1,na2,nb1,nb2,nsgfa,nsgfb,ncoa,ncob,npgfa,npgfb,nseta,nsetb,&
nshella,nshellb
REAL(wp), DIMENSION(3) :: ra,rab
INTEGER, DIMENSION(:), POINTER :: lb_grid,orb_neighbors
REAL(wp), DIMENSION(:), POINTER :: orb_r2,rpgfa,rpgfb,zeta,zetb
REAL(wp), DIMENSION(:,:), POINTER :: orb_r,p_block,pab,work
! ---------------------------------------------------------------------------
CALL timeset("calculate_rho_elec","I","",handle)
npgf_product = 0
! *** Allocate work storage ***
NULLIFY (pab,work)
pab => reallocate(pab,1,maxco,1,maxco)
work => reallocate(work,1,maxco,1,maxsgf_set)
NULLIFY (orb_neighbor_list,orb_neighbors,orb_r,orb_r2)
! *** Loop over all atoms ***
orb_neighbor_list => first_neighbor_list(orb_neighbor_list_set)
DO WHILE (ASSOCIATED(orb_neighbor_list))
CALL get_neighbor_list(orb_neighbor_list,iatom)
CALL extract_neighbor_list(orb_neighbor_list,orb_r2,orb_neighbors,orb_r)
ikind = atom_info(iatom)%kind
first_isgf = atom_info(iatom)%first_sgf
ra(:) = atom_info(iatom)%r_pbc(:)
basis_set_a => kind_info(ikind)%orb_basis_set
nseta = basis_set_a%nset
radius_kind_a = basis_set_a%kind_radius
! *** Loop over all neighbor atoms of the current atom "iatom" ***
DO ineighbor=1,SIZE(orb_neighbors)
jatom = orb_neighbors(ineighbor)
! *** Skip all atomic blocks in the lower triangle matrix ***
IF (iatom > jatom) CYCLE
jkind = atom_info(jatom)%kind
first_jsgf = atom_info(jatom)%first_sgf
rab2 = orb_r2(ineighbor)
rab(:) = orb_r(:,ineighbor)
dab = SQRT(rab2)
basis_set_b => kind_info(jkind)%orb_basis_set
nsetb = basis_set_b%nset
radius_kind_b = basis_set_b%kind_radius
CALL get_block_node(matrix=p%matrix,&
block_row=iatom,&
block_col=jatom,&
block=p_block)
IF (MAXVAL(ABS(p_block(:,:))) < 1.0E-14_wp) CYCLE
DO iset=1,nseta
radius_set_a = basis_set_a%set_radius(iset)
IF (radius_set_a + radius_kind_b < dab) CYCLE
la_max = basis_set_a%lmax(iset)
la_min = basis_set_a%lmin(iset)
npgfa = basis_set_a%npgf(iset)
nshella = basis_set_a%nshell(iset)
rpgfa => basis_set_a%pgf_radius(1:npgfa,iset)
zeta => basis_set_a%zet(1:npgfa,iset)
first_sgfa = basis_set_a%first_sgf(1,iset)
last_sgfa = basis_set_a%last_sgf(nshella,iset)
nsgfa = last_sgfa - first_sgfa + 1
ncoa = npgfa*ncoset(la_max)
IF (iatom == jatom) THEN
first_jset = iset
ELSE
first_jset = 1
END IF
DO jset=first_jset,nsetb
radius_set_b = basis_set_b%set_radius(jset)
IF (radius_set_a + radius_set_b < dab) CYCLE
lb_max = basis_set_b%lmax(jset)
lb_min = basis_set_b%lmin(jset)
npgfb = basis_set_b%npgf(jset)
nshellb = basis_set_b%nshell(jset)
rpgfb => basis_set_b%pgf_radius(1:npgfb,jset)
zetb => basis_set_b%zet(1:npgfb,jset)
first_sgfb = basis_set_b%first_sgf(1,jset)
last_sgfb = basis_set_b%last_sgf(nshellb,jset)
nsgfb = last_sgfb - first_sgfb + 1
ncob = npgfb*ncoset(lb_max)
! *** Decontract the density matrix set block ***
CALL dgemm("N","N",ncoa,nsgfb,nsgfa,1.0_wp,&
basis_set_a%sphi(1,first_sgfa),&
SIZE(basis_set_a%sphi,1),&
p_block(first_sgfa,first_sgfb),SIZE(p_block,1),&
0.0_wp,work(1,1),SIZE(work,1))
CALL dgemm("N","T",ncoa,ncob,nsgfb,1.0_wp,&
work(1,1),SIZE(work,1),basis_set_b%sphi(1,first_sgfb),&
SIZE(basis_set_b%sphi,1),0.0_wp,pab(1,1),SIZE(pab,1))
DO ipgf=1,npgfa
IF (rpgfa(ipgf) + radius_set_b < dab) CYCLE
na1 = (ipgf - 1)*ncoset(la_max) + 1
na2 = ipgf*ncoset(la_max)
IF ((iatom == jatom).AND.(iset == jset)) THEN
first_jpgf = ipgf
ELSE
first_jpgf = 1
END IF
DO jpgf=first_jpgf,npgfb
IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) CYCLE
nb1 = (jpgf - 1)*ncoset(lb_max) + 1
nb2 = jpgf*ncoset(lb_max)
IF ((iatom == jatom).AND.&
(iset == jset).AND.&
(ipgf == jpgf)) THEN
scale = 1.0_wp
ELSE
scale = 2.0_wp
END IF
IF (ASSOCIATED(rho%pw%cc3d)) THEN
CALL collocate_pgf_product_gspace(la_max,zeta(ipgf),la_min,&
lb_max,zetb(jpgf),lb_min,&
ra,rab,rab2,scale,&
pab(na1:na2,nb1:nb2),&
rho%pw)
ELSE IF (ASSOCIATED(rho%pw%cr3d)) THEN
CALL collocate_pgf_product_rspace(la_max,zeta(ipgf),la_min,&
lb_max,zetb(jpgf),lb_min,&
ra,rab,rab2,scale,&
pab(na1:na2,nb1:nb2),&
rho%pw)
END IF
END DO
END DO
END DO
END DO
END DO
orb_neighbor_list => next_neighbor_list(orb_neighbor_list)
END DO
total_rho = calculate_total_rho(rho)
IF (PRESENT(nproduct)) nproduct = npgf_product
DEALLOCATE (pab,work)
CALL timestop(0.0_wp,handle)
END SUBROUTINE calculate_rho_elec
! *****************************************************************************
FUNCTION calculate_total_rho(rho) RESULT(total_rho)
TYPE(coeff_type), INTENT(IN), TARGET :: rho
REAL(wp) :: total_rho
! *** Local variables ***
INTEGER, DIMENSION(:), POINTER :: lb_grid
! ---------------------------------------------------------------------------
IF (ASSOCIATED(rho%pw%cc3d)) THEN
lb_grid => rho%pw%pw_grid%bounds(1,:)
total_rho = -rho%pw%pw_grid%vol*rho%pw%cc3d(lb_grid(1),&
lb_grid(2),&
lb_grid(3))
ELSE IF (ASSOCIATED(rho%pw%cr3d)) THEN
total_rho = -rho%pw%pw_grid%dvol*SUM(rho%pw%cr3d)
ELSE
total_rho = 0.0_wp
END IF
END FUNCTION calculate_total_rho
! *****************************************************************************
SUBROUTINE collocate_pgf_product_gspace(la_max,zeta,la_min,&
lb_max,zetb,lb_min,&
ra,rab,rab2,scale,pab,pw)
USE mathconstants, ONLY: pi,twopi
TYPE(pw_type), TARGET, INTENT(INOUT) :: pw
REAL(wp), INTENT(IN) :: rab2,scale,zeta,zetb
INTEGER, INTENT(IN) :: la_max,la_min,lb_max,lb_min
REAL(wp), DIMENSION(3), INTENT(IN) :: ra,rab
REAL(wp), DIMENSION(ncoset(la_max),ncoset(lb_max)), INTENT(IN) :: pab
! *** Local variables ***
COMPLEX(wp) :: yz,z
REAL(wp) :: f,fa,fb,pij,prefactor,rzetp,twozetp,zetp
INTEGER :: ax,ay,az,bx,by,bz,handle,ico,i,ig,ig2,jco,jg,kg,la,lb,&
lb_cube_min,ub_cube_max
COMPLEX(wp), DIMENSION(3) :: phasefactor
REAL(wp), DIMENSION(3) :: dg,expfactor,fap,fbp,rap,rbp,rp
COMPLEX(wp), DIMENSION(:), POINTER :: rag,rbg
REAL(wp), DIMENSION(:), POINTER :: g
INTEGER, DIMENSION(:), POINTER :: lb_cube,ub_cube
COMPLEX(wp), DIMENSION(:,:,:,:), POINTER :: cubeaxis
! ---------------------------------------------------------------------------
CALL timeset("collocate_pgf_product_gspace","I","",handle)
npgf_product = npgf_product + (ncoset(la_max) - ncoset(la_min-1))*&
(ncoset(lb_max) - ncoset(lb_min-1))
dg(:) = twopi/(pw%pw_grid%npts(:)*pw%pw_grid%dr(:))
zetp = zeta + zetb
rzetp = 1.0_wp/zetp
f = zetb*rzetp
rap(:) = f*rab(:)
rbp(:) = rap(:) - rab(:)
rp(:) = ra(:) + rap(:)
twozetp = 2.0_wp*zetp
fap(:) = twozetp*rap(:)
fbp(:) = twozetp*rbp(:)
prefactor = scale*SQRT((pi*rzetp)**3)*EXP(-zeta*f*rab2)
phasefactor(:) = EXP(CMPLX(0.0_wp,-rp(:)*dg(:)))
expfactor(:) = EXP(-0.25*rzetp*dg(:)*dg(:))
lb_cube => pw%pw_grid%bounds(1,:)
ub_cube => pw%pw_grid%bounds(2,:)
lb_cube_min = MINVAL(lb_cube(:))
ub_cube_max = MAXVAL(ub_cube(:))
NULLIFY (cubeaxis,g,rag,rbg)
cubeaxis => reallocate(cubeaxis,lb_cube_min,ub_cube_max,1,3,0,la_max,&
0,lb_max)
g => reallocate(g,lb_cube_min,ub_cube_max)
rag => reallocate(rag,lb_cube_min,ub_cube_max)
rbg => reallocate(rbg,lb_cube_min,ub_cube_max)
DO i=1,3
DO ig=lb_cube(i),ub_cube(i)
ig2 = ig*ig
cubeaxis(ig,i,0,0) = expfactor(i)**ig2*phasefactor(i)**ig
END DO
IF (la_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
g(ig) = REAL(ig,wp)*dg(i)
rag(ig) = CMPLX(fap(i),-g(ig))
cubeaxis(ig,i,1,0) = rag(ig)*cubeaxis(ig,i,0,0)
END DO
DO la=2,la_max
fa = REAL(la-1,wp)*twozetp
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,0) = rag(ig)*cubeaxis(ig,i,la-1,0) +&
fa*cubeaxis(ig,i,la-2,0)
END DO
END DO
IF (lb_max > 0) THEN
fa = twozetp
DO ig=lb_cube(i),ub_cube(i)
rbg(ig) = CMPLX(fbp(i),-g(ig))
cubeaxis(ig,i,0,1) = rbg(ig)*cubeaxis(ig,i,0,0)
cubeaxis(ig,i,1,1) = rbg(ig)*cubeaxis(ig,i,1,0) +&
fa*cubeaxis(ig,i,0,0)
END DO
DO lb=2,lb_max
fb = REAL(lb-1,wp)*twozetp
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,0,lb) = rbg(ig)*cubeaxis(ig,i,0,lb-1) +&
fb*cubeaxis(ig,i,0,lb-2)
cubeaxis(ig,i,1,lb) = rbg(ig)*cubeaxis(ig,i,1,lb-1) +&
fb*cubeaxis(ig,i,1,lb-2) +&
fa*cubeaxis(ig,i,0,lb-1)
END DO
END DO
DO la=2,la_max
fa = REAL(la,wp)*twozetp
DO lb=1,lb_max
fb = REAL(lb-1,wp)*twozetp
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,lb) = rbg(ig)*cubeaxis(ig,i,la,lb-1) +&
fb*cubeaxis(ig,i,la,lb-2) +&
fa*cubeaxis(ig,i,la-1,lb-1)
END DO
END DO
END DO
END IF
ELSE
IF (lb_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
g(ig) = REAL(ig,wp)*dg(i)
rbg(ig) = CMPLX(fbp(i),-g(ig))
cubeaxis(ig,i,0,1) = rbg(ig)*cubeaxis(ig,i,0,0)
END DO
DO lb=2,lb_max
fb = REAL(lb-1,wp)*twozetp
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,0,lb) = rbg(ig)*cubeaxis(ig,i,0,lb-1) +&
fb*cubeaxis(ig,i,0,lb-2)
END DO
END DO
END IF
END IF
END DO
DO la=0,la_max
DO lb=0,lb_max
IF (la + lb == 0) CYCLE
fa = (1.0_wp/twozetp)**(la + lb)
DO i=1,3
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,lb) = fa*cubeaxis(ig,i,la,lb)
END DO
END DO
END DO
END DO
! *** Add the current primitive Gaussian function product to grid ***
DO ico=ncoset(la_min-1)+1,ncoset(la_max)
ax = indco(1,ico)
ay = indco(2,ico)
az = indco(3,ico)
DO jco=ncoset(lb_min-1)+1,ncoset(lb_max)
pij = prefactor*pab(ico,jco)
IF (ABS(pij) < eps_rho_gspace) CYCLE
bx = indco(1,jco)
by = indco(2,jco)
bz = indco(3,jco)
DO kg=lb_cube(3),ub_cube(3)
z = pij*cubeaxis(kg,3,az,bz)
IF (ABS(z) < eps_rho_gspace) CYCLE
DO jg=lb_cube(2),ub_cube(2)
yz = cubeaxis(jg,2,ay,by)*z
IF (ABS(yz) < eps_rho_gspace) CYCLE
DO ig=lb_cube(1),ub_cube(1)
pw%cc3d(ig,jg,kg) = pw%cc3d(ig,jg,kg) + cubeaxis(ig,1,ax,bx)*yz
END DO
END DO
END DO
END DO
END DO
DEALLOCATE (cubeaxis,g,rag,rbg)
CALL timestop(0.0_wp,handle)
END SUBROUTINE collocate_pgf_product_gspace
! *****************************************************************************
SUBROUTINE collocate_pgf_product_rspace(la_max,zeta,la_min,&
lb_max,zetb,lb_min,&
ra,rab,rab2,scale,pab,pw)
TYPE(pw_type), TARGET, INTENT(INOUT) :: pw
REAL(wp), INTENT(IN) :: rab2,scale,zeta,zetb
INTEGER, INTENT(IN) :: la_max,la_min,lb_max,lb_min
REAL(wp), DIMENSION(3), INTENT(IN) :: ra,rab
REAL(wp), DIMENSION(ncoset(la_max),ncoset(lb_max)), INTENT(IN) :: pab
! *** Local variables ***
REAL(wp) :: f,pij,prefactor,radius,yz,z,zetp
INTEGER :: ax,ay,az,bx,by,bz,handle,i,ico,ig,j,jco,jg,k,kg,la,lb,&
lb_cube_min,ub_cube_max
REAL(wp), DIMENSION(3) :: rap,rbp,roffset,rp
INTEGER, DIMENSION(3) :: cubecenter,lb_cube,ub_cube
REAL(wp), DIMENSION(:), POINTER :: dr,rag,rbg,rpg
INTEGER, DIMENSION(:), POINTER :: ng
INTEGER, DIMENSION(:,:), POINTER :: map
REAL(wp), DIMENSION(:,:,:), POINTER :: grid
REAL(wp), DIMENSION(:,:,:,:), POINTER :: cubeaxis
! ---------------------------------------------------------------------------
CALL timeset("collocate_pgf_product_rspace","I","",handle)
zetp = zeta + zetb
f = zetb/zetp
prefactor = scale*EXP(-zeta*f*rab2)
radius = exp_radius(0,zetp,eps_rho_rspace,prefactor)
IF (radius == 0.0_wp) THEN
CALL timestop(0.0_wp,handle)
RETURN
END IF
npgf_product = npgf_product + (ncoset(la_max) - ncoset(la_min-1))*&
(ncoset(lb_max) - ncoset(lb_min-1))
dr => pw%pw_grid%dr(:)
ng => pw%pw_grid%npts(:)
grid => pw%cr3d(:,:,:)
rap(:) = f*rab(:)
rbp(:) = rap(:) - rab(:)
rp(:) = ra(:) + rap(:)
cubecenter(:) = FLOOR(rp(:)/dr(:))
roffset(:) = rp(:) - REAL(cubecenter(:),wp)*dr(:)
lb_cube(:) = FLOOR(-radius/dr(:))
ub_cube(:) = CEILING(radius/dr(:))
! *** Calculate the Gaussian function values for each cube axis ***
lb_cube_min = MINVAL(lb_cube(:))
ub_cube_max = MAXVAL(ub_cube(:))
NULLIFY (cubeaxis,map,rag,rbg,rpg)
cubeaxis => reallocate(cubeaxis,lb_cube_min,ub_cube_max,1,3,0,la_max,&
0,lb_max)
map => reallocate(map,lb_cube_min,ub_cube_max,1,3)
rag => reallocate(rag,lb_cube_min,ub_cube_max)
rbg => reallocate(rbg,lb_cube_min,ub_cube_max)
rpg => reallocate(rpg,lb_cube_min,ub_cube_max)
DO i=1,3
DO ig=lb_cube(i),ub_cube(i)
map(ig,i) = MODULO(cubecenter(i) + ig,ng(i)) + 1
rpg(ig) = REAL(ig,wp)*dr(i) - roffset(i)
cubeaxis(ig,i,0,0) = EXP(-zetp*rpg(ig)**2)
END DO
IF (la_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rag(ig) = rap(i) + rpg(ig)
cubeaxis(ig,i,1,0) = rag(ig)*cubeaxis(ig,i,0,0)
END DO
DO la=2,la_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,0) = rag(ig)*cubeaxis(ig,i,la-1,0)
END DO
END DO
IF (lb_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rbg(ig) = rag(ig) - rab(i)
END DO
DO la=0,la_max
DO lb=1,lb_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,lb) = rbg(ig)*cubeaxis(ig,i,la,lb-1)
END DO
END DO
END DO
END IF
ELSE
IF (lb_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rbg(ig) = rbp(i) + rpg(ig)
cubeaxis(ig,i,0,1) = rbg(ig)*cubeaxis(ig,i,0,0)
END DO
DO lb=2,lb_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,0,lb) = rbg(ig)*cubeaxis(ig,i,0,lb-1)
END DO
END DO
END IF
END IF
END DO
! *** Add the current Gaussian function product to grid ***
DO ico=ncoset(la_min-1)+1,ncoset(la_max)
ax = indco(1,ico)
ay = indco(2,ico)
az = indco(3,ico)
DO jco=ncoset(lb_min-1)+1,ncoset(lb_max)
pij = prefactor*pab(ico,jco)
IF (ABS(pij) < eps_rho_rspace) CYCLE
bx = indco(1,jco)
by = indco(2,jco)
bz = indco(3,jco)
DO kg=lb_cube(3),ub_cube(3)
k = map(kg,3)
z = pij*cubeaxis(kg,3,az,bz)
IF (ABS(z) < eps_rho_rspace) CYCLE
DO jg=lb_cube(2),ub_cube(2)
j = map(jg,2)
yz = cubeaxis(jg,2,ay,by)*z
IF (ABS(yz) < eps_rho_rspace) CYCLE
DO ig=lb_cube(1),ub_cube(1)
i = map(ig,1)
grid(i,j,k) = grid(i,j,k) + cubeaxis(ig,1,ax,bx)*yz
END DO
END DO
END DO
END DO
END DO
DEALLOCATE (cubeaxis,map,rag,rbg,rpg)
CALL timestop(0.0_wp,handle)
END SUBROUTINE collocate_pgf_product_rspace
! *****************************************************************************
END MODULE collocate_density

522
src/control_module.F
View file

@ -28,7 +28,7 @@ MODULE control_module
USE cntl_input, ONLY : read_cntl_section
USE convert_units, ONLY : convert
USE dft_input, ONLY : read_dft_section, read_wave_section
USE dft_types, ONLY : dft_control_type, wave_control_type
USE dft_types, ONLY : dft_control_type
USE dump, ONLY : dump_variables
USE ewalds, ONLY : ewald_print, ewald_correction
USE ewald_parameters_types, ONLY : ewald_parameters_type
@ -41,30 +41,36 @@ MODULE control_module
assign_extended_parameters
USE initialize_molecule_types, ONLY : initialize_molecule_type
USE initialize_particle_types, ONLY : initialize_particle_type
USE initialize_pimd_types, ONLY : initialize_pimd
USE input_types, ONLY : setup_parameters_type
USE integrator, ONLY : velocity_verlet, force, set_energy_parm, energy, &
set_integrator
USE kinds, ONLY : dbl
USE kpoint_initialization, ONLY : initialize_kpoints
USE linklist_control, ONLY : set_ll_parm
USE mathconstants, ONLY : zero
USE mathconstants, ONLY : zero, twopi
USE md, ONLY : read_md_section, simulation_parameters_type, &
initialize_velocities, thermodynamic_type, mdio_parameters_type
USE molecule_input, ONLY : read_molecule_section, read_setup_section, &
charge
USE molecule_types, ONLY : molecule_type, intra_parameters_type
USE nose, ONLY : lnhc_parameters_type, npt_info_type
USE nose, ONLY : lnhc_parameters_type, npt_info_type, yoshida_coef
USE pair_potential, ONLY : spline_nonbond_control
USE particle_types, ONLY : particle_prop_type, particle_type
USE simulation_cell, ONLY : cell_type, get_hinv
USE simulation_cell, ONLY : cell_type, get_hinv, init_cell
USE termination, ONLY : stop_program, stop_memory
USE structure_types, ONLY : structure_type, interaction_type
USE tbmd_debug, ONLY : tbmd_debug_control => debug_control
USE tbmd_initialize, ONLY : tbmd_init, tb_get_numel
!..Problems with pimd
USE tbmd_input, ONLY : read_tb_hamiltonian, read_tb_hopping_elements
USE timings, ONLY : timeset, timestop, trace_debug
USE unit, ONLY : unit_convert_type, set_units
USE util, ONLY : close_unit, get_share
USE physcon, ONLY : boltzmann, h_planck
USE read_pimd, ONLY : read_pimd_section
USE string_utilities, ONLY : xstring, integer_to_string
USE transformations, ONLY : fr2fu, v2ud, ud2v
IMPLICIT NONE
@ -92,6 +98,7 @@ CONTAINS
!!
!! MODIFICATION HISTORY
!! Harald Forbert (Dec-2000): enable multiple linked lists
!! Harald Forbert (Feb-2001): added path integral support
!!
!! USED BY
!! cp2k
@ -109,18 +116,20 @@ SUBROUTINE control ( globenv )
! Locals
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rcut
INTEGER :: handle1, handle2, isos
INTEGER :: nel
INTEGER :: nel, i, ia, ib, ibead, beads
CHARACTER ( LEN = ATOMNAMESLENGTH ), DIMENSION ( : ), POINTER :: atom_names
CHARACTER ( LEN = 40 ) :: set_fn
LOGICAL :: tbmd, fist, dft, wave, quickstep
CHARACTER ( LEN = 40 ) :: set_fn, project_name
CHARACTER ( LEN = 5 ) :: tag
LOGICAL :: tbmd, fist, dft, wave, quickstep, is_pimd
TYPE ( particle_prop_type ), DIMENSION ( : ), POINTER :: pstat
TYPE ( molecule_type ), DIMENSION ( : ), POINTER :: mol_setup
TYPE ( unit_convert_type ) :: units
TYPE ( simulation_parameters_type ) :: simpar
TYPE ( structure_type ) :: struc
TYPE ( structure_type ), ALLOCATABLE, DIMENSION ( : ) :: struc
TYPE ( interaction_type ) :: inter
TYPE ( lnhc_parameters_type ) :: nhc_part, nhc_baro
TYPE ( lnhc_parameters_type ), ALLOCATABLE, DIMENSION ( : ) :: &
nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), POINTER :: npt_info
TYPE ( system_type ) :: ainp
TYPE ( ewald_parameters_type ) :: ewald_param
@ -139,23 +148,6 @@ SUBROUTINE control ( globenv )
CALL timeset ( 'CONTROL', 'I', ' ', handle1 )
CALL timeset ( 'CNTL_INIT', 'I', ' ', handle2 )
struc % ll_data % natom_types = 0
struc % ll_data % list_type = 0
struc % ll_data % counter = 0
struc % ll_data % last_update = 0
struc % ll_data % num_update = 0
struc % ll_data % print_level = 1
NULLIFY ( struc % ll_data % r_last_update )
NULLIFY ( struc % ll_data % rlist_cut )
NULLIFY ( struc % ll_data % rlist_cutsq )
NULLIFY ( struc % ll_data % pp_images )
NULLIFY ( struc % ll_data % pp_ncell )
NULLIFY ( struc % ll_data % pp_startlist_im )
NULLIFY ( struc % ll_data % pp_startlist_nl )
NULLIFY ( struc % ll_data % pp_neighbor )
NULLIFY ( struc % ll_data % pp_startlist_cell )
NULLIFY ( struc % ll_data % pp_cell_ll )
!*apsi* 130201: Waiting for Matthias + Jürg :*)
quickstep = .FALSE.
@ -186,6 +178,46 @@ SUBROUTINE control ( globenv )
! read control section
CALL read_cntl_section ( setup, ewald_param, globenv )
!..check for path integrals
IF ( setup % run_type == 'PIMD' ) THEN
is_pimd = .true.
CALL read_pimd_section ( simpar % pimd_params, globenv )
beads = simpar % pimd_params % beads
ELSE
is_pimd = .false.
beads = 1
simpar % pimd_params % beads = 0
END IF
ALLOCATE ( struc ( beads ), STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'allocstruc', 'struc', beads )
ALLOCATE ( nhc_part ( beads ), STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'allocstruc', 'nhc_part', beads )
ALLOCATE ( nhc_baro ( beads ), STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'allocstruc', 'nhc_baro', beads )
DO ibead = 1, beads
struc(ibead) % ll_data % natom_types = 0
struc(ibead) % ll_data % list_type = 0
struc(ibead) % ll_data % counter = 0
struc(ibead) % ll_data % last_update = 0
struc(ibead) % ll_data % num_update = 0
struc(ibead) % ll_data % print_level = 1
NULLIFY ( struc(ibead) % ll_data % r_last_update )
NULLIFY ( struc(ibead) % ll_data % rlist_cut )
NULLIFY ( struc(ibead) % ll_data % rlist_cutsq )
NULLIFY ( struc(ibead) % ll_data % pp_images )
NULLIFY ( struc(ibead) % ll_data % pp_ncell )
NULLIFY ( struc(ibead) % ll_data % pp_startlist_im )
NULLIFY ( struc(ibead) % ll_data % pp_startlist_nl )
NULLIFY ( struc(ibead) % ll_data % pp_neighbor )
NULLIFY ( struc(ibead) % ll_data % pp_startlist_cell )
NULLIFY ( struc(ibead) % ll_data % pp_cell_ll )
END DO
! read from the setup and molecule section of *.set
set_fn = setup % set_file_name
@ -209,17 +241,12 @@ SUBROUTINE control ( globenv )
END IF
IF ( dft ) THEN
IF ( wave ) THEN
CALL read_dft_section ( setup, dft_control, globenv )
CALL read_wave_section ( setup, dft_control % wave_control, globenv )
ELSE
CALL stop_program ( "control", "DFT method not implemented" )
END IF
END IF
! read the input of the molecular dynamics section
@ -228,24 +255,85 @@ SUBROUTINE control ( globenv )
!..read atomic coordinates, velocities (optional) and the simulation box
ainp % rtype = simpar % read_type
CALL read_coord_vel ( ainp, setup % input_file_name, globenv )
! initialize working units
CALL set_units ( setup % unit_type, units )
CALL xstring ( setup % input_file_name, ia, ib )
DO ibead = 1, beads
IF (is_pimd) THEN
CALL integer_to_string(ibead,tag)
project_name = setup%input_file_name(ia:ib) // '_' // ADJUSTL(tag)
ELSE
project_name = setup%input_file_name(ia:ib)
END IF
CALL read_coord_vel ( ainp, project_name, globenv )
!..initialize box, perd
struc % box % hmat = ainp % box
struc % box % perd = setup % perd
CALL init_cell ( struc(ibead) % box, ainp % box, setup % perd )
IF ( simpar % read_type /= 'INIT' ) THEN
struc % box_ref % hmat = ainp % box_ref
ENDIF
IF ( simpar % read_type /= 'INIT' ) THEN
struc(ibead) % box_ref % hmat = ainp % box_ref
END IF
! If run is a debug. Make box_ref = box to work under
! all ensembles and restart options
IF ( setup % run_type == 'DEBUG' ) THEN
struc % box_ref % hmat = ainp % box
ENDIF
IF ( setup % run_type == 'DEBUG' ) THEN
struc(ibead) % box_ref % hmat = ainp % box
END IF
!..allocate memory for atoms and molecules
CALL allocmem ( ainp, mol_setup, struc(ibead), globenv )
!..initialize particle_type
CALL initialize_particle_type ( atom_names, simpar, mol_setup, &
ainp, pstat, struc(ibead) % part )
IF ( simpar % read_type == 'INIT' ) THEN
CALL convert ( units = units, part = struc(ibead) % part, &
box = struc(ibead) % box)
END IF
!..calculate the inverse box matrix now after the unit conversion,
! so it also has the right units and assign the reference box
CALL get_hinv ( struc(ibead) % box )
IF ( simpar % read_type == 'INIT' ) THEN
struc(ibead) % box_ref = struc(ibead) % box
ENDIF
CALL get_hinv ( struc(ibead) % box_ref )
!..initialize molecule_type
CALL initialize_molecule_type ( mol_setup, intra_param, struc(ibead) % pnode, &
struc(ibead) % part, struc(ibead) % molecule, globenv )
!..allocate lnhc_parameters_type and npt_info and get
! number of degrees of freedom
CALL initialize_extended_system ( struc(ibead) % box, simpar, &
struc(ibead) % molecule, mol_setup, globenv, &
nhc_part(ibead), nhc_baro(ibead), npt_info )
! initialize velocities if needed
IF ( simpar % read_type == 'POS' .OR. simpar % read_type == 'INIT' ) THEN
CALL initialize_velocities ( simpar, struc(ibead) % part, globenv )
END IF
! Assign extended system variables
IF ( simpar % read_type == 'ALL' ) THEN
CALL assign_extended_parameters ( struc(ibead) % box % deth, &
simpar % ensemble, ainp, npt_info, nhc_part(ibead), nhc_baro(ibead) )
ENDIF
CALL release_mem ( ainp )
END DO
!..1.0e-15 because convert_unit expects time in [fs]^-1 not [s]^-1
simpar % pimd_params % wp = 1.0e-15_dbl * SQRT(1.0_dbl*beads) * twopi * &
simpar % temp_ext * boltzmann / h_planck
simpar % pimd_params % beta = 1.0_dbl/simpar%temp_ext
!..K-Points
IF ( SUM ( struc % box % perd ) == 0 ) THEN
IF ( SUM ( struc(1) % box % perd ) == 0 ) THEN
kp % scheme = "NULL"
ELSE IF ( tbmd .OR. wave ) THEN
CALL kpoint_input ( kp, globenv )
@ -253,24 +341,13 @@ SUBROUTINE control ( globenv )
kp % scheme = "NULL"
END IF
! initialize working units
CALL set_units ( setup % unit_type, units )
CALL set_energy_parm ( units % pconv, units % econv, units % l_label, &
units % vol_label, units % e_label, units % pres_label, &
units % temp_label, units % angl_label )
!..allocate memory for atoms and molecules
CALL allocmem ( ainp, mol_setup, struc, globenv )
!..initialize particle_type
CALL initialize_particle_type ( atom_names, simpar, mol_setup, &
ainp, pstat, struc % part )
!..convert the units ( includes part and box ONLY when read_type is 'INIT' )
IF ( simpar % read_type == 'INIT' ) THEN
CALL convert ( units = units, simpar = simpar, &
part = struc % part, pstat = pstat, box = struc % box, &
CALL convert ( units = units, simpar = simpar, pstat = pstat, &
potparm = inter%potparm, intra_param = intra_param, &
ewald_param = ewald_param )
ELSE
@ -279,35 +356,13 @@ SUBROUTINE control ( globenv )
intra_param = intra_param, ewald_param = ewald_param )
ENDIF
!..calculate the inverse box matrix now after the unit conversion,
! so it also has the right units and assign the reference box
CALL get_hinv ( struc % box )
IF ( simpar % read_type == 'INIT' ) THEN
struc % box_ref = struc % box
ENDIF
CALL get_hinv ( struc % box_ref )
IF (is_pimd) THEN
!..initialize pimd_data (transformation related variables)
CALL initialize_pimd( struc , simpar )
!..initialize molecule_type
CALL initialize_molecule_type ( mol_setup, intra_param, struc % pnode, &
struc % part, struc % molecule, globenv )
!..allocate lnhc_parameters_type and npt_info and get
! number of degrees of freedom
CALL initialize_extended_system ( struc % box, simpar, &
struc % molecule, mol_setup, globenv, nhc_part, nhc_baro, npt_info )
! initialize velocities if needed
IF ( simpar % read_type == 'POS' .OR. simpar % read_type == 'INIT' ) THEN
CALL initialize_velocities ( simpar, struc % part, globenv )
CALL v2ud(struc,simpar)
END IF
! Assign extended system variables
IF ( simpar % read_type == 'ALL' ) THEN
CALL assign_extended_parameters ( struc % box % deth, simpar % ensemble, &
ainp, npt_info, nhc_part, nhc_baro )
ENDIF
!...initialize splines
inter%potparm ( :, : ) % energy_cutoff = 0.0_dbl
@ -320,77 +375,32 @@ SUBROUTINE control ( globenv )
rcut ( :, : ) = inter%potparm ( :, : ) % rcutsq
CALL set_ll_parm ( struc % ll_data, globenv, simpar % verlet_skin, &
setup % natom_type, rcut, simpar % n_cell )
DO ibead = 1, beads
CALL set_ll_parm ( struc(ibead) % ll_data, globenv, simpar % verlet_skin, &
setup % natom_type, rcut, simpar % n_cell )
CALL set_ll_parm ( struc % ll_data, globenv, printlevel = globenv % print_level, &
ltype = 'NONBOND' )
CALL set_ll_parm ( struc(ibead) % ll_data, globenv, &
printlevel = globenv % print_level, ltype = 'NONBOND' )
END DO
DEALLOCATE ( rcut, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'rcut' )
!..deallocate arrays needed for atom input
IF ( ASSOCIATED ( ainp % c ) ) THEN
DEALLOCATE ( ainp % c, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%c' )
END IF
IF ( ASSOCIATED ( ainp % v ) ) THEN
DEALLOCATE ( ainp % v, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%v' )
END IF
IF ( ASSOCIATED ( ainp % eta_part ) ) THEN
DEALLOCATE ( ainp % eta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%eta_part' )
END IF
IF ( ASSOCIATED ( ainp % veta_part ) ) THEN
DEALLOCATE ( ainp % veta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veta_part' )
END IF
IF ( ASSOCIATED ( ainp % mass_eta_part ) ) THEN
DEALLOCATE ( ainp % mass_eta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eta_part' )
END IF
IF ( ASSOCIATED ( ainp % eta_baro ) ) THEN
DEALLOCATE ( ainp % eta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%eta_baro' )
END IF
IF ( ASSOCIATED ( ainp % veta_baro ) ) THEN
DEALLOCATE ( ainp % veta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veta_baro' )
END IF
IF ( ASSOCIATED ( ainp % mass_eta_baro ) ) THEN
DEALLOCATE ( ainp % mass_eta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eta_baro' )
END IF
IF ( ASSOCIATED ( ainp % veps ) ) THEN
DEALLOCATE ( ainp % veps, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veps' )
END IF
IF ( ASSOCIATED ( ainp % mass_eps ) ) THEN
DEALLOCATE ( ainp % mass_eps, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eps' )
END IF
!
!..initialize the on-site terms for TB
IF ( tbmd ) CALL tbmd_init ( struc % part, inter%tbatom, inter%tbhop )
!..Problems with pimd?????
IF ( tbmd ) THEN
CALL tbmd_init ( struc(1) % part, inter%tbatom, inter%tbhop )
END IF
!
! Symmetry and K-points
!
IF ( SUM ( struc % box % perd ) == 0 ) THEN
IF ( SUM ( struc(1) % box % perd ) == 0 ) THEN
!!!!!! symmetry setup for molecules
ELSE IF ( tbmd ) THEN
CALL initialize_kpoints ( globenv, kp, setup % symmetry, &
struc % box % hmat, struc % part )
struc(1) % box % hmat, struc(1) % part )
IF ( globenv%ionode .AND. globenv%print_level > 0) &
CALL brillouin_info ( kp, globenv%scr )
END IF
@ -412,7 +422,15 @@ SUBROUTINE control ( globenv )
kp )
! deallocate memory for atoms and molecules
CALL deallocmem ( struc )
DO ibead = 1, beads
CALL deallocmem ( struc(ibead) )
END DO
DEALLOCATE ( nhc_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'nhc_baro' )
DEALLOCATE ( nhc_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'nhc_part' )
DEALLOCATE ( struc, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'struc' )
CALL timestop ( zero, handle1 )
@ -435,9 +453,9 @@ SUBROUTINE control_work ( globenv, units, simpar, struc, inter, nhc_part, &
TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv
TYPE ( unit_convert_type ) :: units
TYPE ( simulation_parameters_type ) :: simpar
TYPE ( structure_type ) :: struc
TYPE ( structure_type ), DIMENSION ( : ) :: struc
TYPE ( interaction_type ) :: inter
TYPE ( lnhc_parameters_type ) :: nhc_part, nhc_baro
TYPE ( lnhc_parameters_type ), DIMENSION ( : ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), POINTER :: npt_info
TYPE ( ewald_parameters_type ) :: ewald_param
TYPE ( setup_parameters_type ) :: setup
@ -461,7 +479,8 @@ SUBROUTINE control_work ( globenv, units, simpar, struc, inter, nhc_part, &
CASE ( "DEBUG" )
! debug the forces
CALL control_debug_work ( globenv, simpar, struc, inter, ewald_param, &
! only for first bead in pimd
CALL control_debug_work ( globenv, simpar, struc(1), inter, ewald_param, &
mdio, tbmd, fist )
CASE ( "ENERGY" )
@ -473,6 +492,11 @@ SUBROUTINE control_work ( globenv, units, simpar, struc, inter, nhc_part, &
CALL control_md_work ( globenv, units, simpar, struc, inter, nhc_part, &
nhc_baro, npt_info, ewald_param, mdio, dft_control, kp )
CASE ( "PIMD" )
CALL control_md_work ( globenv, units, simpar, struc, inter, nhc_part, &
nhc_baro, npt_info, ewald_param, mdio, dft_control, kp )
END SELECT
@ -507,11 +531,11 @@ SUBROUTINE control_debug_work ( globenv, simpar, struc, inter, ewald_param, &
IF ( fist ) then
CALL fist_debug_control ( globenv, ewald_param, struc%part, &
struc%pnode, struc%molecule, struc%box, struc%box_ref, thermo, &
inter%potparm, simpar % ensemble, struc % ll_data )
inter%potparm, struc % ll_data )
ELSE IF ( tbmd ) THEN
CALL tbmd_debug_control ( globenv, ewald_param, struc%part, &
struc%pnode, struc%molecule, struc%box, struc%box_ref, thermo, &
inter%potparm, simpar % ensemble, struc % ll_data )
inter%potparm, struc % ll_data )
ELSE
CALL stop_program ( "control_debug_work", "no method to debug found" )
END IF
@ -529,9 +553,9 @@ SUBROUTINE control_energy_work ( globenv, units, simpar, struc, inter, &
TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv
TYPE ( unit_convert_type ) :: units
TYPE ( simulation_parameters_type ) :: simpar
TYPE ( structure_type ) :: struc
TYPE ( structure_type ), DIMENSION ( : ) :: struc
TYPE ( interaction_type ) :: inter
TYPE ( lnhc_parameters_type ) :: nhc_part, nhc_baro
TYPE ( lnhc_parameters_type ), DIMENSION ( : ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), POINTER :: npt_info
TYPE ( ewald_parameters_type ) :: ewald_param
TYPE ( mdio_parameters_type ) :: mdio
@ -541,34 +565,14 @@ SUBROUTINE control_energy_work ( globenv, units, simpar, struc, inter, &
! Locals
REAL ( dbl ) :: cons
INTEGER :: itimes
LOGICAL, PARAMETER :: box_change = .FALSE.
TYPE ( thermodynamic_type ) :: thermo
!------------------------------------------------------------------------------
! initialize integrator
CALL set_integrator ( globenv, mdio )
! MD
itimes = 0
CALL force ( struc, inter, thermo, simpar, ewald_param, globenv, &
dft_control, kp )
IF ( globenv % ionode .AND. ewald_param % ewald_type /= 'NONE' ) &
CALL ewald_print ( globenv % scr, thermo, struc % box, &
units % e_label )
CALL energy ( itimes, cons, simpar, struc, thermo, nhc_part, &
nhc_baro, npt_info )
CALL velocity_verlet ( itimes, cons, simpar, inter, thermo, &
struc, ewald_param, nhc_part, nhc_baro, npt_info, dft_control, kp )
CALL dump_variables ( struc, nhc_part, nhc_baro, npt_info, &
mdio % dump_file_name, globenv )
IF ( globenv % ionode ) CALL close_unit ( 10, 99 )
call stop_program("control_energy_work","nothing in place")
END SUBROUTINE control_energy_work
!******************************************************************************
@ -582,9 +586,9 @@ SUBROUTINE control_md_work ( globenv, units, simpar, struc, inter, nhc_part, &
TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv
TYPE ( unit_convert_type ) :: units
TYPE ( simulation_parameters_type ) :: simpar
TYPE ( structure_type ) :: struc
TYPE ( structure_type ), DIMENSION ( : ) :: struc
TYPE ( interaction_type ) :: inter
TYPE ( lnhc_parameters_type ) :: nhc_part, nhc_baro
TYPE ( lnhc_parameters_type ), DIMENSION ( : ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), POINTER :: npt_info
TYPE ( ewald_parameters_type ) :: ewald_param
TYPE ( mdio_parameters_type ) :: mdio
@ -594,23 +598,30 @@ SUBROUTINE control_md_work ( globenv, units, simpar, struc, inter, nhc_part, &
! Locals
REAL ( dbl ) :: cons
INTEGER :: itimes
LOGICAL, PARAMETER :: box_change = .FALSE.
LOGICAL :: is_pimd
TYPE ( thermodynamic_type ) :: thermo
!------------------------------------------------------------------------------
! Path integrals?
is_pimd = simpar % pimd_params % beads /= 0
! initialize integrator
CALL set_integrator ( globenv, mdio )
! MD
itimes = 0
CALL force ( struc, inter, thermo, simpar, ewald_param, globenv, &
dft_control, kp )
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
globenv, dft_control, kp )
!+++ what about thermo, should this be an array?
IF ( globenv % ionode .AND. ewald_param % ewald_type /= 'NONE' ) &
CALL ewald_print ( globenv % scr, thermo, struc % box, &
CALL ewald_print ( globenv % scr, thermo, struc(1) % box, &
units % e_label )
IF ( is_pimd ) CALL fr2fu(struc, simpar)
CALL energy ( itimes, cons, simpar, struc, thermo, nhc_part, &
nhc_baro, npt_info )
@ -618,13 +629,20 @@ SUBROUTINE control_md_work ( globenv, units, simpar, struc, inter, nhc_part, &
CALL velocity_verlet ( itimes, cons, simpar, inter, thermo, &
struc, ewald_param, nhc_part, nhc_baro, npt_info, dft_control, kp )
IF ( MOD ( itimes, mdio % idump ) == 0 ) &
IF ( MOD ( itimes, mdio % idump ) == 0 ) THEN
!+++ HAF: TODO: velocity back transform not in place so we dont have to
!+++ transform twice...
IF( is_pimd ) CALL ud2v(struc, simpar)
CALL dump_variables ( struc, nhc_part, nhc_baro, npt_info, &
mdio % dump_file_name, globenv )
mdio % dump_file_name, globenv, is_pimd )
IF( is_pimd ) CALL v2ud(struc, simpar)
ENDIF
END DO
IF( is_pimd ) CALL ud2v(struc, simpar)
CALL dump_variables ( struc, nhc_part, nhc_baro, npt_info, &
mdio % dump_file_name, globenv )
mdio % dump_file_name, globenv, is_pimd )
IF( is_pimd ) CALL v2ud(struc, simpar)
IF ( globenv % ionode ) CALL close_unit ( 10, 99 )
@ -632,92 +650,6 @@ END SUBROUTINE control_md_work
!******************************************************************************
#if defined ( __JUST_A_SECURITY_COPY )
SUBROUTINE control_work ( globenv, units, simpar, struc, inter, nhc_part, &
nhc_baro, npt_info, ewald_param, setup )
IMPLICIT NONE
! Arguments
TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv
TYPE ( unit_convert_type ) :: units
TYPE ( simulation_parameters_type ) :: simpar
TYPE ( structure_type ) :: struc
TYPE ( interaction_type ) :: inter
TYPE ( lnhc_parameters_type ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), POINTER :: npt_info
TYPE ( ewald_parameters_type ) :: ewald_param
TYPE ( setup_parameters_type ) :: setup
LOGICAL :: tbmd, fist
! Locals
REAL ( dbl ) :: cons, ecut
INTEGER :: handle, itimes
TYPE ( thermodynamic_type ) :: thermo
!------------------------------------------------------------------------------
CALL timeset ( 'CNTL_WORK', 'I', ' ', handle )
IF ( setup % run_type == 'DEBUG' ) THEN
! debug the forces
! initialize integrator
CALL set_integrator ( globenv, mdio )
IF ( fist ) then
CALL fist_debug_control( globenv, ewald_param, struc%part, struc%pnode, &
struc%molecule, struc%box, struc%box_ref, thermo, &
inter%potparm, simpar % ensemble, struc % ll_data )
ELSE IF ( tbmd ) THEN
CALL tbmd_debug_control( globenv, ewald_param, struc%part, struc%pnode, &
struc%molecule, struc%box, struc%box_ref, thermo, &
inter%potparm, simpar % ensemble, struc % ll_data )
ENDIF
ELSE
!..initialize integrator
CALL set_integrator ( globenv, mdio )
!..MD
itimes = 0
CALL force ( struc, inter, thermo, simpar, ewald_param, globenv )
IF ( globenv % ionode .AND. ewald_param % ewald_type /= 'NONE' ) &
CALL ewald_print ( globenv % scr, thermo, struc % box, &
units % e_label )
CALL energy ( itimes, cons, simpar, struc, thermo, nhc_part, &
nhc_baro, npt_info )
DO itimes = 1, simpar % nsteps
CALL velocity_verlet ( itimes, cons, simpar, inter, thermo, &
struc, ewald_param, nhc_part, nhc_baro, npt_info )
IF ( MOD ( itimes, mdio % idump ) == 0 ) &
CALL dump_variables ( struc, nhc_part, nhc_baro, &
npt_info, mdio % dump_file_name, globenv )
END DO
CALL dump_variables ( struc, nhc_part, nhc_baro, npt_info, &
mdio % dump_file_name, globenv )
IF ( globenv % ionode ) CALL close_unit ( 10, 99 )
END IF
!..deallocate memory for atoms and molecules
CALL deallocmem ( struc )
CALL timestop ( zero, handle )
END SUBROUTINE control_work
#endif
!******************************************************************************
SUBROUTINE allocmem ( ainp, mol_setup, struc, globenv )
IMPLICIT NONE
@ -798,6 +730,68 @@ END SUBROUTINE allocmem
!******************************************************************************
SUBROUTINE release_mem ( ainp )
IMPLICIT NONE
! Arguments
TYPE ( system_type ) :: ainp
! Local
INTEGER :: isos
!..deallocate arrays needed for atom input
IF ( ASSOCIATED ( ainp % c ) ) THEN
DEALLOCATE ( ainp % c, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%c' )
END IF
IF ( ASSOCIATED ( ainp % v ) ) THEN
DEALLOCATE ( ainp % v, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%v' )
END IF
IF ( ASSOCIATED ( ainp % eta_part ) ) THEN
DEALLOCATE ( ainp % eta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%eta_part' )
END IF
IF ( ASSOCIATED ( ainp % veta_part ) ) THEN
DEALLOCATE ( ainp % veta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veta_part' )
END IF
IF ( ASSOCIATED ( ainp % mass_eta_part ) ) THEN
DEALLOCATE ( ainp % mass_eta_part, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eta_part' )
END IF
IF ( ASSOCIATED ( ainp % eta_baro ) ) THEN
DEALLOCATE ( ainp % eta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%eta_baro' )
END IF
IF ( ASSOCIATED ( ainp % veta_baro ) ) THEN
DEALLOCATE ( ainp % veta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veta_baro' )
END IF
IF ( ASSOCIATED ( ainp % mass_eta_baro ) ) THEN
DEALLOCATE ( ainp % mass_eta_baro, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eta_baro' )
END IF
IF ( ASSOCIATED ( ainp % veps ) ) THEN
DEALLOCATE ( ainp % veps, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%veps' )
END IF
IF ( ASSOCIATED ( ainp % mass_eps ) ) THEN
DEALLOCATE ( ainp % mass_eps, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'control', 'ainp%mass_eps' )
END IF
END SUBROUTINE release_mem
!******************************************************************************
SUBROUTINE deallocmem ( struc )
IMPLICIT NONE
@ -823,3 +817,5 @@ END SUBROUTINE deallocmem
!******************************************************************************
END MODULE control_module
!******************************************************************************

3
src/convert_units.F
View file

@ -77,6 +77,9 @@ SUBROUTINE convert ( units, simpar, part, pstat, box, potparm, &
! convert verlet skin
simpar%verlet_skin = simpar%verlet_skin*units%lconv
! convert omega_p (wp) of PIMD
simpar%pimd_params%wp = simpar%pimd_params%wp * units%econv / units%tconv
! converting extended system time constants
SELECT CASE (simpar%ensemble)
CASE ( 'NVT')

224
src/core_energies.F Normal file
View file

@ -0,0 +1,224 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/core_energies [1.0] *
!!
!! NAME
!! core_energies
!!
!! FUNCTION
!! Calculation of the energies concerning the core charge distribution
!!
!! AUTHOR
!! Matthias Krack (27.04.2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE core_energies
! *****************************************************************************
USE kinds, ONLY: wp => dp
IMPLICIT NONE
PRIVATE
PUBLIC :: calculate_ecore,&
calculate_ecore_overlap,&
calculate_ecore_self
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE calculate_ecore(h,p,ecore)
! Purpose: Calculate the core Hamiltonian energy which includes the kinetic
! and the potential energy of the electrons.
! ***************************************************************************
USE matrix_types, ONLY: first_block_node,&
get_block_node,&
get_matrix_info,&
next_block_node,&
real_block_node_type,&
real_matrix_set_type
TYPE(real_matrix_set_type), INTENT(IN) :: h,p
REAL(wp), INTENT(OUT) :: ecore
! *** Local variables ***
TYPE(real_block_node_type), POINTER :: h_block_node
REAL(wp) :: ecore_block
INTEGER :: i,iblock_col,iblock_row,j,nblock_row
REAL(wp), DIMENSION(:,:), POINTER :: h_block,p_block
! ---------------------------------------------------------------------------
ecore = 0.0_wp
CALL get_matrix_info(matrix=h%matrix,nblock_row=nblock_row)
DO iblock_row=1,nblock_row
h_block_node => first_block_node(matrix=h%matrix,block_row=iblock_row)
DO WHILE (ASSOCIATED(h_block_node))
CALL get_block_node(block_node=h_block_node,&
block_col=iblock_col,&
block=h_block)
CALL get_block_node(matrix=p%matrix,&
block_row=iblock_row,&
block_col=iblock_col,&
block=p_block)
ecore_block = 0.0_wp
DO j=1,SIZE(h_block,2)
DO i=1,SIZE(h_block,1)
ecore_block = ecore_block + p_block(i,j)*h_block(i,j)
END DO
END DO
IF (iblock_row == iblock_col) THEN
ecore = ecore + ecore_block
ELSE
ecore = ecore + 2.0_wp*ecore_block
END IF
h_block_node => next_block_node(h_block_node)
END DO
END DO
END SUBROUTINE calculate_ecore
! *****************************************************************************
SUBROUTINE calculate_ecore_overlap(ecore_overlap)
! Purpose: Calculate the overlap energy of the core charge distribution.
! ***************************************************************************
USE atomic_kinds, ONLY: kind_info
USE atoms, ONLY: atom_info,natom
USE cell_parameters, ONLY: abc
REAL(wp), INTENT(OUT) :: ecore_overlap
! *** Local variables ***
REAL(wp) :: alpha_a,alpha_ab,alpha_b,dab,dabmax,radius_a,radius_b,za,zb,zab
INTEGER :: atom_a,atom_b,iatom,icell,ikind,jatom,jcell,jkind,kcell
REAL(wp), DIMENSION(3) :: ra,rab,rb
INTEGER, DIMENSION(3) :: ncell
REAL(wp), EXTERNAL :: erfc
! ---------------------------------------------------------------------------
ecore_overlap = 0.0_wp
DO iatom=1,natom
ikind = atom_info(iatom)%kind
alpha_a = kind_info(ikind)%alpha_core_charge
radius_a = kind_info(ikind)%core_charge_radius
za = REAL(kind_info(ikind)%zeff,wp)
ra(:) = atom_info(iatom)%r_pbc(:)
DO jatom=iatom+1,natom
jkind = atom_info(jatom)%kind
alpha_b = kind_info(jkind)%alpha_core_charge
radius_b = kind_info(jkind)%core_charge_radius
zb = REAL(kind_info(jkind)%zeff,wp)
rb(:) = atom_info(jatom)%r_pbc(:)
dabmax = radius_a + radius_b
ncell(:) = CEILING(dabmax/abc(:))
alpha_ab = SQRT(alpha_a*alpha_b/(alpha_a + alpha_b))
zab = za*zb
DO icell=-ncell(1),ncell(1)
DO jcell=-ncell(2),ncell(2)
DO kcell=-ncell(3),ncell(3)
! *** Calculate the distance vector between the two atoms ***
rab(:) = rb(:) - ra(:) + REAL((/icell,jcell,kcell/),wp)*abc(:)
! *** Calculate the interatomic distance ***
dab = SQRT(rab(1)*rab(1) + rab(2)*rab(2) + rab(3)*rab(3))
IF (dab < dabmax) THEN
ecore_overlap = ecore_overlap + zab*erfc(alpha_ab*dab)/dab
END IF
END DO
END DO
END DO
END DO
END DO
END SUBROUTINE calculate_ecore_overlap
! *****************************************************************************
SUBROUTINE calculate_ecore_self(ecore_self)
! Purpose: Calculate the self energy of the core charge distribution.
! ***************************************************************************
USE atomic_kinds, ONLY: kind_info,nkind
USE mathconstants, ONLY: twopi
REAL(wp), INTENT(OUT) :: ecore_self
! *** Local variables ***
INTEGER :: ikind
! ---------------------------------------------------------------------------
ecore_self = 0.0_wp
DO ikind=1,nkind
ecore_self = ecore_self - REAL(kind_info(ikind)%natom,wp)*&
REAL(kind_info(ikind)%zeff,wp)**2*&
SQRT(kind_info(ikind)%alpha_core_charge)
END DO
ecore_self = ecore_self/SQRT(twopi)
END SUBROUTINE calculate_ecore_self
! *****************************************************************************
END MODULE core_energies

188
src/core_hamiltonian.F
View file

@ -84,17 +84,17 @@ MODULE core_hamiltonian
! SUBROUTINE build_core_hamiltonian_matrix(globenv)
! SUBROUTINE distribute_s_matrix()
! SUBROUTINE build_h_matrix()
! SUBROUTINE add_prj_ppnl_matrix()
! SUBROUTINE add_ppnl_matrix()
! *****************************************************************************
USE kinds, ONLY: wp => dp,&
wp_size => dp_size
USE kinds, ONLY: wp => dp
USE atoms, ONLY: atom_info,natom,nsgf
USE atomic_kinds, ONLY: all_potential_present,&
gth_potential_present,&
kind_info,nkind
USE basis_set_types, ONLY: maxco,maxsgf
USE global_types, ONLY: global_environment_type
USE matrix_types, ONLY: add_block_node,&
allocate_matrix,&
@ -121,9 +121,8 @@ MODULE core_hamiltonian
next_neighbor_node
USE nl, ONLY: orb_neighbor_list_set,&
verfc_neighbor_list_set,&
verf_ppl_neighbor_list_set,&
vexp_ppl_neighbor_list_set,&
vprj_ppnl_ca_neighbor_list_set
vppl_neighbor_list_set,&
vppnl_ca_neighbor_list_set
USE om_utilities, ONLY: write_spherical_matrix
USE orbital_pointers, ONLY: nco,ncoset
USE external_potential_types, ONLY: maxlppnl
@ -139,7 +138,7 @@ MODULE core_hamiltonian
TYPE(real_matrix_set_type) :: h,s,sca_prj_ppnl,scb_prj_ppnl,t
LOGICAL :: init_pointers_done = .FALSE.
REAL(wp), DIMENSION(:,:), ALLOCATABLE :: hab,sab,work
REAL(wp), DIMENSION(:,:), POINTER :: hab,sab,work
! *** Public variables ***
@ -172,7 +171,7 @@ CONTAINS
! *** Local variables ***
INTEGER :: handle,ikind,iset,istat,la_max,maxco,maxfun,maxprj,maxsgf,npgfa
INTEGER :: handle,istat,maxfun
! ---------------------------------------------------------------------------
@ -191,42 +190,20 @@ CONTAINS
! *** Allocate work storage ***
maxco = 0
maxsgf = 0
maxfun = MAX(maxco,ncoset(maxlppnl))
DO ikind=1,nkind
DO iset=1,kind_info(ikind)%orb_basis_set%nset
maxsgf = MAX(maxsgf,kind_info(ikind)%orb_basis_set%nsgf)
npgfa = kind_info(ikind)%orb_basis_set%npgf(iset)
la_max = kind_info(ikind)%orb_basis_set%lmax(iset) + maxder
maxco = MAX(maxco,npgfa*ncoset(la_max))
END DO
END DO
NULLIFY (hab,sab,work)
maxprj = ncoset(maxlppnl)
hab => reallocate(hab,1,maxco,1,maxco)
sab => reallocate(sab,1,maxfun,1,maxco)
work => reallocate(work,1,maxfun,1,maxsgf)
ALLOCATE (hab(maxco,maxco),STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"hab",wp_size*maxco*maxco)
END IF
hab(:,:) = 0.0_wp
maxfun = MAX(maxco,maxprj)
ALLOCATE (sab(maxfun,maxco),STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"sab",wp_size*maxfun*maxco)
END IF
sab(:,:) = 0.0_wp
ALLOCATE (work(maxfun,maxsgf),STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"work",wp_size*maxfun*maxsgf)
END IF
work(:,:) = 0.0_wp
! *** Allocate the overlap matrix and distribute the atomic blocks ***
CALL distribute_s_matrix(globenv)
! *** Allocate the core Hamiltonian matrix ***
CALL replicate_matrix_structure(source=s%matrix,&
target=h%matrix,&
target_name="CORE HAMILTONIAN MATRIX")
@ -237,8 +214,12 @@ CONTAINS
target_name="KINETIC ENERGY MATRIX")
END IF
! *** Calculate the overlap and the core Hamiltonian matrix ***
CALL build_h_matrix(globenv)
! *** Printing ***
IF (globenv%print%overlap_matrix) THEN
CALL write_spherical_matrix(s%matrix,4,6,globenv)
END IF
@ -253,21 +234,21 @@ CONTAINS
! *** Release work storage ***
IF (ALLOCATED(hab)) THEN
IF (ASSOCIATED(hab)) THEN
DEALLOCATE (hab,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"hab")
END IF
END IF
IF (ALLOCATED(sab)) THEN
IF (ASSOCIATED(sab)) THEN
DEALLOCATE (sab,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"sab")
END IF
END IF
IF (ALLOCATED(work)) THEN
IF (ASSOCIATED(work)) THEN
DEALLOCATE (work,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"work")
@ -432,8 +413,7 @@ CONTAINS
TYPE(neighbor_list_type), POINTER :: orb_neighbor_list,&
verfc_neighbor_list,&
verf_ppl_neighbor_list,&
vexp_ppl_neighbor_list
vppl_neighbor_list
REAL(wp) :: dab,dac,dbc,rab2,rac2,rbc2,radius_a,radius_b,radius_c,zetc
INTEGER :: first_sgfa,first_sgfb,i,&
@ -446,18 +426,17 @@ CONTAINS
REAL(wp), DIMENSION(1) :: gccc
REAL(wp), DIMENSION(3) :: rab,rac,rbc
INTEGER, DIMENSION(:), POINTER :: orb_neighbors,verfc_neighbors,&
verf_ppl_neighbors,vexp_ppl_neighbors
REAL(wp), DIMENSION(:), POINTER :: orb_r2,rpgfa,rpgfb,verfc_r2,&
verf_ppl_r2,vexp_ppl_r2,zeta,zetb
vppl_neighbors
REAL(wp), DIMENSION(:), POINTER :: orb_r2,rpgfa,rpgfb,verfc_r2,vppl_r2,&
zeta,zetb
REAL(wp), DIMENSION(:,:), POINTER :: h_block,orb_r,s_block,t_block,&
verfc_r,verf_ppl_r,vexp_ppl_r
verfc_r,vppl_r
! ---------------------------------------------------------------------------
NULLIFY (orb_neighbor_list,orb_neighbors,orb_r,orb_r2)
NULLIFY (verfc_neighbor_list,verfc_neighbors,verfc_r,verfc_r2)
NULLIFY (verf_ppl_neighbor_list,verf_ppl_neighbors,verf_ppl_r,verf_ppl_r2)
NULLIFY (vexp_ppl_neighbor_list,vexp_ppl_neighbors,vexp_ppl_r,vexp_ppl_r2)
NULLIFY (vppl_neighbor_list,vppl_neighbors,vppl_r,vppl_r2)
! *** Loop over all atoms ***
@ -479,19 +458,11 @@ CONTAINS
END IF
IF (gth_potential_present) THEN
IF (allchem) THEN
verf_ppl_neighbor_list =>&
find_neighbor_list(verf_ppl_neighbor_list_set,iatom)
IF (ASSOCIATED(verf_ppl_neighbor_list)) THEN
CALL extract_neighbor_list(verf_ppl_neighbor_list,verf_ppl_r2,&
verf_ppl_neighbors,verf_ppl_r)
END IF
END IF
vexp_ppl_neighbor_list =>&
find_neighbor_list(vexp_ppl_neighbor_list_set,iatom)
IF (ASSOCIATED(vexp_ppl_neighbor_list)) THEN
CALL extract_neighbor_list(vexp_ppl_neighbor_list,vexp_ppl_r2,&
vexp_ppl_neighbors,vexp_ppl_r)
vppl_neighbor_list =>&
find_neighbor_list(vppl_neighbor_list_set,iatom)
IF (ASSOCIATED(vppl_neighbor_list)) THEN
CALL extract_neighbor_list(vppl_neighbor_list,vppl_r2,&
vppl_neighbors,vppl_r)
END IF
END IF
@ -639,17 +610,17 @@ CONTAINS
! *** GTH pseudopotential atoms ***
IF (ASSOCIATED(verf_ppl_neighbor_list)) THEN
IF (ASSOCIATED(vppl_neighbor_list)) THEN
DO jneighbor=1,SIZE(verf_ppl_neighbors)
DO jneighbor=1,SIZE(vppl_neighbors)
katom = verf_ppl_neighbors(jneighbor)
katom = vppl_neighbors(jneighbor)
kkind = atom_info(katom)%kind
radius_c = kind_info(kkind)%gth_potential%erf_ppl_radius
radius_c = kind_info(kkind)%gth_potential%ppl_radius
rac2 = verf_ppl_r2(jneighbor)
rac(:) = verf_ppl_r(:,jneighbor)
rac2 = vppl_r2(jneighbor)
rac(:) = vppl_r(:,jneighbor)
dac = SQRT(rac2)
IF (radius_a + radius_c < dac) CYCLE
@ -660,8 +631,8 @@ CONTAINS
IF (radius_b + radius_c < dbc) CYCLE
zetc = kind_info(kkind)%gth_potential%alpha_exp_ppl
gccc(1) = -kind_info(kkind)%cerf
zetc = kind_info(kkind)%gth_potential%alpha_ppl
gccc(1) = -kind_info(kkind)%gth_potential%cerf_ppl
CALL coulomb3(la_max,zeta,rpgfa,la_min,&
lb_max,zetb,rpgfb,lb_min,&
@ -683,7 +654,7 @@ CONTAINS
katom = verfc_neighbors(jneighbor)
kkind = atom_info(katom)%kind
radius_c = kind_info(kkind)%all_potential%erfc_radius
radius_c = kind_info(kkind)%core_charge_radius
rac2 = verfc_r2(jneighbor)
rac(:) = verfc_r(:,jneighbor)
@ -697,13 +668,13 @@ CONTAINS
IF (radius_b + radius_c < dbc) CYCLE
zetc = kind_info(kkind)%alpha_erf**2
zetc = kind_info(kkind)%alpha_core_charge
CALL verfc(la_max,zeta,rpgfa,la_min,&
lb_max,zetb,rpgfb,lb_min,&
zetc,radius_c,&
REAL(kind_info(kkind)%z,wp),&
kind_info(kkind)%cerf,&
kind_info(kkind)%ccore_charge,&
rab,rab2,rac,rac2,rbc,rbc2,hab)
END DO
@ -714,17 +685,17 @@ CONTAINS
! *** GTH pseudopotential atoms ***
IF (ASSOCIATED(vexp_ppl_neighbor_list)) THEN
IF (ASSOCIATED(vppl_neighbor_list)) THEN
DO jneighbor=1,SIZE(vexp_ppl_neighbors)
DO jneighbor=1,SIZE(vppl_neighbors)
katom = vexp_ppl_neighbors(jneighbor)
katom = vppl_neighbors(jneighbor)
kkind = atom_info(katom)%kind
radius_c = kind_info(kkind)%gth_potential%exp_ppl_radius
radius_c = kind_info(kkind)%gth_potential%ppl_radius
rac2 = vexp_ppl_r2(jneighbor)
rac(:) = vexp_ppl_r(:,jneighbor)
rac2 = vppl_r2(jneighbor)
rac(:) = vppl_r(:,jneighbor)
dac = SQRT(rac2)
IF (radius_a + radius_c < dac) CYCLE
@ -735,7 +706,7 @@ CONTAINS
IF (radius_b + radius_c < dbc) CYCLE
zetc = kind_info(kkind)%gth_potential%alpha_exp_ppl
zetc = kind_info(kkind)%gth_potential%alpha_ppl
CALL overlap_ppl(la_max,zeta,rpgfa,la_min,&
lb_max,zetb,rpgfb,lb_min,&
@ -783,7 +754,7 @@ CONTAINS
! *** Add the V(non-local) contribution of the GTH pseudopotential ***
IF (gth_potential_present) CALL add_prj_ppnl_matrix()
IF (gth_potential_present) CALL add_ppnl_matrix()
! *** Release work storage ***
@ -829,45 +800,24 @@ CONTAINS
END IF
END IF
IF (ASSOCIATED(verf_ppl_neighbors)) THEN
DEALLOCATE (verf_ppl_neighbors,STAT=istat)
IF (ASSOCIATED(vppl_neighbors)) THEN
DEALLOCATE (vppl_neighbors,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"verf_ppl_neighbors")
CALL stop_memory(routine,"vppl_neighbors")
END IF
END IF
IF (ASSOCIATED(verf_ppl_r)) THEN
DEALLOCATE (verf_ppl_r,STAT=istat)
IF (ASSOCIATED(vppl_r)) THEN
DEALLOCATE (vppl_r,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"verf_ppl_r")
CALL stop_memory(routine,"vppl_r")
END IF
END IF
IF (ASSOCIATED(verf_ppl_r2)) THEN
DEALLOCATE (verf_ppl_r2,STAT=istat)
IF (ASSOCIATED(vppl_r2)) THEN
DEALLOCATE (vppl_r2,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"verf_ppl_r2")
END IF
END IF
IF (ASSOCIATED(vexp_ppl_neighbors)) THEN
DEALLOCATE (vexp_ppl_neighbors,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"vexp_ppl_neighbors")
END IF
END IF
IF (ASSOCIATED(vexp_ppl_r)) THEN
DEALLOCATE (vexp_ppl_r,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"vexp_ppl_r")
END IF
END IF
IF (ASSOCIATED(vexp_ppl_r2)) THEN
DEALLOCATE (vexp_ppl_r2,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory(routine,"vexp_ppl_r2")
CALL stop_memory(routine,"vppl_r2")
END IF
END IF
@ -875,7 +825,7 @@ CONTAINS
! *****************************************************************************
SUBROUTINE add_prj_ppnl_matrix()
SUBROUTINE add_ppnl_matrix()
! Purpose: Add the non-local contribution of the GTH pseudopotential to the
! core Hamiltonian matrix.
@ -887,7 +837,7 @@ CONTAINS
USE ai_overlap, ONLY: overlap
CHARACTER(LEN=*), PARAMETER :: routine =&
"SUBROUTINE add_prj_ppnl_matrix (MODULE core_hamiltonian)"
"SUBROUTINE add_ppnl_matrix (MODULE core_hamiltonian)"
TYPE(neighbor_list_type), POINTER :: neighbor_list
TYPE(real_block_node_type), POINTER :: block_node_ca,block_node_cb
@ -913,7 +863,7 @@ CONTAINS
! *** Get the number of operator atoms ***
CALL get_neighbor_list_set_info(neighbor_list_set=&
vprj_ppnl_ca_neighbor_list_set,&
vppnl_ca_neighbor_list_set,&
nlist=natom_prj_ppnl)
! *** Prepare the allocation of the projector (ppnl) overlap matrix ***
@ -924,7 +874,7 @@ CONTAINS
iatom_prj_ppnl = 0
nprj_ppnl = 0
neighbor_list => first_neighbor_list(vprj_ppnl_ca_neighbor_list_set)
neighbor_list => first_neighbor_list(vppnl_ca_neighbor_list_set)
DO WHILE (ASSOCIATED(neighbor_list))
iatom_prj_ppnl = iatom_prj_ppnl + 1
@ -967,7 +917,7 @@ CONTAINS
iatom_prj_ppnl = 0
neighbor_list => first_neighbor_list(vprj_ppnl_ca_neighbor_list_set)
neighbor_list => first_neighbor_list(vppnl_ca_neighbor_list_set)
DO WHILE (ASSOCIATED(neighbor_list))
@ -981,7 +931,7 @@ CONTAINS
CALL extract_neighbor_list(neighbor_list,r2,neighbors,r,cell)
kkind = atom_info(katom)%kind
rprjc(1) = kind_info(kkind)%gth_potential%prj_ppnl_radius
rprjc(1) = kind_info(kkind)%gth_potential%ppnl_radius
! *** Loop over all neighbor atoms of the current operator atom "katom" ***
@ -1026,7 +976,7 @@ CONTAINS
lc_max = l + 2*(kind_info(kkind)%gth_potential%nprj_ppnl(l) - 1)
lc_min = l
zetc(1) = kind_info(kkind)%gth_potential%alpha_prj_ppnl(l)
zetc(1) = kind_info(kkind)%gth_potential%alpha_ppnl(l)
ncoc = ncoset(lc_max)
DO iset=1,nseta
@ -1224,7 +1174,7 @@ CONTAINS
END IF
END IF
END SUBROUTINE add_prj_ppnl_matrix
END SUBROUTINE add_ppnl_matrix
! *****************************************************************************

47
src/cp2k.F
View file

@ -41,7 +41,7 @@
!------------------------------------------------------------------------------
PROGRAM cp2k
USE atom_module,ONLY : atomic_code
USE control_module, ONLY : control
USE cp2k_input, ONLY : read_cp2k_section
@ -51,30 +51,26 @@ PROGRAM cp2k
USE library_tests,ONLY : lib_test
USE parallel, ONLY : start_parallel, end_parallel
USE physcon, ONLY : write_physcon
USE qs_main, ONLY : quickstep
USE termination, ONLY: stop_program
USE core_hamiltonian, ONLY: build_core_hamiltonian_matrix
USE nl, ONLY: build_neighbor_list_sets
USE readin, ONLY: read_files
USE start_program_run, ONLY: start_qs_program_run
IMPLICIT NONE
TYPE ( global_environment_type ) :: globenv
!------------------------------------------------------------------------------
CALL start_parallel ( globenv )
CALL initialisation ( globenv )
CALL read_cp2k_section ( globenv )
IF ( globenv % ionode .AND. globenv % print_level > 9 ) &
CALL print_kind_info ( globenv % scr )
IF ( globenv % ionode .AND. globenv % print_level > 4 ) &
CALL write_physcon ( globenv % scr )
SELECT CASE ( globenv % program_name )
CASE DEFAULT
@ -85,25 +81,10 @@ PROGRAM cp2k
CASE ( "FIST", "TBMD", "WAVE" )
CALL control ( globenv )
CASE ( "QUICKSTEP", "QS" )
! *** Initialize the Quickstep program run ***
CALL start_qs_program_run(globenv)
! *** Read the input and the database files ***
! *** and perform further initializations ***
CALL read_files(globenv)
! *** Build neighbor list sets ***
CALL build_neighbor_list_sets(globenv)
! *** Calculate the core Hamiltonian integral matrix ***
CALL build_core_hamiltonian_matrix(globenv)
CALL quickstep ( globenv )
CASE ( "ATOM" )
@ -114,11 +95,11 @@ PROGRAM cp2k
CALL lib_test ( globenv )
END SELECT
CALL end_parallel ( )
CALL trailer ( globenv )
!------------------------------------------------------------------------------
END PROGRAM cp2k

16
src/cp2k_input.F
View file

@ -23,7 +23,7 @@ MODULE cp2k_input
USE kinds, ONLY : dbl
USE fft_tools, ONLY : init_fft
USE fft_tools, ONLY : init_fft, fft3d
USE global_types, ONLY : global_environment_type
USE message_passing, ONLY : mp_bcast
USE parser, ONLY : parser_init, parser_end, read_line, test_next, &
@ -76,7 +76,8 @@ SUBROUTINE read_cp2k_section ( globenv )
TYPE ( global_environment_type ), INTENT ( INOUT ) :: globenv
! Locals
INTEGER :: ierror, ilen, iw, source, allgrp, i1, i2
INTEGER :: ierror, ilen, iw, source, allgrp, i1, i2, n(3), stat
COMPLEX ( dbl ) :: zz(4,4,4)
CHARACTER ( LEN = 6 ) :: string
CHARACTER ( LEN = 5 ) :: label
@ -140,8 +141,15 @@ SUBROUTINE read_cp2k_section ( globenv )
! initialize FFT library
CALL xstring ( globenv % default_fft_library, i1, i2 )
CALL init_fft ( fftlib = globenv % default_fft_library ( i1:i2 ) )
! test for FFT library
n = 4
zz = 0._dbl
CALL fft3d ( 1, n, zz, status=stat )
IF ( stat /= 0 .AND. globenv % ionode ) THEN
CALL stop_program ( "read_cp2k_section", &
"Default FFT library not available" )
END IF
!
IF ( globenv % ionode ) THEN
! ..write some information to output
WRITE ( iw, '( A, T41, A )' ) ' CP2K| Program name ', &

4
src/dft_structure_control.F
View file

@ -64,7 +64,7 @@ CONTAINS
!******************************************************************************
SUBROUTINE dft_force_control ( molecule, pnode, part, box, thermo, &
potparm, ewald_param, ensemble, lldata, dft_control, kp, &
potparm, ewald_param, box_change, lldata, dft_control, kp, &
dftpar, wavepar )
IMPLICIT NONE
@ -77,7 +77,7 @@ SUBROUTINE dft_force_control ( molecule, pnode, part, box, thermo, &
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
LOGICAL, INTENT ( IN ) :: box_change
TYPE ( linklist_internal_data_type), INTENT (INOUT) :: lldata
TYPE ( global_environment_type ), INTENT ( IN ) :: dftpar, wavepar
TYPE ( dft_control_type ), INTENT ( IN ) :: dft_control

3
src/dg_rho0s.F
View file

@ -70,8 +70,7 @@ SUBROUTINE dg_rho0_setup ( dg_rho0, pw_grid )
CALL coeff_allocate ( dg_rho0 % density, pw_grid, PW_REALDATA3D )
CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 ) )
CASE ( "SPME" )
CALL coeff_allocate ( dg_rho0 % density, pw_grid, PW_REALDATA3D )
CALL dg_rho0_pme_gauss ( dg_rho0 % density, dg_rho0 % zet ( 1 ) )
CALL stop_program ( 'dg_rho0_setup', 'type not implemented' )
CASE DEFAULT
CALL stop_program ( 'dg_rho0_setup', 'type not implemented' )
END SELECT

982
src/dgs.F
View file

File diff suppressed because it is too large Load diff

314
src/diis.F Normal file
View file

@ -0,0 +1,314 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/diis [1.0] *
!!
!! NAME
!! diis
!!
!! FUNCTION
!! Perform a direct inversion in the iterative subspace (DIIS).
!!
!! AUTHOR
!! Matthias Krack (28.06.2000)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE diis
USE kinds, ONLY: wp => dp
USE core_hamiltonian, ONLY: s
USE global_types, ONLY: global_environment_type
USE mathlib, ONLY: diagonalize_matrix,&
symmetrize_matrix
USE matrix_types, ONLY: allocate_matrix,&
copy_matrix,&
get_block_node,&
get_matrix_info,&
real_matrix_set_type
USE memory_utilities, ONLY: reallocate
USE mo_types, ONLY: mo_set_type
USE timings, ONLY: timeset,timestop
IMPLICIT NONE
PRIVATE
TYPE diis_buffer_type
PRIVATE
INTEGER :: nbuffer,ncall
TYPE(real_matrix_set_type), DIMENSION(:), POINTER :: error,parameter
REAL(wp), DIMENSION(:,:), POINTER :: b_matrix
END TYPE diis_buffer_type
TYPE(diis_buffer_type) :: scf_diis_buffer
REAL(wp) :: eps_diis = 0.1_wp
INTEGER :: max_diis = 4
LOGICAL :: init_scf_diis_buffer_done = .FALSE.
! *** Public variables ***
PUBLIC :: eps_diis,max_diis
! *** Public subroutines ***
PUBLIC :: scf_diis
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE allocate_scf_diis_buffer(nbuffer,nao)
! Purpose: Allocate and initialize a DIIS buffer for "nao*nao" parameter
! variables and with a buffer size of "nbuffer".
! History: - Creation (07.05.2001, Matthias Krack)
! ***************************************************************************
INTEGER, INTENT(IN) :: nbuffer,nao
! *** Local variables ***
INTEGER :: ibuffer
! ---------------------------------------------------------------------------
scf_diis_buffer%nbuffer = nbuffer
scf_diis_buffer%ncall = 0
ALLOCATE (scf_diis_buffer%error(nbuffer))
ALLOCATE (scf_diis_buffer%parameter(nbuffer))
DO ibuffer=1,nbuffer
NULLIFY (scf_diis_buffer%error(ibuffer)%matrix)
CALL allocate_matrix(matrix=scf_diis_buffer%error(ibuffer)%matrix,&
nrow=nao,&
ncol=nao,&
matrix_name="SCF DIIS ERROR MATRIX",&
matrix_symmetry="symmetric")
NULLIFY (scf_diis_buffer%parameter(ibuffer)%matrix)
CALL allocate_matrix(matrix=scf_diis_buffer%parameter(ibuffer)%matrix,&
nrow=nao,&
ncol=nao,&
matrix_name="SCF DIIS PARAMETER MATRIX",&
matrix_symmetry="symmetric")
END DO
NULLIFY (scf_diis_buffer%b_matrix)
scf_diis_buffer%b_matrix => reallocate(scf_diis_buffer%b_matrix,&
1,nbuffer+1,&
1,nbuffer+1)
init_scf_diis_buffer_done = .TRUE.
END SUBROUTINE allocate_scf_diis_buffer
! *****************************************************************************
SUBROUTINE scf_diis(globenv,c,kc,sc,delta,error_max,diis_step)
! Purpose: Update the SCF DIIS buffer.
! History: - Creation (07.05.2001, Matthias Krack)
! ***************************************************************************
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(mo_set_type), INTENT(IN) :: c
TYPE(real_matrix_set_type), INTENT(INOUT) :: kc,sc
REAL(wp), INTENT(IN) :: delta
REAL(wp), INTENT(OUT) :: error_max
LOGICAL, INTENT(OUT) :: diis_step
! *** Local variables ***
INTEGER :: handle,ib,jb,nao,nb,nb1,nmo,nparameter,output_unit
REAL(wp), DIMENSION(:), POINTER :: ev
REAL(wp), DIMENSION(:,:), POINTER :: a,b,c_matrix,kc_matrix,&
new_error_matrix,old_error_matrix,&
parameter_matrix,sc_matrix
! ---------------------------------------------------------------------------
CALL timeset("scf_diis","I","",handle)
diis_step = .FALSE.
! *** Quick return, if no DIIS is requested ***
IF (max_diis < 1) RETURN
output_unit= globenv%scr
CALL get_matrix_info(matrix=c%eigenvectors%matrix,nrow=nao)
nmo = c%homo
nparameter = nao*nao
IF (.NOT.init_scf_diis_buffer_done) THEN
CALL allocate_scf_diis_buffer(max_diis,nao)
IF (globenv%print%diis_information) THEN
WRITE (UNIT=output_unit,FMT="(/,T2,A)")&
"The SCF DIIS buffer was allocated and initialised"
END IF
END IF
ib = MODULO(scf_diis_buffer%ncall,scf_diis_buffer%nbuffer) + 1
scf_diis_buffer%ncall = scf_diis_buffer%ncall + 1
nb = MIN(scf_diis_buffer%ncall,scf_diis_buffer%nbuffer)
CALL get_block_node(matrix=scf_diis_buffer%parameter(ib)%matrix,&
block_row=1,&
block_col=1,&
block=parameter_matrix)
CALL get_block_node(matrix=scf_diis_buffer%error(ib)%matrix,&
block_row=1,&
block_col=1,&
block=new_error_matrix)
CALL get_block_node(matrix=c%eigenvectors%matrix,&
block_row=1,&
block_col=1,&
block=c_matrix)
CALL get_block_node(matrix=kc%matrix,&
block_row=1,&
block_col=1,&
block=kc_matrix)
CALL get_block_node(matrix=sc%matrix,&
block_row=1,&
block_col=1,&
block=sc_matrix)
parameter_matrix(:,:) = kc_matrix(:,:)
new_error_matrix(:,:) = 0.0_wp
CALL copy_matrix(s%matrix,scf_diis_buffer%error(ib)%matrix)
CALL symmetrize_matrix(new_error_matrix,"upper_to_lower")
CALL dgemm("T","N",nao,nmo,nao,2.0_wp,parameter_matrix,nao,c_matrix,nao,&
0.0_wp,kc_matrix,nao)
CALL dgemm("T","N",nao,nmo,nao,2.0_wp,new_error_matrix,nao,c_matrix,nao,&
0.0_wp,sc_matrix,nao)
CALL dgemm("N","T",nao,nao,nmo,1.0_wp,sc_matrix,nao,kc_matrix,nao,0.0_wp,&
new_error_matrix,nao)
CALL dgemm("N","T",nao,nao,nmo,1.0_wp,kc_matrix,nao,sc_matrix,nao,-1.0_wp,&
new_error_matrix,nao)
! *** Get maximum error ***
error_max = MAXVAL(ABS(new_error_matrix))
IF (globenv%print%diis_information) THEN
WRITE (UNIT=output_unit,FMT="(/,T2,A,E12.3)")&
"Maximum SCF DIIS error vector element:",error_max
END IF
! *** Check, if a DIIS step is appropiate ***
diis_step = ((scf_diis_buffer%ncall > 1).AND.(delta < eps_diis))
! *** Update the SCF DIIS buffer ***
IF (error_max < eps_diis) THEN
DO jb=1,nb
CALL get_block_node(matrix=scf_diis_buffer%error(jb)%matrix,&
block_row=1,&
block_col=1,&
block=old_error_matrix)
CALL dgemm("T","N",1,1,nparameter,1.0_wp,old_error_matrix,nparameter,&
new_error_matrix,nparameter,0.0_wp,&
scf_diis_buffer%b_matrix(jb,ib),&
SIZE(scf_diis_buffer%b_matrix,1))
scf_diis_buffer%b_matrix(ib,jb) = scf_diis_buffer%b_matrix(jb,ib)
END DO
IF (globenv%print%diis_information) THEN
WRITE (UNIT=output_unit,FMT="(/,T2,A)")&
"The SCF DIIS buffer was updated"
END IF
ELSE
diis_step = .FALSE.
END IF
! *** Perform DIIS update ***
IF (diis_step) THEN
nb1 = nb + 1
NULLIFY (a,b,ev)
a => reallocate(a,1,nb1,1,nb1)
b => reallocate(b,1,nb1,1,nb1)
ev => reallocate(ev,1,nb1)
! *** Set up the linear DIIS equation system ***
b(1:nb,1:nb) = scf_diis_buffer%b_matrix(1:nb,1:nb)
b(1:nb,nb1) = -1.0_wp
b(nb1,1:nb) = -1.0_wp
b(nb1,nb1) = 0.0_wp
! *** Solve the linear DIIS equation system ***
CALL diagonalize_matrix(b(1:nb1,1:nb1),ev(1:nb1))
a(1:nb1,1:nb1) = b(1:nb1,1:nb1)
DO jb=1,nb1
IF (ABS(ev(jb)) < 1.0E-12_wp) THEN
a(1:nb1,jb) = 0.0_wp
ELSE
a(1:nb1,jb) = a(1:nb1,jb)/ev(jb)
END IF
END DO
ev(1:nb) = MATMUL(a(1:nb,1:nb1),b(nb1,1:nb1))
! *** Update Kohn-Sham matrix ***
kc_matrix(:,:) = 0.0_wp
DO jb=1,nb
CALL get_block_node(matrix=scf_diis_buffer%parameter(jb)%matrix,&
block_row=1,&
block_col=1,&
block=parameter_matrix)
kc_matrix(:,:) = kc_matrix(:,:) - ev(jb)*parameter_matrix(:,:)
END DO
DEALLOCATE (a,b,ev)
ELSE
kc_matrix(:,:) = parameter_matrix(:,:)
END IF
CALL timestop(0.0_wp,handle)
END SUBROUTINE scf_diis
! *****************************************************************************
END MODULE diis

150
src/dump.F
View file

@ -25,6 +25,7 @@ MODULE dump
USE nose, ONLY : lnhc_parameters_type, npt_info_type
USE structure_types, ONLY : structure_type
USE util, ONLY : get_unit
USE string_utilities, ONLY : xstring, integer_to_string
PRIVATE
PUBLIC :: dump_variables
@ -51,104 +52,119 @@ CONTAINS
!******************************************************************************
SUBROUTINE dump_variables ( struc, nhc_part, nhc_baro, npt_info, &
dump_file_name, globenv )
dump_file_name, globenv, is_pimd )
! routine to dump all simulation variables periodically and at the last step.
IMPLICIT NONE
! Arguments
TYPE ( structure_type ), INTENT ( IN ) :: struc
TYPE ( structure_type ), DIMENSION ( : ), INTENT ( IN ) :: struc
CHARACTER ( LEN = * ), INTENT ( IN ) :: dump_file_name
TYPE ( global_environment_type ), INTENT ( IN ) :: globenv
TYPE ( lnhc_parameters_type ), INTENT ( IN ) :: nhc_part, nhc_baro
TYPE ( lnhc_parameters_type ), DIMENSION ( : ), INTENT ( IN ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), DIMENSION ( :, : ), INTENT ( IN ) :: npt_info
LOGICAL, INTENT ( IN ) :: is_pimd
! Locals
INTEGER :: i, j, size1, size2, natoms, dmp
INTEGER :: i, j, size1, size2, natoms, dmp, ibead, beads, ia, ib
CHARACTER ( LEN = 80 ) :: file_name
CHARACTER ( LEN = 5 ) :: tag
!------------------------------------------------------------------------------
IF ( globenv % ionode ) THEN
dmp = get_unit()
OPEN ( UNIT = dmp, FILE = dump_file_name, STATUS = 'unknown', &
POSITION = 'rewind' )
END IF
beads = SIZE ( struc )
IF (globenv % ionode) THEN
natoms = size(struc % part)
WRITE (dmp,*) natoms
DO ibead = 1, beads
IF ( globenv % ionode ) THEN
dmp = get_unit()
IF ( is_pimd ) THEN
CALL xstring ( dump_file_name, ia, ib )
CALL integer_to_string ( ibead, tag )
file_name = dump_file_name(ia:ib) // '_' // ADJUSTL(tag)
OPEN ( UNIT = dmp, FILE = file_name, STATUS = 'unknown', &
POSITION = 'rewind' )
ELSE
OPEN ( UNIT = dmp, FILE = dump_file_name, STATUS = 'unknown', &
POSITION = 'rewind' )
END IF
END IF
IF (globenv % ionode) THEN
natoms = size(struc(ibead) % part)
WRITE (dmp,*) natoms
! position
DO i = 1, natoms
WRITE (dmp,*) struc % part(i) %r
END DO
DO i = 1, natoms
WRITE (dmp,*) struc(ibead) % part(i) %r
END DO
! hmat
DO i = 1, 3
WRITE (dmp,*) struc % box % hmat(i,:)
END DO
DO i = 1, 3
WRITE (dmp,*) struc(ibead) % box % hmat(i,:)
END DO
! hmat_ref
DO i = 1, 3
WRITE (dmp,*) struc % box_ref % hmat(i,:)
END DO
DO i = 1, 3
WRITE (dmp,*) struc(ibead) % box_ref % hmat(i,:)
END DO
! velocities
DO i = 1, natoms
WRITE (dmp,*) struc % part(i) % v
END DO
DO i = 1, natoms
WRITE (dmp,*) struc(ibead) % part(i) % v
END DO
! particle thermostat postions, velocities, masses
size1 = SIZE ( nhc_part % nvt, 1 )
size2 = SIZE ( nhc_part % nvt, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part % nvt ( i, j ) % eta
size1 = SIZE ( nhc_part(ibead) % nvt, 1 )
size2 = SIZE ( nhc_part(ibead) % nvt, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part(ibead) % nvt ( i, j ) % eta
ENDDO
ENDDO
ENDDO
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part % nvt ( i, j ) % v
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part(ibead) % nvt ( i, j ) % v
ENDDO
ENDDO
ENDDO
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part % nvt ( i, j ) % mass
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_part(ibead) % nvt ( i, j ) % mass
ENDDO
ENDDO
ENDDO
! barostat thermostat postions, velocities, masses
size1 = SIZE ( nhc_baro % nvt, 1 )
size2 = SIZE ( nhc_baro % nvt, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro % nvt ( i, j ) % eta
size1 = SIZE ( nhc_baro(ibead) % nvt, 1 )
size2 = SIZE ( nhc_baro(ibead) % nvt, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro(ibead) % nvt ( i, j ) % eta
ENDDO
ENDDO
ENDDO
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro % nvt ( i, j ) % v
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro(ibead) % nvt ( i, j ) % v
ENDDO
ENDDO
ENDDO
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro % nvt ( i, j ) % mass
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) nhc_baro(ibead) % nvt ( i, j ) % mass
ENDDO
ENDDO
ENDDO
! barostat velocities, masses
size1 = SIZE ( npt_info, 1 )
size2 = SIZE ( npt_info, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) npt_info ( i, j ) % v
size1 = SIZE ( npt_info, 1 )
size2 = SIZE ( npt_info, 2 )
WRITE ( dmp, * ) size1, size2
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) npt_info ( i, j ) % v
ENDDO
ENDDO
ENDDO
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) npt_info ( i, j ) % mass
DO i = 1, size1
DO j = 1, size2
WRITE ( dmp, * ) npt_info ( i, j ) % mass
ENDDO
ENDDO
ENDDO
CLOSE (dmp)
END IF
CLOSE (dmp)
END IF
END DO
END SUBROUTINE dump_variables

277
src/eigenvalueproblems.F
View file

@ -8,11 +8,13 @@
!! eigenvalueproblems
!!
!! FUNCTION
!! Provides interfaces to LAPACK eigenvalue/SVD routines
!!
!! AUTHOR
!! APSI
!!
!! MODIFICATION HISTORY
!! none
!! JGH (26-5-2001): delay D/S C/Z problem to the lapack library call
!!
!! NOTES
!! We are using LAPACK interfaces, so please make sure in IBM/AIX you have
@ -24,25 +26,28 @@
MODULE eigenvalueproblems
USE kinds, ONLY : dbl
USE lapack, ONLY : lapack_ssyev, lapack_chpev, lapack_chpgv
USE lapack, ONLY : lapack_ssyev, lapack_chpev, lapack_sspgv, lapack_chpgv, &
lapack_sgesvd, lapack_cgesvd
USE termination, ONLY : stop_program
IMPLICIT NONE
PRIVATE
PUBLIC :: diagonalise, diagonalise_overlap
PUBLIC :: diagonalise, diagonalise_general_packed, singular_values
INTERFACE diagonalise
MODULE PROCEDURE diagonalise_ssyev
MODULE PROCEDURE diagonalise_dsyev
MODULE PROCEDURE diagonalise_chpev
MODULE PROCEDURE diagonalise_zhpev
END INTERFACE
INTERFACE diagonalise_overlap
INTERFACE diagonalise_general_packed
MODULE PROCEDURE diagonalise_sspgv
MODULE PROCEDURE diagonalise_chpgv
MODULE PROCEDURE diagonalise_zhpgv
END INTERFACE
INTERFACE singular_values
MODULE PROCEDURE cp2k_sgesvd
MODULE PROCEDURE cp2k_cgesvd
END INTERFACE
!!*****
@ -60,16 +65,16 @@ SUBROUTINE diagonalise_ssyev ( matrix, mysize, storageform, eigenvalues, &
! 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 ( :, : )
REAL ( KIND = dbl ), INTENT ( IN ) :: matrix ( :, : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: eigenvalues ( : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: eigenvectors ( :, : )
! Local
CHARACTER :: jobz = "V", uplo
INTEGER :: info, itype
INTEGER :: lwork, lda
REAL ( KIND = 4 ) :: work ( 3 * mysize - 1 )
REAL ( KIND = dbl ) :: work ( 3 * mysize - 1 )
!------------------------------------------------------------------------------
@ -88,7 +93,6 @@ SUBROUTINE diagonalise_ssyev ( matrix, mysize, storageform, eigenvalues, &
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, &
@ -101,55 +105,6 @@ 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_program ( "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_program ( "diagonalise_dsyev", "error in diagonalisation" )
END IF
END SUBROUTINE diagonalise_dsyev
!******************************************************************************
SUBROUTINE diagonalise_chpev ( matrix, mysize, storageform, eigenvalues, &
eigenvectors )
@ -158,16 +113,16 @@ SUBROUTINE diagonalise_chpev ( matrix, mysize, storageform, eigenvalues, &
! 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 ( : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: eigenvalues ( : )
COMPLEX ( KIND = dbl ), INTENT ( OUT ) :: eigenvectors ( :, : )
COMPLEX ( KIND = dbl ), 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 )
REAL ( KIND = dbl ) :: rwork ( 3 * mysize - 2 )
COMPLEX ( KIND = dbl ) :: work ( 2 * mysize - 1 )
!------------------------------------------------------------------------------
@ -193,66 +148,22 @@ END SUBROUTINE diagonalise_chpev
!******************************************************************************
SUBROUTINE diagonalise_zhpev ( matrix, mysize, storageform, eigenvalues, &
eigenvectors )
SUBROUTINE diagonalise_sspgv ( matrix, overlap, mysize, type, 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_program ( "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_program ( "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 ( : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: eigenvalues ( : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: eigenvectors ( :, : )
REAL ( KIND = dbl ), 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 )
INTEGER :: info
REAL ( kind = dbl ) :: work ( 2 * mysize - 1 )
!----------------------------------------------------------------------
@ -265,7 +176,49 @@ SUBROUTINE diagonalise_chpgv ( matrix, overlap, mysize, type, storageform, &
storageform ( 1:5 ) == "UPPER" ) then
uplo = "U"
ELSE
CALL stop_program ( "diagonalise_chpev", "unknown form of storage" )
CALL stop_program ( "diagonalise_sspgv", "unknown form of storage" )
END IF
CALL lapack_sspgv ( type, jobz, uplo, mysize, matrix, overlap, eigenvalues, &
eigenvectors, mysize, work, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "diagonalise_sspgv", "error in diagonalisation" )
END IF
END SUBROUTINE diagonalise_sspgv
!******************************************************************************
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 = dbl ), INTENT ( OUT ) :: eigenvalues ( : )
COMPLEX ( KIND = dbl ), INTENT ( OUT ) :: eigenvectors ( :, : )
COMPLEX ( KIND = dbl ), INTENT ( INOUT ) :: matrix ( : ), overlap ( : )
! Local
CHARACTER :: jobz = "V", uplo
INTEGER :: info
REAL ( kind = dbl ) :: rwork ( 3 * mysize - 2 )
COMPLEX ( kind = dbl ) :: 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_program ( "diagonalise_chpgv", "unknown form of storage" )
END IF
CALL lapack_chpgv ( type, jobz, uplo, mysize, matrix, overlap, eigenvalues, &
@ -278,45 +231,75 @@ END SUBROUTINE diagonalise_chpgv
!******************************************************************************
SUBROUTINE diagonalise_zhpgv ( matrix, overlap, mysize, type, storageform, &
eigenvalues, eigenvectors )
SUBROUTINE cp2k_sgesvd ( matrix, svalues, mrow, ncol, uvec, vtvec )
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 ( : )
INTEGER, INTENT ( IN ) :: mrow, ncol
REAL ( KIND = dbl ), INTENT ( IN ) :: matrix ( :, : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: svalues ( : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: uvec ( :, : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: vtvec ( :, : )
! Local
CHARACTER :: jobz = "V", uplo
INTEGER :: info
REAL ( KIND = 8 ) :: rwork ( 3 * mysize - 2 )
COMPLEX ( KIND = 8 ) :: work ( 2 * mysize - 1 )
CHARACTER, PARAMETER :: jobu = "A", jobvt = "A"
INTEGER :: lda, ldu, ldvt, lwork, info
REAL ( kind = dbl ) :: work ( 25 * ( mrow + ncol ) )
!------------------------------------------------------------------------------
!----------------------------------------------------------------------
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_program ( "diagonalise_chpev", "unknown form of storage" )
END IF
lwork = 25 * ( mrow + ncol )
lda = SIZE ( matrix, 1 )
ldu = SIZE ( uvec, 1 )
ldvt = SIZE ( vtvec, 1 )
CALL lapack_chpgv ( type, jobz, uplo, mysize, matrix, overlap, eigenvalues, &
eigenvectors, mysize, work, rwork, info )
CALL lapack_sgesvd( jobu, jobvt, mrow, ncol, matrix, lda, svalues, &
uvec, ldu, vtvec, ldvt, work, lwork, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "diagonalise_zhpgv", "error in diagonalisation" )
CALL stop_program ( "cp2k_sgesvd", &
"error in singular value decomposition" )
END IF
END SUBROUTINE diagonalise_zhpgv
END SUBROUTINE cp2k_sgesvd
!******************************************************************************
SUBROUTINE cp2k_cgesvd ( matrix, svalues, mrow, ncol, uvec, vtvec )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: mrow, ncol
COMPLEX ( KIND = dbl ), INTENT ( IN ) :: matrix ( :, : )
REAL ( KIND = dbl ), INTENT ( OUT ) :: svalues ( : )
COMPLEX ( KIND = dbl ), INTENT ( OUT ) :: uvec ( :, : )
COMPLEX ( KIND = dbl ), INTENT ( OUT ) :: vtvec ( :, : )
! Local
CHARACTER, PARAMETER :: jobu = "A", jobvt = "A"
INTEGER :: lda, ldu, ldvt, lwork, info
REAL ( kind = dbl ) :: rwork ( 25 * ( mrow + ncol ) )
COMPLEX ( kind = dbl ) :: work ( 25 * ( mrow + ncol ) )
!----------------------------------------------------------------------
lwork = 25 * ( mrow + ncol )
lda = SIZE ( matrix, 1 )
ldu = SIZE ( uvec, 1 )
ldvt = SIZE ( vtvec, 1 )
CALL lapack_cgesvd( jobu, jobvt, mrow, ncol, matrix, lda, svalues, &
uvec, ldu, vtvec, ldvt, work, lwork, rwork, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "cp2k_cgesvd", &
"error in singular value decomposition" )
END IF
END SUBROUTINE cp2k_cgesvd
!******************************************************************************
END MODULE eigenvalueproblems
!******************************************************************************

2
src/ewald_parameters_types.F
View file

@ -32,7 +32,7 @@ MODULE ewald_parameters_types
INTEGER :: ns_max ! # grid points for small grid (PME)
INTEGER :: o_spline ! order of spline (SPME)
INTEGER :: gtot ! total number of g-vectors
INTEGER :: ewald_grp ! parallel group
INTEGER :: group ! parallel group
END TYPE ewald_parameters_type
PRIVATE

138
src/ewalds.F
View file

@ -12,7 +12,8 @@
!! AUTHOR
!!
!! MODIFICATION HISTORY
!! none
!! JGH (15-Mar-2001) : New routine ewald_setup (former pme_setup)
!! JGH (23-Mar-2001) : Get rid of global variable ewald_grp
!!
!! SOURCE
!******************************************************************************
@ -22,6 +23,7 @@ MODULE ewalds
USE coefficient_types, ONLY : coeff_type
USE dgs, ONLY : dg_grid_setup
USE dg_types, ONLY : dg_type
USE dg_rho0s, ONLY : dg_rho0_setup
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE global_types, ONLY : global_environment_type
USE kinds, ONLY : dbl
@ -30,9 +32,10 @@ MODULE ewalds
USE molecule_types, ONLY : particle_node_type
USE message_passing, ONLY : mp_sum
USE particle_types, ONLY : particle_type
USE pme, ONLY : pme_setup
USE particle_lists, ONLY : particle_list_select
USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE
USE pw_grids, ONLY : pw_find_cutoff, pw_grid_setup, pw_grid_construct
USE realspace_grid_types, ONLY : realspace_grid_type, rs_grid_setup
USE simulation_cell, ONLY : cell_type
USE structure_factor_types, ONLY : structure_factor_type
USE structure_factors, ONLY : structure_factor_evaluate, &
@ -45,21 +48,19 @@ MODULE ewalds
IMPLICIT NONE
PRIVATE
PUBLIC :: ewald_gaussian, ewald_correction, ewald_self
PUBLIC :: ewald_evaluate, ewald_correction, ewald_self, ewald_setup
PUBLIC :: ewald_print, ewald_initialize
INTEGER :: ewald_grp
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** ewalds/ewald_gaussian [1.0] *
!!****** ewalds/ewald_evaluate [1.0] *
!!
!! NAME
!! ewald_gaussian
!! ewald_evaluate
!!
!! FUNCTION
!! computes the potential and the force from the g-space part of
@ -73,11 +74,12 @@ CONTAINS
!! MODIFICATION HISTORY
!! JGH (28-Feb-2001) : added fft_usage flag to pw_grid_setup and calls to
!! pw_grid_construct
!! JGH (21-Feb-2001) : changed name
!!
!! SOURCE
!******************************************************************************
SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, &
SUBROUTINE ewald_evaluate (dg, ewald_param, fg_coulomb, vg_coulomb, &
pv_g, pnode, box )
IMPLICIT NONE
@ -166,7 +168,7 @@ SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, &
+ pw_grid % ngpts_cut * nnodes * 20.0_dbl
#if defined(__parallel)
CALL mp_sum ( summe, ewald_grp )
CALL mp_sum ( summe, ewald_param % group )
#endif
! looping over the positive g-vectors
@ -214,7 +216,7 @@ SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, &
pv_g(2,3) = pv_g(2,3) - common * &
( 2.0_dbl * pw_grid % g ( 2, gpt ) * pw_grid % g ( 3, gpt ) * denom )
pv_g(3,1) = pv_g(3,1) - common * &
( 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 1, gpt ) * denom)
( 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 1, gpt ) * denom )
pv_g(3,2) = pv_g(3,2) - common * &
( 2.0_dbl * pw_grid % g ( 3, gpt ) * pw_grid % g ( 2, gpt ) * denom )
pv_g(3,3) = pv_g(3,3) + common * ( 1.0_dbl &
@ -224,7 +226,7 @@ SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, &
flops = flops + pw_grid % ngpts_cut * 55.0_dbl &
+ pw_grid % ngpts_cut * nnodes * 23.0_dbl
pref = 1.0_dbl / ( ewald_param % eps0 * box % deth )
pref = 1.0_dbl / ( ewald_param % eps0 * pw_grid % vol )
vg_coulomb = vg_coulomb * pref
pv_g = pv_g * pref
@ -239,7 +241,7 @@ SUBROUTINE ewald_gaussian (dg, ewald_param, fg_coulomb, vg_coulomb, &
flops = flops * 1.0E-6_dbl
CALL timestop ( flops, handle )
END SUBROUTINE ewald_gaussian
END SUBROUTINE ewald_evaluate
!!*****
!******************************************************************************
@ -284,12 +286,13 @@ SUBROUTINE ewald_self ( ewald_param, thermo, pnode )
END DO
#if defined(__parallel)
CALL mp_sum(q_self,ewald_grp)
CALL mp_sum(q_sum,ewald_grp)
CALL mp_sum(q_self,ewald_param%group)
CALL mp_sum(q_sum,ewald_param%group)
#endif
IF ( ewald_param % ewald_type == 'EWALD' .OR. &
ewald_param % ewald_type == 'PME' ) THEN
ewald_param % ewald_type == 'PME' .OR. &
ewald_param % ewald_type == 'SPME' ) THEN
thermo % e_self = -q_self * ewald_param % alpha &
/ ( 4.0_dbl * ewald_param % eps0 * pi * SQRT ( pi ) )
@ -408,7 +411,9 @@ END SUBROUTINE ewald_print
!! CJM
!!
!! MODIFICATION HISTORY
!! JGH (12-01-2001): Added SPME part
!! JGH (12-Jan-2001): Added SPME part
!! JGH (15-Mar-2001): Work newly distributed between initialize, setup,
!! and force routine
!!
!! SOURCE
!******************************************************************************
@ -424,7 +429,7 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode
TYPE ( global_environment_type ), INTENT ( IN ) :: pnode_grp
TYPE ( cell_type ), INTENT ( IN ) :: box
TYPE ( cell_type ), INTENT ( INOUT ) :: 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
@ -433,14 +438,16 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
! Locals
INTEGER :: natoms, iat, jat, gmax, npts_s ( 3 ), iw
REAL ( dbl ) :: qi, qj, i, cutoff
REAL ( dbl ) :: i, cutoff, ecut
TYPE ( realspace_grid_type ) :: rs
!------------------------------------------------------------------------------
! 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 % group
! This holds only for normal Ewald sums!
! For the grid based methods, G-Space/Real Space are distributed differently
ewald_param % group = pnode_grp % group
natoms = SIZE ( part )
@ -466,7 +473,7 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
WRITE ( iw, '( A,T71,I10 )' ) &
' Ewald| G-space max. Miller index', ewald_param % gmax
WRITE ( iw, '( A,T71,I10 )' ) &
' EWALD| Spline interpolation order ', ewald_param % o_spline
' Ewald| Spline interpolation order ', ewald_param % o_spline
END SELECT
ELSE
@ -486,7 +493,7 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
CALL ewald_self ( ewald_param, thermo, pnode )
IF ( PRESENT ( ewald_grid ) ) THEN
! set up EWALD
! set up EWALD "Classic"
CALL pw_grid_construct( ewald_grid )
gmax = ewald_param % gmax
IF ( gmax == 2 * ( gmax / 2 ) ) THEN
@ -500,13 +507,12 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
CALL pw_find_cutoff ( npts_s, box, cutoff )
CALL pw_grid_setup( box, ewald_grid, cutoff = cutoff, &
ecut = 0.5_dbl * cutoff * cutoff
CALL pw_grid_setup( box, ewald_grid, cutoff = ecut, &
info = iw, fft_usage = .FALSE. )
CALL pme_setup (pnode, ewald_grid, ewald_param, dg )
ELSEIF ( PRESENT ( pme_small_grid ) .AND. PRESENT ( pme_big_grid ) ) THEN
! set up PME
! set up PME, the double grid method
CALL pw_grid_construct( pme_small_grid )
CALL pw_grid_construct( pme_big_grid )
@ -516,7 +522,11 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
ewald_param % alpha, pme_small_grid, &
pme_big_grid, ewald_param % ewald_type, pnode_grp )
CALL pme_setup (pnode, pme_small_grid, ewald_param, dg )
CALL rs_grid_setup ( rs, pme_big_grid, pme_small_grid % npts, &
pnode_grp % scr )
! set up a list with all particles having a chage
CALL particle_list_select ( pnode, dg % plist, dg % nparts )
IF ( pnode_grp % ionode ) THEN
WRITE ( iw, '( A,T71,E10.4 )' ) &
@ -528,24 +538,25 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
END IF
ELSEIF ( PRESENT ( spme_grid ) ) THEN
! set up SPME
! set up SPME
CALL pw_grid_construct( spme_grid )
gmax = ewald_param % gmax
IF ( gmax == 2 * ( gmax / 2 ) ) THEN
IF ( pnode_grp % ionode ) &
CALL stop_program ( "initialize_ewalds", "gmax has to be odd" )
END IF
spme_grid % bounds ( 1, : ) = -gmax / 2
spme_grid % bounds ( 2, : ) = +gmax / 2
npts_s = (/ gmax, gmax, gmax /)
spme_grid % grid_span = HALFSPACE
CALL pw_find_cutoff ( npts_s, box, cutoff )
spme_grid % grid_span = HALFSPACE
spme_grid % bounds ( 1, : ) = -gmax/2
spme_grid % bounds ( 2, : ) = -gmax/2 + gmax - 1
CALL pw_grid_setup( box, spme_grid, cutoff = cutoff, &
info = pnode_grp % scr, fft_usage = .TRUE. )
ecut = 0.5_dbl * cutoff * cutoff
CALL pw_grid_setup( box, spme_grid, cutoff = ecut, &
pe_group = pnode_grp % group, info = pnode_grp % scr, &
fft_usage = .TRUE. )
CALL pme_setup (pnode, spme_grid, ewald_param, dg )
npts_s ( : ) = ewald_param % o_spline
CALL rs_grid_setup ( rs, spme_grid, npts_s, pnode_grp % scr )
! set up a list with all particles having a chage
CALL particle_list_select ( pnode, dg % plist, dg % nparts )
END IF
@ -553,6 +564,55 @@ SUBROUTINE ewald_initialize ( dg, part, pnode, pnode_grp, ewald_param, box, &
END SUBROUTINE ewald_initialize
!!*****
!******************************************************************************
!!****** ewalds/ewald_setup [1.0] *
!!
!! NAME
!! ewald_setup
!!
!! FUNCTION
!! Calculates the Fourier transform of the "Ewald function"
!!
!! AUTHOR
!! JGH (15-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE ewald_setup ( pw_grid, ewald_param, dg )
IMPLICIT NONE
! Arguments
TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param
TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid
TYPE ( dg_type ), INTENT ( OUT ) :: dg
! Locals
INTEGER :: isos
!------------------------------------------------------------------------------
! This is the first (and only) double grid
dg % grid_index = 1
ALLOCATE ( dg % dg_rho0 % zet (1) , STAT = isos)
IF ( isos /= 0 ) CALL stop_memory ('ewald_setup', 'zet', 0 )
! No contracted Gaussians are used here
NULLIFY ( dg % dg_rho0 % gcc )
dg % dg_rho0 % type = ewald_param % ewald_type
dg % dg_rho0 % zet ( 1 ) = ewald_param % alpha
CALL dg_rho0_setup ( dg % dg_rho0, pw_grid )
END SUBROUTINE ewald_setup
!!*****
!******************************************************************************

70
src/external_potential_types.F
View file

@ -32,10 +32,12 @@ MODULE external_potential_types
! SUBROUTINE init_cprj_ppnl(gth_potential)
! SUBROUTINE init_gth_potential(gth_potential)
! SUBROUTINE init_vprj_ppnl(gth_potential)
! SUBROUTINE read_all_potential(element_symbol,potential_name,alpha_erf,&
! elec_conf,all_potential,globenv)
! SUBROUTINE read_gth_potential(element_symbol,potential_name,alpha_erf,&
! elec_conf,gth_potential,globenv)
! SUBROUTINE read_all_potential(element_symbol,potential_name,&
! alpha_core_charge,elec_conf,zeff,&
! all_potential,globenv)
! SUBROUTINE read_gth_potential(element_symbol,potential_name,&
! alpha_core_charge,elec_conf,zeff,&
! gth_potential,globenv)
! *****************************************************************************
@ -52,7 +54,6 @@ MODULE external_potential_types
TYPE all_potential_type
CHARACTER(LEN=60), DIMENSION(2) :: description
REAL(wp) :: erfc_radius
END TYPE all_potential_type
! *** Define the GTH potential type ***
@ -64,11 +65,11 @@ MODULE external_potential_types
TYPE gth_potential_type
CHARACTER(LEN=60), DIMENSION(3) :: description
REAL(wp) :: alpha_exp_ppl,erf_ppl_radius,&
exp_ppl_radius,prj_ppnl_radius
REAL(wp) :: alpha_ppl,cerf_ppl,ppl_radius,&
ppnl_radius
INTEGER :: lppnl,lprj_ppnl_max,nexp_ppl,&
nppnl,nprj_ppnl_max
REAL(wp), DIMENSION(:), POINTER :: alpha_prj_ppnl,cexp_ppl
REAL(wp), DIMENSION(:), POINTER :: alpha_ppnl,cexp_ppl
INTEGER, DIMENSION(:), POINTER :: elec_conf,nprj_ppnl
REAL(wp), DIMENSION(:,:), POINTER :: cprj,cprj_ppnl,vprj_ppnl
REAL(wp), DIMENSION(:,:,:), POINTER :: hprj_ppnl
@ -184,7 +185,7 @@ CONTAINS
IF (istat /= 0) CALL stop_memory(routine,"gth_potential",0)
NULLIFY (gth_potential%alpha_prj_ppnl)
NULLIFY (gth_potential%alpha_ppnl)
NULLIFY (gth_potential%cexp_ppl)
NULLIFY (gth_potential%elec_conf)
NULLIFY (gth_potential%cprj)
@ -269,8 +270,8 @@ CONTAINS
! *** Deallocate the parameters of the non-local part ***
IF (gth_potential%nppnl > 0) THEN
DEALLOCATE (gth_potential%alpha_prj_ppnl,STAT=istat)
IF (istat /= 0) CALL stop_memory(routine,"gth_potential%alpha_prj_ppnl")
DEALLOCATE (gth_potential%alpha_ppnl,STAT=istat)
IF (istat /= 0) CALL stop_memory(routine,"gth_potential%alpha_ppnl")
DEALLOCATE (gth_potential%cprj,STAT=istat)
IF (istat /= 0) CALL stop_memory(routine,"gth_potential%cprj")
DEALLOCATE (gth_potential%cprj_ppnl,STAT=istat)
@ -308,7 +309,7 @@ CONTAINS
! *** Local variables ***
REAL(wp) :: alpha_prj_ppnl,cp
REAL(wp) :: alpha_ppnl,cp
INTEGER :: cpx,cpy,cpz,cx,cy,cz,ico,iprj,iprj_ppnl,l,lp,lprj_ppnl,nprj,&
px,py,pz
@ -317,12 +318,12 @@ CONTAINS
nprj = 0
DO l=0,gth_potential%lppnl
alpha_prj_ppnl = gth_potential%alpha_prj_ppnl(l)
alpha_ppnl = gth_potential%alpha_ppnl(l)
DO iprj_ppnl=1,gth_potential%nprj_ppnl(l)
lp = iprj_ppnl - 1
lprj_ppnl = l + 2*lp
cp = SQRT(2.0_wp**(2.0_wp*REAL(lprj_ppnl,wp) + 3.5_wp)*&
alpha_prj_ppnl**(REAL(lprj_ppnl,wp) + 1.5_wp)/&
alpha_ppnl**(REAL(lprj_ppnl,wp) + 1.5_wp)/&
(SQRT(pi)*dfac(2*lprj_ppnl + 1)))
gth_potential%cprj_ppnl(iprj_ppnl,l) = cp
DO cx=0,l
@ -426,8 +427,9 @@ CONTAINS
! *****************************************************************************
SUBROUTINE read_all_potential(element_symbol,potential_name,alpha_erf,&
elec_conf,all_potential,globenv)
SUBROUTINE read_all_potential(element_symbol,potential_name,&
alpha_core_charge,elec_conf,zeff,&
all_potential,globenv)
! Purpose: Read an atomic all-electron potential data structure from the
! database file.
@ -449,7 +451,8 @@ CONTAINS
TYPE(all_potential_type), POINTER :: all_potential
TYPE(global_environment_type), INTENT(IN) :: globenv
CHARACTER(LEN=*), INTENT(IN) :: element_symbol,potential_name
REAL(wp), INTENT(OUT) :: alpha_erf
REAL(wp), INTENT(OUT) :: alpha_core_charge
INTEGER, INTENT(OUT) :: zeff
INTEGER, DIMENSION(:), POINTER :: elec_conf
! *** Local parameters ***
@ -506,12 +509,14 @@ CONTAINS
CALL test_object(test_result)
END DO
zeff = SUM(elec_conf)
! *** Read r(loc) to define the exponent ***
! *** of the nuclear charge distribution ***
! *** of the core charge distribution ***
CALL read_object(r,skip_lines=1)
alpha_erf = 1.0_wp/(SQRT(2.0_wp)*r)
alpha_core_charge = 1.0_wp/(2.0_wp*r**2)
EXIT search_loop
@ -537,8 +542,9 @@ CONTAINS
! *****************************************************************************
SUBROUTINE read_gth_potential(element_symbol,potential_name,alpha_erf,&
elec_conf,gth_potential,globenv)
SUBROUTINE read_gth_potential(element_symbol,potential_name,&
alpha_core_charge,elec_conf,zeff,&
gth_potential,globenv)
! Purpose: Read an atomic GTH potential data structure from the database
! file.
@ -558,6 +564,7 @@ CONTAINS
search,&
start_input_session,&
test_object
USE mathconstants, ONLY: pi
USE mathlib, ONLY: symmetrize_matrix
USE memory_utilities, ONLY: reallocate
USE orbital_pointers, ONLY: init_orbital_pointers,nco,ncoset
@ -567,7 +574,8 @@ CONTAINS
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(gth_potential_type), POINTER :: gth_potential
CHARACTER(LEN=*), INTENT(IN) :: element_symbol,potential_name
REAL(wp), INTENT(OUT) :: alpha_erf
REAL(wp), INTENT(OUT) :: alpha_core_charge
INTEGER, INTENT(OUT) :: zeff
INTEGER, DIMENSION(:), POINTER :: elec_conf
! *** Local parameters ***
@ -656,14 +664,18 @@ CONTAINS
DEALLOCATE (gth_elec_conf)
zeff = SUM(gth_potential%elec_conf)
! *** Read r(loc) to define the exponent ***
! *** of the nuclear charge distribution ***
! *** of the core charge distribution ***
CALL read_object(r,skip_lines=1)
alpha_erf = 1.0_wp/(SQRT(2.0_wp)*r)
alpha_core_charge = 1.0_wp/(2.0_wp*r**2)
gth_potential%alpha_exp_ppl = alpha_erf**2
gth_potential%alpha_ppl = alpha_core_charge
gth_potential%cerf_ppl = REAL(zeff,wp)*&
SQRT((alpha_core_charge/pi)**3)
! *** Read the parameters for the local part ***
! *** of the GTH pseudopotential (ppl) ***
@ -675,7 +687,7 @@ CONTAINS
DO i=1,n
CALL read_object(gth_potential%cexp_ppl(i))
gth_potential%cexp_ppl(i) =&
(2.0_wp*gth_potential%alpha_exp_ppl)**(i - 1)*&
(2.0_wp*gth_potential%alpha_ppl)**(i - 1)*&
gth_potential%cexp_ppl(i)
END DO
@ -705,8 +717,8 @@ CONTAINS
! *** Load the parameter for n non-local projectors ***
gth_potential%alpha_prj_ppnl =>&
reallocate(gth_potential%alpha_prj_ppnl,0,lppnl)
gth_potential%alpha_ppnl =>&
reallocate(gth_potential%alpha_ppnl,0,lppnl)
gth_potential%nprj_ppnl =>&
reallocate(gth_potential%nprj_ppnl,0,lppnl)
@ -715,7 +727,7 @@ CONTAINS
DO l=0,lppnl
CALL read_object(r,skip_lines=1)
gth_potential%alpha_prj_ppnl(l) = 1.0_wp/(2.0_wp*r**2)
gth_potential%alpha_ppnl(l) = 1.0_wp/(2.0_wp*r**2)
CALL read_object(nprj_ppnl)
gth_potential%nprj_ppnl(l) = nprj_ppnl
nppnl = nppnl + nprj_ppnl*nco(l)

55
src/fft_tools.F
View file

@ -456,36 +456,40 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug )
ld ( 1 ) = SIZE ( zin ( :, 1, 1) )
ld ( 2 ) = SIZE ( zin ( 1, :, 1) )
ld ( 3 ) = SIZE ( zin ( 1, 1, :) )
in_sum = ABS ( SUM ( zin ) )
in_sum = SUM ( ABS ( zin ) )
ENDIF
sign = fsign
SELECT CASE ( fft_type )
CASE ( 1 )
IF ( PRESENT ( zout ) ) THEN
CALL sg_fft3d ( sign, norm, n, zin, zout )
ELSE
CALL sg_fft3d ( sign, norm, n, zin )
END IF
CALL sg_fft3d ( sign, norm, n, zin, zout )
! IF ( PRESENT ( zout ) ) THEN
! CALL sg_fft3d ( sign, norm, n, zin, zout )
! ELSE
! CALL sg_fft3d ( sign, norm, n, zin )
! END IF
CASE ( 2 )
IF ( PRESENT ( zout ) ) THEN
CALL w_fft3d ( sign, norm, n, zin, zout )
ELSE
CALL w_fft3d ( sign, norm, n, zin )
END IF
CALL w_fft3d ( sign, norm, n, zin, zout )
! IF ( PRESENT ( zout ) ) THEN
! CALL w_fft3d ( sign, norm, n, zin, zout )
! ELSE
! CALL w_fft3d ( sign, norm, n, zin )
! END IF
CASE ( 3 )
IF ( PRESENT ( zout ) ) THEN
CALL i_fft3d ( sign, norm, n, zin, zout )
ELSE
CALL i_fft3d ( sign, norm, n, zin )
END IF
CALL i_fft3d ( sign, norm, n, zin, zout )
! IF ( PRESENT ( zout ) ) THEN
! CALL i_fft3d ( sign, norm, n, zin, zout )
! ELSE
! CALL i_fft3d ( sign, norm, n, zin )
! END IF
CASE ( 4 )
IF ( PRESENT ( zout ) ) THEN
CALL sgi_fft3d ( sign, norm, n, zin, zout )
ELSE
CALL sgi_fft3d ( sign, norm, n, zin )
END IF
CALL sgi_fft3d ( sign, norm, n, zin, zout )
! IF ( PRESENT ( zout ) ) THEN
! CALL sgi_fft3d ( sign, norm, n, zin, zout )
! ELSE
! CALL sgi_fft3d ( sign, norm, n, zin )
! END IF
CASE DEFAULT
CALL stop_program ("fft3d", "Unknown FFT library")
END SELECT
@ -500,7 +504,7 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug )
IF ( test ) THEN
IF ( PRESENT ( zout ) ) THEN
out_sum = ABS ( SUM ( zout ) )
out_sum = SUM ( ABS ( zout ) )
lo ( 1 ) = SIZE ( zout ( :, 1, 1) )
lo ( 2 ) = SIZE ( zout ( 1, :, 1) )
lo ( 3 ) = SIZE ( zout ( 1, 1, :) )
@ -511,7 +515,7 @@ SUBROUTINE fft3d_s ( fsign, n, zin, zout, scale, status, debug )
WRITE ( *, '(A,T61,E20.14)') " Sum of input data ",in_sum
WRITE ( *, '(A,T61,E20.14)') " Sum of output data ",out_sum
ELSE
out_sum = ABS ( SUM ( zin ) )
out_sum = SUM ( ABS ( zin ) )
WRITE ( *, '(A)') " In place 3D FFT (local) : fft3d_s"
WRITE ( *, '(A,T60,3I7)') " Transform lengths ",n
WRITE ( *, '(A,T60,3I7)') " Input/output array dimensions ",ld
@ -1427,7 +1431,7 @@ SUBROUTINE fft3d_pb ( fsign, n, zin, gin, group, bo, scale, status, debug )
ALLOCATE ( abuf ( n(3), mx*my ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "fft3d", "abuf", n(3)*mx*my )
CALL Zcopy(n(3)*mx*my,bbuf,1,abuf,1)
CALL zcopy(n(3)*mx*my,bbuf,1,abuf,1)
DEALLOCATE ( bbuf, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "fft3d", "bbuf" )
@ -1540,6 +1544,7 @@ SUBROUTINE x_to_yz ( sb, group, my_pos, p2p, yzp, nray, bo, tb )
CALL mp_transpose ( sb, scount, sdispl, rr, rcount, rdispl, group )
tb = 0._dbl
nx = bo ( 2, 1, mpr ) - bo ( 1, 1, mpr ) + 1
DO ip = 0, np - 1
nr = nray ( ip )
@ -1635,7 +1640,7 @@ SUBROUTINE yz_to_x ( tb, group, my_pos, p2p, yzp, nray, bo, sb )
nx = bo ( 2, 1, mpr ) - bo ( 1, 1, mpr ) + 1
DO ip = 0, np - 1
nr = nray ( ip )
scount ( ip ) = nm * nx
scount ( ip ) = nr * nx
sdispl ( ip ) = nm * nx * ip
END DO

13
src/fist_debug.F
View file

@ -72,7 +72,7 @@ CONTAINS
!******************************************************************************
SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
box_ref, thermo, potparm, ensemble, lldata )
box_ref, thermo, potparm, lldata )
IMPLICIT NONE
@ -84,9 +84,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
TYPE ( potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm
TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule
TYPE ( cell_type ), INTENT ( INOUT ) :: box
TYPE ( cell_type ), INTENT ( IN ) :: box_ref
TYPE ( cell_type ), INTENT ( INOUT ) :: box_ref
TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo
CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble
TYPE ( linklist_internal_data_type ) :: lldata
! Locals
@ -94,13 +93,14 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
TYPE ( pw_grid_type ) :: ewald_grid
INTEGER :: iflag, i, natoms, isos, iatom, iw, iwf, ir, npts_s(3), gmax
INTEGER, DIMENSION ( 2 ) :: dum
REAL ( dbl ) :: delta, energy_numer, cutoff
REAL ( dbl ) :: delta, energy_numer, cutoff, ecut
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
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff
LOGICAL, PARAMETER :: box_change = .FALSE.
!------------------------------------------------------------------------------
@ -136,7 +136,7 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
! Call to analytical force routine:
CALL force_control ( molecule, pnode, part, box, box_ref, thermo, &
potparm, ewald_param, ensemble, globenv, lldata, dbg )
potparm, ewald_param, box_change, globenv, lldata, dbg )
! Debug real-space non-bonded interactions
WRITE ( iw, '( A )' ) &
@ -543,7 +543,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
CALL pw_find_cutoff ( npts_s, box_ref, cutoff )
CALL pw_grid_setup( box_ref, ewald_grid, cutoff, fft_usage = .FALSE. )
ecut = 0.5_dbl * cutoff * cutoff
CALL pw_grid_setup( box_ref, ewald_grid, ecut, fft_usage = .FALSE. )
WRITE ( iw, '( A )' ) &
' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?'

114
src/fist_force.F
View file

@ -22,11 +22,13 @@
MODULE fist_force
USE dg_types, ONLY : dg_type
USE dgs, ONLY : dg_grid_change
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE ewalds, ONLY : ewald_gaussian, ewald_initialize
USE ewalds, ONLY : ewald_evaluate, ewald_initialize, ewald_setup
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 greens_fn, ONLY : pw_green_fn_init
USE kinds, ONLY : dbl
USE linklist_control, ONLY : list_control
USE mathconstants, ONLY : pi, zero
@ -41,7 +43,7 @@ MODULE fist_force
USE pw_grid_types, ONLY : pw_grid_type
USE pw_grids, ONLY : pw_grid_change
USE simulation_cell, ONLY : cell_type, get_hinv
USE spme, ONLY : spme_evaluate
USE spme, ONLY : spme_evaluate, spme_coeff_calculate
USE termination, ONLY : stop_program, stop_memory
USE timings, ONLY : timeset, timestop
USE linklist_types, ONLY : linklist_internal_data_type
@ -63,7 +65,7 @@ MODULE fist_force
CONTAINS
!******************************************************************************
!!****** fist_force/force_control [1.0] *
!!****** fist_force/force_control [1.1] *
!!
!! NAME
!! force_control
@ -78,13 +80,16 @@ CONTAINS
!! MODIFICATION HISTORY
!! Harald Forbert (Dec-2000): Changes for multiple linked lists
!! cjm, 20-Feb-2001: box_ref used to initialize ewald. Now
!! have consistent restarts with npt and ewald
!! have consistent restarts with npt and ewald
!! JGH (15-Mar-2001) : box_change replaces ensemble parameter
!! Call ewald_setup if box has changed
!! Consistent setup for PME and SPME
!!
!! SOURCE
!******************************************************************************
SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
potparm, ewald_param, ensemble, fc_global, lldata, debug)
potparm, ewald_param, box_change, fc_global, lldata, debug)
IMPLICIT NONE
@ -93,17 +98,17 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode
TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule
TYPE ( cell_type ), INTENT ( INOUT ) :: box
TYPE ( cell_type ), INTENT ( IN ) :: box_ref
TYPE ( cell_type ), INTENT ( INOUT ) :: box_ref
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
LOGICAL, INTENT ( IN ) :: box_change
TYPE ( global_environment_type ), INTENT ( IN ) :: fc_global
TYPE ( linklist_internal_data_type), INTENT (INOUT) :: lldata
TYPE ( debug_variables_type ), INTENT ( OUT ), OPTIONAL :: debug
! Locals
INTEGER :: id, i, ii, natoms, nnodes, handle, isos
INTEGER :: id, i, ii, natoms, nnodes, handle, isos, n
REAL ( dbl ) :: pot_nonbond, pot_bond, pot_bend, pot_torsion, vg_coulomb
REAL ( dbl ), DIMENSION ( :,: ), ALLOCATABLE, SAVE :: f_nonbond
REAL ( dbl ), DIMENSION ( 3,3 ) :: pv_nonbond, pv_bond, pv_bend, pv_torsion
@ -135,6 +140,8 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
ALLOCATE ( f_nonbond ( 3,natoms ), STAT = isos )
IF ( isos /= 0 ) &
CALL stop_memory ( 'force_control', 'f_nonbond', 3 * natoms )
! change in system, do a full reinitialisation
first_time = .TRUE.
END IF
! initialize ewalds with the REFERENCE box ( for consistent NPT restarts )
@ -152,25 +159,35 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
CALL ewald_initialize ( dg, part, pnode, fc_global, &
ewald_param, box_ref, thermo, &
spme_grid = grid_spme )
n = ewald_param%o_spline
ALLOCATE ( box % green % p3m_coeff ( -(n-1):n-1, 0:n-1 ), STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'spme','coeff', 2*n*n )
CALL spme_coeff_calculate ( n, box % green % p3m_coeff )
END SELECT
END IF
! reinitialize the gspace for the new box
SELECT CASE ( ensemble ( 1:3 ) )
CASE ( 'NPT' )
IF ( box_change .OR. first_time ) THEN
CALL get_hinv ( box )
SELECT CASE ( ewald_param % ewald_type )
CASE ( 'EWALD', 'SPME' )
CASE ( 'EWALD' )
CALL pw_grid_change ( box, grid_ewald )
CALL ewald_setup ( grid_ewald, ewald_param, dg )
CASE ( 'PME' )
CALL stop_program ( 'force_control', &
'constant pressure with PME not implemented' )
CALL pw_grid_change ( box, grid_b )
CALL pw_green_fn_init ( box % green, grid_b )
CALL dg_grid_change ( box, grid_b, grid_s )
CALL ewald_setup ( grid_s, ewald_param, dg )
CASE ( 'SPME' )
CALL pw_grid_change ( box, grid_spme )
CALL pw_green_fn_init ( box % green, grid_spme, p3m=ewald_param%o_spline, &
alpha = ewald_param%alpha )
END SELECT
END SELECT
END IF
!
! first check with list_control to update neighbor lists
@ -193,30 +210,38 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
! get real-space non-bonded forces:
!
f_nonbond = zero
CALL force_nonbond ( ewald_param,pnode,box,potparm, &
pot_nonbond,f_nonbond,pv_nonbond )
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
! compute g-space part of the ewald sum
SELECT CASE ( ewald_param % ewald_type )
CASE ( "EWALD" )
CALL ewald_gaussian ( dg, ewald_param, fg_coulomb, vg_coulomb, &
! Parallelisation over atoms --> allocate only nnodes
ALLOCATE ( fg_coulomb ( 3, nnodes ), STAT=isos )
IF ( isos /= 0 ) &
CALL stop_memory ( 'force_control', 'fg_coulomb', 3 * nnodes )
CALL ewald_evaluate ( dg, ewald_param, fg_coulomb, vg_coulomb, &
pv_g, pnode, box )
CASE ( "PME" )
CALL pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
! Parallelisation over grids --> allocate all atoms
ALLOCATE ( fg_coulomb ( 3, natoms ), STAT=isos )
IF ( isos /= 0 ) &
CALL stop_memory ( 'force_control', 'fg_coulomb', 3 * nnodes )
CALL pme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_s, grid_b, ewald_param )
CASE ( "SPME" )
CALL spme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
! Parallelisation over grids --> allocate all atoms
ALLOCATE ( fg_coulomb ( 3, natoms ), STAT=isos )
IF ( isos /= 0 ) &
CALL stop_memory ( 'force_control', 'fg_coulomb', 3 * nnodes )
CALL spme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_spme, ewald_param )
CASE DEFAULT
@ -267,8 +292,7 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
! ewald forces are strictly local -> sum only over pnode
! We first sum the forces in f_nonbond, this allows for a more efficient
! global sum in the parallel code and in the end copy them back to part
isos = 0
IF ( .NOT. ALLOCATED ( f_total ) ) ALLOCATE ( f_total ( 3,natoms ), STAT=isos )
ALLOCATE ( f_total ( 3,natoms ), STAT=isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'f_total', 3 * natoms )
DO i = 1, natoms
f_total ( 1, i ) = part ( i ) % f ( 1 ) + f_nonbond ( 1, i )
@ -276,12 +300,22 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
f_total ( 3, i ) = part ( i ) % f ( 3 ) + f_nonbond ( 3, i )
END DO
IF ( ewald_param % ewald_type /= 'NONE' ) THEN
DO i = 1, nnodes
ii = pnode ( i ) % p % iatom
f_total ( 1, ii ) = f_total ( 1, ii ) + fg_coulomb ( 1, i )
f_total ( 2, ii ) = f_total ( 2, ii ) + fg_coulomb ( 2, i )
f_total ( 3, ii ) = f_total ( 3, ii ) + fg_coulomb ( 3, i )
END DO
SELECT CASE ( ewald_param % ewald_type )
CASE ( "EWALD" )
DO i = 1, nnodes
ii = pnode ( i ) % p % iatom
f_total ( 1, ii ) = f_total ( 1, ii ) + fg_coulomb ( 1, i )
f_total ( 2, ii ) = f_total ( 2, ii ) + fg_coulomb ( 2, i )
f_total ( 3, ii ) = f_total ( 3, ii ) + fg_coulomb ( 3, i )
END DO
CASE ( "PME" )
f_total ( :, : ) = f_total ( :, : ) + fg_coulomb ( :, : )
CASE ( "SPME" )
f_total ( :, : ) = f_total ( :, : ) + fg_coulomb ( :, : )
CASE DEFAULT
CALL stop_program ( "force_control", "illegal value of ewald_type: "//&
ewald_param % ewald_type )
END SELECT
END IF
! add up all the pressure tensors
@ -340,12 +374,14 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
END DO
! 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' )
isos = 0
IF ( ALLOCATED ( f_total ) ) DEALLOCATE ( f_total, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'f_total' )
IF ( ALLOCATED ( fg_coulomb ) ) THEN
DEALLOCATE ( fg_coulomb, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'fg_coulomb' )
END IF
IF ( ALLOCATED ( f_total ) ) THEN
DEALLOCATE ( f_total, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'f_total' )
END IF
CALL timestop ( zero, handle )

7
src/fist_force_numer.F
View file

@ -1249,7 +1249,7 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,pw_grid,pv_test,delta)
REAL ( dbl ), DIMENSION (3,3) :: dvdh
REAL ( dbl ) :: idelta, vm, vp
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: s
REAL ( dbl ) :: alpha, epsilon0, cutoff
REAL ( dbl ) :: alpha, epsilon0, cutoff, ecut
REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: gauss
COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: sum_igr
INTEGER :: i, j, k, ii, jj, natoms, isos, gmax, npts_s(3), ngtot
@ -1286,6 +1286,7 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,pw_grid,pv_test,delta)
gmax = ewald_param % gmax
npts_s = (/ gmax, gmax, gmax /)
CALL pw_find_cutoff ( npts_s, box, cutoff )
ecut = 0.5_dbl * cutoff * cutoff
! Defining the increments
idelta = 1.0_dbl/(2.0_dbl*delta)
@ -1303,7 +1304,7 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,pw_grid,pv_test,delta)
! compute the g-vectors
CALL pw_grid_construct( pw_grid_local )
CALL pw_grid_setup( box_local, pw_grid_local, cutoff)
CALL pw_grid_setup( box_local, pw_grid_local, ecut)
CALL potential_g_numer ( vp, pnode_local, sum_igr, gauss, alpha, &
pw_grid_local % g, ngtot )
@ -1321,7 +1322,7 @@ SUBROUTINE pvg_numer(ewald_param,pnode,box,pw_grid,pv_test,delta)
END DO
! compute the g-vectors
CALL pw_grid_setup( box_local, pw_grid_local, cutoff)
CALL pw_grid_setup( box_local, pw_grid_local, ecut)
CALL potential_g_numer ( vm, pnode_local, sum_igr, gauss, alpha, &
pw_grid_local % g, ngtot )

206
src/fist_input.F
View file

@ -1,206 +0,0 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/fist_input [1.0] *
!!
!! NAME
!! fist_input
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM & JGH
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
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 message_passing, 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
!******************************************************************************
!!****** fist_input/read_fist_section [1.0] *
!!
!! NAME
!! read_fist_section
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM & JGH
!!
!! MODIFICATION HISTORY
!! none
!!
!! INPUTS
!!I---------------------------------------------------------------------------I
!!I SECTION: &fist ... &end I
!!I I
!!I simulation [md,debug] I
!!I printlevel fistpar%print_level I
!!I units [kelvin,atomic] I
!!I periodic [0,1][0,1][0,1] I
!!I Ewald_type [pme_gauss,ewald_gauss] I
!!I Ewald_param alpha,[gmax,ns_max,epsilon] I
!!I set_file "filename" I
!!I input_file "filename" I
!!I I
!!I---------------------------------------------------------------------------I
!!
!! SOURCE
!******************************************************************************
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
!******************************************************************************

72
src/fist_nonbond_force.F
View file

@ -13,7 +13,7 @@
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!! JGH (11 May 2001) : cleaning up of support structures
!!
!! SOURCE
!******************************************************************************
@ -22,7 +22,7 @@ MODULE fist_nonbond_force
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE kinds, ONLY : dbl
USE mathconstants, ONLY : pi, zero
USE mathconstants, ONLY : pi
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
@ -59,7 +59,6 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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
@ -71,18 +70,18 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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
INTEGER, DIMENSION(:,:), ALLOCATABLE :: n_images
REAL ( dbl ), ALLOCATABLE, DIMENSION ( :, : ) :: rtest
!------------------------------------------------------------------------------
CALL timeset ( 'NONBOND', 'E', 'Mflops', handle )
flops = zero
flops = 0._dbl
! initializing the potential energy, pressure tensor and force
pot_nonbond = zero
f_nonbond = zero
ptens_nonbond = zero
pot_nonbond = 0._dbl
f_nonbond = 0._dbl
ptens_nonbond = 0._dbl
! local copies of the box parameters
hmat = box % hmat
@ -91,11 +90,9 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
! 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', &
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
@ -103,31 +100,20 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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 )
ALLOCATE ( n_images ( natom_types, natom_types ), STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', &
'n_images', natom_types ** 2 )
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
CALL get_cell_param ( box, cell_lengths )
n_images = 0
DO itype = 1, natom_types
DO jtype = itype, natom_types
rcut = SQRT ( rtest ( itype, jtype ) )
quotient ( : ) = rcut / cell_lengths ( : )
IF ( ANY ( quotient ( : ) > 0.5_dbl ) ) n_images ( itype, jtype ) = 1
n_images ( jtype, itype ) = n_images ( itype, jtype )
END DO
END IF
END DO
!
! starting the force loop
!
@ -135,14 +121,13 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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
@ -150,7 +135,7 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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 ( 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
@ -165,12 +150,11 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
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
rijsq = rij(1) *rij(1) + rij(2) * rij(2) + rij(3) * rij(3)
flops = flops + 41.0_dbl
IF ( i /= 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
!
@ -179,7 +163,6 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
flops = flops + 64.0_dbl
END IF
!
! now sum over lattice translations of neighbors
!
@ -214,6 +197,11 @@ SUBROUTINE force_nonbond ( ewald_param, pnode, box, potparm, pot_nonbond, &
!we will add the long range correction
!
! pot_nonbond=pot_nonbond+lrc*(1./box % deth)
!
DEALLOCATE ( rtest, STAT = ios )
IF ( ios /= 0 ) CALL stop_memory ( 'fist_nonbond_force', 'rtest' )
DEALLOCATE ( n_images, STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'force_control', 'n_images' )
!
flops = flops * 1.E-6_dbl
CALL timestop ( flops, handle )

97
src/force_control.F
View file

@ -38,6 +38,10 @@ MODULE force_control
PRIVATE
PUBLIC :: force
INTERFACE force
MODULE PROCEDURE force_1, force_n
END INTERFACE
!!*****
!******************************************************************************
@ -62,21 +66,84 @@ CONTAINS
!! SOURCE
!******************************************************************************
SUBROUTINE force ( struc, inter, thermo, simpar, ewald_param, globenv, &
dft_control, kp )
SUBROUTINE force_n ( struc, inter, thermo, simpar, ewald_param, box_change, &
globenv, dft_control, kp )
IMPLICIT NONE
! Arguments
TYPE ( structure_type ),DIMENSION ( : ), INTENT ( INOUT ) :: struc
TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo
TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar
TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param
LOGICAL, INTENT ( IN ) :: box_change
TYPE ( interaction_type ), INTENT ( IN ) :: inter
TYPE ( global_environment_type), INTENT ( IN ) :: globenv
TYPE ( dft_control_type ), INTENT ( IN ) :: dft_control
TYPE ( kpoint_type ), INTENT ( IN ) :: kp
! Local
INTEGER :: i, n
REAL (dbl) :: e_pot
!------------------------------------------------------------------------------
thermo % ptens_aval = .FALSE.
n = SIZE ( struc )
e_pot = 0.0_dbl
DO i = 1, n
SELECT CASE ( simpar % program )
CASE DEFAULT
CALL stop_program ( 'force', 'not implemented' )
CASE ( 'FIST' )
CALL fist_force_control ( struc(i) % molecule, struc(i) % pnode, &
struc(i) % part, struc(i) % box, struc(i) % box_ref, thermo, &
inter%potparm, ewald_param, box_change, globenv, struc(i) % ll_data )
CASE ( 'TBMD' )
CALL tbmd_force_control ( struc(i) % molecule, struc(i) % pnode, &
struc(i) % part, struc(i) % box, struc(i) % box_ref, thermo, &
inter%potparm, ewald_param, box_change, globenv, struc(i) % ll_data )
CASE ( 'WAVE' )
CALL dft_force_control ( struc(i) % molecule, struc(i) % pnode, &
struc(i) % part, struc(i) % box, thermo, inter % potparm, &
ewald_param, box_change, struc(i) % ll_data, dft_control, kp, &
dftpar = globenv, wavepar = globenv )
END SELECT
e_pot = e_pot + thermo % pot
END DO
thermo % pot = e_pot
END SUBROUTINE force_n
!******************************************************************************
SUBROUTINE force_1 ( struc, inter, thermo, simpar, ewald_param, box_change, &
globenv, dft_control, kp )
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
LOGICAL, INTENT ( IN ) :: box_change
TYPE ( interaction_type ), INTENT ( IN ) :: inter
TYPE ( global_environment_type), INTENT ( IN ) :: globenv
TYPE ( dft_control_type ), INTENT ( IN ) :: dft_control
TYPE ( kpoint_type ), INTENT ( IN ) :: kp
!------------------------------------------------------------------------------
thermo % ptens_aval = .FALSE.
@ -86,24 +153,24 @@ SUBROUTINE force ( struc, inter, thermo, simpar, ewald_param, globenv, &
CALL stop_program ( 'force', 'not implemented' )
CASE ( 'FIST' )
CALL fist_force_control ( struc % molecule, struc % pnode, struc % part, &
struc % box, struc % box_ref, thermo, inter%potparm, ewald_param, &
simpar % ensemble, globenv, struc%ll_data )
CALL fist_force_control ( struc % molecule, struc % pnode, &
struc % part, struc % box, struc % box_ref, thermo, &
inter%potparm, ewald_param, box_change, globenv, struc % ll_data )
CASE ( 'TBMD' )
CALL tbmd_force_control ( struc % molecule, struc % pnode, struc % part, &
struc % box, struc % box_ref, thermo, inter%potparm, ewald_param, &
simpar % ensemble, globenv , struc%ll_data )
CALL tbmd_force_control ( struc % molecule, struc % pnode, &
struc % part, struc % box, struc % box_ref, thermo, &
inter%potparm, ewald_param, box_change, globenv, struc % ll_data )
CASE ( 'WAVE' )
CALL dft_force_control ( struc % molecule, struc % pnode, struc % part, &
struc % box, thermo, inter % potparm, ewald_param, &
simpar % ensemble, struc % ll_data, dft_control, kp, &
CALL dft_force_control ( struc % molecule, struc % pnode, &
struc % part, struc % box, thermo, inter % potparm, &
ewald_param, box_change, struc % ll_data, dft_control, kp, &
dftpar = globenv, wavepar = globenv )
END SELECT
END SUBROUTINE force
END SUBROUTINE force_1
!!*****
!******************************************************************************

3
src/global_types.F
View file

@ -32,8 +32,9 @@ MODULE global_types
TYPE global_environment_type
TYPE(print_key_type), POINTER :: print
CHARACTER ( LEN = 200 ) :: basis_set_file_name,&
input_file_name,&
potential_file_name,&
input_file_name
restart_file_name
CHARACTER ( LEN = 200 ) :: program_name
CHARACTER ( LEN = 200 ) :: project_name
CHARACTER ( LEN = 200 ) :: default_fft_library

195
src/greens_fn.F
View file

@ -16,6 +16,7 @@
!! MODIFICATION HISTORY
!! JGH (9-Mar-2001) : include influence_function into greens_function_type
!! add cell volume as indicator for updates
!! JGH (30-Mar-2001) : Added B-spline routines
!!
!! SOURCE
!******************************************************************************
@ -26,17 +27,17 @@ MODULE greens_fn
USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_deallocate, &
PLANEWAVES
USE kinds, ONLY : dbl
USE mathconstants, ONLY : fourpi
USE mathconstants, ONLY : fourpi, twopi, pi
USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE
USE pw_types, ONLY : pw_type, pw_allocate, pw_deallocate, &
USE pw_types, ONLY : pw_type, pw_allocate, pw_deallocate, pw_transfer, &
REALDATA1D, COMPLEXDATA1D, REALDATA3D, COMPLEXDATA3D, &
NOSPACE, REALSPACE, RECIPROCALSPACE
USE termination, ONLY : stop_program
USE termination, ONLY : stop_program, stop_memory
IMPLICIT NONE
PRIVATE
PUBLIC :: pw_green_fn, greens_function_type
PUBLIC :: pw_green_fn, pw_green_fn_init, greens_function_type
PUBLIC :: PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, &
MT2D, MT1D, MT0D, HOCKNEY2D, HOCKNEY1D, HOCKNEY0D
@ -45,8 +46,15 @@ MODULE greens_fn
INTEGER :: special_dimension
REAL ( dbl ) :: radius
REAL ( dbl ) :: slab_size
REAL ( dbl ) :: alpha
REAL ( dbl ) :: volume
LOGICAL :: p3m
INTEGER :: p3m_order
REAL ( dbl ) :: p3m_alpha
REAL ( dbl ), DIMENSION ( :, : ), POINTER :: p3m_coeff
REAL ( dbl ), DIMENSION ( :, : ), POINTER :: p3m_bm2
TYPE ( pw_type ), POINTER :: influence_function
TYPE ( pw_type ), POINTER :: p3m_charge
END TYPE greens_function_type
INTEGER, PARAMETER :: PERIODIC3D = 1000, ANALYTIC2D = 1001, &
@ -59,6 +67,73 @@ MODULE greens_fn
CONTAINS
!******************************************************************************
!!****** greens_fn/pw_green_fn_init [1.0] *
!!
!! NAME
!! pw_green_fn_init
!!
!! FUNCTION
!! Initialisation
!!
!! AUTHOR
!! JGH (12-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE pw_green_fn_init ( gftype, grid, p3m, alpha )
IMPLICIT NONE
! Arguments
TYPE ( greens_function_type ), INTENT ( INOUT ) :: gftype
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid
INTEGER, OPTIONAL, INTENT ( IN ) :: p3m
REAL ( dbl ), OPTIONAL, INTENT ( IN ) :: alpha
! Locals
INTEGER :: use_data, ierr, n
!------------------------------------------------------------------------------
SELECT CASE ( gftype % method )
CASE ( PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, MT2D, MT1D, MT0D )
ALLOCATE ( gftype % influence_function, STAT = ierr )
IF ( ierr /= 0 ) call stop_memory ( "pw_green_fn_init", &
"gftype % influence_function", 0 )
use_data = REALDATA1D
CALL pw_allocate ( gftype % influence_function, grid, use_data )
gftype % influence_function % in_space = RECIPROCALSPACE
IF ( PRESENT ( p3m ) ) THEN
gftype % p3m = .TRUE.
gftype % p3m_order = p3m
IF ( PRESENT ( alpha ) ) THEN
gftype % p3m_alpha = alpha
ELSE
CALL stop_program ( "pw_green_fn_init", "P3M needs alpha parameter")
END IF
ALLOCATE ( gftype % p3m_charge, STAT = ierr )
IF ( ierr /= 0 ) call stop_memory ( "pw_green_fn_init", &
"gftype % p3m_charge", 0 )
CALL pw_allocate ( gftype % p3m_charge, grid, REALDATA1D )
gftype % p3m_charge % in_space = RECIPROCALSPACE
CALL influence_factor ( gftype )
ELSE
gftype % p3m = .FALSE.
END IF
CASE ( HOCKNEY2D, HOCKNEY1D, HOCKNEY0D )
CALL stop_program ( "pw_green_fn_init", " Method not implemented ")
CASE DEFAULT
CALL stop_program ( "pw_green_fn_init", " Method not implemented ")
END SELECT
END SUBROUTINE pw_green_fn_init
!!*****
!******************************************************************************
!!****** greens_fn/pw_green_fn [1.0] *
!!
@ -69,10 +144,10 @@ CONTAINS
!! Calculates the Green's function in reciprocal space '''
!!
!! AUTHOR
!! JGH (19-12-2000)
!! JGH (19-Dec-2000)
!!
!! MODIFICATION HISTORY
!! JGH (9-Mar-2001) : update check through voulme
!! JGH (9-Mar-2001) : update check through volume
!!
!! SOURCE
!******************************************************************************
@ -87,7 +162,7 @@ SUBROUTINE pw_green_fn ( gftype )
! Locals
TYPE ( pw_type ), POINTER :: gf
TYPE ( pw_grid_type ), POINTER :: grid
INTEGER :: method, ig, iz, nz
INTEGER :: method, ig, iz, nz, l, m, n
REAL ( dbl ) :: rlength, zlength, g3d, gxy, g2, j0g, j1g, k0g, k1g, gg
!------------------------------------------------------------------------------
@ -100,7 +175,7 @@ SUBROUTINE pw_green_fn ( gftype )
SELECT CASE ( method )
CASE ( PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, MT2D, MT1D, MT0D )
IF ( gf % in_space /= RECIPROCALSPACE .OR. &
gf % in_use /= COMPLEXDATA1D ) &
gf % in_use /= REALDATA1D ) &
CALL stop_program ( "greens_fn", "gf wrong space or data type" )
CASE ( HOCKNEY2D, HOCKNEY1D, HOCKNEY0D )
CALL stop_program ( "pw_green_fn", " Method not implemented ")
@ -118,10 +193,10 @@ SUBROUTINE pw_green_fn ( gftype )
CASE ( PERIODIC3D )
DO ig = grid % first_gne0, grid % ngpts_cut_local
g2 = grid % glsq ( ig )
gf % cc ( ig ) = fourpi / g2
g2 = grid % gsq ( ig )
gf % cr ( ig ) = fourpi / g2
END DO
IF ( grid % have_g0 ) gf % cc ( 1 ) = 0._dbl
IF ( grid % have_g0 ) gf % cr ( 1 ) = 0._dbl
CASE ( ANALYTIC2D )
@ -129,12 +204,12 @@ SUBROUTINE pw_green_fn ( gftype )
zlength = gftype % slab_size ! zlength is the thickness of the cell
DO ig = grid % first_gne0, grid % ngpts_cut_local
nz = grid % g_hat ( iz, ig )
g2 = grid % glsq ( ig )
g2 = grid % gsq ( ig )
g3d = fourpi / g2
gg = 0.5_dbl * SQRT ( g2 )
gf % cc ( ig ) = g3d * ( 1._dbl - (-1._dbl)**nz * EXP ( - gg * zlength ) )
gf % cr ( ig ) = g3d * ( 1._dbl - (-1._dbl)**nz * EXP ( - gg * zlength ) )
END DO
IF ( grid % have_g0 ) gf % cc ( 1 ) = 0._dbl
IF ( grid % have_g0 ) gf % cr ( 1 ) = 0._dbl
CASE ( ANALYTIC1D )
@ -143,29 +218,29 @@ SUBROUTINE pw_green_fn ( gftype )
! rlength is the radius of the tube
rlength = gftype % radius
DO ig = grid % first_gne0, grid % ngpts_cut_local
g2 = grid % glsq ( ig )
g2 = grid % gsq ( ig )
g3d = fourpi / g2
gxy = SQRT ( g2 - grid % g(iz,ig) * grid % g(iz,ig) )
j0g = bessj0 ( rlength * gxy )
j1g = bessj1 ( rlength * gxy )
k0g = bessk0 ( rlength * grid % g(iz,ig) )
k1g = bessk1 ( rlength * grid % g(iz,ig) )
gf % cc ( ig ) = g3d * ( 1._dbl - rlength * &
gf % cr ( ig ) = g3d * ( 1._dbl - rlength * &
( gxy * j1g * k0g - grid % g(iz,ig) * j0g * k1g ) )
END DO
IF ( grid % have_g0 ) gf % cc ( 1 ) = 0._dbl
IF ( grid % have_g0 ) gf % cr ( 1 ) = 0._dbl
CASE ( ANALYTIC0D )
rlength = gftype % radius ! rlength is the radius of the sphere
DO ig = grid % first_gne0, grid % ngpts_cut_local
g2 = grid % glsq ( ig )
g2 = grid % gsq ( ig )
gg = 0.5_dbl * SQRT ( g2 )
g3d = fourpi / g2
gf % cc ( ig ) = g3d * ( 1._dbl - COS ( rlength * gg ) )
gf % cr ( ig ) = g3d * ( 1._dbl - COS ( rlength * gg ) )
END DO
IF ( grid % have_g0 ) &
gf % cc ( 1 ) = 0.5_dbl * fourpi * rlength * rlength
gf % cr ( 1 ) = 0.5_dbl * fourpi * rlength * rlength
CASE ( MT2D )
CALL stop_program ( "pw_green_fn", " Method not implemented ")
@ -187,6 +262,86 @@ SUBROUTINE pw_green_fn ( gftype )
END SUBROUTINE pw_green_fn
!!*****
!******************************************************************************
!!****** greens_fn/influence_factor [1.0] *
!!
!! NAME
!! influence_factor
!!
!! FUNCTION
!! Calculates the influence_factor for the
!! SPME Green's function in reciprocal space'''
!!
!! AUTHOR
!! DH (29-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE influence_factor ( gftype )
IMPLICIT NONE
! Arguments
TYPE ( greens_function_type ), TARGET, INTENT ( INOUT ) :: gftype
! Locals
INTEGER :: dim, ierr, j, k, l, n, pt
INTEGER, DIMENSION ( : ), POINTER :: lb, ub
INTEGER, DIMENSION ( 3 ) :: npts
REAL ( dbl ) :: l_arg, prod_arg, val
REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: m_assign
COMPLEX ( dbl ) :: exp_m, sum_m, b_m
!------------------------------------------------------------------------------
n = gftype % p3m_order
! calculate the assignment function values
lb => gftype % influence_function % pw_grid % bounds (1, : )
ub => gftype % influence_function % pw_grid % bounds (2, : )
ALLOCATE ( gftype % p3m_bm2 ( 3, MINVAL(lb):MAXVAL(ub) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( 'influence_factor', &
'gftype % p3m_bm2', 3*(MAXVAL(ub)-MINVAL(lb)+1) )
ALLOCATE ( m_assign ( 0:n-2 ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( 'influence_factor', 'm_assign', n-1 )
m_assign = 0._dbl
DO k = 0, n-2
j = -(n-1) + 2 * k
DO l = 0, n-1
l_arg = 0.5_dbl ** l
prod_arg = gftype % p3m_coeff ( j, l ) * l_arg
m_assign ( k ) = m_assign ( k ) + prod_arg
END DO
END DO
! calculate the absolute b values
npts ( : ) = ub ( : ) - lb ( : ) + 1
DO dim = 1, 3
DO pt = lb (dim), ub (dim)
val = twopi * ( REAL ( pt, dbl ) / REAL ( npts ( dim ), dbl ) )
exp_m = CMPLX ( COS ( val ), -SIN ( val ), dbl )
sum_m = CMPLX ( 0._dbl, 0._dbl, dbl )
DO k = 0, n-2
sum_m = sum_m + m_assign ( k ) * exp_m ** k
END DO
b_m = exp_m ** ( n - 1 ) / sum_m
gftype % p3m_bm2 ( dim, pt ) = SQRT ( REAL ( b_m * CONJG ( b_m ), dbl ) )
END DO
END DO
DEALLOCATE ( m_assign, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( 'influence_factor', 'm_assign', 0 )
END SUBROUTINE influence_factor
!!*****
!******************************************************************************

124
src/hartree.F
View file

@ -1,76 +1,138 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/hartree [1.0] *
!!
!! NAME
!! hartree
!!
!!@Author Christopher Mundy
!! FUNCTION
!! Calculate Hartree energy and potential
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! JGH (12-Mar-2001) :
!!
!! SOURCE
!******************************************************************************
MODULE hartree
USE kinds, ONLY : dbl
USE coefficient_types, ONLY : coeff_type, PLANEWAVES
USE coefficients, ONLY : integral
USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_deallocate, &
PLANEWAVES
USE pws, ONLY : pw_poisson_solver
USE termination, ONLY: stop_memory
USE timings, ONLY: timeset, timestop
IMPLICIT NONE
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** hartree/calculate_hartree [1.0] *
!!
!! NAME
!! calculate_hartree
!!
!! FUNCTION
!!
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! JGH (12-Mar-2001) : stress
!!
!! SOURCE
!******************************************************************************
SUBROUTINE calculate_hartree ( n, ehartree, vhartree, dvhartree )
SUBROUTINE calculate_hartree ( density, ehartree, vhartree, dvhartree, h_stress )
! Arguments
TYPE ( coeff_type ), INTENT ( IN ) :: n ! Total density
TYPE ( coeff_type ), INTENT ( INOUT ) :: density
REAL ( dbl ), INTENT ( OUT ) :: ehartree
!! vxc is optional in case you only want the energy
TYPE ( coeff_type ), INTENT ( OUT ), OPTIONAL :: vhartree
TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), &
OPTIONAL :: dvhartree
TYPE ( coeff_type ), TARGET, INTENT ( OUT ), OPTIONAL :: vhartree
TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), OPTIONAL :: dvhartree
REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( OUT ), OPTIONAL :: h_stress
! Local
REAL ( dbl ) :: eps0 ! TMPTMPTMP
INTEGER :: handle, ierr
TYPE ( coeff_type ), POINTER :: vh
!------------------------------------------------------------------------------
IF ( PRESENT ( dvhartree ) ) THEN
CALL poisson_solver ( n, vhartree, dvhartree )
CALL timeset ( 'HARTREE', 'I', ' ', handle )
IF ( PRESENT ( vhartree ) ) THEN
vh => vhartree
ELSE
CALL poisson_solver ( n, vhartree )
ALLOCATE ( vh, STAT = ierr )
IF ( ierr /= 0 ) call stop_memory ( "calculate_hartree", "vh", 0 )
CALL coeff_allocate ( vh, density )
END IF
CALL poisson_solver ( density, ehartree, vh, dvhartree, h_stress )
eps0 = 1._dbl !TMPTMPTMP
ehartree = 0.5_dbl * integral ( n, vhartree ) / eps0
IF ( .NOT. PRESENT ( vhartree ) ) THEN
CALL coeff_deallocate ( vh )
DEALLOCATE ( vh, STAT = ierr )
IF ( ierr /= 0 ) call stop_memory ( "calculate_hartree", "vh" )
END IF
CALL timestop ( 0.0_dbl, handle )
END SUBROUTINE calculate_hartree
!!*****
!******************************************************************************
!!****** hartree/poisson_solver [1.0] *
!!
!! NAME
!! poisson_solver
!!
!! FUNCTION
!!
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! JGH (12-Mar-2001) : stress
!!
!! SOURCE
!******************************************************************************
SUBROUTINE poisson_solver ( n, vhartree, dvhartree )
!! obtains electrostatic potential and its derivatives with respect to r
!! from the density
SUBROUTINE poisson_solver ( density, ehartree, vhartree, dvhartree, h_stress )
IMPLICIT NONE
! Arguments
TYPE ( coeff_type ), INTENT ( IN ) :: n
TYPE ( coeff_type ), INTENT ( OUT ), OPTIONAL :: vhartree
TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), &
OPTIONAL :: dvhartree
TYPE ( coeff_type ), INTENT ( INOUT ) :: density
REAL ( dbl ), INTENT ( OUT ) :: ehartree
TYPE ( coeff_type ), INTENT ( OUT ) :: vhartree
TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), OPTIONAL :: dvhartree
REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( OUT ), OPTIONAL :: h_stress
!------------------------------------------------------------------------------
IF ( n % in_use == PLANEWAVES ) THEN
IF ( PRESENT ( dvhartree ) ) THEN
CALL pw_poisson_solver ( n, vhartree, dvhartree )
ELSE
CALL pw_poisson_solver ( n, vhartree )
END IF
IF ( density % in_use == PLANEWAVES ) THEN
CALL pw_poisson_solver ( density, ehartree, vhartree, dvhartree, h_stress )
ELSE
stop "poisson_solver, no grid type implemented"
END IF
END SUBROUTINE poisson_solver
!!*****
!******************************************************************************
END MODULE hartree
!******************************************************************************

122
src/initialize_pimd_types.F Normal file
View file

@ -0,0 +1,122 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/initialize_pimd_types [1.0] *
!!
!! NAME
!! initialize_pimd_types
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE initialize_pimd_types
USE structure_types, ONLY : structure_type, pimd_data_type
USE termination, ONLY : stop_memory
USE kinds, ONLY : dbl
USE md, ONLY : simulation_parameters_type
USE transformations, ONLY : r2u, transformation_eigenvalues
IMPLICIT NONE
PRIVATE
PUBLIC :: initialize_pimd
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** md/initialize_pimd [1.0] *
!!
!! NAME
!! initialize_pimd
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE initialize_pimd ( struc, simpar )
IMPLICIT NONE
! Arguments
TYPE ( structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: struc
TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar
! Locals:
INTEGER :: ios,i,j,k,beads,natoms
REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: lambdas
REAL ( dbl ) :: fac, edt, phi
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(lambdas(beads), STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'initialize_pimd', 'lambdas', beads )
CALL transformation_eigenvalues( lambdas, &
simpar % pimd_params % transformation)
edt = simpar % dt / simpar % pimd_params % ndelta
DO i= 1, beads
struc(i) % pimd_data % lbd = lambdas(i)
struc(i) % pimd_data % slbd = SQRT(lambdas(i))
!+++ here is the place for facstage and wmass
IF (lambdas(i) == 0.0_dbl) THEN
struc(i) % pimd_data % meff = 1.0
struc(i) % pimd_data % ismeff = 1.0/SQRT(struc(i)%pimd_data%meff)
struc(i) % pimd_data % harmonic_prop (1,1)=1.0
struc(i) % pimd_data % harmonic_prop(1,2)=edt*struc(i)%pimd_data%ismeff
struc(i) % pimd_data % harmonic_prop(2,1)=0.0
struc(i) % pimd_data % harmonic_prop(2,2)=1.0
ELSE
struc(i) % pimd_data % meff = lambdas(i)
struc(i) % pimd_data % ismeff = 1.0/SQRT(struc(i)%pimd_data%meff)
phi = simpar % pimd_params % wp * edt * &
struc(i) % pimd_data % slbd * struc(i) % pimd_data % ismeff
fac = struc(i) % pimd_data % slbd * simpar % pimd_params % wp
struc(i) % pimd_data % harmonic_prop(1,1) = cos( phi )
struc(i) % pimd_data % harmonic_prop(1,2) = sin( phi ) / fac
struc(i) % pimd_data % harmonic_prop(2,1) = - sin( phi ) * fac
struc(i) % pimd_data % harmonic_prop(2,2) = cos( phi )
END IF
END DO
DEALLOCATE( lambdas , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'initialize_pimd', 'lambdas' )
DO j= 1, beads
ALLOCATE(struc(j)%pimd_data%u(3,natoms), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'initialize_pimd', 'u', 3*natoms)
END DO
CALL r2u( struc, simpar)
END SUBROUTINE initialize_pimd
!!*****
!******************************************************************************
END MODULE initialize_pimd_types
!******************************************************************************

120
src/input_utilities.F
View file

@ -26,12 +26,12 @@ MODULE input_utilities
! Index:
! SUBROUTINE broadcast_input_information(ifail)
! SUBROUTINE close_input_file()
! SUBROUTINE close_file()
! SUBROUTINE finish_input_session()
! SUBROUTINE get_next_input_line(nline,ifail)
! SUBROUTINE get_next_input_string()
! SUBROUTINE get_special_input_character(comment,section)
! SUBROUTINE open_input_file(input_file_name)
! SUBROUTINE open_file(file_name,file_form,file_action,unit_number)
! SUBROUTINE read_integer_object(object,skip_lines)
! SUBROUTINE read_next_input_line(nline,ifail)
! SUBROUTINE read_real_object(object,skip_lines)
@ -89,13 +89,19 @@ MODULE input_utilities
! *** Public subroutines ***
PUBLIC :: finish_input_session,&
PUBLIC :: close_file,&
finish_input_session,&
get_special_input_character,&
open_file,&
read_object,&
search,&
start_input_session,&
test_object
! *** Public functions ***
PUBLIC :: get_unit_number
! *****************************************************************************
INTERFACE read_object
@ -131,7 +137,7 @@ CONTAINS
! *****************************************************************************
SUBROUTINE close_input_file()
SUBROUTINE close_file(unit_number,file_status)
! Purpose: Close the current input file.
@ -139,15 +145,19 @@ CONTAINS
! ***************************************************************************
CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: file_status
INTEGER, INTENT(IN) :: unit_number
! *** Local parameters ***
CHARACTER(LEN=*), PARAMETER :: routine =&
"SUBROUTINE close_input_file (MODULE input_utilities)"
"SUBROUTINE close_file (MODULE input_utilities)"
! *** Local variables ***
CHARACTER(LEN=max_file_name_length) :: input_file_name
CHARACTER(LEN=max_file_name_length) :: file_name
CHARACTER(LEN=max_message_length) :: message
CHARACTER(LEN=6) :: status_string
INTEGER :: istat
LOGICAL :: exists,opened
@ -155,39 +165,45 @@ CONTAINS
! *** Check the specified input file name ***
INQUIRE (UNIT=input_unit,EXIST=exists,OPENED=opened,IOSTAT=istat)
INQUIRE (UNIT=unit_number,EXIST=exists,OPENED=opened,IOSTAT=istat)
IF (istat /= 0) THEN
WRITE (UNIT=message,FMT="(A,I6,A,I6,A)")&
"An error occurred inquiring the input unit ",input_unit,&
"An error occurred inquiring the unit with the number ",unit_number,&
" (IOSTAT = ",istat,")"
CALL compress(message)
CALL stop_program(routine,message)
ELSE IF (.NOT.exists) THEN
WRITE (UNIT=message,FMT="(A,I6,A,I6,A)")&
"The specified input unit ",input_unit," does not exist"
"The specified unit number ",unit_number," does not exist"
CALL compress(message)
CALL stop_program(routine,message)
END IF
! *** Close the specified input file ***
! *** Close the specified file ***
IF (opened) THEN
CLOSE (UNIT=input_unit,IOSTAT=istat,STATUS="KEEP")
IF (PRESENT(file_status)) THEN
status_string = file_status
CALL uppercase(status_string)
ELSE
status_string = "KEEP"
END IF
CLOSE (UNIT=unit_number,IOSTAT=istat,STATUS=TRIM(status_string))
IF (istat /= 0) THEN
WRITE (UNIT=message,FMT="(A,I6,A,I6,A)")&
"An error occurred closing the input file <"//&
TRIM(input_file_name)//"> with the unit number ",input_unit,&
"(IOSTAT = ",istat,")"
"An error occurred closing the file <"//TRIM(file_name)//&
"> with the unit number ",unit_number," (IOSTAT = ",istat,")"
CALL compress(message)
CALL stop_program(routine,message)
END IF
END IF
END SUBROUTINE close_input_file
END SUBROUTINE close_file
! *****************************************************************************
@ -216,7 +232,7 @@ CONTAINS
"Cannot finish an input session that was never "//&
" started")
ELSE
CALL close_input_file()
CALL close_file(unit_number=input_unit)
END IF
END IF
@ -457,79 +473,105 @@ CONTAINS
! *****************************************************************************
SUBROUTINE open_input_file(input_file_name)
SUBROUTINE open_file(file_name,file_status,file_form,file_action,unit_number)
! Purpose: Open the input file with the name "input_file_name".
! Purpose: Open the file with the name "file_name".
! History: - Creation (13.02.2001, Matthias Krack)
! ***************************************************************************
CHARACTER(LEN=*), INTENT(IN) :: input_file_name
CHARACTER(LEN=*), INTENT(IN) :: file_name
CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: file_action,file_form,file_status
INTEGER, INTENT(OUT) :: unit_number
! *** Local parameters ***
CHARACTER(LEN=*), PARAMETER :: routine =&
"SUBROUTINE open_input_file (MODULE input_utilities)"
"SUBROUTINE open_file (MODULE input_utilities)"
! *** Local variables ***
CHARACTER(LEN=max_message_length) :: message
CHARACTER(LEN=11) :: action_string,form_string,&
status_string
INTEGER :: istat
LOGICAL :: exists,opened
! ---------------------------------------------------------------------------
IF (PRESENT(file_status)) THEN
status_string = file_status
CALL uppercase(status_string)
ELSE
status_string = "OLD"
END IF
IF (PRESENT(file_form)) THEN
form_string = file_form
CALL uppercase(form_string)
ELSE
form_string = "FORMATTED"
END IF
IF (PRESENT(file_action)) THEN
action_string = file_action
CALL uppercase(action_string)
ELSE
action_string = "READ"
END IF
! *** Check the specified input file name ***
INQUIRE (FILE=input_file_name,EXIST=exists,OPENED=opened,IOSTAT=istat)
INQUIRE (FILE=file_name,EXIST=exists,OPENED=opened,IOSTAT=istat)
IF (istat /= 0) THEN
WRITE (UNIT=message,FMT="(A,I6,A)")&
"An error occurred inquiring the input file <"//&
TRIM(input_file_name)//"> (IOSTAT = ",istat,")"
"An error occurred inquiring the file <"//TRIM(file_name)//&
"> (IOSTAT = ",istat,")"
CALL stop_program(routine,message)
ELSE IF (.NOT.exists) THEN
CALL stop_program(routine,&
"The specified input file <"//TRIM(input_file_name)//&
"> does not exist")
ELSE IF (status_string == "OLD") THEN
IF (.NOT.exists) THEN
CALL stop_program(routine,&
"The specified file <"//TRIM(file_name)//&
"> does not exist")
END IF
END IF
! *** Open the specified input file ***
IF (opened) THEN
INQUIRE (FILE=input_file_name,NUMBER=input_unit)
REWIND (input_unit)
INQUIRE (FILE=file_name,NUMBER=unit_number)
REWIND (UNIT=unit_number)
ELSE
! *** Find an unused unit number ***
input_unit = get_unit_number()
unit_number = get_unit_number()
IF (input_unit < 0) THEN
IF (unit_number < 0) THEN
CALL stop_program(routine,&
"Could not find a logical unit number which "//&
"exists and is not connected")
END IF
OPEN (UNIT=input_unit,FILE=input_file_name,STATUS="OLD",&
ACCESS="SEQUENTIAL",FORM="FORMATTED",POSITION="REWIND",&
ACTION="READ",IOSTAT=istat)
OPEN (UNIT=unit_number,FILE=file_name,STATUS=TRIM(status_string),&
ACCESS="SEQUENTIAL",FORM=TRIM(form_string),POSITION="REWIND",&
ACTION=TRIM(action_string),IOSTAT=istat)
IF (istat /= 0) THEN
WRITE (UNIT=message,FMT="(A,I6,A,I6,A)")&
"An error occurred opening the input file <"//&
TRIM(input_file_name)//"> with the unit number ",input_unit,&
"(IOSTAT = ",istat,")"
"An error occurred opening the file <"//TRIM(file_name)//&
"> with the unit number ",unit_number," (IOSTAT = ",istat,")"
CALL compress(message)
CALL stop_program(routine,message)
END IF
END IF
END SUBROUTINE open_input_file
END SUBROUTINE open_file
! *****************************************************************************
@ -951,7 +993,7 @@ CONTAINS
IF (ionode) THEN
IF (input_unit == 0) THEN
CALL open_input_file(input_file_name)
CALL open_file(file_name=input_file_name,unit_number=input_unit)
ELSE
WRITE (UNIT=output_unit,FMT="(/,T2,A,I6,/,T2,A)")&
"Current input unit: ",input_unit,&

408
src/integrate_potential.F Normal file
View file

@ -0,0 +1,408 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/integrate_potential [1.0] *
!!
!! NAME
!! integrate_potential
!!
!! FUNCTION
!! Build up the plane wave density by collocating the primitive Gaussian
!! functions (pgf).
!!
!! AUTHOR
!! Matthias Krack (03.04.2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE integrate_potential
! *****************************************************************************
USE kinds, ONLY: wp => dp
USE atomic_kinds, ONLY: kind_info,nkind
USE atoms, ONLY: atom_info
USE basis_set_types, ONLY: gto_basis_set_type,maxco,maxsgf,maxsgf_set
USE coefficient_types, ONLY: coeff_type
USE mathlib, ONLY: symmetrize_matrix
USE matrix_types, ONLY: get_block_node,&
real_matrix_set_type
USE memory_utilities, ONLY: reallocate
USE neighbor_list_types, ONLY: extract_neighbor_list,&
find_neighbor_list,&
first_neighbor_list,&
first_neighbor_node,&
get_neighbor_list,&
get_neighbor_node,&
neighbor_list_type,&
neighbor_node_type,&
next_neighbor_list,&
next_neighbor_node
USE nl, ONLY: orb_neighbor_list_set
USE orbital_pointers, ONLY: coset,indco,ncoset
USE pw_types, ONLY: pw_type
USE timings, ONLY: timeset,timestop
IMPLICIT NONE
PRIVATE
INTEGER :: npgf_product = 0
PUBLIC :: integrate_v_rspace
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE integrate_v_rspace(v_rspace,h,nproduct)
TYPE(coeff_type), INTENT(IN) :: v_rspace
TYPE(real_matrix_set_type), INTENT(INOUT) :: h
INTEGER, OPTIONAL, INTENT(OUT) :: nproduct
! *** Local variables ***
TYPE(gto_basis_set_type), POINTER :: basis_set_a,basis_set_b
TYPE(neighbor_list_type), POINTER :: orb_neighbor_list
REAL(wp) :: dab,rab2,radius_kind_a,radius_kind_b,radius_set_a,radius_set_b
INTEGER :: first_isgf,first_jset,first_jsgf,first_sgfa,&
first_sgfb,handle,iatom,ico,ikind,ineighbor,ipgf,iset,isgf,&
isgfa,isgfb,ishell,istat,jatom,jco,jkind,jneighbor,jpgf,jset,&
jsgf,jshell,la_max,la_min,last_sgfa,last_sgfb,lb_max,lb_min,&
na1,na2,nb1,nb2,nsgfa,nsgfb,ncoa,ncob,npgfa,npgfb,nseta,nsetb,&
nshella,nshellb
REAL(wp), DIMENSION(3) :: ra,rab
INTEGER, DIMENSION(:), POINTER :: orb_neighbors
REAL(wp), DIMENSION(:), POINTER :: orb_r2,rpgfa,rpgfb,zeta,zetb
REAL(wp), DIMENSION(:,:), POINTER :: h_block,hab,orb_r,work
! ---------------------------------------------------------------------------
CALL timeset("integrate_v_rspace","I","",handle)
npgf_product = 0
! *** Allocate work storage ***
NULLIFY (hab,work)
hab => reallocate(hab,1,maxco,1,maxco)
work => reallocate(work,1,maxco,1,maxsgf_set)
NULLIFY (orb_neighbor_list,orb_neighbors,orb_r,orb_r2)
! *** Loop over all atoms ***
orb_neighbor_list => first_neighbor_list(orb_neighbor_list_set)
DO WHILE (ASSOCIATED(orb_neighbor_list))
CALL get_neighbor_list(orb_neighbor_list,iatom)
CALL extract_neighbor_list(orb_neighbor_list,orb_r2,orb_neighbors,orb_r)
ikind = atom_info(iatom)%kind
first_isgf = atom_info(iatom)%first_sgf
ra(:) = atom_info(iatom)%r_pbc(:)
basis_set_a => kind_info(ikind)%orb_basis_set
nseta = basis_set_a%nset
radius_kind_a = basis_set_a%kind_radius
! *** Loop over all neighbor atoms of the current atom "iatom" ***
DO ineighbor=1,SIZE(orb_neighbors)
jatom = orb_neighbors(ineighbor)
! *** Skip all atomic blocks in the lower triangle matrix ***
IF (iatom > jatom) CYCLE
jkind = atom_info(jatom)%kind
first_jsgf = atom_info(jatom)%first_sgf
rab2 = orb_r2(ineighbor)
rab(:) = orb_r(:,ineighbor)
dab = SQRT(rab2)
basis_set_b => kind_info(jkind)%orb_basis_set
nsetb = basis_set_b%nset
radius_kind_b = basis_set_b%kind_radius
CALL get_block_node(matrix=h%matrix,&
block_row=iatom,&
block_col=jatom,&
block=h_block)
DO iset=1,nseta
radius_set_a = basis_set_a%set_radius(iset)
IF (radius_set_a + radius_kind_b < dab) CYCLE
la_max = basis_set_a%lmax(iset)
la_min = basis_set_a%lmin(iset)
npgfa = basis_set_a%npgf(iset)
nshella = basis_set_a%nshell(iset)
rpgfa => basis_set_a%pgf_radius(1:npgfa,iset)
zeta => basis_set_a%zet(1:npgfa,iset)
first_sgfa = basis_set_a%first_sgf(1,iset)
last_sgfa = basis_set_a%last_sgf(nshella,iset)
nsgfa = last_sgfa - first_sgfa + 1
ncoa = npgfa*ncoset(la_max)
IF (iatom == jatom) THEN
first_jset = iset
ELSE
first_jset = 1
END IF
DO jset=first_jset,nsetb
radius_set_b = basis_set_b%set_radius(jset)
IF (radius_set_a + radius_set_b < dab) CYCLE
lb_max = basis_set_b%lmax(jset)
lb_min = basis_set_b%lmin(jset)
npgfb = basis_set_b%npgf(jset)
nshellb = basis_set_b%nshell(jset)
rpgfb => basis_set_b%pgf_radius(1:npgfb,jset)
zetb => basis_set_b%zet(1:npgfb,jset)
first_sgfb = basis_set_b%first_sgf(1,jset)
last_sgfb = basis_set_b%last_sgf(nshellb,jset)
nsgfb = last_sgfb - first_sgfb + 1
ncob = npgfb*ncoset(lb_max)
DO jco=1,ncob
DO ico=1,ncoa
hab(ico,jco) = 0.0_wp
END DO
END DO
DO ipgf=1,npgfa
IF (rpgfa(ipgf) + radius_set_b < dab) CYCLE
na1 = (ipgf - 1)*ncoset(la_max) + 1
na2 = ipgf*ncoset(la_max)
DO jpgf=1,npgfb
IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) CYCLE
nb1 = (jpgf - 1)*ncoset(lb_max) + 1
nb2 = jpgf*ncoset(lb_max)
CALL integrate_pgf_product_rspace(la_max,zeta(ipgf),la_min,&
lb_max,zetb(jpgf),lb_min,&
ra,rab,rab2,v_rspace%pw,&
hab(na1:na2,nb1:nb2))
END DO
END DO
! *** Contract the operator matrix set block ***
CALL dgemm("N","N",ncoa,nsgfb,ncob,1.0_wp,hab(1,1),SIZE(hab,1),&
basis_set_b%sphi(1,first_sgfb),&
SIZE(basis_set_b%sphi,1),0.0_wp,work(1,1),SIZE(work,1))
CALL dgemm("T","N",nsgfa,nsgfb,ncoa,1.0_wp,&
basis_set_a%sphi(1,first_sgfa),&
SIZE(basis_set_a%sphi,1),work(1,1),SIZE(work,1),1.0_wp,&
h_block(first_sgfa,first_sgfb),SIZE(h_block,1))
END DO
END DO
IF (iatom == jatom) CALL symmetrize_matrix(h_block,"upper_to_lower")
END DO
orb_neighbor_list => next_neighbor_list(orb_neighbor_list)
END DO
IF (PRESENT(nproduct)) nproduct = npgf_product
DEALLOCATE (hab,work)
CALL timestop(0.0_wp,handle)
END SUBROUTINE integrate_v_rspace
! *****************************************************************************
SUBROUTINE integrate_pgf_product_rspace(la_max,zeta,la_min,&
lb_max,zetb,lb_min,&
ra,rab,rab2,pw,hab)
USE interactions, ONLY: eps_rho_rspace,exp_radius
TYPE(pw_type), TARGET, INTENT(IN) :: pw
REAL(wp), INTENT(IN) :: rab2,zeta,zetb
INTEGER, INTENT(IN) :: la_max,la_min,lb_max,lb_min
REAL(wp), DIMENSION(3), INTENT(IN) :: ra,rab
REAL(wp), DIMENSION(ncoset(la_max),ncoset(lb_max)), INTENT(INOUT) :: hab
! *** Local variables ***
REAL(wp) :: f,prefactor,radius,yz,z,zetp
INTEGER :: ax,ay,az,bx,by,bz,handle,i,ico,ig,j,jco,jg,k,kg,la,lb,&
lb_cube_min,ub_cube_max
REAL(wp), DIMENSION(3) :: rap,rbp,roffset,rp
INTEGER, DIMENSION(3) :: cubecenter,lb_cube,ub_cube
REAL(wp), DIMENSION(:), POINTER :: dr,rag,rbg,rpg
INTEGER, DIMENSION(:), POINTER :: ng
INTEGER, DIMENSION(:,:), POINTER :: map
REAL(wp), DIMENSION(:,:,:), POINTER :: grid
REAL(wp), DIMENSION(:,:,:,:), POINTER :: cubeaxis
! ---------------------------------------------------------------------------
CALL timeset("integrate_pgf_product_rspace","I","",handle)
zetp = zeta + zetb
f = zetb/zetp
prefactor = EXP(-zeta*f*rab2)
radius = exp_radius(0,zetp,eps_rho_rspace,prefactor)
IF (radius == 0.0_wp) THEN
CALL timestop(0.0_wp,handle)
RETURN
END IF
npgf_product = npgf_product + (ncoset(la_max) - ncoset(la_min-1))*&
(ncoset(lb_max) - ncoset(lb_min-1))
dr => pw%pw_grid%dr(:)
ng => pw%pw_grid%npts(:)
grid => pw%cr3d(:,:,:)
rap(:) = f*rab(:)
rbp(:) = rap(:) - rab(:)
rp(:) = ra(:) + rap(:)
cubecenter(:) = FLOOR(rp(:)/dr(:))
roffset(:) = rp(:) - REAL(cubecenter(:),wp)*dr(:)
lb_cube(:) = FLOOR(-radius/dr(:))
ub_cube(:) = CEILING(radius/dr(:))
! *** Calculate the Gaussian function values for each cube axis ***
lb_cube_min = MINVAL(lb_cube(:))
ub_cube_max = MAXVAL(ub_cube(:))
NULLIFY (cubeaxis,map,rag,rbg,rpg)
cubeaxis => reallocate(cubeaxis,lb_cube_min,ub_cube_max,1,3,0,la_max,&
0,lb_max)
map => reallocate(map,lb_cube_min,ub_cube_max,1,3)
rag => reallocate(rag,lb_cube_min,ub_cube_max)
rbg => reallocate(rbg,lb_cube_min,ub_cube_max)
rpg => reallocate(rpg,lb_cube_min,ub_cube_max)
DO i=1,3
DO ig=lb_cube(i),ub_cube(i)
map(ig,i) = MODULO(cubecenter(i) + ig,ng(i)) + 1
rpg(ig) = REAL(ig,wp)*dr(i) - roffset(i)
cubeaxis(ig,i,0,0) = EXP(-zetp*rpg(ig)**2)
END DO
IF (la_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rag(ig) = rap(i) + rpg(ig)
cubeaxis(ig,i,1,0) = rag(ig)*cubeaxis(ig,i,0,0)
END DO
DO la=2,la_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,0) = rag(ig)*cubeaxis(ig,i,la-1,0)
END DO
END DO
IF (lb_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rbg(ig) = rag(ig) - rab(i)
END DO
DO la=0,la_max
DO lb=1,lb_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,la,lb) = rbg(ig)*cubeaxis(ig,i,la,lb-1)
END DO
END DO
END DO
END IF
ELSE
IF (lb_max > 0) THEN
DO ig=lb_cube(i),ub_cube(i)
rbg(ig) = rbp(i) + rpg(ig)
cubeaxis(ig,i,0,1) = rbg(ig)*cubeaxis(ig,i,0,0)
END DO
DO lb=2,lb_max
DO ig=lb_cube(i),ub_cube(i)
cubeaxis(ig,i,0,lb) = rbg(ig)*cubeaxis(ig,i,0,lb-1)
END DO
END DO
END IF
END IF
END DO
! *** Add the current Gaussian function product to grid ***
DO ico=ncoset(la_min-1)+1,ncoset(la_max)
ax = indco(1,ico)
ay = indco(2,ico)
az = indco(3,ico)
DO jco=ncoset(lb_min-1)+1,ncoset(lb_max)
bx = indco(1,jco)
by = indco(2,jco)
bz = indco(3,jco)
DO kg=lb_cube(3),ub_cube(3)
k = map(kg,3)
z = prefactor*cubeaxis(kg,3,az,bz)
IF (ABS(z) < eps_rho_rspace) CYCLE
DO jg=lb_cube(2),ub_cube(2)
j = map(jg,2)
yz = cubeaxis(jg,2,ay,by)*z
IF (ABS(yz) < eps_rho_rspace) CYCLE
DO ig=lb_cube(1),ub_cube(1)
i = map(ig,1)
hab(ico,jco) = hab(ico,jco) + grid(i,j,k)*cubeaxis(ig,1,ax,bx)*yz
END DO
END DO
END DO
END DO
END DO
DEALLOCATE (cubeaxis,map,rag,rbg,rpg)
CALL timestop(0.0_wp,handle)
END SUBROUTINE integrate_pgf_product_rspace
! *****************************************************************************
END MODULE integrate_potential

508
src/integrator.F
View file

@ -15,7 +15,8 @@
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!! JGH (15-Mar-2001) : Pass logical for box change to force routine
!! Harald Forbert (Apr-2001): added path integral routine pimd_nvt
!!
!! SOURCE
!******************************************************************************
@ -37,13 +38,14 @@ MODULE integrator
mdio_parameters_type
USE molecule_types, ONLY : molecule_structure_type, particle_node_type, &
linklist_atoms
USE message_passing, ONLY : mp_sum
USE nose, ONLY : lnhc_parameters_type, npt_info_type, lnhc
USE message_passing, ONLY : mp_sum, mp_sync, mp_comm_dup
USE nose, ONLY : lnhc_parameters_type, npt_info_type, lnhc, yoshida_coef
USE particle_types, ONLY : particle_type
USE simulation_cell, ONLY : get_cell_param
USE structure_types, ONLY : structure_type, interaction_type
USE termination, ONLY : stop_memory, stop_program
USE timings, ONLY : timeset, timestop
USE transformations, ONLY : u2r, fr2fu
USE util, ONLY : get_unit, matvec_3x3, matmul_3x3, transpose_3d
IMPLICIT NONE
@ -113,8 +115,9 @@ SUBROUTINE velocity_verlet ( itimes, constant, simpar, inter, &
REAL ( dbl ), INTENT ( INOUT ) :: constant
TYPE ( simulation_parameters_type ), INTENT ( IN ) :: simpar
TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo
TYPE ( structure_type ), INTENT ( INOUT ) :: struc
TYPE ( lnhc_parameters_type ), INTENT ( INOUT ) :: nhc_part, nhc_baro
TYPE ( structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: struc
TYPE ( lnhc_parameters_type ), DIMENSION ( : ), &
INTENT ( INOUT ) :: nhc_part, nhc_baro
TYPE ( npt_info_type ), INTENT ( INOUT ), DIMENSION ( :, : ) :: npt
TYPE ( ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param
TYPE ( interaction_type ), INTENT ( IN ) :: inter
@ -125,24 +128,34 @@ SUBROUTINE velocity_verlet ( itimes, constant, simpar, inter, &
!------------------------------------------------------------------------------
CALL timeset ( 'VERLET', 'I', ' ', handle )
SELECT CASE ( simpar % ensemble )
CASE DEFAULT
CALL stop_program ( 'velocity_verlet','integrator not implemented')
CASE ( 'NVE')
CALL nve ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
dft_control, kp )
CASE ( 'NVT')
CALL nvt ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
nhc_part, dft_control, kp )
CASE ( 'NPT_I')
CALL npt_i(itimes,constant,simpar,inter,thermo,struc,ewald_param, &
nhc_part,nhc_baro,npt, dft_control, kp )
CASE ( 'NPT_F')
CALL npt_f(itimes,constant,simpar,inter,thermo,struc,ewald_param, &
nhc_part,nhc_baro,npt, dft_control, kp )
END SELECT
CALL energy(itimes,constant,simpar,struc,thermo,nhc_part,nhc_baro,npt)
IF (simpar % pimd_params % beads > 0) THEN
SELECT CASE ( simpar % ensemble )
CASE DEFAULT
CALL stop_program('velocity','PIMD not possible yet with this integrator')
CASE ( 'NVT' )
CALL pimd_nvt(itimes,constant,simpar,inter,thermo,struc, &
ewald_param, nhc_part, dft_control, kp )
END SELECT
CALL energy(itimes,constant,simpar,struc,thermo,nhc_part,nhc_baro,npt)
ELSE
SELECT CASE ( simpar % ensemble )
CASE DEFAULT
CALL stop_program ( 'velocity_verlet','integrator not implemented')
CASE ( 'NVE')
CALL nve ( itimes, constant, simpar, inter, thermo, struc(1), ewald_param, &
dft_control, kp )
CASE ( 'NVT')
CALL nvt ( itimes, constant, simpar, inter, thermo, struc(1), ewald_param, &
nhc_part(1), dft_control, kp )
CASE ( 'NPT_I')
CALL npt_i(itimes,constant,simpar,inter,thermo,struc(1),ewald_param, &
nhc_part(1),nhc_baro(1),npt, dft_control, kp )
CASE ( 'NPT_F')
CALL npt_f(itimes,constant,simpar,inter,thermo,struc(1),ewald_param, &
nhc_part(1),nhc_baro(1),npt, dft_control, kp )
END SELECT
CALL energy(itimes,constant,simpar,struc,thermo,nhc_part,nhc_baro,npt)
END IF
CALL timestop ( zero, handle )
@ -162,7 +175,7 @@ END SUBROUTINE velocity_verlet
!! JGH
!!
!! MODIFICATION HISTORY
!! none
!! JGH (29-Mar-2001) : duplicate communicator, instead of copy
!!
!! NOTES
!! Call this subroutine before the first call to energy or velocity_verlet
@ -173,6 +186,7 @@ END SUBROUTINE velocity_verlet
SUBROUTINE set_integrator ( globenv, mdio )
IMPLICIT NONE
! Arguments
@ -182,10 +196,11 @@ SUBROUTINE set_integrator ( globenv, mdio )
!------------------------------------------------------------------------------
intenv = globenv
CALL mp_comm_dup ( globenv % group, intenv % group )
ionode = globenv % ionode
int_group = globenv % group
scr = globenv % scr
ionode = intenv % ionode
int_group = intenv % group
scr = intenv % scr
crd_file_name = mdio % crd_file_name
vel_file_name = mdio % vel_file_name
@ -273,9 +288,9 @@ SUBROUTINE energy ( itimes, constant, simpar, struc, thermo, &
INTEGER, INTENT ( IN ) :: itimes
REAL ( dbl ), INTENT ( INOUT ) :: constant
TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar
TYPE (structure_type ), INTENT ( INOUT ) :: struc
TYPE (structure_type ), DIMENSION(:), INTENT ( INOUT ) :: struc
TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo
TYPE (lnhc_parameters_type ), INTENT ( INOUT ) :: nhc_part, nhc_baro
TYPE (lnhc_parameters_type ), DIMENSION(:), INTENT ( INOUT ) :: nhc_part, nhc_baro
TYPE (npt_info_type ), INTENT ( INOUT ), DIMENSION ( :, : ) :: npt
! Locals
@ -306,11 +321,11 @@ SUBROUTINE energy ( itimes, constant, simpar, struc, thermo, &
iw = scr
thermo % kin = zero
nnodes = SIZE ( struc % pnode )
nnodes = SIZE ( struc(1) % pnode )
DO i = 1, nnodes
thermo%kin = thermo%kin + 0.5_dbl*struc%pnode(i) %p%prop%mass*(struc &
%pnode(i)%p%v(1)*struc%pnode(i)%p%v(1)+struc%pnode(i)%p%v(2)*struc &
%pnode(i)%p%v(2)+struc%pnode(i)%p%v(3)*struc%pnode(i)%p%v(3))
thermo%kin = thermo%kin + 0.5_dbl*struc(1)%pnode(i) %p%prop%mass*(struc(1) &
%pnode(i)%p%v(1)*struc(1)%pnode(i)%p%v(1)+struc(1)%pnode(i)%p%v(2)*struc(1) &
%pnode(i)%p%v(2)+struc(1)%pnode(i)%p%v(3)*struc(1)%pnode(i)%p%v(3))
END DO
! sum all contributions to energy over calculated parts on all processors
@ -331,31 +346,31 @@ SUBROUTINE energy ( itimes, constant, simpar, struc, thermo, &
IF (ionode .AND. mod(itimes,icrd)==0) THEN
DO i=1, nnodes
WRITE (crd,'(i6,3(2x,f12.5) )' ) itimes, struc%pnode(i) %p%r
WRITE (crd,'(i6,3(2x,f12.5) )' ) itimes, struc(1)%pnode(i) %p%r
END DO
END IF
IF (ionode .AND. mod(itimes,ivel)==0) THEN
IF (ionode .AND. mod(itimes,ivel)==0) THEN
DO i=1, nnodes
WRITE (vel,'(i6,3f10.5 )' ) itimes, struc%pnode(i) %p%v
WRITE (vel,'(i6,3f10.5 )' ) itimes, struc(1)%pnode(i) %p%v
END DO
END IF
IF (simpar%ensemble/='NVE') THEN
nhc_part_kin = 0.0_dbl
nhc_part_pot = 0.0_dbl
DO n = 1, nhc_part % num_nhc
DO l = 1, nhc_part % nhc_len
DO n = 1, nhc_part(1) % num_nhc
DO l = 1, nhc_part(1) % nhc_len
nhc_part_kin = nhc_part_kin + &
0.5_dbl * nhc_part % nvt ( l, n ) % mass * &
nhc_part % nvt ( l, n ) % v * nhc_part % nvt ( l, n ) % v
0.5_dbl * nhc_part(1) % nvt ( l, n ) % mass * &
nhc_part(1) % nvt ( l, n ) % v * nhc_part(1) % nvt ( l, n ) % v
nhc_part_pot = nhc_part_pot + nhc_part % nvt ( l, n ) % nkt * &
nhc_part % nvt ( l, n ) % eta
nhc_part_pot = nhc_part_pot + nhc_part(1) % nvt ( l, n ) % nkt * &
nhc_part(1) % nvt ( l, n ) % eta
END DO
END DO
#if defined(__parallel)
IF (nhc_part%dis_type=='DIS_REP') THEN
IF (nhc_part(1)%dis_type=='DIS_REP') THEN
CALL mp_sum(nhc_part_kin,int_group)
CALL mp_sum(nhc_part_pot,int_group)
END IF
@ -365,18 +380,18 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
IF (simpar%ensemble (1:3 ) == 'NPT' ) THEN
nhc_baro_kin = 0.0_dbl
nhc_baro_pot = 0.0_dbl
DO n = 1, nhc_baro % num_nhc
DO l = 1, nhc_baro % nhc_len
DO n = 1, nhc_baro(1) % num_nhc
DO l = 1, nhc_baro(1) % nhc_len
nhc_baro_kin = nhc_baro_kin + &
0.5_dbl * nhc_baro % nvt ( l, n ) % mass * &
nhc_baro % nvt ( l, n ) % v * nhc_baro % nvt ( l, n ) % v
0.5_dbl * nhc_baro(1) % nvt ( l, n ) % mass * &
nhc_baro(1) % nvt ( l, n ) % v * nhc_baro(1) % nvt ( l, n ) % v
nhc_baro_pot = nhc_baro_pot + nhc_baro % nvt ( l, n ) % nkt * &
nhc_baro % nvt ( l, n ) % eta
nhc_baro_pot = nhc_baro_pot + nhc_baro(1) % nvt ( l, n ) % nkt * &
nhc_baro(1) % nvt ( l, n ) % eta
END DO
END DO
#if defined(__parallel)
IF (nhc_part%dis_type=='DIS_REP') THEN
IF (nhc_part(1)%dis_type=='DIS_REP') THEN
CALL mp_sum(nhc_baro_kin,int_group)
CALL mp_sum(nhc_baro_pot,int_group)
END IF
@ -384,11 +399,11 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
END IF
IF ( simpar%ensemble == 'NPT_I' ) THEN
baro_pot = simpar % p_ext * struc % box % deth
baro_pot = simpar % p_ext * struc(1) % box % deth
baro_kin = 0.5_dbl * npt ( 1, 1 ) % v * npt ( 1, 1 ) % v * &
npt ( 1, 1 ) % mass
ELSE IF ( simpar%ensemble=='NPT_F' ) THEN
baro_pot = simpar % p_ext * struc % box % deth
baro_pot = simpar % p_ext * struc(1) % box % deth
baro_kin = 0._dbl
DO i = 1, 3
DO j = 1, 3
@ -400,7 +415,7 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
IF (simpar%ensemble(1:3)=='NPT') THEN
#if defined(__parallel)
IF (nhc_baro%dis_type=='DIS_REP') THEN
IF (nhc_baro(1)%dis_type=='DIS_REP') THEN
CALL mp_sum(baro_kin,int_group)
CALL mp_sum(baro_pot,int_group)
END IF
@ -423,12 +438,12 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
IF (itimes /= 0 ) econs = abs((cons-constant)/constant)
! cell parameters:
CALL get_cell_param ( struc % box, cell, ang )
CALL get_cell_param ( struc(1) % box, cell, ang )
! initializing pv_const=0
IF (itimes==0) THEN
thermo%pv_const = 0._dbl
CALL pressure(struc%pnode,thermo)
CALL pressure(struc(1)%pnode,thermo)
END IF
! computing the scalar pressure
@ -436,7 +451,7 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
DO i = 1, 3
pv_scalar = pv_scalar + thermo%ptens(i,i)
END DO
pv_scalar = pv_scalar/3._dbl/struc%box%deth
pv_scalar = pv_scalar/3._dbl/struc(1)%box%deth
pv_scalar = pv_scalar*p_conv
! average quantities:
@ -452,7 +467,7 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
averages%avetemp = temp
averages%avepot = thermo%pot
averages%avekin = thermo%kin
averages%avevol = struc%box%deth
averages%avevol = struc(1)%box%deth
averages%aveca = cell(1)
averages%avecb = cell(2)
averages%avecc = cell(3)
@ -469,7 +484,7 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
real(itimes)
averages%avekin = (averages%avekin*real(itimes-1)+thermo%kin)/ &
real(itimes)
averages%avevol = (averages%avevol*real(itimes-1)+struc%box%deth)/ &
averages%avevol = (averages%avevol*real(itimes-1)+struc(1)%box%deth)/ &
real(itimes)
averages%aveca = (averages%aveca*real(itimes-1)+cell(1))/real(itimes)
averages%avecb = (averages%avecb*real(itimes-1)+cell(2))/real(itimes)
@ -532,7 +547,7 @@ IF (ionode .AND. mod(itimes,ivel)==0) THEN
adjustl(temp_label), '= ', temp, averages%avetemp
WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' PRESSURE', &
adjustl(pres_label), '= ', pv_scalar, averages%avepress
CALL get_ll_parm ( struc % ll_data, lup, aup )
CALL get_ll_parm ( struc(1) % ll_data, lup, aup )
IF (simpar%ensemble(1:3)=='NPT') THEN
WRITE ( iw, '( A,A,T31,A,T49,2(1X,E15.7) )' ) ' VOLUME', &
adjustl(vol_label), '= ', struc%box%deth, averages%avevol
@ -562,9 +577,22 @@ END SUBROUTINE energy
!!*****
!******************************************************************************
! nve integrator for particle positions & momenta
! velocity Verlet
!!****** integrator/nve [1.0] *
!!
!! NAME
!! nve
!!
!! FUNCTION
!! nve integrator for particle positions & momenta
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE nve ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
dft_control, kp )
@ -585,6 +613,7 @@ SUBROUTINE nve ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
! Local
INTEGER :: i, nnodes
REAL ( dbl ) :: dtom
LOGICAL, PARAMETER :: box_change = .FALSE.
!------------------------------------------------------------------------------
@ -618,8 +647,8 @@ SUBROUTINE nve ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
!
! get new forces
!
CALL force ( struc, inter, thermo, simpar, ewald_param, intenv, &
dft_control, kp )
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
intenv, dft_control, kp )
!
! second half of velocity verlet
@ -647,6 +676,23 @@ SUBROUTINE nve ( itimes, constant, simpar, inter, thermo, struc, ewald_param, &
END SUBROUTINE nve
!!*****
!******************************************************************************
!!****** integrator/nvt [1.0] *
!!
!! NAME
!! nvt
!!
!! FUNCTION
!! nvt integrator for particle positions & momenta
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE nvt ( itimes, constant, simpar, inter, thermo, struc, &
@ -669,6 +715,7 @@ SUBROUTINE nvt ( itimes, constant, simpar, inter, thermo, struc, &
! Locals
INTEGER :: i, nnodes
REAL ( dbl ) :: dtom
LOGICAL, PARAMETER :: box_change = .FALSE.
!------------------------------------------------------------------------------
@ -704,9 +751,8 @@ SUBROUTINE nvt ( itimes, constant, simpar, inter, thermo, struc, &
!
! get new forces
!
CALL force ( struc, inter, thermo, simpar, ewald_param, intenv, &
dft_control, kp )
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
intenv, dft_control, kp )
!
! second half of velocity verlet
!
@ -735,6 +781,24 @@ SUBROUTINE nvt ( itimes, constant, simpar, inter, thermo, struc, &
END SUBROUTINE nvt
!!*****
!******************************************************************************
!!****** integrator/npt_i [1.0] *
!!
!! NAME
!! npt_i
!!
!! FUNCTION
!! npt_i integrator for particle positions & momenta
!! isotropic box changes
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE npt_i ( itimes, constant, simpar, inter, thermo, struc, &
@ -764,6 +828,7 @@ SUBROUTINE npt_i ( itimes, constant, simpar, inter, thermo, struc, &
REAL ( dbl ) :: arg_r, poly_r, scale_r, roll_tol
REAL ( dbl ) :: arg_v, poly_v, scale_v, kin, fdotr, infree
REAL ( dbl ), DIMENSION (3) :: vector_r, vector_v
LOGICAL, PARAMETER :: box_change = .TRUE.
LOGICAL :: first
!------------------------------------------------------------------------------
@ -853,8 +918,8 @@ SUBROUTINE npt_i ( itimes, constant, simpar, inter, thermo, struc, &
!
! get new forces
!
CALL force ( struc, inter, thermo, simpar, ewald_param, intenv, &
dft_control, kp )
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
intenv, dft_control, kp )
!
! second half of velocity verlet
@ -902,10 +967,25 @@ SUBROUTINE npt_i ( itimes, constant, simpar, inter, thermo, struc, &
END SUBROUTINE npt_i
!!*****
!******************************************************************************
!!****** integrator/pressure [1.0] *
!!
!! NAME
!! pressure
!!
!! FUNCTION
!! Computes the kinetic part of the pressure tensor and updates
!! the full VIRIAL (PV)
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
! computes the kinetic part of the pressure tensor and updates
! the full VIRIAL (PV)
SUBROUTINE pressure ( pnode, thermo )
@ -947,6 +1027,22 @@ SUBROUTINE pressure ( pnode, thermo )
END SUBROUTINE pressure
!!*****
!******************************************************************************
!!****** integrator/update_structure [1.0] *
!!
!! NAME
!! update_structure
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE update_structure(struc,task)
@ -966,7 +1062,7 @@ SUBROUTINE update_structure(struc,task)
CALL timeset ( 'UPDATE_STRUCTURE', 'E', ' ', handle )
natoms = size(struc%part)
natoms = SIZE ( struc % part )
ALLOCATE (atot(3,natoms),STAT=ios)
IF ( ios /= 0 ) CALL stop_memory ( 'update_structure', 'atot', 3 * natoms )
atot = zero
@ -1012,6 +1108,22 @@ SUBROUTINE update_structure(struc,task)
END SUBROUTINE update_structure
!!*****
!******************************************************************************
!!****** integrator/set [1.0] *
!!
!! NAME
!! set
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE set(struc,npt,char)
@ -1067,6 +1179,23 @@ SUBROUTINE set(struc,npt,char)
END SUBROUTINE set
!!*****
!******************************************************************************
!!****** integrator/npt_f [1.0] *
!!
!! NAME
!! npt_f
!!
!! FUNCTION
!! Velocity Verlet integrator for the NPT ensemble with fully flexible cell
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE npt_f ( itimes, constant, simpar, inter, thermo, struc, &
@ -1097,6 +1226,7 @@ SUBROUTINE npt_f ( itimes, constant, simpar, inter, thermo, struc, &
REAL ( dbl ), DIMENSION (3,3) :: pv_kinetic, u, uh
REAL ( dbl ), DIMENSION (3) :: arg_r, poly_r, scale_r, e_val, ur, uv, uf
REAL ( dbl ), DIMENSION (3) :: arg_v, poly_v, scale_v
LOGICAL, PARAMETER :: box_change = .TRUE.
LOGICAL :: first
!------------------------------------------------------------------------------
@ -1194,8 +1324,8 @@ SUBROUTINE npt_f ( itimes, constant, simpar, inter, thermo, struc, &
!
! get new forces
!
CALL force ( struc, inter, thermo, simpar, ewald_param, intenv, &
dft_control, kp )
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
intenv, dft_control, kp )
!
! second half of velocity verlet
@ -1241,6 +1371,22 @@ SUBROUTINE npt_f ( itimes, constant, simpar, inter, thermo, struc, &
END SUBROUTINE npt_f
!!*****
!******************************************************************************
!!****** integrator/rattle_roll_setup [1.0] *
!!
!! NAME
!! rattle_roll_setup
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE rattle_roll_setup ( npt, struc, thermo, simpar, vector_v, &
@ -1293,6 +1439,22 @@ SUBROUTINE rattle_roll_setup ( npt, struc, thermo, simpar, vector_v, &
END SUBROUTINE rattle_roll_setup
!!*****
!******************************************************************************
!!****** integrator/get_veps [1.0] *
!!
!! NAME
!! get_veps
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE get_veps ( npt, simpar, struc, thermo, infree )
@ -1366,6 +1528,202 @@ SUBROUTINE get_veps ( npt, simpar, struc, thermo, infree )
END SUBROUTINE get_veps
!!*****
!******************************************************************************
!!****** integrator/pimd_nvt [1.0] *
!!
!! NAME
!! pimd_nvt
!!
!! FUNCTION
!! pimd_nvt integrator for particle positions & momenta
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE pimd_nvt(itimes,constant,simpar,inter,thermo,struc, &
ewald_param,nhc,dft_control,kp)
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: itimes
REAL ( dbl ), INTENT ( INOUT ) :: constant
TYPE (simulation_parameters_type ), INTENT ( IN ) :: simpar
TYPE (thermodynamic_type ), INTENT ( INOUT ) :: thermo
TYPE (structure_type ), DIMENSION ( : ), INTENT ( INOUT ) :: struc
TYPE (lnhc_parameters_type ), DIMENSION ( : ), INTENT ( INOUT ) :: nhc
TYPE (ewald_parameters_type ), INTENT ( INOUT ) :: ewald_param
TYPE (interaction_type ), INTENT ( IN ) :: inter
TYPE ( dft_control_type ) :: dft_control
TYPE ( kpoint_type ), INTENT ( IN ) :: kp
! Locals
INTEGER :: i, j, k, nnodes, beads
REAL ( dbl ) :: dtom, transdt, old_u, fac
LOGICAL, PARAMETER :: box_change=.false.
!------------------------------------------------------------------------------
beads = simpar % pimd_params % beads
DO i = 1, beads
CALL lnhc ( nhc(i), struc(i) % pnode, int_group )
END DO
! IF ( simpar % constraint ) CALL getold ( struc % molecule )
IF ( simpar % constraint ) CALL stop_program('pimd_nvt', &
'contraints not supported atm with PIMD')
#if defined(__parallel)
CALL stop_program('pimd_nvt','parallel computation not supported with PIMD atm')
#endif
!
! first half of velocity verlet
!
fac = 0.5_dbl/beads
nnodes = size(struc(1)%pnode)
DO j=1, beads
transdt = simpar%dt*struc(j)%pimd_data%ismeff
DO i = 1, nnodes
dtom = fac*transdt/struc(j)%pnode(i) %p%prop%mass
struc(j)%pnode(i) %p%v(1) = struc(j)%pnode(i) %p%v(1) + &
dtom*struc(j)%pnode(i) %p%f(1)
struc(j)%pnode(i) %p%v(2) = struc(j)%pnode(i) %p%v(2) + &
dtom*struc(j)%pnode(i) %p%f(2)
struc(j)%pnode(i) %p%v(3) = struc(j)%pnode(i) %p%v(3) + &
dtom*struc(j)%pnode(i) %p%f(3)
END DO
END DO
! IF ( simpar % constraint ) CALL shake_control ( struc % molecule, simpar )
#if defined(__parallel)
! CALL update_structure ( struc, 'POS' )
#endif
! Harmonic bead-bead forces, assuming diagonalizing transformation for now
DO j=1, beads
DO i=1, nnodes
old_u = struc(j)%pimd_data%u(1,i)
struc(j)%pimd_data%u(1,i)= old_u * struc(j)%pimd_data%harmonic_prop(1,1)&
+ struc(j)%pnode(i)%p%v(1) * struc(j)%pimd_data%harmonic_prop(1,2)
struc(j)%pnode(i)%p%v(1) = old_u * struc(j)%pimd_data%harmonic_prop(2,1)&
+ struc(j)%pnode(i)%p%v(1) * struc(j)%pimd_data%harmonic_prop(2,2)
old_u = struc(j)%pimd_data%u(2,i)
struc(j)%pimd_data%u(2,i)= old_u * struc(j)%pimd_data%harmonic_prop(1,1)&
+ struc(j)%pnode(i)%p%v(2) * struc(j)%pimd_data%harmonic_prop(1,2)
struc(j)%pnode(i)%p%v(2) = old_u * struc(j)%pimd_data%harmonic_prop(2,1)&
+ struc(j)%pnode(i)%p%v(2) * struc(j)%pimd_data%harmonic_prop(2,2)
old_u = struc(j)%pimd_data%u(3,i)
struc(j)%pimd_data%u(3,i)= old_u * struc(j)%pimd_data%harmonic_prop(1,1)&
+ struc(j)%pnode(i)%p%v(3) * struc(j)%pimd_data%harmonic_prop(1,2)
struc(j)%pnode(i)%p%v(3) = old_u * struc(j)%pimd_data%harmonic_prop(2,1)&
+ struc(j)%pnode(i)%p%v(3) * struc(j)%pimd_data%harmonic_prop(2,2)
END DO
END DO
IF (simpar%pimd_params%ndelta > 1) THEN
! double time step for thermostats
DO i=1, beads
CALL yoshida_coef(nhc(i),2.0_dbl*simpar % dt / &
simpar % pimd_params % ndelta)
END DO
DO k= 2, simpar%pimd_params%ndelta
DO i = 1, beads
CALL lnhc ( nhc(i), struc(i) % pnode, int_group )
DO j=1, nnodes
old_u = struc(i)%pimd_data%u(1,j)
struc(i)%pimd_data%u(1,j)= old_u * &
struc(i)%pimd_data%harmonic_prop(1,1) &
+ struc(i)%pnode(j)%p%v(1) * &
struc(i)%pimd_data%harmonic_prop(1,2)
struc(i)%pnode(j)%p%v(1) = old_u * &
struc(i)%pimd_data%harmonic_prop(2,1) &
+ struc(i)%pnode(j)%p%v(1) * &
struc(i)%pimd_data%harmonic_prop(2,2)
old_u = struc(i)%pimd_data%u(2,j)
struc(i)%pimd_data%u(2,j)= old_u * &
struc(i)%pimd_data%harmonic_prop(1,1) &
+ struc(i)%pnode(j)%p%v(2) * &
struc(i)%pimd_data%harmonic_prop(1,2)
struc(i)%pnode(j)%p%v(2) = old_u * &
struc(i)%pimd_data%harmonic_prop(2,1) &
+ struc(i)%pnode(j)%p%v(2) * &
struc(i)%pimd_data%harmonic_prop(2,2)
old_u = struc(i)%pimd_data%u(3,j)
struc(i)%pimd_data%u(3,j)= old_u * &
struc(i)%pimd_data%harmonic_prop(1,1) &
+ struc(i)%pnode(j)%p%v(3) * &
struc(i)%pimd_data%harmonic_prop(1,2)
struc(i)%pnode(j)%p%v(3) = old_u * &
struc(i)%pimd_data%harmonic_prop(2,1) &
+ struc(i)%pnode(j)%p%v(3) * &
struc(i)%pimd_data%harmonic_prop(2,2)
END DO
END DO
END DO
! set time step for thermostats back to normal
DO i=1, beads
CALL yoshida_coef(nhc(i),simpar % dt / &
simpar % pimd_params % ndelta)
END DO
END IF
CALL u2r (struc, simpar)
!
! get new forces
!
CALL force ( struc, inter, thermo, simpar, ewald_param, box_change, &
intenv, dft_control, kp )
CALL fr2fu (struc, simpar)
!
! second half of velocity verlet
!
DO j=1, beads
transdt = 0.5_dbl*simpar%dt*struc(j)%pimd_data%ismeff / beads
DO i = 1, nnodes
dtom = transdt/struc(j)%pnode(i) %p%prop%mass
struc(j)%pnode(i) %p%v(1) = struc(j)%pnode(i) %p%v(1) + &
dtom*struc(j)%pnode(i) %p%f(1)
struc(j)%pnode(i) %p%v(2) = struc(j)%pnode(i) %p%v(2) + &
dtom*struc(j)%pnode(i) %p%f(2)
struc(j)%pnode(i) %p%v(3) = struc(j)%pnode(i) %p%v(3) + &
dtom*struc(j)%pnode(i) %p%f(3)
END DO
END DO
! IF ( simpar % constraint ) CALL rattle_control ( struc % molecule, simpar )
DO i = 1, beads
CALL lnhc ( nhc(i), struc(i) % pnode, int_group )
END DO
#if defined(__parallel)
! CALL update_structure(struc,'VEL')
#endif
! updating the virial
! IF (simpar%constraint) CALL pv_constraint(struc%molecule,thermo, &
! 'FULL',int_group )
!+++ that is not right yet either:
CALL pressure(struc(1)%pnode,thermo)
END SUBROUTINE pimd_nvt
!!*****
!******************************************************************************
END MODULE integrator

490
src/interactions.F
View file

@ -28,20 +28,17 @@ MODULE interactions
! SUBROUTINE read_interaction_thresholds(start_section,end_section)
! SUBROUTINE write_interaction_thresholds(lunit)
! SUBROUTINE init_interaction_radii(globenv)
! SUBROUTINE calculate_erfc_radii
! SUBROUTINE write_erfc_radii(lunit)
! SUBROUTINE calculate_erf_ppl_radii
! SUBROUTINE write_erf_ppl_radii(lunit)
! SUBROUTINE calculate_exp_ppl_radii
! SUBROUTINE write_exp_ppl_radii(lunit)
! SUBROUTINE calculate_core_charge_radii
! SUBROUTINE write_core_charge_radii(lunit)
! SUBROUTINE calculate_pgf_aux_radii
! SUBROUTINE write_pgf_aux_radii(lunit)
! SUBROUTINE calculate_pgf_orb_radii
! SUBROUTINE write_pgf_orb_radii(lunit)
! SUBROUTINE calculate_prj_ppnl_radii
! SUBROUTINE write_prj_ppnl_radii(lunit)
! SUBROUTINE calculate_ppl_radii
! SUBROUTINE write_ppl_radii(lunit)
! SUBROUTINE calculate_ppnl_radii
! SUBROUTINE write_ppnl_radii(lunit)
! FUNCTION erfc_radius(alpha,threshold,prefactor) RESULT(radius)
! FUNCTION exp_radius(l,alpha,threshold,prefactor) RESULT(radius)
! *****************************************************************************
@ -64,12 +61,18 @@ MODULE interactions
PRIVATE
REAL(wp) :: eps_erfc,&
eps_erf_ppl,&
eps_exp_ppl,&
REAL(wp) :: eps_core_charge,&
eps_pgf_aux,&
eps_pgf_orb,&
eps_prj_ppnl
eps_ppl,&
eps_ppnl,&
eps_rho_gspace,&
eps_rho_rspace
! *** Public variables ***
PUBLIC :: eps_rho_gspace,&
eps_rho_rspace
! *** Public subroutines ***
@ -77,6 +80,10 @@ MODULE interactions
read_interaction_thresholds,&
write_interaction_thresholds
! *** Public functions ***
PUBLIC :: exp_radius
! *****************************************************************************
CONTAINS
@ -116,12 +123,13 @@ CONTAINS
! *** Load the default values ***
eps_erfc = 1.0E-12_wp
eps_erf_ppl = 1.0E-12_wp
eps_exp_ppl = 1.0E-12_wp
eps_core_charge = 1.0E-12_wp
eps_pgf_aux = 1.0E-6_wp
eps_pgf_orb = 1.0E-6_wp
eps_prj_ppnl = 1.0E-12_wp
eps_ppl = 1.0E-12_wp
eps_ppnl = 1.0E-12_wp
eps_rho_gspace = 1.0E-8_wp
eps_rho_rspace = 1.0E-8_wp
CALL start_input_session(globenv%input_file_name,globenv)
@ -140,24 +148,30 @@ CONTAINS
SELECT CASE (TRIM(keyword))
CASE ("EPS_DEFAULT","DEFAULT")
CALL read_object(eps_default)
eps_erfc = eps_default
eps_erf_ppl = eps_default
eps_exp_ppl = eps_default
eps_core_charge = eps_default
eps_pgf_aux = eps_default
eps_pgf_orb = eps_default
eps_prj_ppnl = eps_default
CASE ("EPS_ERFC")
CALL read_object(eps_erfc)
CASE ("EPS_ERF_PPL")
CALL read_object(eps_erf_ppl)
CASE ("EPS_EXP_PPL")
CALL read_object(eps_exp_ppl)
eps_ppl = eps_default
eps_ppnl = eps_default
eps_rho_gspace = eps_default
eps_rho_rspace = eps_default
CASE ("EPS_CORE_CHARGE")
CALL read_object(eps_core_charge)
CASE ("EPS_PGF_AUX")
CALL read_object(eps_pgf_aux)
CASE ("EPS_PGF_ORB")
CALL read_object(eps_pgf_orb)
CASE ("EPS_PRJ_PPNL","EPS_PPNL")
CALL read_object(eps_prj_ppnl)
CASE ("EPS_PPL")
CALL read_object(eps_ppl)
CASE ("EPS_PPNL")
CALL read_object(eps_ppnl)
CASE ("EPS_RHO")
CALL read_object(eps_rho_gspace)
eps_rho_rspace = eps_rho_gspace
CASE ("EPS_RHO_GSPACE")
CALL read_object(eps_rho_gspace)
CASE ("EPS_RHO_RSPACE")
CALL read_object(eps_rho_rspace)
CASE DEFAULT
IF (keyword == end_section) THEN
EXIT
@ -194,24 +208,26 @@ CONTAINS
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/)") "INTERACTION THRESHOLDS"
WRITE (UNIT=lunit,FMT="(T3,A,ES8.1)") "eps_pgf_orb: ",eps_pgf_orb
WRITE (UNIT=lunit,FMT="(T3,A,T20,ES8.1)") "eps_pgf_orb:",eps_pgf_orb
IF (allchem) THEN
WRITE (UNIT=lunit,FMT="(T3,A,ES8.1)") "eps_pgf_aux: ",eps_pgf_aux
END IF
IF (gpw.AND.all_potential_present) THEN
WRITE (UNIT=lunit,FMT="(T3,A,ES8.1)") "eps_erfc: ",eps_erfc
WRITE (UNIT=lunit,FMT="(T3,A,T20,ES8.1)")&
"eps_pgf_aux:",eps_pgf_aux
ELSE
WRITE (UNIT=lunit,FMT="(T3,A,T20,ES8.1)")&
"eps_core_charge:",eps_core_charge
END IF
IF (gth_potential_present) THEN
IF (allchem) THEN
WRITE (UNIT=lunit,FMT="(T3,A,ES8.1)") "eps_erf_ppl: ",eps_erf_ppl
END IF
WRITE (UNIT=lunit,FMT="(T3,A,ES8.1)") "eps_exp_ppl: ",eps_exp_ppl,&
"eps_prj_ppnl: ",eps_prj_ppnl
WRITE (UNIT=lunit,FMT="(T3,A,T20,ES8.1)")&
"eps_ppl:",eps_ppl,&
"eps_ppnl:",eps_ppnl
END IF
WRITE (UNIT=lunit,FMT="(T3,A,T20,ES8.1)")&
"eps_rho_rspace:",eps_rho_rspace,&
"eps_rho_gspace:",eps_rho_gspace
END SUBROUTINE write_interaction_thresholds
! *****************************************************************************
@ -242,29 +258,21 @@ CONTAINS
IF (allchem) THEN
CALL calculate_pgf_aux_radii
IF (ionode) CALL write_pgf_aux_radii(globenv)
END IF
IF (gpw.AND.all_potential_present) THEN
CALL calculate_erfc_radii
IF (ionode.AND.globenv%print%erfc_radii) THEN
CALL write_erfc_radii(output_unit)
ELSE
CALL calculate_core_charge_radii
IF (ionode.AND.globenv%print%core_charge_radii) THEN
CALL write_core_charge_radii(output_unit)
END IF
END IF
IF (gth_potential_present) THEN
IF (allchem) THEN
CALL calculate_erf_ppl_radii
IF (ionode.AND.globenv%print%erf_ppl_radii) THEN
CALL write_erf_ppl_radii(output_unit)
END IF
CALL calculate_ppl_radii
IF (ionode.AND.globenv%print%ppl_radii) THEN
CALL write_ppl_radii(output_unit)
END IF
CALL calculate_exp_ppl_radii
IF (ionode.AND.globenv%print%exp_ppl_radii) THEN
CALL write_exp_ppl_radii(output_unit)
END IF
CALL calculate_prj_ppnl_radii
IF (ionode.AND.globenv%print%prj_ppnl_radii) THEN
CALL write_prj_ppnl_radii(output_unit)
CALL calculate_ppnl_radii
IF (ionode.AND.globenv%print%ppnl_radii) THEN
CALL write_ppnl_radii(output_unit)
END IF
END IF
@ -272,10 +280,10 @@ CONTAINS
! *****************************************************************************
SUBROUTINE calculate_erfc_radii
SUBROUTINE calculate_core_charge_radii
! Purpose: Calculate the radii of the nuclear charge distributions for a
! given threshold.
! Purpose: Calculate the radii of the core charge distributions for a given
! threshold.
! History: - Creation (15.09.2000, Matthias Krack)
@ -288,20 +296,18 @@ CONTAINS
! ---------------------------------------------------------------------------
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%all_potential)) THEN
kind_info(ikind)%all_potential%erfc_radius =&
erfc_radius(kind_info(ikind)%alpha_erf,eps_erfc,&
REAL(kind_info(ikind)%z,wp))
END IF
kind_info(ikind)%core_charge_radius =&
exp_radius(0,kind_info(ikind)%alpha_core_charge,eps_core_charge,&
kind_info(ikind)%ccore_charge)
END DO
END SUBROUTINE calculate_erfc_radii
END SUBROUTINE calculate_core_charge_radii
! *****************************************************************************
SUBROUTINE write_erfc_radii(lunit)
SUBROUTINE write_core_charge_radii(lunit)
! Purpose: Write the radii of the nuclear charge distributions to the logical
! Purpose: Write the radii of the core charge distributions to the logical
! unit number "lunit".
! History: - Creation (15.09.2000, Matthias Krack)
@ -319,152 +325,16 @@ CONTAINS
! ---------------------------------------------------------------------------
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,T10,A,T22,A,/)")&
"RADII OF THE NUCLEAR CHARGE DISTRIBUTIONS IN "//&
"RADII OF THE CORE CHARGE DISTRIBUTIONS IN "//&
TRIM(unit_of_length_name),"Kind","Label","Radius"
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%all_potential)) THEN
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%all_potential%erfc_radius/unit_of_length
END IF
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%core_charge_radius/unit_of_length
END DO
END SUBROUTINE write_erfc_radii
! *****************************************************************************
SUBROUTINE calculate_erf_ppl_radii
! Purpose: Calculate the radii of the error functions of the Goedecker
! pseudopotential (GTH, local part).
! History: - Creation (07.11.2000, Matthias Krack)
! ***************************************************************************
! *** Local variables ***
REAL(wp) :: alpha,c
INTEGER :: ikind
! ---------------------------------------------------------------------------
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
alpha = kind_info(ikind)%gth_potential%alpha_exp_ppl
c = kind_info(ikind)%cerf
kind_info(ikind)%gth_potential%erf_ppl_radius =&
exp_radius(0,alpha,eps_erf_ppl,c)
END IF
END DO
END SUBROUTINE calculate_erf_ppl_radii
! *****************************************************************************
SUBROUTINE write_erf_ppl_radii(lunit)
! Purpose: Write the radii of the error functions of the Goedecker
! pseudopotential (GTH, local part) to the logical unit number
! "lunit".
! History: - Creation (07.11.2000, Matthias Krack)
! ***************************************************************************
USE cell_parameters, ONLY: unit_of_length,unit_of_length_name
INTEGER, INTENT(IN) :: lunit
! *** Local variables ***
INTEGER :: ikind
! ---------------------------------------------------------------------------
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,T10,A,T22,A,/)")&
"RADII OF THE ERROR FUNCTIONS OF THE GTH PSEUDOPOTENTIAL IN "//&
TRIM(unit_of_length_name),"Kind","Label","Radius"
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%gth_potential%erf_ppl_radius/unit_of_length
END IF
END DO
END SUBROUTINE write_erf_ppl_radii
! *****************************************************************************
SUBROUTINE calculate_exp_ppl_radii
! Purpose: Calculate the radii of the exponential functions of the Goedecker
! pseudopotential (GTH, local part).
! History: - Creation (06.10.2000, Matthias Krack)
! ***************************************************************************
REAL(wp) :: alpha_exp_ppl,cexp_ppl,exp_ppl_radius
INTEGER :: iexp_ppl,ikind,lppl
! ---------------------------------------------------------------------------
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
alpha_exp_ppl = kind_info(ikind)%gth_potential%alpha_exp_ppl
exp_ppl_radius = 0.0_wp
DO iexp_ppl=1,kind_info(ikind)%gth_potential%nexp_ppl
lppl = 2*(iexp_ppl - 1)
cexp_ppl = kind_info(ikind)%gth_potential%cexp_ppl(iexp_ppl)
exp_ppl_radius = MAX(exp_ppl_radius,&
exp_radius(lppl,alpha_exp_ppl,eps_exp_ppl,&
cexp_ppl))
END DO
kind_info(ikind)%gth_potential%exp_ppl_radius = exp_ppl_radius
END IF
END DO
END SUBROUTINE calculate_exp_ppl_radii
! *****************************************************************************
SUBROUTINE write_exp_ppl_radii(lunit)
! Purpose: Write the radii of the exponential functions of the Goedecker
! pseudopotential (GTH, local part) to the logical unit number
! "lunit".
! History: - Creation (06.10.2000, Matthias Krack)
! ***************************************************************************
USE cell_parameters, ONLY: unit_of_length,unit_of_length_name
INTEGER, INTENT(IN) :: lunit
! *** Local variables ***
INTEGER :: ikind
! ---------------------------------------------------------------------------
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,T10,A,T22,A,/)")&
"RADII OF THE EXPONENTIAL FUNCTIONS OF THE GTH PSEUDOPOTENTIAL IN "//&
TRIM(unit_of_length_name),"Kind","Label","Radius"
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%gth_potential%exp_ppl_radius/unit_of_length
END IF
END DO
END SUBROUTINE write_exp_ppl_radii
END SUBROUTINE write_core_charge_radii
! *****************************************************************************
@ -688,7 +558,76 @@ CONTAINS
! *****************************************************************************
SUBROUTINE calculate_prj_ppnl_radii
SUBROUTINE calculate_ppl_radii
! Purpose: Calculate the radii of the local part of the Goedecker pseudo-
! potential (GTH).
! History: - Creation (06.10.2000, Matthias Krack)
! ***************************************************************************
REAL(wp) :: alpha_ppl,cerf_ppl,cexp_ppl,ppl_radius
INTEGER :: iexp_ppl,ikind,lppl
! ---------------------------------------------------------------------------
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
alpha_ppl = kind_info(ikind)%gth_potential%alpha_ppl
cerf_ppl = kind_info(ikind)%gth_potential%cerf_ppl
ppl_radius = exp_radius(0,alpha_ppl,eps_ppl,cerf_ppl)
DO iexp_ppl=1,kind_info(ikind)%gth_potential%nexp_ppl
lppl = 2*(iexp_ppl - 1)
cexp_ppl = kind_info(ikind)%gth_potential%cexp_ppl(iexp_ppl)
ppl_radius = MAX(ppl_radius,&
exp_radius(lppl,alpha_ppl,eps_ppl,cexp_ppl))
END DO
kind_info(ikind)%gth_potential%ppl_radius = ppl_radius
END IF
END DO
END SUBROUTINE calculate_ppl_radii
! *****************************************************************************
SUBROUTINE write_ppl_radii(lunit)
! Purpose: Write the radii of the exponential functions of the Goedecker
! pseudopotential (GTH, local part) to the logical unit number
! "lunit".
! History: - Creation (06.10.2000, Matthias Krack)
! ***************************************************************************
USE cell_parameters, ONLY: unit_of_length,unit_of_length_name
INTEGER, INTENT(IN) :: lunit
! *** Local variables ***
INTEGER :: ikind
! ---------------------------------------------------------------------------
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,T10,A,T22,A,/)")&
"RADII OF THE LOCAL PART OF THE GTH PSEUDOPOTENTIAL IN "//&
TRIM(unit_of_length_name),"Kind","Label","Radius"
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%gth_potential%ppl_radius/unit_of_length
END IF
END DO
END SUBROUTINE write_ppl_radii
! *****************************************************************************
SUBROUTINE calculate_ppnl_radii
! Purpose: Calculate the radii of the projector functions of the Goedecker
! pseudopotential (GTH, non-local part).
@ -697,34 +636,34 @@ CONTAINS
! ***************************************************************************
REAL(wp) :: alpha_prj_ppnl,cprj_ppnl,prj_ppnl_radius
REAL(wp) :: alpha_ppnl,cprj_ppnl,ppnl_radius
INTEGER :: ikind,iprj_ppnl,l,lprj_ppnl,nprj_ppnl
! ---------------------------------------------------------------------------
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
prj_ppnl_radius = 0.0_wp
ppnl_radius = 0.0_wp
DO l=0,kind_info(ikind)%gth_potential%lppnl
alpha_prj_ppnl = kind_info(ikind)%gth_potential%alpha_prj_ppnl(l)
alpha_ppnl = kind_info(ikind)%gth_potential%alpha_ppnl(l)
nprj_ppnl = kind_info(ikind)%gth_potential%nprj_ppnl(l)
DO iprj_ppnl=1,nprj_ppnl
lprj_ppnl = l + 2*(iprj_ppnl - 1)
cprj_ppnl = kind_info(ikind)%gth_potential%cprj_ppnl(iprj_ppnl,l)
prj_ppnl_radius = MAX(prj_ppnl_radius,&
exp_radius(lprj_ppnl,alpha_prj_ppnl,&
eps_prj_ppnl,cprj_ppnl))
ppnl_radius = MAX(ppnl_radius,&
exp_radius(lprj_ppnl,alpha_ppnl,eps_ppnl,&
cprj_ppnl))
END DO
END DO
kind_info(ikind)%gth_potential%prj_ppnl_radius = prj_ppnl_radius
kind_info(ikind)%gth_potential%ppnl_radius = ppnl_radius
END IF
END DO
END SUBROUTINE calculate_prj_ppnl_radii
END SUBROUTINE calculate_ppnl_radii
! *****************************************************************************
SUBROUTINE write_prj_ppnl_radii(lunit)
SUBROUTINE write_ppnl_radii(lunit)
! Purpose: Write the radii of the projector functions of the Goedecker
! pseudopotential (GTH, non-local part) to the logical unit number
@ -745,121 +684,18 @@ CONTAINS
! ---------------------------------------------------------------------------
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,T10,A,T22,A,/)")&
"RADII OF THE PROJECTOR FUNCTIONS OF THE GTH PSEUDOPOTENTIAL IN "//&
"RADII OF THE NON-LOCAL PART OF THE GTH PSEUDOPOTENTIAL IN "//&
TRIM(unit_of_length_name),"Kind","Label","Radius"
DO ikind=1,nkind
IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN
WRITE (UNIT=lunit,FMT="(T2,I5,3X,A5,2X,F12.6)")&
ikind,kind_info(ikind)%label,&
kind_info(ikind)%gth_potential%prj_ppnl_radius/unit_of_length
kind_info(ikind)%gth_potential%ppnl_radius/unit_of_length
END IF
END DO
END SUBROUTINE write_prj_ppnl_radii
! *****************************************************************************
FUNCTION erfc_radius(alpha,threshold,prefactor) RESULT(radius)
! Purpose: The radius of the function prefactor*erfc(alpha*r) for a given
! threshold is calculated. The Newton-Raphson procedure is used to
! locate the requested radius.
! g(r) = prefactor*erfc(alpha*r) - threshold = 0
! History: - Creation (04.08.1999, Matthias Krack)
! ***************************************************************************
! alpha : Prefactor of r.
! prefactor: Prefactor of the function.
! radius : Calculated radius of the function.
! threshold: Threshold for the radius.
! delta : Newton-Raphson step length.
! dg : First derivative of the function g(r).
! epsiter: Convergence criterion of the Newton-Raphson iteration.
! g : The function g(r).
! maxiter: Maximum number of Newton-Raphson iterations.
! ***************************************************************************
USE mathconstants, ONLY: pi
USE termination, ONLY: stop_program
REAL(wp), INTENT(IN) :: alpha,prefactor,threshold
REAL(wp) :: radius
! *** Local parameters ***
CHARACTER(LEN=*), PARAMETER :: routine =&
"FUNCTION erfc_radius (MODULE mathlib)"
REAL(wp), PARAMETER :: epsiter = 1.0E-12_wp
INTEGER, PARAMETER :: maxiter = 50
! *** Local variables ***
REAL(wp) :: a,ar,c,d,delta,dg,g,r,t
INTEGER :: iter
! *** Functions ***
REAL(wp), EXTERNAL :: erfc
! ---------------------------------------------------------------------------
! *** Initialize function value ***
radius = 0.0_wp
! *** Load and check parameter values ***
IF (alpha == 0.0_wp) THEN
CALL stop_program(routine,"The requested exponent is zero")
ELSE
a = ABS(alpha)
END IF
IF (threshold == 0.0_wp) THEN
CALL stop_program(routine,"The requested threshold is zero")
ELSE
t = ABS(threshold)
END IF
IF (prefactor == 0.0_wp) THEN
RETURN
ELSE
d = ABS(prefactor)
END IF
c = -2.0_wp*a/SQRT(pi)
t = t/d
! *** Define an initial radius for the Newton-Raphson iteration ***
r = SQRT(-LOG(t)/a**2)
! *** Perform a Newton-Raphson procedure to find the requested radius ***
DO iter=1,maxiter
ar = a*r
g = erfc(ar) - t
dg = c*exp(-ar**2)
delta = g/dg
r = r - SIGN(MIN(ABS(delta),0.5_wp*r),delta)
IF (ABS(delta) < epsiter) THEN
radius = r
RETURN
END IF
END DO
CALL stop_program(routine,"Maximum number of iterations exceeded")
END FUNCTION erfc_radius
END SUBROUTINE write_ppnl_radii
! *****************************************************************************
@ -947,7 +783,7 @@ CONTAINS
ar2 = a*r*r
IF (l == 0) THEN
g = d*EXP(-ar2)
g = d
ELSE
g = d*r**l*EXP(-ar2)
END IF

257
src/lapack.F
View file

@ -8,130 +8,229 @@
!! lapack
!!
!! FUNCTION
!! Interface to the LAPACK F77 library
!!
!! AUTHOR
!! APSI
!!
!! MODIFICATION HISTORY
!! none
!! JGH (26-5-2001): New flag __sp_lib
!! : Added SVD routines
!! JGH (30-5-2001): Added Cholesky facotrisation and triangular inverse
!!
!! SOURCE
!******************************************************************************
#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
#if defined (__sp_lib)
INTERFACE lapack_ssyev
SUBROUTINE ssyev ( jobz, uplo, n, a, lda, w, work, lwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: INFO, LDA, LWORK, N
REAL ( KIND = 4 ) :: A( LDA, * ), W( * ), WORK( * )
REAL ( KIND = dbl ) :: A( LDA, * ), W( * ), WORK( * )
END SUBROUTINE ssyev
END INTERFACE
INTERFACE lapack_chpev
SUBROUTINE chpev ( jobz, uplo, n, ap, w, z, ldz, work, rwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: n, ldz, info
REAL ( KIND = dbl ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: ap ( * ), work ( * ), z ( ldz, * )
END SUBROUTINE chpev
END INTERFACE
INTERFACE lapack_sspgv
SUBROUTINE sspgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, &
info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: itype, n, ldz, info
REAL ( KIND = dbl ) :: w ( * )
COMPLEX ( KIND = dbl ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * )
END SUBROUTINE sspgv
END INTERFACE
INTERFACE lapack_chpgv
SUBROUTINE chpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, &
rwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: itype, n, ldz, info
REAL ( KIND = dbl ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * )
END SUBROUTINE chpgv
END INTERFACE
INTERFACE lapack_sgesvd
SUBROUTINE sgesvd ( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, &
work, lwork, info )
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl
CHARACTER :: jobz, jobvt
INTEGER :: m, n, lda, ldu, ldvt, lwork, info
REAL ( KIND = dbl ) :: a ( lda, * ), s ( * ), u ( ldu, * ), &
vt ( ldvt, * ), work ( * )
END SUBROUTINE sgesvd
END INTERFACE
INTERFACE lapack_cgesvd
SUBROUTINE cgesvd ( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, &
work, lwork, rwork, info )
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl
CHARACTER :: jobz, jobvt
INTEGER :: m, n, lda, ldu, ldvt, lwork, info
REAL ( KIND = dbl ) :: s ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: a ( lda, * ), u ( ldu, * ), &
vt ( ldvt, * ), work ( * )
END SUBROUTINE cgesvd
END INTERFACE
INTERFACE lapack_spotrf
SUBROUTINE spotrf ( uplo, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo
INTEGER :: info, n, lda
REAL ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE spotrf
END INTERFACE
INTERFACE lapack_cpotrf
SUBROUTINE cpotrf ( uplo, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo
INTEGER :: info, n, lda
COMPLEX ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE cpotrf
END INTERFACE
INTERFACE lapack_strtri
SUBROUTINE strtri ( uplo, diag, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo, diag
INTEGER :: info, n, lda
COMPLEX ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE strtri
END INTERFACE
INTERFACE lapack_ctrtri
SUBROUTINE ctrtri ( uplo, diag, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo, diag
INTEGER :: info, n, lda
COMPLEX ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE ctrtri
END INTERFACE
#else
INTERFACE lapack_ssyev
SUBROUTINE dsyev ( jobz, uplo, n, a, lda, w, work, lwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: INFO, LDA, LWORK, N
REAL ( KIND = 8 ) :: A( LDA, * ), W( * ), WORK( * )
REAL ( KIND = dbl ) :: 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 )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: n, ldz, info
REAL ( KIND = 8 ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = 8 ) :: ap ( * ), work ( * ), z ( ldz, * )
REAL ( KIND = dbl ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: 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 )
INTERFACE lapack_sspgv
SUBROUTINE dspgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, &
info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: itype, n, ldz, info
REAL ( KIND = 4 ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = 4 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * )
END SUBROUTINE chpgv
REAL ( KIND = dbl ) :: w ( * )
REAL ( KIND = dbl ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * )
END SUBROUTINE dspgv
END INTERFACE
INTERFACE lapack_chpgv
SUBROUTINE zhpgv ( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, &
rwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobz, uplo
INTEGER :: itype, n, ldz, info
REAL ( KIND = 8 ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = 8 ) :: ap ( * ), bp ( * ), work ( * ), z ( ldz, * )
REAL ( KIND = dbl ) :: w ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: 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
INTERFACE lapack_sgesvd
SUBROUTINE dgesvd ( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, &
work, lwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobu, jobvt
INTEGER :: m, n, lda, ldu, ldvt, lwork, info
REAL ( KIND = dbl ) :: a ( lda, * ), s ( * ), u ( ldu, * ), &
vt ( ldvt, * ), work ( * )
END SUBROUTINE dgesvd
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
INTERFACE lapack_cgesvd
SUBROUTINE zgesvd ( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, &
work, lwork, rwork, info )
USE kinds, ONLY : dbl
CHARACTER :: jobu, jobvt
INTEGER :: m, n, lda, ldu, ldvt, lwork, info
REAL ( KIND = dbl ) :: s ( * ), rwork ( * )
COMPLEX ( KIND = dbl ) :: a ( lda, * ), u ( ldu, * ), &
vt ( ldvt, * ), work ( * )
END SUBROUTINE zgesvd
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
INTERFACE lapack_spotrf
SUBROUTINE dpotrf ( uplo, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo
INTEGER :: info, n, lda
REAL ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE dpotrf
END INTERFACE
END MODULE lapack
INTERFACE lapack_cpotrf
SUBROUTINE zpotrf ( uplo, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo
INTEGER :: info, n, lda
COMPLEX ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE zpotrf
END INTERFACE
INTERFACE lapack_strtri
SUBROUTINE dtrtri ( uplo, diag, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo, diag
INTEGER :: info, n, lda
REAL ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE dtrtri
END INTERFACE
INTERFACE lapack_ctrtri
SUBROUTINE ztrtri ( uplo, diag, n, a, lda, info )
USE kinds, ONLY : dbl
CHARACTER :: uplo, diag
INTEGER :: info, n, lda
COMPLEX ( KIND = dbl ) :: a( lda, * )
END SUBROUTINE ztrtri
END INTERFACE
#endif
END MODULE lapack
!!*****
!******************************************************************************

105
src/lib/fast.F Normal file
View file

@ -0,0 +1,105 @@
!-----------------------------------------------------------------------------!
! Some F77 style routines to get full performance
!-----------------------------------------------------------------------------!
SUBROUTINE rankup ( n, za, cmat, zb, ex, ey, ez, scr )
!
! cmat(i,j,k) <- za * cmat(i,j,k) + ex(i) * ey(j) * ez(k)
!
IMPLICIT NONE
INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 )
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: n
COMPLEX ( dbl ), INTENT ( IN ) :: za, zb
COMPLEX ( dbl ), INTENT ( IN ) :: ex ( * )
COMPLEX ( dbl ), INTENT ( IN ) :: ey ( * )
COMPLEX ( dbl ), INTENT ( IN ) :: ez ( * )
COMPLEX ( dbl ), INTENT ( INOUT ) :: cmat ( * )
COMPLEX ( dbl ), INTENT ( INOUT ) :: scr ( * )
INTEGER :: n2, n3, i
COMPLEX ( dbl ) :: cone
cone = CMPLX ( 1._dbl, KIND = dbl )
n2 = n ( 1 ) * n ( 2 )
n3 = n2 * n ( 3 )
scr ( 1:n2 ) = CMPLX ( 0._dbl, KIND = dbl )
#if defined (__sp_lib)
CALL cgeru ( n ( 1 ), n ( 2 ), zb, ex, 1, ey, 1, scr, n ( 1 ) )
CALL cscal ( n3, za, cmat, 1 )
CALL cgeru ( n2, n ( 3 ), cone, scr, 1, ez, 1, cmat, n2 )
#else
CALL zgeru ( n ( 1 ), n ( 2 ), zb, ex, 1, ey, 1, scr, n ( 1 ) )
CALL zscal ( n3, za, cmat, 1 )
CALL zgeru ( n2, n ( 3 ), cone, scr, 1, ez, 1, cmat, n2 )
#endif
END SUBROUTINE rankup
!-----------------------------------------------------------------------------!
SUBROUTINE vr_x_vc ( n, rvec, cvec )
!
! cden(i) <- cden(i) * rden(i)
!
IMPLICIT NONE
INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 )
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), INTENT ( IN ) :: rvec (*)
REAL ( dbl ), INTENT ( INOUT ) :: cvec (2,*)
INTEGER :: i
DO i = 1, n
cvec ( 1, i ) = cvec ( 1, i ) * rvec ( i )
cvec ( 2, i ) = cvec ( 2, i ) * rvec ( i )
END DO
END SUBROUTINE vr_x_vc
!-----------------------------------------------------------------------------!
SUBROUTINE copy_cri ( n, z, r1, r2 )
!
! r1 = real ( z )
! r2 = imag ( z )
!
IMPLICIT NONE
INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 )
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), INTENT ( OUT ) :: r1(*), r2(*)
REAL ( dbl ), INTENT ( IN ) :: z(2,*)
INTEGER :: i
DO i = 1, n
r1 ( i ) = z ( 1, i )
r2 ( i ) = z ( 2, i )
END DO
END SUBROUTINE copy_cri
!-----------------------------------------------------------------------------!
SUBROUTINE copy_cr ( n, z, r1 )
!
! r1 = real ( z )
!
IMPLICIT NONE
INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 )
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), INTENT ( OUT ) :: r1(*)
REAL ( dbl ), INTENT ( IN ) :: z(2,*)
INTEGER :: i
DO i = 1, n
r1 ( i ) = z ( 1, i )
END DO
END SUBROUTINE copy_cr
!-----------------------------------------------------------------------------!

44
src/lib/fftpre.F
View file

@ -24,7 +24,7 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, &
ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, &
vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, &
am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4
am, ap, bm, bp, bbs, s25, s34, r34, r25, sin2, sin4
REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5)
REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2
REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5)
@ -513,6 +513,7 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
ia = 1
nin1 = ia - after
nout1 = ia - atn
bbs = isign * bb
DO ib = 1, before
nin1 = nin1 + after
nin2 = nin1 + atb
@ -533,8 +534,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -567,8 +568,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb*(r2-r3)
s2 = bb*(s2-s3)
r2 = bbs*(r2-r3)
s2 = bbs*(s2-s3)
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -598,8 +599,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -633,8 +634,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -666,8 +667,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -709,8 +710,8 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -971,6 +972,7 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
END IF
END DO
ELSE IF ( now == 6 ) THEN
bbs = isign * bb
ia = 1
nin1 = ia - after
nout1 = ia - atn
@ -1002,10 +1004,10 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
ur2 = r1 - s * bb
ui2 = s1 + r * bb
ur3 = r1 + s * bb
ui3 = s1 - r * bb
ur2 = r1 - s * bbs
ui2 = s1 + r * bbs
ur3 = r1 + s * bbs
ui3 = s1 - r * bbs
r2 = zin ( 1, nin6, j )
s2 = zin ( 2, nin6, j )
@ -1021,10 +1023,10 @@ SUBROUTINE fftpre ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
vr2 = r1 - s * bb
vi2 = s1 + r * bb
vr3 = r1 + s * bb
vi3 = s1 - r * bb
vr2 = r1 - s * bbs
vi2 = s1 + r * bbs
vr3 = r1 + s * bbs
vi3 = s1 - r * bbs
zout ( 1, j, nout1 ) = ur1 + vr1
zout ( 2, j, nout1 ) = ui1 + vi1

44
src/lib/fftrot.F
View file

@ -24,7 +24,7 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, &
ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, &
vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, &
am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4
am, ap, bm, bp, bbs, s25, s34, r34, r25, sin2, sin4
REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5)
REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2
REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5)
@ -510,6 +510,7 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
END DO
END IF
ELSE IF ( now == 3 ) THEN
bbs = isign * bb
ia = 1
nin1 = ia - after
nout1 = ia - atn
@ -533,8 +534,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -567,8 +568,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb*(r2-r3)
s2 = bb*(s2-s3)
r2 = bbs*(r2-r3)
s2 = bbs*(s2-s3)
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -598,8 +599,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -633,8 +634,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -666,8 +667,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -709,8 +710,8 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, nout1, j ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, nout2, j ) = r1 - s2
zout ( 2, nout2, j ) = s1 + r2
zout ( 1, nout3, j ) = r1 + s2
@ -971,6 +972,7 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
END IF
END DO
ELSE IF ( now == 6 ) THEN
bbs = isign * bb
ia = 1
nin1 = ia - after
nout1 = ia - atn
@ -1002,10 +1004,10 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
ur2 = r1 - s * bb
ui2 = s1 + r * bb
ur3 = r1 + s * bb
ui3 = s1 - r * bb
ur2 = r1 - s * bbs
ui2 = s1 + r * bbs
ur3 = r1 + s * bbs
ui3 = s1 - r * bbs
r2 = zin ( 1, j, nin6 )
s2 = zin ( 2, j, nin6 )
@ -1021,10 +1023,10 @@ SUBROUTINE fftrot ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
vr2 = r1 - s * bb
vi2 = s1 + r * bb
vr3 = r1 + s * bb
vi3 = s1 - r * bb
vr2 = r1 - s * bbs
vi2 = s1 + r * bbs
vr3 = r1 + s * bbs
vi3 = s1 - r * bbs
zout ( 1, nout1, j ) = ur1 + vr1
zout ( 2, nout1, j ) = ui1 + vi1

44
src/lib/fftstp.F
View file

@ -24,7 +24,7 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
r, r1, r2, r3, r4, r5, r6, r7, r8, cr2, cr3, cr4, cr5, &
ci2, ci3, ci4, ci5, ur1, ur2, ur3, ui1, ui2, ui3, &
vr1, vr2, vr3, vi1, vi2, vi3, cm, cp, dm, dp, &
am, ap, bm, bp,s25, s34, r34, r25, sin2, sin4
am, ap, bm, bp, bbs, s25, s34, r34, r25, sin2, sin4
REAL ( dbl ), PARAMETER :: rt2i = 0.7071067811865475_dbl ! sqrt(0.5)
REAL ( dbl ), PARAMETER :: bb = 0.8660254037844387_dbl ! sqrt(3)/2
REAL ( dbl ), PARAMETER :: cos2 = 0.3090169943749474_dbl ! cos(2*pi/5)
@ -510,6 +510,7 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
END DO
END IF
ELSE IF ( now == 3 ) THEN
bbs = isign * bb
ia = 1
nin1 = ia - after
nout1 = ia - atn
@ -533,8 +534,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -567,8 +568,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb*(r2-r3)
s2 = bb*(s2-s3)
r2 = bbs*(r2-r3)
s2 = bbs*(s2-s3)
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -598,8 +599,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -633,8 +634,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -666,8 +667,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -709,8 +710,8 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
zout ( 2, j, nout1 ) = s + s1
r1 = r1 - 0.5_dbl * r
s1 = s1 - 0.5_dbl * s
r2 = bb * ( r2 - r3 )
s2 = bb * ( s2 - s3 )
r2 = bbs * ( r2 - r3 )
s2 = bbs * ( s2 - s3 )
zout ( 1, j, nout2 ) = r1 - s2
zout ( 2, j, nout2 ) = s1 + r2
zout ( 1, j, nout3 ) = r1 + s2
@ -971,6 +972,7 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
END IF
END DO
ELSE IF ( now == 6 ) THEN
bbs = isign * bb
ia = 1
nin1 = ia - after
nout1 = ia - atn
@ -1002,10 +1004,10 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
ur2 = r1 - s * bb
ui2 = s1 + r * bb
ur3 = r1 + s * bb
ui3 = s1 - r * bb
ur2 = r1 - s * bbs
ui2 = s1 + r * bbs
ur3 = r1 + s * bbs
ui3 = s1 - r * bbs
r2 = zin ( 1, j, nin6 )
s2 = zin ( 2, j, nin6 )
@ -1021,10 +1023,10 @@ SUBROUTINE fftstp ( mm, nfft, m, nn, n, zin, zout, &
s1 = s1 - 0.5_dbl * s
r = r2 - r3
s = s2 - s3
vr2 = r1 - s * bb
vi2 = s1 + r * bb
vr3 = r1 + s * bb
vi3 = s1 - r * bb
vr2 = r1 - s * bbs
vi2 = s1 + r * bbs
vr3 = r1 + s * bbs
vi3 = s1 - r * bbs
zout ( 1, j, nout1 ) = ur1 + vr1
zout ( 2, j, nout1 ) = ui1 + vi1

4
src/lib/mltfftsg.F
View file

@ -49,10 +49,10 @@ SUBROUTINE mltfftsg ( transa, transb, a, ldax, lday, b, ldbx, ldby, &
ENDIF
IF ( TSCAL ) THEN
IF ( LOT == NFFT ) THEN
CALL DSCAL ( 2 * LOT * N, SCALE, Z ( 1, 1 ), 1 )
CALL dscal ( 2 * LOT * N, SCALE, Z ( 1, 1 ), 1 )
ELSE
DO I = 1, N
CALL DSCAL ( 2 * NFFT, SCALE, Z ( LOT * ( I - 1 ) + 1, 1 ), 1 )
CALL dscal ( 2 * NFFT, SCALE, Z ( LOT * ( I - 1 ) + 1, 1 ), 1 )
END DO
END IF
END IF

12
src/library_tests.F
View file

@ -381,7 +381,7 @@ SUBROUTINE matmul_test ( globenv )
tstart = m_cputime ( )
DO j = 1, ntim
CALL DGEMM ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
CALL dgemm ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
END DO
tend = m_cputime ( )
t = tend - tstart
@ -394,8 +394,8 @@ SUBROUTINE matmul_test ( globenv )
tstart = m_cputime ( )
DO j = 1, ntim
CALL DGEMM ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
CALL DCOPY ( len * len , mc, 1, ma, 1)
CALL dgemm ( "N", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
CALL dcopy ( len * len , mc, 1, ma, 1)
END DO
tend = m_cputime ( )
t = tend - tstart
@ -408,7 +408,7 @@ SUBROUTINE matmul_test ( globenv )
tstart = m_cputime ( )
DO j = 1, ntim
CALL DGEMM ( "N", "T", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
CALL dgemm ( "N", "T", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
END DO
tend = m_cputime ( )
t = tend - tstart
@ -421,7 +421,7 @@ SUBROUTINE matmul_test ( globenv )
tstart = m_cputime ( )
DO j = 1, ntim
CALL DGEMM ( "T", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
CALL dgemm ( "T", "N", len, len, len, 1._dbl, ma, len, mb, len, 0._dbl, mc, len )
END DO
tend = m_cputime ( )
t = tend - tstart
@ -768,7 +768,7 @@ SUBROUTINE pw_fft_test ( globenv )
! grid % grid_span = HALFSPACE
CALL pw_find_cutoff ( np, box, cutoff )
cutoff = cutoff * cutoff
cutoff = 0.5_dbl * cutoff * cutoff
CALL pw_grid_setup ( box, grid, cutoff = cutoff, pe_group = globenv % group, &
info = globenv % scr )

136
src/linear_systems.F Normal file
View file

@ -0,0 +1,136 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/linear_systems [1.0] *
!!
!! NAME
!! linear_systems
!!
!! FUNCTION
!! Provides interfaces to LAPACK routines for factorisation and
!! linear system solving
!!
!! AUTHOR
!! JGH (30-5-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!! We are using LAPACK interfaces, so please make sure in IBM/AIX you have
!! the lapack library before essl: "xlf90 ... -llapack -lessl" !!!
!!
!! SOURCE
!******************************************************************************
MODULE linear_systems
USE kinds, ONLY : dbl
USE lapack, ONLY : lapack_spotrf, lapack_cpotrf, lapack_strtri, lapack_ctrtri
USE termination, ONLY : stop_program
IMPLICIT NONE
PRIVATE
PUBLIC :: cholesky_inverse
INTERFACE cholesky_inverse
MODULE PROCEDURE ch_inv_pdsym
MODULE PROCEDURE ch_inv_pdher
END INTERFACE
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
SUBROUTINE ch_inv_pdsym ( matrix, mysize, storageform )
IMPLICIT NONE
! Arguments
CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform
INTEGER, INTENT ( IN ) :: mysize
REAL ( KIND = dbl ), INTENT ( INOUT ) :: matrix ( :, : )
! Local
CHARACTER :: uplo, diag="N"
INTEGER :: info, lda
!------------------------------------------------------------------------------
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_program ( "ch_inv_pdsym", "unknown form of storage" )
END IF
lda = SIZE ( matrix, 1 )
CALL lapack_spotrf ( uplo, mysize, matrix, lda, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "ch_inv_pdsym", "error in Cholesky factorisation" )
END IF
CALL lapack_strtri ( uplo, diag, mysize, matrix, lda, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "ch_inv_pdsym", "error in inversion" )
END IF
END SUBROUTINE ch_inv_pdsym
!******************************************************************************
SUBROUTINE ch_inv_pdher ( matrix, mysize, storageform )
IMPLICIT NONE
! Arguments
CHARACTER ( LEN = * ), INTENT ( IN ) :: storageform
INTEGER, INTENT ( IN ) :: mysize
COMPLEX ( KIND = dbl ), INTENT ( INOUT ) :: matrix ( :, : )
! Local
CHARACTER :: uplo, diag="N"
INTEGER :: info, lda
!------------------------------------------------------------------------------
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_program ( "ch_inv_pdher", "unknown form of storage" )
END IF
lda = SIZE ( matrix, 1 )
CALL lapack_cpotrf ( uplo, mysize, matrix, lda, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "ch_inv_pdher", "error in Cholesky factorisation" )
END IF
CALL lapack_ctrtri ( uplo, diag, mysize, matrix, lda, info )
IF ( info /= 0 ) THEN
CALL stop_program ( "ch_inv_pdher", "error in inversion" )
END IF
END SUBROUTINE ch_inv_pdher
!******************************************************************************
END MODULE linear_systems
!******************************************************************************

2
src/linklist_cell_list.F
View file

@ -175,7 +175,7 @@ SUBROUTINE cell_list ( natom_types, n_cell, rcut, tag, pnode, part, &
END DO
END DO
#if defined ( __PGI ) || defined ( __AIX )
#if defined ( __PGI ) || defined ( __AIX ) || defined ( __DEC )
!*apsi* Due to some strange "feature" in PGI-3.2
DO kk = 1, n_cell(3)
DO jj = 1, n_cell(2)

11
src/machine_t3e.F
View file

@ -132,14 +132,3 @@ 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 termination, ONLY : stop_program
IMPLICIT NONE
CHARACTER :: jobz, uplo
INTEGER :: INFO, LDA, LWORK, N
REAL ( KIND = 4 ) :: A( LDA, * ), W( * ), WORK( * )
CALL stop_program ( "gsyev", "not defined" )
END SUBROUTINE gsyev

73
src/mathlib.F
View file

@ -196,8 +196,6 @@ CONTAINS
! ***************************************************************************
USE timings, ONLY: timeset,timestop
REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(wp), DIMENSION(:,:), INTENT(OUT) :: eigvec
REAL(wp), DIMENSION(:), INTENT(OUT) :: eigval
@ -205,7 +203,7 @@ CONTAINS
! *** Local variables ***
REAL(wp) :: abstol
INTEGER :: handle,info,istat,liwork,lwork,m,n,n_eigvec,nb
INTEGER :: info,istat,liwork,lwork,m,n,n_eigvec,nb
REAL(wp), DIMENSION(:), ALLOCATABLE :: work
INTEGER, DIMENSION(:), ALLOCATABLE :: ifail,iwork
@ -219,10 +217,6 @@ CONTAINS
! ---------------------------------------------------------------------------
! *** Start timer ***
CALL timeset("diamat (diagonalize_matrix)","I","",handle)
! *** Get the size of the matrix a ***
n = SIZE(a(:,:),1)
@ -309,10 +303,6 @@ CONTAINS
IF (istat /= 0) CALL stop_memory("SUBROUTINE diagonalize_matrix "//&
"(MODULE mathlib)","ifail")
! *** Stop timer ***
CALL timestop(0.0_wp,handle)
END SUBROUTINE diamat
! *****************************************************************************
@ -333,8 +323,6 @@ CONTAINS
! ***************************************************************************
USE timings, ONLY: timeset,timestop
REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(wp), DIMENSION(:), INTENT(OUT) :: eigval
@ -342,7 +330,7 @@ CONTAINS
! *** Local variables ***
INTEGER :: handle,info,istat,liwork,lwork,n,nb
INTEGER :: info,istat,liwork,lwork,n,nb
LOGICAL :: divide_and_conquer
REAL(wp), DIMENSION(:), ALLOCATABLE :: work
@ -352,14 +340,11 @@ CONTAINS
INTEGER, EXTERNAL :: ilaenv
EXTERNAL dsyev,dsyevd
!MK EXTERNAL dsyev,dsyevd
EXTERNAL dsyev
! ---------------------------------------------------------------------------
! *** Start timer ***
CALL timeset("diamat_all (diagonalize_matrix)","I","",handle)
! *** Get the size of the matrix a ***
n = SIZE(a(:,:),1)
@ -380,11 +365,11 @@ CONTAINS
! *** Check, if the divide-and-conquer algorithm is requested ***
IF (PRESENT(dac)) THEN
divide_and_conquer = dac
ELSE
!MK IF (PRESENT(dac)) THEN
! divide_and_conquer = dac
! ELSE
divide_and_conquer = .FALSE.
END IF
! END IF
! *** Get the optimal work storage size ***
@ -409,12 +394,12 @@ CONTAINS
! *** Diagonalize the matrix a ***
IF (divide_and_conquer) THEN
CALL dsyevd("V","U",n,a(:,:),n,eigval(:),work(:),lwork,iwork(:),liwork,&
info)
ELSE
CALL dsyev("V","U",n,a(:,:),n,eigval(:),work(:),lwork,info)
END IF
!MK IF (divide_and_conquer) THEN
! CALL dsyevd("V","U",n,a(:,:),n,eigval(:),work(:),lwork,iwork(:),liwork,&
! info)
! ELSE
CALL dsyev("V","U",n,a(1,1),n,eigval(1),work(1),lwork,info)
! END IF
IF (info /= 0) THEN
IF (divide_and_conquer) THEN
@ -437,10 +422,6 @@ CONTAINS
"(MODULE mathlib)","iwork")
END IF
! *** Stop timer ***
CALL timestop(0.0_wp,handle)
END SUBROUTINE diamat_all
! *****************************************************************************
@ -565,7 +546,6 @@ CONTAINS
! ***************************************************************************
USE termination, ONLY: get_error_unit
USE timings, ONLY: timeset,timestop
REAL(wp), INTENT(OUT) :: error
@ -579,7 +559,7 @@ CONTAINS
CHARACTER(LEN=80) :: message
CHARACTER(LEN=1) :: norm,trans
REAL(wp) :: a_norm,old_error,r_cond
INTEGER :: handle,info,istat,iter,n,output_unit
INTEGER :: info,istat,iter,n,output_unit
REAL(wp), DIMENSION(:), ALLOCATABLE :: berr,ferr,work
INTEGER, DIMENSION(:), ALLOCATABLE :: ipiv,iwork
@ -594,10 +574,6 @@ CONTAINS
! ---------------------------------------------------------------------------
! *** Start timer ***
CALL timeset("invert_matrix","I","",handle)
! *** Check for optional parameter ***
IF (PRESENT(option)) THEN
@ -753,10 +729,6 @@ CONTAINS
IF (istat /= 0) CALL stop_memory("SUBROUTINE invert_matrix "//&
"(MODULE mathlib)","a_lu")
! *** Stop timer ***
CALL timestop(0.0_wp,handle)
END SUBROUTINE invert_matrix
! *****************************************************************************
@ -783,8 +755,6 @@ CONTAINS
! ***************************************************************************
USE timings, ONLY: timeset,timestop
REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: a
REAL(wp), DIMENSION(:,:), INTENT(OUT) :: a_power
@ -797,7 +767,7 @@ CONTAINS
! *** Local variables ***
REAL(wp) :: eps_eigval,expa
INTEGER :: handle,i,istat,n,n_dep
INTEGER :: i,istat,n,n_dep
LOGICAL :: divide_and_conquer
REAL(wp), DIMENSION(:), ALLOCATABLE :: eigval
@ -806,10 +776,6 @@ CONTAINS
! ---------------------------------------------------------------------------
! *** Start timer ***
CALL timeset("power_matrix","I","",handle)
! *** Define the threshold for the eigenvalue quenching ***
IF (PRESENT(threshold)) THEN
@ -844,7 +810,8 @@ CONTAINS
! *** Check, if the divide-and-conquer algorithm is requested ***
IF (PRESENT(dac)) THEN
divide_and_conquer = dac
!MK divide_and_conquer = dac
divide_and_conquer = .FALSE.
ELSE
divide_and_conquer = .FALSE.
END IF
@ -887,10 +854,6 @@ CONTAINS
IF (istat /= 0) CALL stop_memory("SUBROUTINE power_matrix "//&
"(MODULE mathlib)","eigval")
! *** Stop timer ***
CALL timestop(0.0_wp,handle)
END SUBROUTINE power_matrix
! *****************************************************************************

35
src/matrix_types.F
View file

@ -178,9 +178,9 @@ CONTAINS
USE memory_utilities, ONLY: reallocate
USE termination, ONLY: stop_memory,stop_program
TYPE(real_matrix_type), POINTER :: matrix
INTEGER, INTENT(IN) :: block_col,block_row
REAL(wp), DIMENSION(:,:), OPTIONAL, POINTER:: block
TYPE(real_matrix_type), POINTER :: matrix
INTEGER, INTENT(IN) :: block_col,block_row
REAL(wp), DIMENSION(:,:), OPTIONAL, POINTER :: block
! *** Local parameters ***
@ -408,13 +408,12 @@ CONTAINS
TYPE(real_block_node_type), POINTER :: source_block_node,&
target_block_node
INTEGER :: source_first_col,source_first_row,&
INTEGER :: first_col,first_row,iblock_col,iblock_row,icol,irow,istat,&
jblock_col,jblock_row,jcol,jrow,last_col,last_row,&
source_first_col,source_first_row,&
source_last_col,source_last_row,&
target_first_col,target_first_row,&
target_last_col,target_last_row,&
first_col,first_row,&
iblock_col,iblock_row,icol,irow,istat,&
jblock_col,jblock_row,jcol,jrow
target_last_col,target_last_row
! ---------------------------------------------------------------------------
@ -463,18 +462,24 @@ CONTAINS
IF ((target_first_col <= source_last_col).AND.&
(target_last_col >= source_first_col)) THEN
first_row = MAX(source_first_row,target_first_row)
first_col = MAX(source_first_col,target_first_col)
first_row = MAX(source_first_row,target_first_row)
DO irow=first_row-source_first_row+1,&
source_last_row-source_first_row+1
jrow = first_row - target_first_row + irow
DO icol=first_col-source_first_col+1,&
source_last_col-source_first_col+1
jcol = first_col - target_first_col + icol
last_col = MIN(source_last_col,target_last_col)
last_row = MIN(source_last_row,target_last_row)
jcol = first_col - target_first_col + 1
DO icol=first_col-source_first_col+1,&
last_col-source_first_col+1
jrow = first_row - target_first_row + 1
DO irow=first_row-source_first_row+1,&
last_row-source_first_row+1
target_block_node%block(jrow,jcol) =&
source_block_node%block(irow,icol)
jrow = jrow + 1
END DO
jcol = jcol + 1
END DO
END IF

2
src/md.F
View file

@ -26,6 +26,7 @@ MODULE md
USE parser, ONLY : parser_init, parser_end, read_line, test_next, &
cfield, p_error, get_real, get_int, stop_parser
USE particle_types, ONLY : particle_type
USE read_pimd, ONLY : pimd_parameters_type
USE string_utilities, ONLY : uppercase, xstring
USE util, ONLY : gasdev
@ -54,6 +55,7 @@ MODULE md
REAL ( dbl ), POINTER, DIMENSION ( : ) :: dt_yosh
REAL ( dbl ) :: shake_tol
REAL ( dbl ) :: verlet_skin
TYPE ( pimd_parameters_type ) :: pimd_params
END TYPE simulation_parameters_type
TYPE thermodynamic_type

267
src/memory_utilities.F
View file

@ -37,7 +37,9 @@ MODULE memory_utilities
! *****************************************************************************
INTERFACE reallocate
MODULE PROCEDURE reallocate_i0,reallocate_i1,reallocate_i2,reallocate_i3,&
MODULE PROCEDURE reallocate_c0,reallocate_c1,reallocate_c2,reallocate_c3,&
reallocate_c4,&
reallocate_i0,reallocate_i1,reallocate_i2,reallocate_i3,&
reallocate_i4,&
reallocate_r0,reallocate_r1,reallocate_r2,reallocate_r3,&
reallocate_r4
@ -47,6 +49,269 @@ MODULE memory_utilities
CONTAINS
! *****************************************************************************
FUNCTION reallocate_c0(p_old) RESULT(p_new)
! Purpose: (Re)Allocate a pointer to a complex number.
! History: - Creation (30.03.2001, Matthias Krack)
! ***************************************************************************
COMPLEX(wp), POINTER :: p_old
COMPLEX(wp), POINTER :: p_new
! *** Local variables ***
INTEGER :: istat
! ---------------------------------------------------------------------------
ALLOCATE (p_new,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c0 (MODULE memory_utilities)",&
"p_new",wp_size)
END IF
p_new = 0.0_wp
IF (ASSOCIATED(p_old)) THEN
p_new = p_old
DEALLOCATE (p_old,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c0 (MODULE memory_utilities)",&
"p_old")
END IF
END IF
END FUNCTION reallocate_c0
! *****************************************************************************
FUNCTION reallocate_c1(p_old,n1_new,n2_new) RESULT(p_new)
! Purpose: (Re)Allocate a real vector of with a new dimension.
! History: - Creation (20.08.1999, Matthias Krack)
! ***************************************************************************
INTEGER, INTENT(IN) :: n1_new,n2_new
COMPLEX(wp), DIMENSION(:), POINTER :: p_old
COMPLEX(wp), DIMENSION(:), POINTER :: p_new
! *** Local variables ***
INTEGER :: istat,n1,n1_old,n2,n2_old,new_size
! ---------------------------------------------------------------------------
ALLOCATE (p_new(n1_new:n2_new),STAT=istat)
IF (istat /= 0) THEN
new_size = (n2_new - n1_new + 1)*wp_size
CALL stop_memory("FUNCTION reallocate_c1 (MODULE memory_utilities)",&
"p_new",new_size)
END IF
p_new(:) = 0.0_wp
IF (ASSOCIATED(p_old)) THEN
n1_old = LBOUND(p_old,1)
n2_old = UBOUND(p_old,1)
n1 = MAX(n1_new,n1_old)
n2 = MIN(n2_new,n2_old)
p_new(n1:n2) = p_old(n1:n2)
DEALLOCATE (p_old,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c1 (MODULE memory_utilities)",&
"p_old")
END IF
END IF
END FUNCTION reallocate_c1
! *****************************************************************************
FUNCTION reallocate_c2(p_old,m1_new,m2_new,&
n1_new,n2_new) RESULT(p_new)
! Purpose: (Re)Allocate a real array with new dimensions.
! History: - Creation (25.06.1999, Matthias Krack)
! ***************************************************************************
INTEGER, INTENT(IN) :: m1_new,m2_new,n1_new,n2_new
COMPLEX(wp), DIMENSION(:,:), POINTER :: p_old
COMPLEX(wp), DIMENSION(:,:), POINTER :: p_new
! *** Local variables ***
INTEGER :: istat,m1,m1_old,m2,m2_old,n1,n1_old,n2,n2_old,new_size
! ---------------------------------------------------------------------------
ALLOCATE (p_new(m1_new:m2_new,n1_new:n2_new),STAT=istat)
IF (istat /= 0) THEN
new_size = (m2_new - m1_new + 1)*&
(n2_new - n1_new + 1)*wp_size
CALL stop_memory("FUNCTION reallocate_c2 (MODULE memory_utilities)",&
"p_new",new_size)
END IF
p_new(:,:) = 0.0_wp
IF (ASSOCIATED(p_old)) THEN
m1_old = LBOUND(p_old,1)
m2_old = UBOUND(p_old,1)
n1_old = LBOUND(p_old,2)
n2_old = UBOUND(p_old,2)
m1 = MAX(m1_new,m1_old)
m2 = MIN(m2_new,m2_old)
n1 = MAX(n1_new,n1_old)
n2 = MIN(n2_new,n2_old)
p_new(m1:m2,n1:n2) = p_old(m1:m2,n1:n2)
DEALLOCATE (p_old,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c2 (MODULE memory_utilities)",&
"p_old")
END IF
END IF
END FUNCTION reallocate_c2
! *****************************************************************************
FUNCTION reallocate_c3(p_old,l1_new,l2_new,&
m1_new,m2_new,&
n1_new,n2_new) RESULT(p_new)
! Purpose: (Re)Allocate a real array with new dimensions.
! History: - Creation (25.06.1999, Matthias Krack)
! ***************************************************************************
INTEGER, INTENT(IN) :: l1_new,l2_new,m1_new,m2_new,n1_new,n2_new
COMPLEX(wp), DIMENSION(:,:,:), POINTER :: p_old
COMPLEX(wp), DIMENSION(:,:,:), POINTER :: p_new
! *** Local variables ***
INTEGER :: istat,l1,l1_old,l2,l2_old,m1,m1_old,m2,m2_old,n1,n1_old,n2,&
n2_old,new_size
! ---------------------------------------------------------------------------
ALLOCATE (p_new(l1_new:l2_new,m1_new:m2_new,n1_new:n2_new),STAT=istat)
IF (istat /= 0) THEN
new_size = (l2_new - l1_new + 1)*&
(m2_new - m1_new + 1)*&
(n2_new - n1_new + 1)*wp_size
CALL stop_memory("FUNCTION reallocate_c3 (MODULE memory_utilities)",&
"p_new",new_size)
END IF
p_new(:,:,:) = 0.0_wp
IF (ASSOCIATED(p_old)) THEN
l1_old = LBOUND(p_old,1)
l2_old = UBOUND(p_old,1)
m1_old = LBOUND(p_old,2)
m2_old = UBOUND(p_old,2)
n1_old = LBOUND(p_old,3)
n2_old = UBOUND(p_old,3)
l1 = MAX(l1_new,l1_old)
l2 = MIN(l2_new,l2_old)
m1 = MAX(m1_new,m1_old)
m2 = MIN(m2_new,m2_old)
n1 = MAX(n1_new,n1_old)
n2 = MIN(n2_new,n2_old)
p_new(l1:l2,m1:m2,n1:n2) = p_old(l1:l2,m1:m2,n1:n2)
DEALLOCATE (p_old,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c3 (MODULE memory_utilities)",&
"p_old")
END IF
END IF
END FUNCTION reallocate_c3
! *****************************************************************************
FUNCTION reallocate_c4(p_old,k1_new,k2_new,&
l1_new,l2_new,&
m1_new,m2_new,&
n1_new,n2_new) RESULT(p_new)
! Purpose: (Re)Allocate a real array with new dimensions.
! History: - Creation (25.06.1999, Matthias Krack)
! ***************************************************************************
INTEGER, INTENT(IN) :: k1_new,k2_new,l1_new,l2_new,m1_new,m2_new,n1_new,&
n2_new
COMPLEX(wp), DIMENSION(:,:,:,:), POINTER :: p_old
COMPLEX(wp), DIMENSION(:,:,:,:), POINTER :: p_new
! *** Local variables ***
INTEGER :: istat,k1,k1_old,k2,k2_old,l1,l1_old,l2,l2_old,m1,m1_old,m2,&
m2_old,n1,n1_old,n2,n2_old,new_size
! ---------------------------------------------------------------------------
ALLOCATE (p_new(k1_new:k2_new,l1_new:l2_new,m1_new:m2_new,n1_new:n2_new),&
STAT=istat)
IF (istat /= 0) THEN
new_size = (k2_new - k1_new + 1)*&
(l2_new - l1_new + 1)*&
(m2_new - m1_new + 1)*&
(n2_new - n1_new + 1)*wp_size
CALL stop_memory("FUNCTION reallocate_c4 (MODULE memory_utilities)",&
"p_new",new_size)
END IF
p_new(:,:,:,:) = 0.0_wp
IF (ASSOCIATED(p_old)) THEN
k1_old = LBOUND(p_old,1)
k2_old = UBOUND(p_old,1)
l1_old = LBOUND(p_old,2)
l2_old = UBOUND(p_old,2)
m1_old = LBOUND(p_old,3)
m2_old = UBOUND(p_old,3)
n1_old = LBOUND(p_old,4)
n2_old = UBOUND(p_old,4)
k1 = MAX(k1_new,k1_old)
k2 = MIN(k2_new,k2_old)
l1 = MAX(l1_new,l1_old)
l2 = MIN(l2_new,l2_old)
m1 = MAX(m1_new,m1_old)
m2 = MIN(m2_new,m2_old)
n1 = MAX(n1_new,n1_old)
n2 = MIN(n2_new,n2_old)
p_new(k1:k2,l1:l2,m1:m2,n1:n2) = p_old(k1:k2,l1:l2,m1:m2,n1:n2)
DEALLOCATE (p_old,STAT=istat)
IF (istat /= 0) THEN
CALL stop_memory("FUNCTION reallocate_c4 (MODULE memory_utilities)",&
"p_old")
END IF
END IF
END FUNCTION reallocate_c4
! *****************************************************************************
FUNCTION reallocate_i0(p_old) RESULT(p_new)

178
src/message_passing.F
View file

@ -14,11 +14,12 @@
!! JGH
!!
!! MODIFICATION HISTORY
!! JGH (2-1-2001): New error handling
!! Performance tools
!! JGH (02-Jan-2001): New error handling
!! Performance tools
!! JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
!! mp_rank_compare, mp_transpose
!! JGH (6-Feb-2001): New routines mp_comm_free
!! JGH (06-Feb-2001): New routines mp_comm_free
!! JGH (22-Mar-2001): New routines mp_comm_dup
!!
!! SOURCE
!******************************************************************************
@ -33,18 +34,19 @@ MODULE message_passing
PUBLIC :: mp_start, mp_end, mp_world_setup, mp_group, mp_cart_create, &
mp_bcast, mp_stop, mp_sum, mp_max, mp_min, mp_sync, mp_environ, &
mp_gather, mp_comm_compare, mp_cart_coords, mp_rank_compare, &
mp_transpose, mp_dims_create, mp_cart_rank, mp_cart_sub, mp_comm_free
mp_transpose, mp_dims_create, mp_cart_rank, mp_cart_sub, mp_comm_free, &
mp_comm_dup, mp_cart_shift, mp_sendrecv
INTERFACE mp_bcast
MODULE PROCEDURE mp_bcast_i1, mp_bcast_r1, mp_bcast_c1, mp_bcast_z, &
mp_bcast_iv, mp_bcast_rv, mp_bcast_cv, mp_bcast_l, mp_bcast_rm, &
mp_bcast_cm, mp_bcast_im
mp_bcast_cm, mp_bcast_im, mp_bcast_rm3
END INTERFACE
INTERFACE mp_sum
MODULE PROCEDURE mp_sum_i1, mp_sum_r1, mp_sum_c1, mp_sum_iv, &
mp_sum_rv, mp_sum_cv, mp_sum_im, mp_sum_rm, mp_sum_cm, &
mp_sum_im3
mp_sum_im3, mp_sum_rm3, mp_sum_root_rm3
END INTERFACE
INTERFACE mp_max
@ -67,6 +69,10 @@ MODULE message_passing
MODULE PROCEDURE mp_transpose_c22v, mp_transpose_i
END INTERFACE
INTERFACE mp_sendrecv
MODULE PROCEDURE mp_sendrecv_rm3
END INTERFACE
TYPE mp_perf_type
CHARACTER ( LEN = 20 ) :: name
INTEGER :: count
@ -74,11 +80,12 @@ MODULE message_passing
REAL ( dbl ) :: time
END TYPE mp_perf_type
INTEGER, PARAMETER :: MAX_PERF = 6
INTEGER, PARAMETER :: MAX_PERF = 7
TYPE ( mp_perf_type ), DIMENSION ( MAX_PERF ) :: mp_perf
CHARACTER ( LEN = 20 ), PARAMETER :: sname ( MAX_PERF ) = &
(/"MP_Group ", "MP_Bcast ", "MP_Allreduce ", &
"MP_Gather ", "MP_Sync ", "MP_Transpose "/)
"MP_Gather ", "MP_Sync ", "MP_Transpose ", &
"MP_SendRecv "/)
REAL ( dbl ) :: t_start, t_end
INTEGER :: intlen, reallen, charlen, loglen
@ -196,12 +203,13 @@ SUBROUTINE mp_stop ( ierr, prg_code )
CALL mp_world_setup ( numtask, taskid, groupid )
WRITE(*,'(/,A,T71,I10,/)') ' CP2K| Stopped by processor number',taskid
WRITE(*,'(/,A,T71,I10)') ' CP2K| Stopped by processor number',taskid
WRITE(*,'(A,T31,A50)') ' CP2K| ', ADJUSTR ( prg_code )
WRITE(*,'(A,T71,I10,/)') ' CP2K| Error number was ',ierr
#if defined(__parallel)
CALL mpi_error_string ( ierr, error_string, len )
WRITE(*,'(A,A)') ' CP2K| ', ADJUSTR ( error_string )
WRITE(*,'(A,T31,A50,/)') ' CP2K| ', ADJUSTR ( prg_code )
CALL mpi_abort ( MPI_COMM_WORLD, prg_code )
#endif
@ -387,6 +395,9 @@ SUBROUTINE mp_cart_create ( comm_old, ndims, dims, pos, comm_cart )
mp_perf ( 2 ) % count = mp_perf ( 2 ) % count + 1
t_end = cputime ( )
mp_perf ( 1 ) % time = mp_perf ( 1 ) % time + ( t_end - t_start )
#else
dims = 1
comm_cart = 0
#endif
END SUBROUTINE mp_cart_create
@ -410,12 +421,39 @@ SUBROUTINE mp_cart_coords ( comm, rank, coords)
#if defined(__parallel)
CALL mpi_cart_coords ( comm, rank, m, coords, ierr )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_cart_coords @ mp_cart_coords" )
#else
coords = 0
#endif
END SUBROUTINE mp_cart_coords
!******************************************************************************
!..mp_cart_shift
SUBROUTINE mp_cart_shift ( comm, dir, disp, source, dest )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: comm, dir, disp
INTEGER, INTENT ( OUT ) :: source, dest
! Locals
INTEGER :: ierr
ierr = 0
#if defined(__parallel)
CALL mpi_cart_shift ( comm, dir, disp, source, dest, ierr )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_cart_shift @ mp_cart_shift" )
#else
source = 0
dest = 0
#endif
END SUBROUTINE mp_cart_shift
!******************************************************************************
!..mp_comm_compare
SUBROUTINE mp_comm_compare ( comm1, comm2, result)
@ -482,6 +520,27 @@ SUBROUTINE mp_comm_free ( comm )
END SUBROUTINE mp_comm_free
!******************************************************************************
!..mp_comm_dup
SUBROUTINE mp_comm_dup ( comm1, comm2 )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: comm1
INTEGER, INTENT ( OUT ) :: comm2
! Locals
INTEGER :: ierr
ierr = 0
#if defined(__parallel)
CALL mpi_comm_dup ( comm1, comm2, ierr )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_comm_dup @ mp_comm_dup" )
#endif
END SUBROUTINE mp_comm_dup
!******************************************************************************
@ -592,7 +651,7 @@ SUBROUTINE mp_transpose_c22v ( sb, scount, sdispl, rb, rcount, rdispl, group )
t_start = cputime ( )
CALL mpi_alltoallv ( sb, scount, sdispl, MPI_DOUBLE_COMPLEX, &
rb, rcount, rdispl, MPI_DOUBLE_COMPLEX, group, ierr )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_alltoallv @ mp_transpose_c23v" )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_alltoallv @ mp_transpose_c22v" )
mp_perf ( 6 ) % count = mp_perf ( 6 ) % count + 1
msglen = SUM ( scount ) + SUM ( rcount )
mp_perf ( 6 ) % msg_size = mp_perf ( 6 ) % msg_size + msglen * 2 * reallen
@ -742,6 +801,24 @@ SUBROUTINE mp_bcast_rm(msg,source,gid)
mp_perf ( 2 ) % time = mp_perf ( 2 ) % time + ( t_end - t_start )
#endif
END SUBROUTINE mp_bcast_rm
SUBROUTINE mp_bcast_rm3(msg,source,gid)
IMPLICIT NONE
REAL ( dbl ) :: msg ( :, :, : )
INTEGER :: source, gid
INTEGER :: msglen, ierr
ierr = 0
msglen = size(msg)
#if defined(__parallel)
t_start = cputime ( )
CALL mpi_bcast(msg,msglen,MPI_DOUBLE_PRECISION,source,gid,ierr)
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_bcast @ mp_bcast_rm" )
mp_perf ( 2 ) % count = mp_perf ( 2 ) % count + 1
mp_perf ( 2 ) % msg_size = mp_perf ( 2 ) % msg_size + msglen * reallen
t_end = cputime ( )
mp_perf ( 2 ) % time = mp_perf ( 2 ) % time + ( t_end - t_start )
#endif
END SUBROUTINE mp_bcast_rm3
SUBROUTINE mp_bcast_c1(msg,source,gid)
IMPLICIT NONE
COMPLEX ( dbl ) :: msg
@ -1002,6 +1079,60 @@ SUBROUTINE mp_sum_rm(msg,gid)
mp_perf ( 3 ) % time = mp_perf ( 3 ) % time + ( t_end - t_start )
#endif
END SUBROUTINE mp_sum_rm
SUBROUTINE mp_sum_rm3(msg,gid)
IMPLICIT NONE
REAL ( dbl ), INTENT ( INOUT ) :: msg ( :, :, : )
INTEGER, INTENT ( IN ) :: gid
INTEGER :: msglen, m1, m2, m3, ierr
REAL ( dbl ), ALLOCATABLE :: res ( :, :, : )
#if defined(__parallel)
t_start = cputime ( )
msglen = size(msg)
m1 = size(msg,1)
m2 = size(msg,2)
m3 = size(msg,3)
ALLOCATE (res(m1,m2,m3),STAT=ierr)
IF ( ierr /= 0 ) CALL mp_stop( 0, "allocate @ mp_sum_rm3" )
CALL mpi_allreduce(msg,res,msglen,MPI_DOUBLE_PRECISION,MPI_SUM,gid, &
ierr)
msg = res
DEALLOCATE (res)
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_allreduce @ mp_sum_rm3" )
mp_perf ( 3 ) % count = mp_perf ( 3 ) % count + 1
mp_perf ( 3 ) % msg_size = mp_perf ( 3 ) % msg_size + msglen * reallen
t_end = cputime ( )
mp_perf ( 3 ) % time = mp_perf ( 3 ) % time + ( t_end - t_start )
#endif
END SUBROUTINE mp_sum_rm3
SUBROUTINE mp_sum_root_rm3(msg,root,gid)
IMPLICIT NONE
REAL ( dbl ), INTENT ( INOUT ) :: msg ( :, :, : )
INTEGER, INTENT ( IN ) :: root,gid
INTEGER :: msglen, m1, m2, m3, ierr, taskid
REAL ( dbl ), ALLOCATABLE :: res ( :, :, : )
#if defined(__parallel)
t_start = cputime ( )
CALL mpi_comm_rank ( gid, taskid, ierr )
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_comm_rank @ mp_sum_root_rm3" )
msglen = size(msg)
m1 = size(msg,1)
m2 = size(msg,2)
m3 = size(msg,3)
ALLOCATE (res(m1,m2,m3),STAT=ierr)
IF ( ierr /= 0 ) CALL mp_stop( 0, "allocate @ mp_sum_root_rm3" )
CALL mpi_reduce(msg,res,msglen,MPI_DOUBLE_PRECISION,MPI_SUM,&
root,gid,ierr)
IF ( taskid == root ) THEN
msg = res
END IF
DEALLOCATE (res)
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_reduce @ mp_sum_root_rm" )
mp_perf ( 3 ) % count = mp_perf ( 3 ) % count + 1
mp_perf ( 3 ) % msg_size = mp_perf ( 3 ) % msg_size + msglen * reallen
t_end = cputime ( )
mp_perf ( 3 ) % time = mp_perf ( 3 ) % time + ( t_end - t_start )
#endif
END SUBROUTINE mp_sum_root_rm3
SUBROUTINE mp_sum_c1(msg,gid)
IMPLICIT NONE
COMPLEX ( dbl ), INTENT ( INOUT ) :: msg
@ -1325,6 +1456,31 @@ SUBROUTINE mp_gather_rv(msg,msg_gather,root,gid)
#endif
END SUBROUTINE mp_gather_rv
!******************************************************************************
SUBROUTINE mp_sendrecv_rm3(msgin,dest,msgout,source,comm)
IMPLICIT NONE
REAL ( dbl ), INTENT ( IN ) :: msgin ( :, :, : )
REAL ( dbl ), INTENT ( OUT ) :: msgout ( :, :, : )
INTEGER, INTENT ( IN ) :: dest, source, comm
INTEGER :: msglen, ierr, send_tag, recv_tag, status
#if defined(__parallel)
t_start = cputime ( )
msglen = SIZE(msgin)
send_tag = 0 ! cannot think of something better here, this might be dangerous
recv_tag = 0 ! cannot think of something better here, this might be dangerous
CALL mpi_sendrecv(msgin,msglen,MPI_DOUBLE_PRECISION,dest,send_tag,msgout,&
msglen,MPI_DOUBLE_PRECISION,source,recv_tag,comm,status,ierr)
! we do not check the status
IF ( ierr /= 0 ) CALL mp_stop( ierr, "mpi_sendrecv @ mp_send_recv_rm3" )
mp_perf ( 7 ) % count = mp_perf ( 7 ) % count + 1
mp_perf ( 7 ) % msg_size = mp_perf ( 7 ) % msg_size + msglen * reallen
t_end = cputime ( )
mp_perf ( 7 ) % time = mp_perf ( 7 ) % time + ( t_end - t_start )
#else
msgout = msgin
#endif
END SUBROUTINE mp_sendrecv_rm3
!******************************************************************************

324
src/mo_types.F Normal file
View file

@ -0,0 +1,324 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/mo_types [1.0] *
!!
!! NAME
!! mo_types
!!
!! FUNCTION
!! Definition and initialisation of the mo data type.
!!
!! AUTHOR
!! Matthias Krack (09.05.2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE mo_types
! *****************************************************************************
USE kinds, ONLY: wp => dp
USE global_types, ONLY: global_environment_type
USE input_utilities, ONLY: close_file,&
open_file
USE matrix_types, ONLY: allocate_matrix,&
deallocate_matrix,&
get_block_node,&
real_matrix_set_type
IMPLICIT NONE
PRIVATE
TYPE mo_set_type
INTEGER :: homo,lfomo
REAL(wp), DIMENSION(:), POINTER :: eigenvalues,occupation_numbers
TYPE(real_matrix_set_type) :: eigenvectors
END TYPE mo_set_type
! *** Public data types ***
PUBLIC :: mo_set_type
! *** Public subroutines ***
PUBLIC :: allocate_mo_set,&
deallocate_mo_set,&
read_mo_set,&
write_mo_set
! *****************************************************************************
INTERFACE write_mo_set
MODULE PROCEDURE write_mo_set_to_output_unit,write_mo_set_to_restart_unit
END INTERFACE
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE allocate_mo_set(mo_set,nao,nmo)
USE memory_utilities, ONLY: reallocate
TYPE(mo_set_type), INTENT(OUT) :: mo_set
INTEGER, INTENT(IN) :: nao,nmo
! ---------------------------------------------------------------------------
mo_set%homo = 0
mo_set%lfomo = 0
NULLIFY (mo_set%eigenvalues)
mo_set%eigenvalues => reallocate(mo_set%eigenvalues,1,nmo)
NULLIFY (mo_set%occupation_numbers)
mo_set%occupation_numbers => reallocate(mo_set%occupation_numbers,1,nmo)
NULLIFY (mo_set%eigenvectors%matrix)
CALL allocate_matrix(matrix=mo_set%eigenvectors%matrix,&
nrow=nao,&
ncol=nmo,&
matrix_name="MO EIGENVECTORS",&
matrix_symmetry="none")
END SUBROUTINE allocate_mo_set
! *****************************************************************************
SUBROUTINE deallocate_mo_set(mo_set)
TYPE(mo_set_type), INTENT(INOUT) :: mo_set
! ---------------------------------------------------------------------------
DEALLOCATE (mo_set%eigenvalues)
DEALLOCATE (mo_set%occupation_numbers)
CALL deallocate_matrix(matrix=mo_set%eigenvectors%matrix)
END SUBROUTINE deallocate_mo_set
! *****************************************************************************
SUBROUTINE read_mo_set(mo_set,globenv)
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(mo_set_type), INTENT(IN) :: mo_set
! *** Local variables ***
INTEGER :: iao,imo,restart_unit
REAL(wp), DIMENSION(:,:), POINTER :: mo_eigenvectors
! ---------------------------------------------------------------------------
CALL get_block_node(matrix=mo_set%eigenvectors%matrix,&
block_row=1,&
block_col=1,&
block=mo_eigenvectors)
CALL open_file(file_name=globenv%restart_file_name,&
file_action="READ",&
file_form="UNFORMATTED",&
file_status="OLD",&
unit_number=restart_unit)
READ (UNIT=restart_unit) ((mo_eigenvectors(iao,imo),&
iao=1,SIZE(mo_eigenvectors,1)),&
imo=1,SIZE(mo_eigenvectors,2))
CALL close_file(unit_number=restart_unit)
END SUBROUTINE read_mo_set
! *****************************************************************************
SUBROUTINE write_mo_set_to_restart_unit(mo_set,globenv)
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(mo_set_type), INTENT(IN) :: mo_set
! *** Local variables ***
INTEGER :: iao,imo,restart_unit
REAL(wp), DIMENSION(:,:), POINTER :: mo_eigenvectors
! ---------------------------------------------------------------------------
CALL get_block_node(matrix=mo_set%eigenvectors%matrix,&
block_row=1,&
block_col=1,&
block=mo_eigenvectors)
CALL open_file(file_name=globenv%restart_file_name,&
file_action="WRITE",&
file_form="UNFORMATTED",&
file_status="REPLACE",&
unit_number=restart_unit)
WRITE (UNIT=restart_unit) ((mo_eigenvectors(iao,imo),&
iao=1,SIZE(mo_eigenvectors,1)),&
imo=1,SIZE(mo_eigenvectors,2))
CALL close_file(unit_number=restart_unit)
END SUBROUTINE write_mo_set_to_restart_unit
! *****************************************************************************
SUBROUTINE write_mo_set_to_output_unit(mo_set,before,after,globenv)
! Purpose: Write the MO eigenvalues, MO occupation numbers and
! MO eigenvectors.
! History: - Creation (15.05.2001, Matthias Krack)
! ***************************************************************************
! List of variables:
! after : Number of digits after point.
! before: Number of digits before point.
! ---------------------------------------------------------------------------
USE atomic_kinds, ONLY: kind_info
USE atoms, ONLY: atom_info,natom,nsgf
USE orbital_pointers, ONLY: nso
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(mo_set_type), INTENT(IN) :: mo_set
INTEGER, INTENT(IN) :: after,before
! *** Local variables ***
CHARACTER(LEN=60) :: name
CHARACTER(LEN=25) :: fmtstr1
CHARACTER(LEN=22) :: fmtstr2
CHARACTER(LEN=35) :: fmtstr3
INTEGER :: from,iatom,icol,ikind,irow,iset,isgf,iso,ishell,jcol,&
l,left,ncol,output_unit,right,to,width
REAL(wp), DIMENSION(:,:), POINTER :: matrix
! ---------------------------------------------------------------------------
IF (.NOT.globenv%print%mo_eigenvalues) RETURN
output_unit = globenv%scr
CALL get_block_node(matrix=mo_set%eigenvectors%matrix,&
block_row=1,&
block_col=1,&
block=matrix)
IF (.NOT.globenv%ionode) RETURN
! *** Definition of the variable formats ***
fmtstr1 = "(/,T2,23X, ( X,I5, X))"
fmtstr2 = "(T2,23X, (1X,F . ))"
fmtstr3 = "(T2,2I5,2X,A2,1X,A8, (1X,F . ))"
! *** Write headline ***
IF (globenv%print%mo_eigenvectors) THEN
name = "MO EIGENVALUES, MO OCCUPATION NUMBERS AND MO EIGENVECTORS"
ELSE IF (globenv%print%mo_occupation_numbers) THEN
name = "MO EIGENVALUES AND MO OCCUPATION NUMBERS"
ELSE
name = "MO EIGENVALUES"
END IF
WRITE (output_unit,"(/,/,T2,A)") TRIM(name)
! *** Write the variable format strings ***
width = before + after + 3
ncol = INT(56/width)
right = MAX((after-2),1)
left = width - right - 5
WRITE (fmtstr1(11:12),"(I2)") ncol
WRITE (fmtstr1(14:15),"(I2)") left
WRITE (fmtstr1(21:22),"(I2)") right
WRITE (fmtstr2(9:10),"(I2)") ncol
WRITE (fmtstr2(16:17),"(I2)") width - 1
WRITE (fmtstr2(19:20),"(I2)") after
WRITE (fmtstr3(22:23),"(I2)") ncol
WRITE (fmtstr3(29:30),"(I2)") width - 1
WRITE (fmtstr3(32:33),"(I2)") after
! *** Write the matrix in the selected format ***
DO icol=1,nsgf,ncol
from = icol
to = MIN((from+ncol-1),nsgf)
WRITE (output_unit,fmtstr1)&
(jcol,jcol=from,to)
WRITE (output_unit,fmtstr2)&
(mo_set%eigenvalues(jcol),jcol=from,to)
WRITE (output_unit,"(A)") ""
IF (globenv%print%mo_occupation_numbers) THEN
WRITE (output_unit,fmtstr2)&
(mo_set%occupation_numbers(jcol),jcol=from,to)
WRITE (output_unit,"(A)") ""
END IF
IF (globenv%print%mo_eigenvectors) THEN
irow = 1
DO iatom=1,natom
IF (iatom /= 1) WRITE (output_unit,"(A)") ""
ikind = atom_info(iatom)%kind
isgf = 1
DO iset=1,kind_info(ikind)%orb_basis_set%nset
DO ishell=1,kind_info(ikind)%orb_basis_set%nshell(iset)
l = kind_info(ikind)%orb_basis_set%l(ishell,iset)
DO iso=1,nso(l)
WRITE (output_unit,fmtstr3)&
irow,iatom,kind_info(ikind)%element_symbol,&
kind_info(ikind)%orb_basis_set%sgf_symbol(isgf),&
(matrix(irow,jcol),jcol=from,to)
isgf = isgf + 1
irow = irow + 1
END DO
END DO
END DO
END DO
END IF
END DO
WRITE (output_unit,"(/)")
END SUBROUTINE write_mo_set_to_output_unit
! *****************************************************************************
END MODULE mo_types

77
src/nl.F
View file

@ -56,10 +56,9 @@ MODULE nl
TYPE(neighbor_list_set_type), POINTER :: aux_neighbor_list_set,&
orb_neighbor_list_set,&
verfc_neighbor_list_set,&
verf_ppl_neighbor_list_set,&
vexp_ppl_neighbor_list_set,&
vprj_ppnl_ac_neighbor_list_set,&
vprj_ppnl_ca_neighbor_list_set
vppl_neighbor_list_set,&
vppnl_ac_neighbor_list_set,&
vppnl_ca_neighbor_list_set
LOGICAL :: init_pointers_done = .FALSE.
! *** Public variables ***
@ -67,9 +66,8 @@ MODULE nl
PUBLIC :: aux_neighbor_list_set,&
orb_neighbor_list_set,&
verfc_neighbor_list_set,&
verf_ppl_neighbor_list_set,&
vexp_ppl_neighbor_list_set,&
vprj_ppnl_ca_neighbor_list_set
vppl_neighbor_list_set,&
vppnl_ca_neighbor_list_set
! *** Public subroutines ***
@ -105,11 +103,10 @@ CONTAINS
IF (.NOT.init_pointers_done) THEN
NULLIFY (aux_neighbor_list_set)
NULLIFY (orb_neighbor_list_set)
NULLIFY (verf_ppl_neighbor_list_set)
NULLIFY (verfc_neighbor_list_set)
NULLIFY (vexp_ppl_neighbor_list_set)
NULLIFY (vprj_ppnl_ac_neighbor_list_set)
NULLIFY (vprj_ppnl_ca_neighbor_list_set)
NULLIFY (vppl_neighbor_list_set)
NULLIFY (vppnl_ac_neighbor_list_set)
NULLIFY (vppnl_ca_neighbor_list_set)
init_pointers_done = .TRUE.
END IF
@ -143,20 +140,15 @@ CONTAINS
IF (gth_potential_present) THEN
IF (ionode) THEN
IF (allchem.AND.globenv%print%nl_verf_ppl) THEN
CALL write_neighbor_list_set(verf_ppl_neighbor_list_set,output_unit)
IF (globenv%print%nl_vppl) THEN
CALL write_neighbor_list_set(vppl_neighbor_list_set,output_unit)
END IF
IF (globenv%print%nl_vexp_ppl) THEN
CALL write_neighbor_list_set(vexp_ppl_neighbor_list_set,output_unit)
END IF
IF (globenv%print%nl_vprj_ppnl) THEN
CALL write_neighbor_list_set(vprj_ppnl_ac_neighbor_list_set,&
output_unit)
CALL write_neighbor_list_set(vprj_ppnl_ca_neighbor_list_set,&
output_unit)
IF (globenv%print%nl_vppnl) THEN
CALL write_neighbor_list_set(vppnl_ac_neighbor_list_set,output_unit)
CALL write_neighbor_list_set(vppnl_ca_neighbor_list_set,output_unit)
END IF
END IF
CALL deallocate_neighbor_list_set(vprj_ppnl_ac_neighbor_list_set)
CALL deallocate_neighbor_list_set(vppnl_ac_neighbor_list_set)
END IF
CALL timestop(0.0_wp,handle)
@ -266,14 +258,9 @@ CONTAINS
END IF
IF (gth_potential_present) THEN
IF (allchem) THEN
CALL allocate_neighbor_list_set(verf_ppl_neighbor_list_set,"VERF_PPL")
END IF
CALL allocate_neighbor_list_set(vexp_ppl_neighbor_list_set,"VEXP_PPL")
CALL allocate_neighbor_list_set(vprj_ppnl_ac_neighbor_list_set,&
"VPRJ_PPNL_AC")
CALL allocate_neighbor_list_set(vprj_ppnl_ca_neighbor_list_set,&
"VPRJ_PPNL_CA")
CALL allocate_neighbor_list_set(vppl_neighbor_list_set,"VPPL")
CALL allocate_neighbor_list_set(vppnl_ac_neighbor_list_set,"VPPNL_AC")
CALL allocate_neighbor_list_set(vppnl_ca_neighbor_list_set,"VPPNL_CA")
END IF
! *** Create the neighbor lists for all atoms of each atomic kind ***
@ -287,27 +274,21 @@ CONTAINS
DO kkind=1,nkind
IF (ASSOCIATED(kind_info(kkind)%all_potential)) THEN
IF (gpw) THEN
radius_c = kind_info(kkind)%all_potential%erfc_radius
radius_c = kind_info(kkind)%core_charge_radius
CALL build_neighbor_list(verfc_neighbor_list_set,&
atom_a,cell(:),radius_a,&
kind_info(kkind),radius_c)
END IF
ELSE IF (ASSOCIATED(kind_info(kkind)%gth_potential)) THEN
IF (allchem) THEN
radius_c = kind_info(kkind)%gth_potential%erf_ppl_radius
CALL build_neighbor_list(verf_ppl_neighbor_list_set,&
atom_a,cell(:),radius_a,&
kind_info(kkind),radius_c)
END IF
IF (kind_info(kkind)%gth_potential%nexp_ppl > 0) THEN
radius_c = kind_info(kkind)%gth_potential%exp_ppl_radius
CALL build_neighbor_list(vexp_ppl_neighbor_list_set,&
IF ((kind_info(kkind)%gth_potential%nexp_ppl > 0).OR.allchem) THEN
radius_c = kind_info(kkind)%gth_potential%ppl_radius
CALL build_neighbor_list(vppl_neighbor_list_set,&
atom_a,cell(:),radius_a,&
kind_info(kkind),radius_c)
END IF
IF (kind_info(kkind)%gth_potential%nppnl > 0) THEN
radius_c = kind_info(kkind)%gth_potential%prj_ppnl_radius
CALL build_neighbor_list(vprj_ppnl_ac_neighbor_list_set,&
radius_c = kind_info(kkind)%gth_potential%ppnl_radius
CALL build_neighbor_list(vppnl_ac_neighbor_list_set,&
atom_a,cell(:),radius_a,&
kind_info(kkind),radius_c)
END IF
@ -316,8 +297,8 @@ CONTAINS
END DO
END DO
! *** Create the neighbor list set "VPRJ_PPNL_CA" ***
! *** using the neighbor list set "VPRJ_PPNL_AC" ***
! *** Create the neighbor list set "VPPNL_CA" ***
! *** using the neighbor list set "VPPNL_AC" ***
IF (gth_potential_present) THEN
@ -329,7 +310,7 @@ CONTAINS
! *** Build a list of all operator atoms "c" ***
neighbor_list => first_neighbor_list(vprj_ppnl_ac_neighbor_list_set)
neighbor_list => first_neighbor_list(vppnl_ac_neighbor_list_set)
DO WHILE (ASSOCIATED(neighbor_list))
@ -377,17 +358,17 @@ CONTAINS
atom_prj_ppnl => reallocate(atom_prj_ppnl,1,4,1,natom_prj_ppnl)
! *** Build the neighbor list set "VPRJ_PPNL_CA" ***
! *** Build the neighbor list set "VPPNL_CA" ***
DO iatom_prj_ppnl=1,natom_prj_ppnl
IF (globenv%mepos /= MODULO(iatom_prj_ppnl,globenv%num_pe)) CYCLE
atom_c = atom_prj_ppnl(1,iatom_prj_ppnl)
cell(:) = atom_prj_ppnl(2:4,iatom_prj_ppnl)
kkind = atom_info(atom_c)%kind
radius_c = kind_info(kkind)%gth_potential%prj_ppnl_radius
radius_c = kind_info(kkind)%gth_potential%ppnl_radius
DO ikind=1,nkind
radius_a = kind_info(ikind)%orb_basis_set%kind_radius
CALL build_neighbor_list(vprj_ppnl_ca_neighbor_list_set,&
CALL build_neighbor_list(vppnl_ca_neighbor_list_set,&
atom_c,cell,radius_c,&
kind_info(ikind),radius_a)
END DO

6
src/nl_utilities.F
View file

@ -245,7 +245,7 @@ CONTAINS
! *** Write headline ***
WRITE (lunit,"(/,/,T2,A,/,/,T3,A,7X,A,2(11X,A),10X,A)")&
WRITE (UNIT=lunit,FMT="(/,/,T2,A,/,/,T3,A,7X,A,2(11X,A),10X,A)")&
TRIM(name)//" NEIGHBOR LIST IN "//TRIM(unit_of_length_name),&
"Atom Neighbor Cell(i,j,k)","X","Y","Z","Distance"
@ -262,7 +262,7 @@ CONTAINS
ra(:) = atom_info(iatom)%r_pbc(:) + REAL(cell(:),wp)*abc(:)
WRITE (lunit,"(/,T2,I5,3X,I6,2X,3I4,3F12.6)")&
WRITE (UNIT=lunit,FMT="(/,T2,I5,3X,I6,2X,3I4,3F12.6)")&
iatom,nneighbor,cell(:),ra(:)/unit_of_length
! *** Direct the work pointer to the start point of the current list ***
@ -282,7 +282,7 @@ CONTAINS
rb(:) = ra(:) + rab(:)
WRITE (lunit,"(T10,I6,2X,3I4,3F12.6,2X,F12.6)")&
WRITE (UNIT=lunit,FMT="(T10,I6,2X,3I4,3F12.6,2X,F12.6)")&
neighbor,cell(:),rb(:)/unit_of_length,SQRT(rab2)/unit_of_length
neighbor_node => next_neighbor_node(neighbor_node)

6
src/om_utilities.F
View file

@ -193,7 +193,8 @@ CONTAINS
! *****************************************************************************
SUBROUTINE write_spherical_matrix(block_matrix,before,after,globenv)
SUBROUTINE write_spherical_matrix(block_matrix,before,after,globenv,&
matrix_name)
! Purpose: Write a spherical matrix.
@ -228,6 +229,7 @@ CONTAINS
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(real_matrix_type), POINTER :: block_matrix
INTEGER, INTENT(IN) :: after,before
CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: matrix_name
! *** Local variables ***
@ -250,6 +252,8 @@ CONTAINS
matrix_name=name,&
matrix_symmetry=symmetry)
IF (PRESENT(matrix_name)) name = matrix_name
NULLIFY (full_matrix)
CALL allocate_matrix(matrix=full_matrix,&

18
src/orbital_pointers.F
View file

@ -48,8 +48,8 @@ MODULE orbital_pointers
INTEGER :: current_maxl = -1
INTEGER, DIMENSION(:), POINTER :: nco,ncoset,nso,nsoset
INTEGER, DIMENSION(:), POINTER :: nco,ncoset,nso,nsoset
INTEGER, DIMENSION(:,:), POINTER :: indco
INTEGER, DIMENSION(:,:,:), POINTER :: co,coset
! *** Public subroutines ***
@ -61,6 +61,7 @@ MODULE orbital_pointers
PUBLIC :: co,&
coset,&
current_maxl,&
indco,&
nco,&
ncoset,&
nso
@ -95,7 +96,7 @@ CONTAINS
! *** Initialize pointers in the first call ***
IF (current_maxl == -1) NULLIFY(co,coset,nco,ncoset,nso,nsoset)
IF (current_maxl == -1) NULLIFY(co,coset,indco,nco,ncoset,nso,nsoset)
! *** Number of Cartesian orbitals for each l ***
@ -130,6 +131,17 @@ CONTAINS
END DO
END DO
indco => reallocate(indco,1,3,1,ncoset(maxl))
DO l=0,maxl
DO lx=0,l
DO ly=0,l-lx
lz = l - lx - ly
indco(1:3,coset(lx,ly,lz)) = (/lx,ly,lz/)
END DO
END DO
END DO
! *** Number of spherical orbitals for each l ***
nso => reallocate(nso,-1,maxl)

862
src/pme.F
View file

@ -2,7 +2,7 @@
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/pme [1.0] *
!!****** cp2k/pme [2.0] *
!!
!! NAME
!! pme
@ -10,41 +10,44 @@
!! FUNCTION
!!
!! AUTHOR
!! CJM and APSI
!!
!! MODIFICATION HISTORY
!! none
!! JGH (21-Mar-2001) : Complete rewrite
!!
!! SOURCE
!******************************************************************************
MODULE pme
USE coefficients, ONLY : integral
USE coefficient_types, ONLY : coeff_type, coeff_allocate, &
coeff_deallocate, coeff_zero, PW_COMPLEXDATA3D, PW_REALDATA3D, &
PW_REALSPACE
USE dgs, ONLY : dg_sum_patch, dg_sum_patch_force, &
dg_get_1x_patch, dg_get_2x_patch, dg_get_strucfac, dg_get_rho_tot
USE dg_rho0s, ONLY : dg_rho0_setup
coeff_deallocate, coeff_zero, coeff_transform_space, &
PW_COMPLEXDATA3D, PW_REALDATA3D, &
PW_REALSPACE, PW_COMPLEXDATA1D, PW_RECIPROCALSPACE
USE dgs, ONLY : dg_get_strucfac, dg_get_patch, dg_sum_patch, &
dg_sum_patch_force
USE dg_types, ONLY : dg_type
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE kinds, ONLY: dbl, sgl, YES, NO
USE mathconstants, ONLY : fourpi
USE molecule_types, ONLY : particle_node_type
USE particle_lists, ONLY : particle_list_type, particle_list_select
USE hartree, ONLY : calculate_hartree
USE kinds, ONLY: dbl, sgl, dp_size, sp_size
USE mathconstants, ONLY : fourpi, pi
USE particle_lists, ONLY : particle_list_type
USE particle_types, ONLY : particle_type
USE pw_grid_types, ONLY : pw_grid_type
USE pws, ONLY : pw_poisson_solver
USE pws, ONLY : pw_poisson_solver, init_pw_poisson_solver, pw_integral_a2b
USE pw_types, ONLY : pw_transfer, pw_type
USE realspace_grid_types, ONLY : realspace_grid_type, rs_grid_allocate, &
rs_grid_deallocate, rs_grid_setup, rs_pw_transfer
USE simulation_cell, ONLY : cell_type, get_hinv
USE structure_factors, ONLY : structure_factor_allocate, &
structure_factor_deallocate
USE structure_factor_types, ONLY : structure_factor_type
USE termination, ONLY : stop_memory, stop_program
USE timings, ONLY: timeset, timestop
IMPLICIT NONE
PRIVATE
PUBLIC :: pme_evaluate, pme_setup
PUBLIC :: pme_evaluate
!!*****
!******************************************************************************
@ -52,477 +55,460 @@ MODULE pme
CONTAINS
!******************************************************************************
SUBROUTINE pme_setup ( pnode, grid_s, ewald_param, dg )
IMPLICIT NONE
! Arguments
TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( IN ) :: pnode
TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_s
TYPE ( dg_type ), INTENT ( OUT ) :: dg
! Locals
INTEGER :: isos
!------------------------------------------------------------------------------
! This is the first (and only) double grid
dg % grid_index = 1
ALLOCATE ( dg % dg_rho0 % zet (1) , STAT = isos)
IF ( isos /= 0 ) CALL stop_memory ('pme_setup', 'zet', 0 )
! No contracted Gaussians are used here
NULLIFY ( dg % dg_rho0 % gcc )
dg % dg_rho0 % type = ewald_param % ewald_type
dg % dg_rho0 % zet ( 1 ) = ewald_param % alpha
CALL particle_list_select ( pnode, dg % plist, dg % nparts )
CALL dg_rho0_setup ( dg % dg_rho0, grid_s )
END SUBROUTINE pme_setup
!!****** pme/pme_evaluate [2.0] *
!!
!! NAME
!! pme_evaluate
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM and APSI
!!
!! MODIFICATION HISTORY
!! JGH (15-Mar-2001) : New electrostatic calculation and pressure tensor
!! JGH (21-Mar-2001) : Complete rewrite
!! JGH (21-Mar-2001) : Introduced real space density type for future
!! parallelisation
!!
!! SOURCE
!******************************************************************************
SUBROUTINE pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
SUBROUTINE pme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_s, grid_b, ewald_param )
IMPLICIT NONE
! Arguments
TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg
TYPE ( cell_type ), INTENT ( IN ) :: box
TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: grid_s
TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: grid_b
TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: fg_coulomb
REAL ( dbl ), INTENT ( OUT ) :: vg_coulomb
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_g
TYPE ( cell_type ), INTENT ( IN ) :: box
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_s
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_b
TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param
! Locals
LOGICAL :: doublepack
INTEGER :: handle, part1, part2, i, allocstatus, p_idx
INTEGER :: lb_pbc ( 3 ), ub_pbc ( 3 ), lb_dvhartree ( 3 ), lb_rhob ( 3 )
INTEGER, DIMENSION ( : ), POINTER :: centre1, centre2
INTEGER :: handle2, handle3
REAL ( dbl ) :: r1 ( 3 ), r2 ( 3 ), q1, q2, force ( 3 ), inv_fourpi_eps0
COMPLEX ( dbl ), DIMENSION ( : ), POINTER :: ex1, ey1, ez1, ex2, ey2, ez2
TYPE ( particle_list_type ), POINTER :: plist
TYPE ( structure_factor_type ), TARGET :: exp_igr
TYPE ( coeff_type ), POINTER :: rho0
TYPE ( coeff_type ) :: rhos1_r, rhos2_r, rhob_r, phi_r, dphi_r ( 3 ), rhos_r
!*apsi* TYPE ( coeff_type ) :: rho_r
! For saved FFTs
LOGICAL, SAVE :: saved_ffts_singleprecision = YES
INTEGER :: nsaved_ffts_maxmemory = 512 !*apsi in megabytes
INTEGER :: nsaved_ffts_max, nsaved_ffts, highest_fft_saved, nsize
INTEGER :: size_of_rhos_r_save
INTEGER, SAVE :: previous_size_of_rhos_r_save = -1
!*apsi Change to f9x intrinsic?
INTEGER :: bytes_per_real_sgl = 4
INTEGER :: bytes_per_real_dbl = 8
INTEGER :: bytes_per_real
INTEGER, DIMENSION ( : ), ALLOCATABLE :: pbc1_b, pbc2_b, pbc3_b
INTEGER, DIMENSION ( : ), POINTER :: npts_b, npts_s
INTEGER, DIMENSION ( :, : ), POINTER :: bounds_s, bounds_b
REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho_b
COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho_s
! To store the values of the allocated pointers
REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos1_ptr, rhos2_ptr
REAL ( sgl ), DIMENSION ( :, :, : ), POINTER :: rhos_r_sgl
REAL ( sgl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: &
rhos_r_save_sgl
REAL ( dbl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: &
rhos_r_save_dbl
REAL ( dbl ), DIMENSION ( :, :, :, : ), ALLOCATABLE, TARGET :: &
dvhartree
INTEGER :: handle, i, j, p1, p2, npart, ipart, jpart
TYPE ( realspace_grid_type ) :: rden, drpot ( 3 )
TYPE ( structure_factor_type ) :: exp_igr
TYPE ( coeff_type ) :: rhob_r, phi_r, dphi_g ( 3 ), rhos1, rhos2
REAL ( dbl ) :: inv_fourpi_eps0, ffa, dvols
REAL ( dbl ), DIMENSION ( 3 ) :: fat
REAL ( dbl ), DIMENSION ( 3, 3 ) :: h_stress, f_stress
!------------------------------------------------------------------------------
!-------------- INITIALISATION ---------------------
CALL timeset ( 'PME', 'I', ' ', handle )
npts_b => grid_b % npts
npts_s => grid_s % npts
bounds_b => grid_b % bounds
bounds_s => grid_s % bounds
! Determine the number of small FFTs to be stored
IF ( saved_ffts_singleprecision ) THEN
bytes_per_real = bytes_per_real_sgl
ELSE
bytes_per_real = bytes_per_real_dbl
END IF
nsize = grid_s % ngpts
nsaved_ffts_max = ( nsaved_ffts_maxmemory * 1024 ** 2 ) &
/ ( nsize * bytes_per_real )
nsaved_ffts_max = MAX ( 0, nsaved_ffts_max )
nsaved_ffts = MIN ( dg % nparts, nsaved_ffts_max )
! Let us make it even so it is easier to deal with in the double packing
IF ( dg % nparts > 1 .AND. nsaved_ffts < dg % nparts ) &
nsaved_ffts = ( nsaved_ffts / 2 ) * 2
ALLOCATE ( dvhartree ( 3, &
bounds_b ( 1, 1 ):bounds_b ( 2, 1 ), &
bounds_b ( 1, 2 ):bounds_b ( 2, 2 ), &
bounds_b ( 1, 3 ):bounds_b ( 2, 3 ) &
), STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'dvhartree', 0 )
IF ( saved_ffts_singleprecision ) THEN
ALLOCATE ( rhos_r_save_sgl ( bounds_s ( 1, 1 ):bounds_s ( 2, 1 ), &
bounds_s ( 1, 2 ):bounds_s ( 2, 2 ), &
bounds_s ( 1, 3 ):bounds_s ( 2, 3 ), &
nsaved_ffts ), STAT = allocstatus )
ELSE
ALLOCATE ( rhos_r_save_dbl ( bounds_s ( 1, 1 ):bounds_s ( 2, 1 ), &
bounds_s ( 1, 2 ):bounds_s ( 2, 2 ), &
bounds_s ( 1, 3 ):bounds_s ( 2, 3 ), &
nsaved_ffts ), STAT = allocstatus )
END IF
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'rhos_r_save', 0 )
IF ( saved_ffts_singleprecision ) THEN
size_of_rhos_r_save = SIZE ( rhos_r_save_sgl ) * bytes_per_real
ELSE
size_of_rhos_r_save = SIZE ( rhos_r_save_dbl ) * bytes_per_real
END IF
!
! this code has to be changed in order to be compliant with the output
! unit set and with parallel computing
! IF ( size_of_rhos_r_save /= previous_size_of_rhos_r_save ) THEN
! IF ( size_of_rhos_r_save / 1024**2 > 4 ) THEN
! WRITE ( 6, '( /, A, I4, A, / )' ) " DG| SIZE(rho) = ", &
! size_of_rhos_r_save / 1024**2, " MB"
! ELSE
! WRITE ( 6, '( /, A, I4, A, / )' ) " DG| SIZE(rho) = ", &
! size_of_rhos_r_save / 1024, " kB"
! END IF
! previous_size_of_rhos_r_save = size_of_rhos_r_save
! END IF
lb_pbc ( : ) = bounds_b ( 1, : ) + bounds_s ( 1, : )
ub_pbc ( : ) = bounds_b ( 2, : ) + bounds_s ( 2, : ) + 2
ALLOCATE ( pbc1_b ( lb_pbc ( 1 ) : ub_pbc ( 1 ) ), STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc1_b', 0 )
ALLOCATE ( pbc2_b ( lb_pbc ( 2 ) : ub_pbc ( 2 ) ), STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc2_b', 0 )
ALLOCATE ( pbc3_b ( lb_pbc ( 3 ) : ub_pbc ( 3 ) ), STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc3_b', 0 )
DO i = lb_pbc ( 1 ), ub_pbc ( 1 )
IF ( i < bounds_b ( 1, 1 ) ) THEN
pbc1_b ( i ) = i + npts_b ( 1 )
ELSE IF ( i > bounds_b ( 2, 1 ) ) THEN
pbc1_b ( i ) = i - npts_b ( 1 )
ELSE
pbc1_b ( i ) = i
END IF
END DO
DO i = lb_pbc ( 2 ), ub_pbc ( 2 )
IF ( i < bounds_b ( 1, 2 ) ) THEN
pbc2_b ( i ) = i + npts_b ( 2 )
ELSE IF ( i > bounds_b ( 2, 2 ) ) THEN
pbc2_b ( i ) = i - npts_b ( 2 )
ELSE
pbc2_b ( i ) = i
END IF
END DO
DO i = lb_pbc ( 3 ), ub_pbc ( 3 )
IF ( i < bounds_b ( 1, 3 ) ) THEN
pbc3_b ( i ) = i + npts_b ( 3 )
ELSE IF ( i > bounds_b ( 2, 3 ) ) THEN
pbc3_b ( i ) = i - npts_b ( 3 )
ELSE
pbc3_b ( i ) = i
END IF
END DO
!!------------- DENSITY CALCULATION ----------------
! initializing TOTAL rho_r
inv_fourpi_eps0 = 1.0_dbl / ( fourpi * ewald_param % eps0 )
npart = SIZE ( part )
!*apsi CALL coeff_allocate ( rho_r, grid_b, use_data = PW_COMPLEXDATA3D )
!*apsi CALL coeff_zero ( rho_r )
CALL structure_factor_allocate ( grid_s % bounds, npart, exp_igr, &
allocate_centre = .TRUE. )
rho0 => dg % dg_rho0 % density
CALL coeff_allocate ( rhos1, grid_s, use_data = PW_REALDATA3D )
CALL coeff_allocate ( rhos2, grid_s, use_data = PW_REALDATA3D )
CALL rs_grid_setup ( rden, grid_b, grid_s % npts )
CALL rs_grid_allocate ( rden )
rden % r = 0._dbl
IF ( rden % parallel .AND. rden % group_dim ( 1 ) /= 1 ) THEN
CALL get_center ( part, box, exp_igr % centre, grid_b % npts )
END IF
!-------------- DENSITY CALCULATION ----------------
ipart = 0
jpart = 0
DO
CALL set_list ( part, npart, exp_igr % centre, p1, p2, rden, &
ipart, jpart )
IF ( p1 == 0 .AND. p2 == 0 ) EXIT
! calculate function on small boxes (we use double packing in FFT)
CALL get_patch ( dg, part, exp_igr, box, p1, p2, grid_b, grid_s, &
rhos1, rhos2 )
! add boxes to real space grid (big box)
CALL dg_sum_patch ( rden, rhos1, exp_igr % centre ( :, p1 ) )
IF ( p2 /= 0 ) CALL dg_sum_patch ( rden, rhos2, &
exp_igr % centre ( :, p2 ) )
END DO
! initialize rho_r on big grid
CALL coeff_allocate ( rhob_r, grid_b, use_data = PW_REALDATA3D )
rhob_r % pw % in_space = PW_REALSPACE
CALL coeff_allocate ( rhos_r, grid_s, use_data = PW_COMPLEXDATA3D )
CALL coeff_allocate ( rhos1_r, grid_s, use_data = PW_REALDATA3D )
CALL coeff_allocate ( rhos2_r, grid_s, use_data = PW_REALDATA3D )
rho_b => rhob_r % pw % cr3d
rho_s => rhos_r % pw % cc3d
rhos1_ptr => rhos1_r % pw % cr3d
rhos2_ptr => rhos2_r % pw % cr3d
CALL rs_pw_transfer ( rden, rhob_r % pw, "FORWARD" )
lb_rhob = LBOUND ( rhob_r % pw % cr3d )
CALL rs_grid_deallocate ( rden )
CALL coeff_zero ( rhob_r )
! Allocate the space for the structure factor
CALL structure_factor_allocate ( grid_s % bounds, dg % nparts, &
exp_igr, allocate_centre = .TRUE. )
IF (.NOT. ASSOCIATED ( dg % plist ) ) &
CALL stop_program ( 'pme_evaluate', 'no charged particles')
CALL timeset ( 'PME_DENSITY', 'I', ' ', handle2 )
p_idx = 1
plist => dg % plist
DO
doublepack = ASSOCIATED ( plist % next )
r1 ( : ) = plist % r ( : )
q1 = plist % charge
part1 = plist % particle_index
centre1 => exp_igr % centre ( :, part1 )
ex1 => exp_igr % ex ( :, part1 )
ey1 => exp_igr % ey ( :, part1 )
ez1 => exp_igr % ez ( :, part1 )
IF ( doublepack ) THEN
plist => plist % next
r2 ( : ) = plist % r ( : )
q2 = plist % charge
part2 = plist % particle_index
centre2 => exp_igr % centre ( :, part2 )
ex2 => exp_igr % ex ( :, part2 )
ey2 => exp_igr % ey ( :, part2 )
ez2 => exp_igr % ez ( :, part2 )
END IF
! CALL timeset ( 'PME_GETSFAC', 'I', ' ', handle3 )
CALL dg_get_strucfac ( box, r1, grid_s % npts, grid_b % npts, &
centre1, exp_igr % lb, ex1, ey1, ez1 )
IF ( doublepack ) THEN
CALL dg_get_strucfac ( box, r2, grid_s % npts, grid_b % npts, &
centre2, exp_igr % lb, ex2, ey2, ez2 )
END IF
! CALL timestop ( 0.0_dbl, handle3 )
! CALL timeset ( 'PME_GETPATCH', 'I', ' ', handle3 )
IF ( doublepack ) THEN
CALL dg_get_2x_patch ( rho0, rhos_r, q1, q2, &
exp_igr % lb, ex1, ey1, ez1, ex2, ey2, ez2 )
ELSE
CALL dg_get_1x_patch ( rho0, rhos_r, q1, &
exp_igr % lb, ex1, ey1, ez1 )
END IF
! CALL timestop ( 0.0_dbl, handle3 )
IF ( p_idx <= nsaved_ffts ) THEN
IF ( saved_ffts_singleprecision ) THEN
rhos_r_save_sgl ( :, :, :, p_idx ) = REAL ( rho_s )
IF ( doublepack ) THEN
rhos_r_save_sgl ( :, :, :, p_idx + 1 ) = AIMAG ( rho_s )
END IF
ELSE
rhos_r_save_dbl ( :, :, :, p_idx ) = REAL ( rho_s )
IF ( doublepack ) THEN
rhos_r_save_dbl ( :, :, :, p_idx + 1 ) = AIMAG ( rho_s )
END IF
END IF
END IF
p_idx = p_idx + 2
rhos1_ptr = REAL ( rho_s )
IF ( doublepack ) THEN
rhos2_ptr = AIMAG ( rho_s )
END IF
! CALL timeset ( 'PME_SUMPATCH1', 'I', ' ', handle3 )
CALL dg_sum_patch ( rhos1_ptr, rho_b, bounds_s, centre1, &
lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob )
IF ( doublepack ) THEN
CALL dg_sum_patch ( rhos2_ptr, rho_b, bounds_s, centre2, &
lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob )
END IF
! CALL timestop ( 0.0_dbl, handle3 )
IF ( .NOT. ASSOCIATED ( plist % next ) ) THEN
EXIT
ELSE
plist => plist % next
END IF
END DO
! Obtain total density on rho_r; not necessary in PME because rho_r and rhob_r
! can be the same...
!*apsi CALL dg_get_rho_tot ( rho_r, rhob_r )
CALL timestop ( 0.0_dbl, handle2 )
!*apsi CALL coeff_deallocate ( rhob_r )
! initialize the forces
!!------------- ELECTROSTATIC CALCULATION -----------
!-------------- ELECTROSTATIC CALCULATION -----------
! allocate intermediate arrays
DO i = 1, 3
CALL coeff_allocate ( dphi_r ( i ), grid_b, use_data = PW_REALDATA3D )
CALL coeff_allocate ( dphi_g ( i ), grid_b, use_data = PW_COMPLEXDATA1D )
dphi_g ( i ) % pw % in_space = PW_RECIPROCALSPACE
END DO
CALL coeff_allocate ( phi_r, grid_b, use_data = PW_REALDATA3D )
phi_r % pw % in_space = PW_REALSPACE
lb_dvhartree = LBOUND ( dphi_r ( 1 ) % pw % cr3d )
CALL init_pw_poisson_solver ( box % green )
CALL timeset ( 'PME_POISSON', 'I', ' ', handle2 )
CALL calculate_hartree ( rhob_r, vg_coulomb, phi_r, dphi_g, h_stress )
!*apsi CALL pw_poisson_solver ( rho_r, phi_r, dphi_r )
CALL pw_poisson_solver ( rhob_r, phi_r, dphi_r )
! dvhartree ( :, :, :, 1 ) = dphi_r ( 1 ) % pw % cr3d
! dvhartree ( :, :, :, 2 ) = dphi_r ( 2 ) % pw % cr3d
! dvhartree ( :, :, :, 3 ) = dphi_r ( 3 ) % pw % cr3d
dvhartree ( 1, :, :, : ) = dphi_r ( 1 ) % pw % cr3d
dvhartree ( 2, :, :, : ) = dphi_r ( 2 ) % pw % cr3d
dvhartree ( 3, :, :, : ) = dphi_r ( 3 ) % pw % cr3d
!*apsi vg_coulomb = 0.5_dbl * integral ( rho_r, phi_r ) * inv_fourpi_eps0 &
!*apsi / grid_b % vol
vg_coulomb = 0.5_dbl * integral ( rhob_r, phi_r ) * inv_fourpi_eps0
CALL timestop ( 0.0_dbl, handle2 )
!*apsi CALL coeff_deallocate ( rho_r )
CALL coeff_deallocate ( rhob_r )
CALL coeff_deallocate ( phi_r )
vg_coulomb = vg_coulomb * inv_fourpi_eps0
fg_coulomb = 0.0_dbl
!---------- END OF ELECTROSTATIC CALCULATION --------
CALL timeset ( 'PME_FORCES', 'I', ' ', handle2 )
p_idx = 1
plist => dg % plist
DO
doublepack = ASSOCIATED ( plist % next )
q1 = plist % charge
part1 = plist % particle_index
centre1 => exp_igr % centre ( :, part1 )
ex1 => exp_igr % ex ( :, part1 )
ey1 => exp_igr % ey ( :, part1 )
ez1 => exp_igr % ez ( :, part1 )
IF ( doublepack ) THEN
plist => plist % next
q2 = plist % charge
part2 = plist % particle_index
centre2 => exp_igr % centre ( :, part2 )
ex2 => exp_igr % ex ( :, part2 )
ey2 => exp_igr % ey ( :, part2 )
ez2 => exp_igr % ez ( :, part2 )
END IF
! Either fetch the densities from memory ...
IF ( p_idx <= nsaved_ffts ) THEN
IF ( saved_ffts_singleprecision ) THEN
rhos1_ptr = rhos_r_save_sgl ( :, :, :, p_idx )
IF ( doublepack ) THEN
rhos2_ptr = rhos_r_save_sgl ( :, :, :, p_idx + 1 )
END IF
ELSE
rhos1_ptr = rhos_r_save_dbl ( :, :, :, p_idx )
IF ( doublepack ) THEN
rhos2_ptr = rhos_r_save_dbl ( :, :, :, p_idx + 1 )
END IF
END IF
ELSE
! ... they have to be calculated
IF ( doublepack ) THEN
CALL dg_get_2x_patch ( rho0, rhos_r, q1, q2, &
exp_igr % lb, ex1, ey1, ez1, ex2, ey2, ez2 )
ELSE
CALL dg_get_1x_patch ( rho0, rhos_r, q1, &
exp_igr % lb, ex1, ey1, ez1 )
END IF
rhos1_ptr = REAL ( rho_s )
IF ( doublepack ) THEN
rhos2_ptr = AIMAG ( rho_s )
END IF
END IF
p_idx = p_idx + 2
! CALL timeset ( 'PME_SUMPATCH2', 'I', ' ', handle3 )
CALL dg_sum_patch_force ( rhos1_ptr, dvhartree, force, &
bounds_s, centre1, &
lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_dvhartree )
fg_coulomb ( :, part1 ) = fg_coulomb ( :, part1 ) &
- force ( : ) * rhos1_r % pw % pw_grid % dvol * inv_fourpi_eps0
IF ( doublepack ) THEN
CALL dg_sum_patch_force ( rhos2_ptr, dvhartree, force, &
bounds_s, centre2, &
lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_dvhartree )
fg_coulomb ( :, part2 ) = fg_coulomb ( :, part2 ) &
- force ( : ) * rhos2_r % pw % pw_grid % dvol * inv_fourpi_eps0
END IF
! CALL timestop ( 0.0_dbl, handle3 )
IF ( .NOT. ASSOCIATED ( plist % next ) ) THEN
EXIT
ELSE
plist => plist % next
END IF
END DO
CALL timestop ( 0.0_dbl, handle2 )
!------------- STRESS TENSOR CALCULATION ------------
DO i = 1, 3
CALL coeff_deallocate ( dphi_r ( i ) )
DO j = i, 3
f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i ) % pw, &
dphi_g ( j ) % pw )
f_stress ( j, i ) = f_stress ( i, j )
END DO
END DO
ffa = ( grid_b % vol / fourpi ) * ( 0.5_dbl / dg % dg_rho0 % zet ( 1 ) ) ** 2
f_stress = -ffa * f_stress
pv_g = inv_fourpi_eps0 * ( h_stress + f_stress )
!--------END OF STRESS TENSOR CALCULATION -----------
CALL rs_grid_setup ( drpot, grid_b , grid_s % npts)
CALL rs_grid_allocate ( drpot ( 1 : 3 ) )
DO i = 1, 3
CALL coeff_transform_space ( dphi_g ( i ), rhob_r )
CALL coeff_deallocate ( dphi_g ( i ) )
CALL rs_pw_transfer ( drpot ( i ), rhob_r % pw, "BACKWARD" )
END DO
CALL coeff_deallocate ( rhos2_r )
CALL coeff_deallocate ( rhos1_r )
CALL coeff_deallocate ( rhos_r )
CALL coeff_deallocate ( rhob_r )
!----------------- FORCE CALCULATION ----------------
! initialize the forces
fg_coulomb = 0._dbl
dvols = rhos1 % pw % pw_grid % dvol * inv_fourpi_eps0
ipart = 0
jpart = 0
DO
CALL set_list ( part, npart, exp_igr % centre, p1, p2, rden, ipart, jpart )
IF ( p1 == 0 .AND. p2 == 0 ) EXIT
! calculate function on small boxes (we use double packing in FFT)
CALL get_patch_again ( dg, part, exp_igr, p1, p2, rhos1, rhos2 )
! sum boxes on real space grids (big box)
CALL dg_sum_patch_force ( drpot, rhos1, exp_igr % centre ( :, p1 ), fat )
fg_coulomb ( 1, p1 ) = fg_coulomb ( 1, p1 ) - fat ( 1 ) * dvols
fg_coulomb ( 2, p1 ) = fg_coulomb ( 2, p1 ) - fat ( 2 ) * dvols
fg_coulomb ( 3, p1 ) = fg_coulomb ( 3, p1 ) - fat ( 3 ) * dvols
IF ( p2 /= 0 ) THEN
CALL dg_sum_patch_force ( drpot, rhos2, exp_igr % centre ( :, p2 ), fat )
fg_coulomb ( 1, p2 ) = fg_coulomb ( 1, p2 ) - fat ( 1 ) * dvols
fg_coulomb ( 2, p2 ) = fg_coulomb ( 2, p2 ) - fat ( 2 ) * dvols
fg_coulomb ( 3, p2 ) = fg_coulomb ( 3, p2 ) - fat ( 3 ) * dvols
END IF
END DO
!--------------END OF FORCE CALCULATION -------------
!------------------CLEANING UP ----------------------
CALL rs_grid_deallocate ( drpot ( 1 : 3 ) )
CALL coeff_deallocate ( rhos1 )
CALL coeff_deallocate ( rhos2 )
CALL structure_factor_deallocate ( exp_igr )
DEALLOCATE ( dvhartree, STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'dvhartree' )
DEALLOCATE ( pbc1_b, STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc1_b' )
DEALLOCATE ( pbc2_b, STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc2_b' )
DEALLOCATE ( pbc3_b, STAT = allocstatus )
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'pbc3_b' )
IF ( saved_ffts_singleprecision ) THEN
DEALLOCATE ( rhos_r_save_sgl, STAT = allocstatus )
ELSE
DEALLOCATE ( rhos_r_save_dbl, STAT = allocstatus )
END IF
IF ( allocstatus /= 0 ) CALL stop_memory ( 'pme_evaluate', 'rhos_r_save' )
! The contribution from the electro-statistics on the pressure tensor has
! not yet been implemented
pv_g = -1.0E+30_dbl
CALL timestop ( 0.0_dbl, handle )
END SUBROUTINE pme_evaluate
!!*****
!******************************************************************************
!!****** pme/get_patch [1.0] *
!!
!! NAME
!! get_patch
!!
!! FUNCTION
!! Calculates local density in a small box
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! JGH (23-Mar-2001) : Switch to integer from particle list pointers
!!
!! SOURCE
!******************************************************************************
SUBROUTINE get_patch ( dg, part, exp_igr, box, p1, p2, &
grid_b, grid_s, rhos1, rhos2 )
IMPLICIT NONE
! Arguments
TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( structure_factor_type ) :: exp_igr
TYPE ( cell_type ), INTENT ( IN ) :: box
INTEGER, INTENT ( IN ) :: p1, p2
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_s
TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_b
TYPE ( coeff_type ) :: rhos1
TYPE ( coeff_type ) :: rhos2
! Local
TYPE ( coeff_type ), POINTER :: rho0
REAL ( dbl ), DIMENSION ( 3 ) :: r1, r2
REAL ( dbl ) :: q1, q2
COMPLEX ( dbl ), DIMENSION ( : ), POINTER :: ex1, ey1, ez1, ex2, ey2, ez2
INTEGER, DIMENSION ( : ), POINTER :: center1, center2
!------------------------------------------------------------------------------
rho0 => dg % dg_rho0 % density
r1 = part ( p1 ) % r
q1 = part ( p1 ) % prop % charge
center1 => exp_igr % centre ( :, p1 )
ex1 => exp_igr % ex ( :, p1 )
ey1 => exp_igr % ey ( :, p1 )
ez1 => exp_igr % ez ( :, p1 )
CALL dg_get_strucfac ( box, r1, grid_s % npts, grid_b % npts, center1, &
exp_igr % lb, ex1, ey1, ez1 )
IF ( p2 /= 0 ) THEN
r2 = part ( p2 ) % r
q2 = part ( p2 ) % prop % charge
center2 => exp_igr % centre ( :, p2 )
ex2 => exp_igr % ex ( :, p2 )
ey2 => exp_igr % ey ( :, p2 )
ez2 => exp_igr % ez ( :, p2 )
CALL dg_get_strucfac ( box, r2, grid_s % npts, grid_b % npts, center2, &
exp_igr % lb, ex2, ey2, ez2 )
END IF
IF ( p2 == 0 ) THEN
CALL dg_get_patch ( rho0, rhos1, q1, ex1, ey1, ez1 )
ELSE
CALL dg_get_patch ( rho0, rhos1, rhos2, q1, q2, &
ex1, ey1, ez1, ex2, ey2, ez2 )
END IF
END SUBROUTINE get_patch
!******************************************************************************
SUBROUTINE get_patch_again ( dg, part, exp_igr, p1, p2, rhos1, rhos2 )
IMPLICIT NONE
! Arguments
TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( structure_factor_type ) :: exp_igr
INTEGER, INTENT ( IN ) :: p1, p2
TYPE ( coeff_type ) :: rhos1
TYPE ( coeff_type ) :: rhos2
! Local
TYPE ( coeff_type ), POINTER :: rho0
REAL ( dbl ) :: q1, q2
COMPLEX ( dbl ), DIMENSION ( : ), POINTER :: ex1, ey1, ez1, ex2, ey2, ez2
!------------------------------------------------------------------------------
rho0 => dg % dg_rho0 % density
q1 = part ( p1 ) % prop % charge
ex1 => exp_igr % ex ( :, p1 )
ey1 => exp_igr % ey ( :, p1 )
ez1 => exp_igr % ez ( :, p1 )
IF ( p2 /= 0 ) THEN
q2 = part ( p2 ) % prop % charge
ex2 => exp_igr % ex ( :, p2 )
ey2 => exp_igr % ey ( :, p2 )
ez2 => exp_igr % ez ( :, p2 )
END IF
IF ( p2 == 0 ) THEN
CALL dg_get_patch ( rho0, rhos1, q1, ex1, ey1, ez1 )
ELSE
CALL dg_get_patch ( rho0, rhos1, rhos2, q1, q2, &
ex1, ey1, ez1, ex2, ey2, ez2 )
END IF
END SUBROUTINE get_patch_again
!!*****
!******************************************************************************
!!****** pme/set_list [1.0] *
!!
!! NAME
!! set_list
!!
!! FUNCTION
!! Radvances in the link list of particles to the next to be calculated
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! JGH (23-Mar-2001) : Switch to integer from particle list pointers
!!
!! SOURCE
!******************************************************************************
SUBROUTINE set_list ( part, npart, center, p1, p2, rs, ipart, jpart )
IMPLICIT NONE
! Arguments
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
INTEGER, INTENT ( IN ) :: npart
INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: center
INTEGER, INTENT ( OUT ) :: p1, p2
TYPE ( realspace_grid_type ) :: rs
INTEGER, INTENT ( INOUT ) :: ipart, jpart
! Local
INTEGER :: dir, lb, ub, ndim, npos
!------------------------------------------------------------------------------
p1 = 0
p2 = 0
IF ( rs % parallel .AND. rs % group_dim ( 1 ) /= 1 ) THEN
dir = rs % direction
lb = rs % lb_local ( dir ) + rs % border
ub = rs % ub_local ( dir ) - rs % border
END IF
IF ( rs % parallel ) THEN
ndim = rs % group_dim ( 2 )
npos = rs % group_coor ( 2 )
END IF
DO
ipart = ipart + 1
IF ( ipart > npart ) EXIT
IF ( part ( ipart ) % prop % charge == 0._dbl ) CYCLE
IF ( rs % parallel ) THEN
IF ( rs % group_dim ( 1 ) == 1 ) THEN
! All processor work on the same grid
IF ( MOD ( ipart, ndim ) == npos ) THEN
p1 = ipart
EXIT
END IF
ELSE
! First check if this atom is on my grid
IF ( in_slice ( center ( dir, ipart ), lb, ub ) ) THEN
jpart = jpart + 1
IF ( MOD ( jpart, ndim ) == npos ) THEN
p1 = ipart
EXIT
END IF
END IF
END IF
ELSE
p1 = ipart
EXIT
END IF
END DO
DO
ipart = ipart + 1
IF ( ipart > npart ) EXIT
IF ( part ( ipart ) % prop % charge == 0._dbl ) CYCLE
IF ( rs % parallel ) THEN
IF ( rs % group_dim ( 1 ) == 1 ) THEN
! All processor work on the same grid
IF ( MOD ( ipart, ndim ) == npos ) THEN
p2 = ipart
EXIT
END IF
ELSE
! First check if this atom is on my grid
IF ( in_slice ( center ( dir, ipart ), lb, ub ) ) THEN
jpart = jpart + 1
IF ( MOD ( jpart, ndim ) == npos ) THEN
p2 = ipart
EXIT
END IF
END IF
END IF
ELSE
p2 = ipart
EXIT
END IF
END DO
END SUBROUTINE set_list
!******************************************************************************
FUNCTION in_slice ( pos, lb, ub ) RESULT ( internal )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: pos, lb, ub
LOGICAL :: internal
IF ( pos >= lb .AND. pos <= ub ) THEN
internal = .TRUE.
ELSE
internal = .FALSE.
END IF
END FUNCTION in_slice
!!*****
!******************************************************************************
SUBROUTINE get_center ( part, box, centre, npts )
IMPLICIT NONE
! Arguments
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( cell_type ), INTENT ( IN ) :: box
INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts
INTEGER, DIMENSION ( :, : ), INTENT ( OUT ) :: centre
! Locals
REAL ( dbl ), DIMENSION ( 3 ) :: s
INTEGER :: ipart
!------------------------------------------------------------------------------
DO ipart = 1, SIZE ( part )
! compute the scaled coordinate of atomi
s = MATMUL ( box % h_inv, part ( ipart ) % r )
s = s - NINT ( s )
! find the closest grid point (on big grid)
centre ( :, ipart ) = NINT ( REAL ( npts ( 1:3 ), dbl ) * s ( 1:3 ) )
END DO
END SUBROUTINE get_center
!******************************************************************************
END MODULE pme
!******************************************************************************

60
src/print_keys.F
View file

@ -36,10 +36,11 @@ MODULE print_keys
cell_parameters,&
charge_density_matrix,&
core_hamiltonian_matrix,&
core_charge_radii,&
density_matrix,&
diis_information,&
distribution,&
erf_ppl_radii,&
erfc_radii,&
exp_ppl_radii,&
each_scf_step,&
hartree_matrix,&
interaction_thresholds,&
interatomic_distances,&
@ -49,32 +50,47 @@ MODULE print_keys
memory,&
method_specifications,&
mo_eigenvalues,&
mo_eigenvectors
mo_eigenvectors,&
mo_occupation_numbers
LOGICAL :: nl_overlap,&
nl_verfc,&
nl_verf_ppl,&
nl_vexp_ppl,&
nl_vprj_ppnl,&
nl_vppl,&
nl_vppnl,&
ortho_matrix,&
overlap_matrix,&
pgf_radii,&
physcon,&
potential,&
prj_ppnl_radii,&
ppl_radii,&
ppnl_radii,&
program_banner,&
program_run_information,&
projectors,&
pw_grid_information,&
scf,&
scf_energies,&
set_radii,&
spherical_harmonics,&
timing_information,&
title,&
total_densities,&
total_numbers
END TYPE print_key_type
INTEGER, PARAMETER :: SILENT = 0,&
LOW = 1,&
MEDIUM = 2,&
HIGH = 3,&
DEBUG = 4
! *** Public data types ***
PUBLIC :: print_key_type
! *** Public variables ***
PUBLIC :: DEBUG,HIGH,LOW,MEDIUM,SILENT
! *** Public subroutines ***
PUBLIC :: init_print_keys
@ -121,10 +137,11 @@ CONTAINS
print_key%cell_parameters = key_value(level,(/t,t,t/))
print_key%charge_density_matrix = key_value(level,(/f,f,t/))
print_key%core_hamiltonian_matrix = key_value(level,(/f,f,t/))
print_key%core_charge_radii = key_value(level,(/f,t,t/))
print_key%density_matrix = key_value(level,(/f,f,t/))
print_key%diis_information = key_value(level,(/f,f,t/))
print_key%distribution = key_value(level,(/f,t,t/))
print_key%erf_ppl_radii = key_value(level,(/f,t,t/))
print_key%erfc_radii = key_value(level,(/f,t,t/))
print_key%exp_ppl_radii = key_value(level,(/f,t,t/))
print_key%each_scf_step = key_value(level,(/f,f,t/))
print_key%hartree_matrix = key_value(level,(/f,t,t/))
print_key%interaction_thresholds = key_value(level,(/f,t,t/))
print_key%interatomic_distances = key_value(level,(/f,f,t/))
@ -135,24 +152,29 @@ CONTAINS
print_key%method_specifications = key_value(level,(/t,t,t/))
print_key%mo_eigenvalues = key_value(level,(/f,t,t/))
print_key%mo_eigenvectors = key_value(level,(/f,f,t/))
print_key%mo_occupation_numbers = key_value(level,(/f,t,t/))
print_key%nl_overlap = key_value(level,(/f,f,t/))
print_key%nl_verfc = key_value(level,(/f,f,t/))
print_key%nl_verf_ppl = key_value(level,(/f,f,t/))
print_key%nl_vexp_ppl = key_value(level,(/f,f,t/))
print_key%nl_vprj_ppnl = key_value(level,(/f,f,t/))
print_key%nl_vppl = key_value(level,(/f,f,t/))
print_key%nl_vppnl = key_value(level,(/f,f,t/))
print_key%ortho_matrix = key_value(level,(/f,f,t/))
print_key%overlap_matrix = key_value(level,(/f,f,t/))
print_key%pgf_radii = key_value(level,(/f,f,t/))
print_key%physcon = key_value(level,(/f,f,t/))
print_key%potential = key_value(level,(/f,f,t/))
print_key%prj_ppnl_radii = key_value(level,(/f,f,t/))
print_key%ppl_radii = key_value(level,(/f,t,t/))
print_key%ppnl_radii = key_value(level,(/f,f,t/))
print_key%program_banner = key_value(level,(/t,t,t/))
print_key%program_run_information = key_value(level,(/t,t,t/))
print_key%projectors = key_value(level,(/f,t,t/))
print_key%set_radii = key_value(level,(/f,t,t/))
print_key%pw_grid_information = key_value(level,(/f,t,t/))
print_key%scf = key_value(level,(/t,t,t/))
print_key%scf_energies = key_value(level,(/f,t,t/))
print_key%set_radii = key_value(level,(/f,f,t/))
print_key%spherical_harmonics = key_value(level,(/f,f,t/))
print_key%timing_information = key_value(level,(/t,t,t/))
print_key%title = key_value(level,(/t,t,t/))
print_key%total_densities = key_value(level,(/f,f,t/))
print_key%total_numbers = key_value(level,(/t,t,t/))
END SUBROUTINE init_print_keys
@ -169,11 +191,11 @@ CONTAINS
! ---------------------------------------------------------------------------
SELECT CASE (level)
CASE (:0)
CASE (:SILENT)
value = .FALSE.
CASE (1:3)
CASE (LOW:HIGH)
value = level_values(level)
CASE (4:)
CASE (DEBUG:)
value = .TRUE.
END SELECT

1
src/pw_grid_types.F
View file

@ -75,7 +75,6 @@ MODULE pw_grid_types
LOGICAL :: have_g0 ! whether I have G = [0,0,0]
INTEGER :: first_gne0 ! first g index /= 0 [1/2]
INTEGER :: nglengths ! # different lengths/shells
REAL ( dbl ), DIMENSION ( : ), POINTER :: glsq ! squared vector lengths
INTEGER :: identifier ! tag of this grid
LOGICAL :: spherical ! spherical cutoff?
END TYPE pw_grid_type

293
src/pw_grids.F
View file

@ -47,7 +47,7 @@ MODULE pw_grids
USE mathconstants, ONLY : twopi
USE message_passing, ONLY : mp_environ, mp_sum, mp_cart_create, mp_group, &
mp_max, mp_min, mp_cart_coords, mp_dims_create, &
mp_cart_rank, mp_sync
mp_cart_rank, mp_sync, mp_comm_free, mp_comm_dup
USE pw_grid_types, ONLY : pw_grid_type, map_pn, HALFSPACE, FULLSPACE
USE output_utilities, ONLY : print_warning
USE simulation_cell, ONLY : cell_type
@ -114,7 +114,7 @@ END SUBROUTINE pw_grid_construct
!! JGH (7-Feb-2001)
!!
!! MODIFICATION HISTORY
!! none
!! JGH (22-Mar-2001) : release group communicators
!!
!! SOURCE
!******************************************************************************
@ -141,10 +141,6 @@ SUBROUTINE pw_grid_destruct ( pw_grid )
DEALLOCATE ( pw_grid % g_hat, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_grid_destruct", "pw_grid % g_hat" )
END IF
IF ( ASSOCIATED ( pw_grid % glsq ) ) THEN
DEALLOCATE ( pw_grid % glsq, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_grid_destruct", "pw_grid % glsq" )
END IF
IF ( ASSOCIATED ( pw_grid % mapl % pos ) ) THEN
DEALLOCATE ( pw_grid % mapl % pos, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_grid_destruct", &
@ -196,7 +192,13 @@ SUBROUTINE pw_grid_destruct ( pw_grid )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_grid_destruct", &
"pw_grid % para % bo" )
END IF
! also release groups
CALL mp_comm_free ( pw_grid % para % group )
CALL mp_comm_free ( pw_grid % para % rs_group )
END IF
END SUBROUTINE pw_grid_destruct
@ -255,35 +257,40 @@ END function pw_grid_compare
!! Christopher Mundy
!!
!! MODIFICATION HISTORY
!! JGH (20-12-2000) : Adapted for parallel use
!! JGH (28-02-2001) : New optional argument fft_usage
!! JGH (20-Dec-2000) : Adapted for parallel use
!! JGH (28-Feb-2001) : New optional argument fft_usage
!! JGH (21-Mar-2001) : Reference grid code
!! JGH (21-Mar-2001) : New optional argument symm_usage
!! JGH (22-Mar-2001) : Simplify group assignment (mp_comm_dup)
!!
!! SOURCE
!******************************************************************************
SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
ref_grid )
symm_usage, ref_grid, orthorhombic )
IMPLICIT NONE
! Arguments
TYPE ( cell_type ), INTENT ( IN ) :: cell
TYPE ( pw_grid_type ), INTENT ( INOUT ) :: pw_grid
REAL ( dbl ), INTENT ( IN ), OPTIONAL :: cutoff
REAL ( dbl ), INTENT ( IN ), OPTIONAL :: cutoff ! in atomic units
INTEGER, OPTIONAL, INTENT ( IN ) :: pe_group ! parent group for this grid
INTEGER, OPTIONAL, INTENT ( IN ) :: info ! output unit for information on grid
LOGICAL, OPTIONAL, INTENT ( IN ) :: fft_usage ! has the grid size to be
! compatible with the FFT
LOGICAL, OPTIONAL, INTENT ( IN ) :: symm_usage ! has the grid size to be
! symmetric (g <-> -g)
LOGICAL, OPTIONAL, INTENT ( IN ) :: orthorhombic
TYPE ( pw_grid_type ), OPTIONAL, INTENT ( IN ) :: ref_grid
! Locals
REAL ( dbl ) :: ecut
INTEGER, DIMENSION ( :, : ), ALLOCATABLE :: yz_mask
INTEGER, DIMENSION ( : ), ALLOCATABLE :: group_list
INTEGER :: allocstat, group_size, my_pos, i, n(3), ntest(3)
REAL ( dbl ) :: rv(3,3)
INTEGER :: aver, amax, amin
LOGICAL :: fft
LOGICAL :: fft, symmetry
!------------------------------------------------------------------------------
! default is to use only fft compatible grids
@ -292,6 +299,12 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
ELSE
fft = .TRUE.
END IF
! default is to use only symmetric grids
IF ( PRESENT ( symm_usage ) ) THEN
symmetry = symm_usage
ELSE
symmetry = .TRUE.
END IF
! assign a unique tag to this grid
grid_tag = grid_tag + 1
@ -301,12 +314,7 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
IF (PRESENT ( pe_group ) ) THEN
CALL mp_environ ( group_size, my_pos, pe_group )
IF ( group_size > 1 ) THEN
ALLOCATE ( group_list ( group_size ), STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_setup", "group_list", &
group_size )
group_list = (/( I, I = 0, group_size - 1 )/)
CALL mp_group ( group_list, group_size, pe_group, &
pw_grid % para % group )
CALL mp_comm_dup ( pe_group, pw_grid % para % group )
CALL mp_environ ( pw_grid % para % group_size, &
pw_grid % para % my_pos, &
pw_grid % para % group )
@ -314,8 +322,6 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
pw_grid % para % group_head = &
( pw_grid % para % group_head_id == pw_grid % para % my_pos )
pw_grid % para % mode = 1
DEALLOCATE ( group_list, STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_setup", "group_list" )
ELSE
pw_grid % para % mode = 0
END IF
@ -327,9 +333,9 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
ecut = cutoff
IF ( SUM ( ABS ( pw_grid % bounds ( :, : ) ) ) == 0 ) &
CALL pw_grid_find_bounds &
( pw_grid % bounds, cell % h_inv, 0.5_dbl * ecut, fft )
( pw_grid % bounds, cell % h_inv, ecut, fft, orthorhombic )
pw_grid % spherical = .TRUE.
pw_grid % cutoff = 0.5_dbl * ABS ( ecut )
pw_grid % cutoff = ABS ( ecut )
ELSE
ecut = 1.e10_dbl ! all g-vectors in the box will be included
IF ( SUM ( ABS ( pw_grid % bounds ( :, : ) ) ) == 0 ) THEN
@ -345,7 +351,7 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
ntest = pw_grid % bounds ( 2, : ) - pw_grid % bounds ( 1, : ) + 1
! without a cutoff and HALFSPACE we have to be sure that there is
! a negative counterpart to every g vector (-> odd number of grid points)
IF ( pw_grid % grid_span == HALFSPACE ) THEN
IF ( pw_grid % grid_span == HALFSPACE .AND. symmetry ) THEN
CALL fft_radix_operations ( ntest(1), n(1), FFT_RADIX_NEXT_ODD )
CALL fft_radix_operations ( ntest(2), n(2), FFT_RADIX_NEXT_ODD )
@ -364,7 +370,8 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
n = pw_grid % bounds ( 2, : ) - pw_grid % bounds ( 1, : ) + 1
! without a cutoff and HALFSPACE we have to be sure that there is
! a negative counterpart to every g vector (-> odd number of grid points)
IF ( pw_grid % grid_span == HALFSPACE ) n = n + MOD ( n + 1, 2 )
IF ( pw_grid % grid_span == HALFSPACE .AND. symmetry ) &
n = n + MOD ( n + 1, 2 )
END IF
@ -414,7 +421,7 @@ SUBROUTINE pw_grid_setup ( cell, pw_grid, cutoff, pe_group, info, fft_usage, &
CALL pw_grid_assign ( cell % h_inv, pw_grid, ecut )
! Sort g vector wrt length (only local for each processor)
CALL pw_grid_sort ( pw_grid )
CALL pw_grid_sort ( pw_grid, ref_grid )
CALL pw_grid_remap ( pw_grid, yz_mask )
@ -906,7 +913,7 @@ SUBROUTINE pw_grid_count ( h_inv, pw_grid, cutoff, yz_mask )
gi ( 1 ) = REAL(l,dbl)
length = twopi * twopi * dotprod_3d ( matvec_3x3 ( gmat, gi ), gi )
IF ( length <= cutoff * cutoff ) THEN
IF ( 0.5_dbl * length <= cutoff ) THEN
gpt = gpt + 1
yz_mask ( mm, nn ) = yz_mask ( mm, nn ) + 1
END IF
@ -998,7 +1005,7 @@ SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff )
length = length_x ** 2 + length_y ** 2 + length_z ** 2
length = twopi * twopi * length
IF ( length <= cutoff * cutoff ) THEN
IF ( 0.5_dbl * length <= cutoff ) THEN
gpt = gpt + 1
pw_grid % g ( 1, gpt ) = twopi * length_x
pw_grid % g ( 2, gpt ) = twopi * length_y
@ -1044,7 +1051,7 @@ SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff )
length = length_x ** 2 + length_y ** 2 + length_z ** 2
length = twopi * twopi * length
IF ( length <= cutoff * cutoff ) THEN
IF ( 0.5_dbl * length <= cutoff ) THEN
gpt = gpt + 1
pw_grid % g ( 1, gpt ) = twopi * length_x
pw_grid % g ( 2, gpt ) = twopi * length_y
@ -1129,11 +1136,11 @@ SUBROUTINE pw_grid_assign ( h_inv, pw_grid, cutoff )
ENDIF
pw_grid % have_g0 = .FALSE.
pw_grid % first_gne0 = 2
DO gpt = 1, pw_grid % ngpts_cut
pw_grid % first_gne0 = 1
DO gpt = 1, pw_grid % ngpts_cut_local
IF ( ALL ( pw_grid % g_hat ( :, gpt ) == 0 ) ) THEN
pw_grid % have_g0 = .TRUE.
pw_grid % first_gne0 = 1
pw_grid % first_gne0 = 2
EXIT
END IF
END DO
@ -1256,7 +1263,7 @@ END SUBROUTINE pw_grid_set_maps
!! SOURCE
!******************************************************************************
SUBROUTINE pw_grid_find_bounds ( bounds, h_inv, cutoff, fft )
SUBROUTINE pw_grid_find_bounds ( bounds, h_inv, cutoff, fft, orthorhombic )
IMPLICIT NONE
@ -1265,6 +1272,7 @@ SUBROUTINE pw_grid_find_bounds ( bounds, h_inv, cutoff, fft )
REAL ( dbl ), INTENT ( IN ) :: cutoff
REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( IN ) :: h_inv
LOGICAL, INTENT ( IN ) :: fft
LOGICAL, OPTIONAL, INTENT ( IN ) :: orthorhombic
! Locals
INTEGER :: l, m, n, test_max, rin(3), rout(3)
@ -1275,36 +1283,46 @@ SUBROUTINE pw_grid_find_bounds ( bounds, h_inv, cutoff, fft )
bounds ( :, : ) = 0
gmat = MATMUL ( h_inv, TRANSPOSE ( h_inv ) )
gi = 1._dbl
length = twopi * SQRT ( dotprod_3d ( matvec_3x3 ( gmat, gi ), gi ) )
test_max = 2 * NINT ( cutoff / length )
IF (PRESENT(orthorhombic)) THEN
bounds(2,1) = FLOOR(SQRT(2.0_dbl*cutoff)/(twopi*h_inv(1,1)))
bounds(2,2) = FLOOR(SQRT(2.0_dbl*cutoff)/(twopi*h_inv(2,2)))
bounds(2,3) = FLOOR(SQRT(2.0_dbl*cutoff)/(twopi*h_inv(3,3)))
ELSE
gmat = MATMUL ( h_inv, TRANSPOSE ( h_inv ) )
gi = 1._dbl
length = twopi * SQRT ( dotprod_3d ( matvec_3x3 ( gmat, gi ), gi ) )
test_max = 2 * NINT ( cutoff / length )
! finds valid g-points within grid
DO n = 0, test_max
gi ( 3 ) = REAL ( n, dbl )
DO m = 0, test_max
gi ( 2 ) = REAL ( m, dbl )
DO l = 0, test_max
gi ( 1 ) = REAL ( l, dbl )
length = 0.5_dbl * twopi * twopi * &
dotprod_3d ( matvec_3x3 ( gmat, gi ), gi )
DO n = 0, test_max
gi ( 3 ) = REAL ( n, dbl )
DO m = 0, test_max
gi ( 2 ) = REAL ( m, dbl )
DO l = 0, test_max
gi ( 1 ) = REAL ( l, dbl )
length = 0.5_dbl * twopi * twopi * &
dotprod_3d ( matvec_3x3 ( gmat, gi ), gi )
IF ( length <= cutoff ) THEN
bounds ( 2, 1 ) = MAX ( bounds ( 2, 1 ), l )
bounds ( 2, 2 ) = MAX ( bounds ( 2, 2 ), m )
bounds ( 2, 3 ) = MAX ( bounds ( 2, 3 ), n )
END IF
IF ( length <= cutoff ) THEN
bounds ( 2, 1 ) = MAX ( bounds ( 2, 1 ), l )
bounds ( 2, 2 ) = MAX ( bounds ( 2, 2 ), m )
bounds ( 2, 3 ) = MAX ( bounds ( 2, 3 ), n )
END IF
END DO
END DO
END DO
END DO
END DO
END DO
IF ( bounds ( 2, 1 ) == test_max .OR. &
bounds ( 2, 2 ) == test_max .OR. &
bounds ( 2, 3 ) == test_max ) THEN
CALL print_warning ( "pw_grid_find_bounds", &
"initial bounds maybe too small:" )
END IF
IF ( bounds ( 2, 1 ) == test_max .OR. &
bounds ( 2, 2 ) == test_max .OR. &
bounds ( 2, 3 ) == test_max ) THEN
CALL print_warning ( "pw_grid_find_bounds", &
"initial bounds maybe too small:" )
END IF
IF ( fft ) THEN
@ -1416,6 +1434,9 @@ END SUBROUTINE pw_grid_allocate
!! WARNING: Global ordering depends now on the number
!! of cpus.
!! JGH (28-02-2001) : check for ordering against reference grid
!! JGH (01-05-2001) : sort spherical cutoff grids also within shells
!! reference grids for non-spherical cutoffs
!! JGH (20-06-2001) : do not sort non-spherical grids
!!
!! SOURCE
!******************************************************************************
@ -1429,46 +1450,65 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid )
TYPE ( pw_grid_type ), OPTIONAL, INTENT ( IN ) :: ref_grid
! Locals
INTEGER :: gpt, gpt_curr, gpt_tmp, int_tmp ( 3 ), allocstat, ng, ngr
INTEGER, ALLOCATABLE, DIMENSION ( : ) :: idx
REAL ( dbl ) :: real_tmp ( 3 )
INTEGER :: ig, allocstat, ng, ngr
INTEGER, ALLOCATABLE, DIMENSION ( : ) :: idx, int_tmp
REAL ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: real_tmp
!------------------------------------------------------------------------------
ng = SIZE ( pw_grid % gsq ( : ) )
ALLOCATE ( idx ( ng ), STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "idx", ng )
IF ( pw_grid % spherical ) THEN
CALL sort ( pw_grid % gsq, ng, idx )
! spherical grids are (locally) ordered by length of G-vectors
ng = SIZE ( pw_grid % gsq ( : ) )
ALLOCATE ( idx ( ng ), STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "idx", ng )
ALLOCATE ( int_tmp ( ng ), STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "int_tmp", ng )
ALLOCATE ( real_tmp ( ng ), STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "real_tmp", ng )
DO gpt = 1, ng - 1
gpt_curr = gpt
CALL sort ( pw_grid % gsq, ng, idx )
CALL sort_shells ( pw_grid % gsq, pw_grid % g_hat, idx )
DO
IF ( idx ( gpt_curr ) == gpt ) EXIT
real_tmp ( 1:ng ) = pw_grid % g ( 1, 1:ng )
pw_grid % g ( 1, 1:ng ) = real_tmp ( idx ( 1:ng ) )
real_tmp ( 1:ng ) = pw_grid % g ( 2, 1:ng )
pw_grid % g ( 2, 1:ng ) = real_tmp ( idx ( 1:ng ) )
real_tmp ( 1:ng ) = pw_grid % g ( 3, 1:ng )
pw_grid % g ( 3, 1:ng ) = real_tmp ( idx ( 1:ng ) )
int_tmp ( 1:ng ) = pw_grid % g_hat ( 1, 1:ng )
pw_grid % g_hat ( 1, 1:ng ) = int_tmp ( idx ( 1:ng ) )
int_tmp ( 1:ng ) = pw_grid % g_hat ( 2, 1:ng )
pw_grid % g_hat ( 2, 1:ng ) = int_tmp ( idx ( 1:ng ) )
int_tmp ( 1:ng ) = pw_grid % g_hat ( 3, 1:ng )
pw_grid % g_hat ( 3, 1:ng ) = int_tmp ( idx ( 1:ng ) )
real_tmp ( : ) = pw_grid % g ( :, gpt_curr )
pw_grid % g ( :, gpt_curr ) = pw_grid % g ( :, idx ( gpt_curr ) )
pw_grid % g ( :, idx ( gpt_curr ) ) = real_tmp ( : )
DEALLOCATE ( idx, STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "idx" )
DEALLOCATE ( int_tmp, STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "int_tmp" )
DEALLOCATE ( real_tmp, STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "real_tmp" )
int_tmp ( : ) = pw_grid % g_hat ( :, gpt_curr )
pw_grid % g_hat ( :, gpt_curr ) &
= pw_grid % g_hat ( :, idx ( gpt_curr ) )
pw_grid % g_hat ( :, idx ( gpt_curr ) ) = int_tmp ( : )
ELSE
gpt_tmp = gpt_curr
gpt_curr = idx ( gpt_curr )
idx ( gpt_tmp ) = gpt_tmp
! We do not sort non-spherical grids, but we have to make sure that
! possible reference grids are compatible
! We have to test if the new grid is larger then the reference grid
IF ( PRESENT ( ref_grid ) ) THEN
IF ( ALL ( pw_grid % npts >= ref_grid % npts ) ) THEN
idx = 0
ngr = SIZE ( ref_grid % gsq ( : ) )
! stop here as this code is not yet working
CALL stop_program ( "pw_grid_sort", "Reference grid code for"//&
" non-spherical cutoff not yet working")
ELSE
CALL stop_program ( "pw_grid_sort", "Reference grid has to"//&
" be smaller then new grid for non-spherical cutoff")
END IF
END IF
IF ( idx ( gpt_curr ) == gpt ) then
idx ( gpt_curr ) = gpt_curr
EXIT
END IF
END DO
END DO
DEALLOCATE ( idx, STAT = allocstat )
IF ( allocstat /= 0 ) CALL stop_memory ( "pw_grid_sort", "idx" )
END IF
! check if ordering is compatible to reference grid
IF ( PRESENT ( ref_grid ) ) THEN
@ -1482,6 +1522,79 @@ SUBROUTINE pw_grid_sort ( pw_grid, ref_grid )
END SUBROUTINE pw_grid_sort
SUBROUTINE sort_shells ( gsq, g_hat, idx )
IMPLICIT NONE
! Argument
REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: gsq
INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: g_hat
INTEGER, DIMENSION ( : ), INTENT ( INOUT ) :: idx
! Locals
REAL ( dbl ), PARAMETER :: small = 1.e-12_dbl
REAL ( dbl ) :: s_begin
INTEGER :: ng, ig, s1, s2
ng = SIZE ( gsq )
s_begin = -1._dbl
s1 = 0
s2 = 0
ig = 1
DO ig = 1, ng
IF ( ABS ( gsq ( ig ) - s_begin ) < small ) THEN
s2 = ig
ELSE
CALL redist ( g_hat, idx, s1, s2)
s_begin = gsq ( ig )
s1 = ig
s2 = ig
END IF
END DO
CALL redist ( g_hat, idx, s1, s2 )
END SUBROUTINE sort_shells
SUBROUTINE redist ( g_hat, idx, s1, s2 )
IMPLICIT NONE
! Argument
INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: g_hat
INTEGER, DIMENSION ( : ), INTENT ( INOUT ) :: idx
INTEGER, INTENT ( IN ) :: s1, s2
! Locals
INTEGER :: ns, info, i, ii
INTEGER, DIMENSION ( : ), ALLOCATABLE :: indl
REAL ( dbl ), DIMENSION ( : ), ALLOCATABLE :: slen
IF ( s2 <= s1 ) RETURN
ns = s2 - s1 + 1
ALLOCATE ( indl ( ns ), STAT = info )
IF ( info /= 0 ) call stop_memory ( "redist", "indl", ns )
ALLOCATE ( slen ( ns ), STAT = info )
IF ( info /= 0 ) call stop_memory ( "redist", "slen", ns )
DO i = s1, s2
ii = idx ( i )
slen ( i - s1 + 1 ) = 1000._dbl * REAL(g_hat(1,ii),dbl) + &
REAL(g_hat(2,ii),dbl) + 0.001_dbl * REAL(g_hat(3,ii),dbl)
END DO
CALL sort ( slen, ns, indl )
DO i = 1, ns
ii = indl ( i ) + s1 - 1
indl ( i ) = idx ( ii )
END DO
idx ( s1:s2 ) = indl ( 1:ns )
DEALLOCATE ( indl, STAT = info )
IF ( info /= 0 ) call stop_memory ( "redist", "indl" )
DEALLOCATE ( slen, STAT = info )
IF ( info /= 0 ) call stop_memory ( "redist", "slen" )
END SUBROUTINE redist
!!*****
!****************************************************************************
!!****** pw_grids/pw_grid_remap [1.0] *
@ -1670,19 +1783,19 @@ SUBROUTINE pw_find_cutoff ( npts, box, cutoff )
! compute 2*pi*h_inv^t*g where g = (npts[1],0,0)
gdum ( : ) = twopi * box % h_inv ( 1, : ) &
* REAL ( npts ( 1 ), dbl ) / 2.0_dbl
* REAL ( ( npts ( 1 ) - 1 ) / 2, dbl )
length = SQRT ( dotprod_3d ( gdum, gdum ) )
gcut = length
! compute 2*pi*h_inv^t*g where g = (0,npts[2],0)
gdum ( : ) = twopi * box % h_inv ( 2, : ) &
* REAL ( npts ( 2 ), dbl ) / 2.0_dbl
* REAL ( ( npts ( 2 ) - 1 ) / 2, dbl )
length = SQRT ( dotprod_3d ( gdum, gdum ) )
gcut = MIN ( gcut, length )
! compute 2*pi*h_inv^t*g where g = (0,0,npts[3])
gdum ( : ) = twopi * box % h_inv ( 3, : ) &
* REAL ( npts ( 3 ), dbl ) / 2.0_dbl
* REAL ( ( npts ( 3 ) - 1 ) / 2, dbl )
length = SQRT ( dotprod_3d ( gdum, gdum ) )
gcut = MIN ( gcut, length )

257
src/pw_types.F
View file

@ -13,7 +13,8 @@
!! apsi
!!
!! MODIFICATION HISTORY
!! JGH (29-12-2000) : Changes for parallel use
!! JGH (29-Dec-2000) : Changes for parallel use
!! JGH (13-Mar-2001) : added timing calls
!!
!! NOTES
!! If parallel mode is distributed certain combination of
@ -64,6 +65,10 @@ MODULE pw_types
! Flags for the structure member 'in_space'
INTEGER, PARAMETER :: NOSPACE = 371, REALSPACE = 372, RECIPROCALSPACE = 373
INTERFACE pw_derive
MODULE PROCEDURE pw_derive_a, pw_derive_ab
END INTERFACE
INTERFACE pw_gather
MODULE PROCEDURE pw_gather_s, pw_gather_p
END INTERFACE
@ -288,21 +293,24 @@ SUBROUTINE pw_copy ( pw1, pw2 )
TYPE ( pw_type ), INTENT ( INOUT ) :: pw2
! Local
INTEGER :: ng1, ng2, ng
INTEGER :: ng1, ng2, ng, handle, ns
REAL ( dbl ) :: zc
!------------------------------------------------------------------------------
CALL timeset ( 'PW_COPY', 'I', 'Mcopy', handle )
IF ( pw1 % pw_grid % identifier /= pw2 % pw_grid % identifier ) THEN
IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D .AND. &
pw1 % in_space == RECIPROCALSPACE .AND. &
pw2 % in_space == RECIPROCALSPACE ) THEN
pw1 % in_space == RECIPROCALSPACE ) THEN
ng1 = SIZE ( pw1 % cc )
ng2 = SIZE ( pw2 % cc )
ng = MIN ( ng1, ng2 )
pw2 % cc ( 1:ng ) = pw1 % cc ( 1:ng )
IF ( ng2 > ng ) pw2 % cc ( ng+1:ng2 ) = CMPLX ( 0._dbl, 0._dbl, dbl )
ns = ng
ELSE
CALL stop_program ( "pw_copy", "no suitable data field" )
END IF
@ -311,19 +319,28 @@ SUBROUTINE pw_copy ( pw1, pw2 )
IF ( pw1 % in_use == REALDATA1D .AND. pw2 % in_use == REALDATA1D ) THEN
pw2 % cr = pw1 % cr
ns = SIZE ( pw1 % cr )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D ) THEN
pw2 % cc = pw1 % cc
ns = 2 * SIZE ( pw1 % cc )
ELSE IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D ) THEN
pw2 % cr3d = pw1 % cr3d
ns = SIZE ( pw1 % cr3d )
ELSE IF ( pw1 % in_use == COMPLEXDATA3D .AND. &
pw2 % in_use == COMPLEXDATA3D ) THEN
pw2 % cc3d = pw1 % cc3d
ns = 2 * SIZE ( pw1 % cc3d )
ELSE
CALL stop_program ( "pw_copy", "no suitable data field" )
END IF
END IF
pw2 % in_space = pw1 % in_space
zc = REAL ( ns, dbl ) * 1.e-6_dbl
CALL timestop ( zc, handle )
END SUBROUTINE pw_copy
@ -335,7 +352,7 @@ END SUBROUTINE pw_copy
!! pw_derive
!!
!! FUNCTION
!! Calculate the deivative of a plane wave vector
!! Calculate the derivative of a plane wave vector
!!
!! AUTHOR
!! JGH (25-Feb-2001)
@ -350,7 +367,7 @@ END SUBROUTINE pw_copy
!! SOURCE
!******************************************************************************
SUBROUTINE pw_derive ( pw, n )
SUBROUTINE pw_derive_a ( pw, n )
IMPLICIT NONE
@ -359,35 +376,55 @@ SUBROUTINE pw_derive ( pw, n )
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: n
! Local
INTEGER :: m
INTEGER :: m, handle, ierr, cnt
COMPLEX ( dbl ) :: im
COMPLEX ( dbl ), ALLOCATABLE, DIMENSION ( : ) :: cc
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_DERIVE', 'I', 'Mflops', handle )
IF ( pw % in_space == RECIPROCALSPACE .AND. &
pw % in_use == COMPLEXDATA1D ) THEN
m = sum ( n )
im = CMPLX ( 0._dbl, 1._dbl, dbl ) ** m
cnt = REAL ( SIZE ( pw % cc ), dbl )
flop = 0._dbl
ALLOCATE ( cc ( cnt ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_derive_a", "cc", cnt )
cc = pw % cc
IF ( ANY ( n < 0 ) ) CALL stop_program ( "pw_derive", "n < 0" )
IF ( n ( 1 ) == 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 1, : )
pw % cc ( : ) = cc ( : ) * pw % pw_grid % g ( 1, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 1 ) > 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 1, : ) ** n ( 1 )
pw % cc ( : ) = cc ( : ) * ( pw % pw_grid % g ( 1, : ) ** n ( 1 ) )
flop = flop + 7 * cnt
END IF
IF ( n ( 2 ) == 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 2, : )
pw % cc ( : ) = cc ( : ) * pw % pw_grid % g ( 2, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 2 ) > 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 2, : ) ** n ( 2 )
pw % cc ( : ) = cc ( : ) * ( pw % pw_grid % g ( 2, : ) ** n ( 2 ) )
flop = flop + 7 * cnt
END IF
IF ( n ( 3 ) == 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 3, : )
pw % cc ( : ) = cc ( : ) * pw % pw_grid % g ( 3, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 3 ) > 1 ) THEN
pw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 3, : ) ** n ( 3 )
pw % cc ( : ) = cc ( : ) * ( pw % pw_grid % g ( 3, : ) ** n ( 3 ) )
flop = flop + 7 * cnt
END IF
DEALLOCATE ( cc, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "pw_derive_a", "cc" )
! im can take the values 1, -1, i, -i
! skip this if im == 1
IF ( ABS ( REAL ( im, dbl ) - 1._dbl ) > 1.e-10 ) THEN
@ -398,7 +435,82 @@ SUBROUTINE pw_derive ( pw, n )
CALL stop_program ( "pw_derive", "no suitable data field" )
END IF
END SUBROUTINE pw_derive
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_derive_a
!******************************************************************************
SUBROUTINE pw_derive_ab ( pw, dpw, n )
IMPLICIT NONE
! Arguments
TYPE ( pw_type ), INTENT ( IN ) :: pw
TYPE ( pw_type ), INTENT ( INOUT ) :: dpw
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: n
! Local
INTEGER :: m, handle
COMPLEX ( dbl ) :: im
REAL ( dbl ) :: flop, cnt
!------------------------------------------------------------------------------
CALL timeset ( 'PW_DERIVE', 'I', 'Mflops', handle )
IF ( pw % in_space == RECIPROCALSPACE .AND. &
pw % in_use == COMPLEXDATA1D .AND. &
dpw % in_use == COMPLEXDATA1D ) THEN
m = sum ( n )
im = CMPLX ( 0._dbl, 1._dbl, dbl ) ** m
IF ( ANY ( n < 0 ) ) CALL stop_program ( "pw_derive", "n < 0" )
cnt = REAL ( SIZE ( pw % cc ), dbl )
flop = 0._dbl
IF ( n ( 1 ) == 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 1, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 1 ) > 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * ( pw % pw_grid % g ( 1, : ) ** n ( 1 ) )
flop = flop + 7 * cnt
END IF
IF ( n ( 2 ) == 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 2, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 2 ) > 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * ( pw % pw_grid % g ( 2, : ) ** n ( 2 ) )
flop = flop + 7 * cnt
END IF
IF ( n ( 3 ) == 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * pw % pw_grid % g ( 3, : )
flop = flop + 6 * cnt
ELSE IF ( n ( 3 ) > 1 ) THEN
dpw % cc ( : ) = pw % cc ( : ) * ( pw % pw_grid % g ( 3, : ) ** n ( 3 ) )
flop = flop + 7 * cnt
END IF
! im can take the values 1, -1, i, -i
! skip this if im == 1
IF ( ABS ( REAL ( im, dbl ) - 1._dbl ) > 1.e-10 ) THEN
dpw % cc ( : ) = im * dpw % cc ( : )
flop = flop + 6 * cnt
END IF
dpw % in_space = RECIPROCALSPACE
ELSE
CALL stop_program ( "pw_derive", "no suitable data field" )
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_derive_ab
!!*****
!******************************************************************************
@ -414,7 +526,7 @@ END SUBROUTINE pw_derive
!! JGH (25-Feb-2001)
!!
!! MODIFICATION HISTORY
!! none
!! JGH (13-Mar-2001) : added gather/scatter cases
!!
!! NOTES
!! Copy routine that allows for in_space changes
@ -432,16 +544,35 @@ SUBROUTINE pw_transfer ( pw1, pw2 )
!------------------------------------------------------------------------------
IF ( ( pw1 % in_space == REALSPACE .AND. pw2 % in_space == REALSPACE ) .OR. &
( pw1 % in_space == RECIPROCALSPACE .AND. &
pw2 % in_space == RECIPROCALSPACE ) ) THEN
IF ( pw1 % in_space == REALSPACE .AND. pw2 % in_space == REALSPACE ) THEN
! simple copy should do
! simple copy should do
CALL pw_copy ( pw1, pw2 )
ELSEIF ( pw1 % in_space == RECIPROCALSPACE .AND. &
pw2 % in_space == RECIPROCALSPACE ) THEN
IF ( pw1 % in_use == pw2 % in_use ) THEN
! simple copy should do
CALL pw_copy ( pw1, pw2 )
ELSE
! we have to gather/scatter the data
IF ( pw1 % in_use == COMPLEXDATA1D ) THEN
CALL pw_scatter ( pw1, pw2 % cc3d )
ELSEIF ( pw2 % in_use == COMPLEXDATA1D ) THEN
CALL pw_gather ( pw2, pw1 % cc3d )
ELSE
CALL stop_program ( "pw_transfer", "Do not know what to do" )
END IF
END IF
ELSE
! FFT needed, all further tests done in pw_fft_wrap
! FFT needed, all further tests done in pw_fft_wrap
CALL pw_fft_wrap ( pw1, pw2 )
END IF
@ -479,23 +610,36 @@ SUBROUTINE pw_add ( pw1, pw2, pw3 )
TYPE ( pw_type ), INTENT ( IN ) :: pw1, pw2
TYPE ( pw_type ), INTENT ( INOUT ) :: pw3
! Local
INTEGER :: handle
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_ADD', 'I', 'Mflops', handle )
IF ( pw1 % in_use == REALDATA1D .AND. pw2 % in_use == REALDATA1D .AND. &
pw3 % in_use == REALDATA1D ) THEN
pw3 % cr = pw1 % cr + pw2 % cr
flop = REAL ( SIZE ( pw2 % cr ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D .AND. pw3 % in_use == COMPLEXDATA1D ) THEN
pw3 % cc = pw1 % cc + pw2 % cc
flop = REAL ( 2 * SIZE ( pw2 % cc ), dbl )
ELSE IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D .AND. &
pw3 % in_use == REALDATA3D ) THEN
pw3 % cr3d = pw1 % cr3d + pw2 % cr3d
flop = REAL ( SIZE ( pw2 % cr3d ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA3D .AND. &
pw2 % in_use == COMPLEXDATA3D .AND. pw3 % in_use == COMPLEXDATA3D ) THEN
pw3 % cc3d = pw1 % cc3d + pw2 % cc3d
flop = REAL ( 2 * SIZE ( pw2 % cc3d ), dbl )
ELSE
CALL stop_program ( "pw_add", "no suitable data field" )
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_add
@ -526,37 +670,52 @@ SUBROUTINE pw_sumup_square ( pw1, pw2 )
TYPE ( pw_type ), INTENT ( INOUT ) :: pw1
TYPE ( pw_type ), INTENT ( IN ) :: pw2
! Local
INTEGER :: handle
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_SUMUP_SQUARE', 'I', 'Mflops', handle )
IF ( pw1 % in_use == REALDATA1D ) THEN
IF ( pw2 % in_use == REALDATA1D ) THEN
pw1 % cr = pw1 % cr + pw2 % cr * pw2 % cr
flop = REAL ( 2 * SIZE ( pw2 % cr ), dbl )
ELSE IF ( pw2 % in_use == COMPLEXDATA1D ) THEN
pw1 % cr = pw1 % cr + REAL ( pw2 % cc * pw2 % cc, dbl )
pw1 % cr = pw1 % cr + REAL ( pw2 % cc * CONJG ( pw2 % cc ), dbl )
flop = REAL ( 7 * SIZE ( pw2 % cc ), dbl )
ELSE
CALL stop_program ( "pw_sumup_square", "no suitable data fields" )
END IF
ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN
IF ( pw2 % in_use == COMPLEXDATA1D ) THEN
pw1 % cc = pw1 % cc + pw2 % cc * pw2 % cc
pw1 % cc = pw1 % cc + pw2 % cc * CONJG ( pw2 % cc )
flop = REAL ( 8 * SIZE ( pw2 % cc ), dbl )
ELSE
CALL stop_program ( "pw_sumup_square", "no suitable data fields" )
END IF
ELSE IF ( pw1 % in_use == REALDATA3D ) THEN
IF ( pw2 % in_use == REALDATA3D ) THEN
pw1 % cr3d = pw1 % cr3d + pw2 % cr3d * pw2 % cr3d
flop = REAL ( 2 * SIZE ( pw2 % cr3d ), dbl )
ELSE IF ( pw2 % in_use == COMPLEXDATA3D ) THEN
pw1 % cr3d = pw1 % cr3d + REAL ( pw2 % cc3d * pw2 % cc3d, dbl )
pw1 % cr3d = pw1 % cr3d + REAL ( pw2 % cc3d * CONJG ( pw2 % cc3d ), dbl )
flop = REAL ( 7 * SIZE ( pw2 % cr3d ), dbl )
ELSE
CALL stop_program ( "pw_sumup_square", "no suitable data fields" )
END IF
ELSE IF ( pw1 % in_use == COMPLEXDATA3D ) THEN
IF ( pw2 % in_use == COMPLEXDATA3D ) THEN
pw1 % cc3d = pw1 % cc3d + pw2 % cc3d * pw2 % cc3d
pw1 % cc3d = pw1 % cc3d + pw2 % cc3d * CONJG ( pw2 % cc3d )
flop = REAL ( 8 * SIZE ( pw2 % cr3d ), dbl )
ELSE
CALL stop_program ( "pw_sumup_square", "no suitable data fields" )
END IF
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_sumup_square
@ -590,22 +749,35 @@ SUBROUTINE pw_sumup ( pw1, pw2 )
! Arguments
TYPE ( pw_type ), INTENT ( IN ) :: pw1
TYPE ( pw_type ), INTENT ( INOUT ) :: pw2
! Local
INTEGER :: handle
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_SUMUP', 'I', 'Mflops', handle )
IF ( pw1 % in_use == REALDATA1D .AND. pw2 % in_use == REALDATA1D ) THEN
pw2 % cr = pw2 % cr + pw1 % cr
flop = REAL ( SIZE ( pw2 % cr ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D ) THEN
pw2 % cc = pw2 % cc + pw1 % cc
flop = REAL ( 2 * SIZE ( pw2 % cc ), dbl )
ELSE IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D ) THEN
pw2 % cr3d = pw2 % cr3d + pw1 % cr3d
flop = REAL ( SIZE ( pw2 % cr3d ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA3D .AND. &
pw2 % in_use == COMPLEXDATA3D ) THEN
pw2 % cc3d = pw2 % cc3d + pw1 % cc3d
flop = REAL ( 2 * SIZE ( pw2 % cc3d ), dbl )
ELSE
CALL stop_program ( "pw_sumup", "no suitable data field" )
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_sumup
@ -640,23 +812,36 @@ SUBROUTINE pw_subtract ( pw1, pw2, pw3 )
TYPE ( pw_type ), INTENT ( IN ) :: pw1, pw2
TYPE ( pw_type ), INTENT ( INOUT ) :: pw3
! Local
INTEGER :: handle
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_SUBTRACT', 'I', 'Mflops', handle )
IF ( pw1 % in_use == REALDATA1D .AND. pw2 % in_use == REALDATA1D .AND. &
pw3 % in_use == REALDATA1D ) THEN
pw3 % cr = pw1 % cr - pw2 % cr
flop = REAL ( SIZE ( pw2 % cr ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D .AND. pw3 % in_use == COMPLEXDATA1D ) THEN
pw3 % cc = pw1 % cc - pw2 % cc
flop = REAL ( 2 * SIZE ( pw2 % cc ), dbl )
ELSE IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D .AND. &
pw3 % in_use == REALDATA3D ) THEN
pw3 % cr3d = pw1 % cr3d - pw2 % cr3d
flop = REAL ( SIZE ( pw2 % cr3d ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA3D .AND. &
pw2 % in_use == COMPLEXDATA3D .AND. pw3 % in_use == COMPLEXDATA3D ) THEN
pw3 % cc3d = pw1 % cc3d - pw2 % cc3d
flop = REAL ( 2 * SIZE ( pw2 % cc3d ), dbl )
ELSE
CALL stop_program ( "pw_subtract", "no suitable data field" )
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_subtract
@ -690,22 +875,35 @@ SUBROUTINE pw_reduce ( pw1, pw2 )
! Arguments
TYPE ( pw_type ), INTENT ( IN ) :: pw1
TYPE ( pw_type ), INTENT ( INOUT ) :: pw2
! Local
INTEGER :: handle
REAL ( dbl ) :: flop
!------------------------------------------------------------------------------
CALL timeset ( 'PW_REDUCE', 'I', 'Mflops', handle )
IF ( pw1 % in_use == REALDATA1D .AND. pw2 % in_use == REALDATA1D ) THEN
pw2 % cr = pw2 % cr - pw1 % cr
flop = REAL ( SIZE ( pw2 % cr ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D ) THEN
pw2 % cc = pw2 % cc - pw1 % cc
flop = REAL ( 2 * SIZE ( pw2 % cc ), dbl )
ELSE IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D ) THEN
pw2 % cr3d = pw2 % cr3d - pw1 % cr3d
flop = REAL ( SIZE ( pw2 % cr3d ), dbl )
ELSE IF ( pw1 % in_use == COMPLEXDATA3D .AND. &
pw2 % in_use == COMPLEXDATA3D ) THEN
pw2 % cc3d = pw2 % cc3d - pw1 % cc3d
flop = REAL ( 2 * SIZE ( pw2 % cc3d ), dbl )
ELSE
CALL stop_program ( "pw_reduce", "no suitable data field" )
END IF
flop = flop * 1.e-6_dbl
CALL timestop ( flop, handle )
END SUBROUTINE pw_reduce
@ -1182,7 +1380,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug )
COMPLEX ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: grays
REAL ( dbl ) :: norm
INTEGER, DIMENSION ( : ), POINTER :: n
INTEGER :: dir, out_space, ierr, nrays, my_pos, nloc ( 3 )
INTEGER :: dir, out_space, ierr, nrays, my_pos, nloc ( 3 ), handle
CHARACTER ( LEN = 9 ) :: mode
LOGICAL :: test
@ -1318,6 +1516,7 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug )
! nothing to do
CASE ( "BW_C3DR3D" )
! use real part only
IF ( test ) write ( *,'(A)') " REAL part "
pw2 % cr3d = REAL ( c_out, dbl )
DEALLOCATE ( c_out, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "fft_wrap_pw1pw2", "c_out" )
@ -1325,10 +1524,12 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug )
! nothing to do
CASE ( "BW_C1DR3D" )
! use real part only
IF ( test ) write ( *,'(A)') " REAL part "
pw2 % cr3d = REAL ( c_out, dbl )
DEALLOCATE ( c_out, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "fft_wrap_pw1pw2", "c_out" )
END SELECT
IF ( test ) WRITE ( *,'(A)') " End of FFT Protocol "
ELSE
@ -1415,6 +1616,8 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug )
CASE ( "BW_C1DC3D" )
! nothing to do
CASE ( "BW_C1DR3D" )
IF ( test .AND. pw1%pw_grid%para%group_head ) &
write ( *,'(A)') " Real part "
pw2 % cr3d = REAL ( c_in, dbl )
DEALLOCATE ( c_in, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "fft_wrap_pw1pw2", "c_in" )
@ -1428,6 +1631,10 @@ SUBROUTINE fft_wrap_pw1pw2 ( pw1, pw2, debug )
!..update the space tag for pw2
pw2 % in_space = out_space
IF ( test .AND. pw1 % pw_grid % para % group_head ) THEN
WRITE ( *,'(A)') " End of FFT Protocol "
END IF
END SUBROUTINE fft_wrap_pw1pw2
!******************************************************************************

10
src/pw_xc.F
View file

@ -32,7 +32,9 @@ MODULE pw_xc
NOSPACE, REALSPACE, RECIPROCALSPACE
USE functionals, ONLY : xc_type, becke88, lyp, pade, pbe_c, pbe_x, &
perdew86_x, perdew86_c, slater, vwn_c, vwn_x
IMPLICIT NONE
INTERFACE pw_calculate_xc
MODULE PROCEDURE pw_calculate_xcns, pw_calculate_xcspin
END INTERFACE
@ -76,7 +78,7 @@ CONTAINS
! Local
TYPE ( pw_type ) :: rho, drho, v_xc, v_xcg, dv, dvg, vg
TYPE ( pw_type ) :: rhog, drhog, drho_i ( 3 )
INTEGER :: i, n ( 3 )
INTEGER :: i, j, n ( 3 )
!------------------------------------------------------------------------------
@ -256,7 +258,7 @@ CONTAINS
TYPE ( pw_type ) :: rhoa, rhob, drhoa, drhob, v_xca, v_xcb, &
v_xcga, v_xcgb, v_xcgab, dv, dvg, vg
TYPE ( pw_type ) :: rhoga, rhogb, drhoga, drhogb, drho_ia ( 3 ), drho_ib ( 3 )
INTEGER :: i, n ( 3 )
INTEGER :: i, j, n ( 3 )
!------------------------------------------------------------------------------
@ -387,7 +389,7 @@ CONTAINS
CALL pw_allocate ( dvg, xc_grid, COMPLEXDATA1D )
dvg % in_space = RECIPROCALSPACE
CALL pw_allocate ( vg, xc_grid, COMPLEXDATA1D )
vg % in_space = RECIPROCAaLSPACE
vg % in_space = RECIPROCALSPACE
! alpha spin
CALL pw_zero ( vg )

365
src/pws.F
View file

@ -14,6 +14,7 @@
!!
!! MODIFICATION HISTORY
!! JGH (4-Jan-2001) : fft_wrap moved to coefficient_types and pw_types
!! JGH (13-Mar-2001) : new pw_poisson_solver, delete pw_greens_fn
!!
!! SOURCE
!******************************************************************************
@ -22,12 +23,16 @@ MODULE pws
USE coefficient_types, ONLY : coeff_type, coeff_allocate, coeff_deallocate, &
SQUARE, SQUAREROOT, PLANEWAVES
USE greens_fn, ONLY : pw_green_fn, greens_function_type, &
PERIODIC3D, ANALYTIC2D, &
ANALYTIC1D, ANALYTIC0D, MT2D, MT1D, MT0D, &
HOCKNEY2D, HOCKNEY1D, HOCKNEY0D
USE kinds, ONLY : dbl
USE mathconstants, ONLY : fourpi
USE message_passing, ONLY : mp_sum
USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE, FULLSPACE
USE pw_types, ONLY : pw_type, pw_allocate, pw_deallocate, &
pw_gather, pw_scatter, pw_fft_wrap, &
pw_copy, pw_derive, pw_transfer, pw_gather, pw_scatter, pw_fft_wrap, &
REALDATA1D, COMPLEXDATA1D, REALDATA3D, COMPLEXDATA3D, &
NOSPACE, REALSPACE, RECIPROCALSPACE
USE termination, ONLY : stop_memory, stop_program
@ -36,14 +41,50 @@ MODULE pws
IMPLICIT NONE
PRIVATE
PUBLIC :: pw_poisson_solver, pw_kinetic_evaluate
PUBLIC :: pw_integral_a, pw_integral_ab, pw_h_psi
PUBLIC :: pw_poisson_solver, pw_kinetic_evaluate, init_pw_poisson_solver
PUBLIC :: pw_integral_aa, pw_integral_ab, pw_integral_a2b, pw_h_psi, &
pw_collect
! Global variable
TYPE ( greens_function_type ), POINTER :: gf
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** pws/init_pw_poisson_solver [1.0] *
!!
!! NAME
!! init_pw_poisson_solver
!!
!! FUNCTION
!! Initialize the module variable gf, used in the poisson solver
!!
!! AUTHOR
!! JGH (12-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE init_pw_poisson_solver ( gftype )
IMPLICIT NONE
! Arguments
TYPE ( greens_function_type ), INTENT ( IN ), TARGET :: gftype
!------------------------------------------------------------------------------
gf => gftype
END SUBROUTINE init_pw_poisson_solver
!!*****
!******************************************************************************
!!****** pws/pw_poisson_solver [1.0] *
!!
@ -59,163 +100,104 @@ CONTAINS
!! apsi
!!
!! MODIFICATION HISTORY
!! none
!! JGH (13-Mar-2001) : completely revised
!!
!! SOURCE
!******************************************************************************
SUBROUTINE pw_poisson_solver ( density, vhartree, dvhartree, h_stress )
SUBROUTINE pw_poisson_solver ( density, ehartree, vhartree, dvhartree, h_stress )
IMPLICIT NONE
! Arguments
TYPE ( coeff_type ), INTENT ( IN ), TARGET :: density
TYPE ( coeff_type ), INTENT ( OUT ), OPTIONAL :: vhartree
TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: density
REAL ( dbl ) , INTENT ( OUT ) :: ehartree
TYPE ( coeff_type ), INTENT ( OUT ) :: vhartree
TYPE ( coeff_type ), DIMENSION ( 3 ), INTENT ( OUT ), OPTIONAL :: dvhartree
REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( OUT ), OPTIONAL :: h_stress
! Locals
INTEGER :: gpt, dir
REAL ( dbl ) :: gf
COMPLEX ( dbl ) :: i_cmplx
INTEGER :: lp, mp, np, ln, mn, nn
INTEGER, DIMENSION ( : ), POINTER :: ghat
INTEGER, DIMENSION ( :, : ), POINTER :: g_hat
TYPE ( pw_grid_type ), POINTER :: pw_grid
TYPE ( pw_type ) :: rho_g, cfft
TYPE ( pw_type ) :: rhog, dvg ( 3 )
REAL ( dbl ) :: ffa
INTEGER, DIMENSION ( 3 ) :: n
INTEGER :: i, gpt, alpha, beta
!------------------------------------------------------------------------------
i_cmplx = ( 0._dbl, 1._dbl )
pw_grid => density % pw % pw_grid
g_hat => pw_grid % g_hat
CALL pw_allocate ( rho_g, pw_grid, use_data = COMPLEXDATA3D )
CALL pw_allocate ( cfft, pw_grid, use_data = COMPLEXDATA3D )
cfft % in_space = RECIPROCALSPACE
!..FWFFT ( real to g space )
CALL pw_fft_wrap ( density%pw, rho_g )
IF ( PRESENT ( vhartree ) ) THEN
cfft % cc3d = 0._dbl
DO gpt = 1, pw_grid % ngpts_cut
! compute Green's function '''
CALL pw_greens_function ( gf, pw_grid % g ( :, gpt ) )
ghat => g_hat ( :, gpt )
lp = pw_grid % mapl % pos ( ghat ( 1 ) )
ln = pw_grid % mapl % neg ( ghat ( 1 ) )
mp = pw_grid % mapm % pos ( ghat ( 2 ) )
mn = pw_grid % mapm % neg ( ghat ( 2 ) )
np = pw_grid % mapn % pos ( ghat ( 3 ) )
nn = pw_grid % mapn % neg ( ghat ( 3 ) )
lp = lp + LBOUND ( cfft % cc3d, 1 )
mp = mp + LBOUND ( cfft % cc3d, 2 )
np = np + LBOUND ( cfft % cc3d, 3 )
ln = ln + LBOUND ( cfft % cc3d, 1 )
mn = mn + LBOUND ( cfft % cc3d, 2 )
nn = nn + LBOUND ( cfft % cc3d, 3 )
cfft % cc3d ( lp, mp, np ) = gf * rho_g % cc3d ( lp, mp, np )
cfft % cc3d ( ln, mn, nn ) = gf * rho_g % cc3d ( ln, mn, nn )
END DO
! get phi_r
!..BWFFT ( g to real space )
CALL pw_fft_wrap ( cfft, vhartree%pw )
IF ( .NOT. ASSOCIATED ( gf ) ) THEN
CALL stop_program ( "pw_poisson_solver", "init_pw_poisson_solver "// &
"has to be used before pw_poisson_solver" )
END IF
! multiply by the Green's function '''
! density in G space
CALL pw_allocate ( rhog, pw_grid, COMPLEXDATA1D )
rhog % in_space = RECIPROCALSPACE
IF ( PRESENT ( dvhartree ) ) THEN
DO dir = 1, 3
cfft % cc3d = 0.0_dbl
! update the greens function
CALL pw_green_fn ( gf )
DO gpt = 1, pw_grid % ngpts_cut
SELECT CASE ( gf % method )
CASE ( PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, MT2D, MT1D, MT0D )
CALL pw_transfer ( density % pw, rhog )
rhog % cc = rhog % cc * gf % influence_function % cr
CALL pw_transfer ( rhog, vhartree % pw )
CASE ( HOCKNEY2D, HOCKNEY1D, HOCKNEY0D )
CALL stop_program ( "pw_poisson_solver", " Method not implemented ")
CASE DEFAULT
CALL stop_program ( "pw_poisson_solver", " Method not implemented ")
END SELECT
! compute Green's function '''
CALL pw_greens_function ( gf, pw_grid % g ( :, gpt ) )
ehartree = 0.5_dbl * pw_integral_ab ( density % pw, vhartree % pw )
ghat => g_hat ( :, gpt )
! do we need to calculate the derivative of the potential?
IF ( PRESENT ( h_stress ) .OR. PRESENT ( dvhartree ) ) THEN
IF ( gf % method /= PERIODIC3D ) THEN
CALL stop_program ( "pw_poisson_solver", &
"Pressure calculation works only for fully priodic systems" )
END IF
DO i = 1, 3
CALL pw_allocate ( dvg ( i ), pw_grid, COMPLEXDATA1D )
dvg ( i ) % in_space = RECIPROCALSPACE
n = 0
n ( i ) = 1
CALL pw_derive ( rhog, dvg ( i ), n )
END DO
! save the derivatives
IF ( PRESENT ( dvhartree ) ) THEN
DO i = 1, 3
CALL pw_transfer ( dvg ( i ), dvhartree ( i ) % pw )
END DO
END IF
! calculate the contribution to the stress tensor
! this is only the contribution from the Greens function
! and the volume factor of the plane waves
IF ( PRESENT ( h_stress ) ) THEN
lp = pw_grid % mapl % pos ( ghat ( 1 ) )
ln = pw_grid % mapl % neg ( ghat ( 1 ) )
mp = pw_grid % mapm % pos ( ghat ( 2 ) )
mn = pw_grid % mapm % neg ( ghat ( 2 ) )
np = pw_grid % mapn % pos ( ghat ( 3 ) )
nn = pw_grid % mapn % neg ( ghat ( 3 ) )
lp = lp + LBOUND ( cfft % cc3d, 1 )
mp = mp + LBOUND ( cfft % cc3d, 2 )
np = np + LBOUND ( cfft % cc3d, 3 )
ln = ln + LBOUND ( cfft % cc3d, 1 )
mn = mn + LBOUND ( cfft % cc3d, 2 )
nn = nn + LBOUND ( cfft % cc3d, 3 )
cfft % cc3d ( lp, mp, np ) = &
i_cmplx * pw_grid % g ( dir, gpt ) * gf &
* rho_g % cc3d ( lp, mp, np )
cfft % cc3d ( ln, mn, nn ) = &
- i_cmplx * pw_grid % g ( dir, gpt ) * gf &
* rho_g % cc3d ( ln, mn, nn )
ffa = -pw_grid % vol / fourpi
h_stress = 0._dbl
DO alpha = 1, 3
h_stress ( alpha, alpha ) = ehartree
DO beta = alpha, 3
h_stress ( alpha, beta ) = h_stress ( alpha, beta ) &
+ ffa * pw_integral_ab ( dvg ( alpha ), dvg ( beta ) )
h_stress ( beta, alpha ) = h_stress ( alpha, beta )
END DO
! get derivative of phi_r
!..BWFFT ( g to real space )
CALL pw_fft_wrap ( cfft, dvhartree ( dir ) %pw)
END DO
END DO
END IF
DO i = 1, 3
CALL pw_deallocate ( dvg ( i ) )
END DO
END IF
CALL pw_deallocate ( cfft )
CALL pw_deallocate ( rho_g )
CALL pw_deallocate ( rhog )
END SUBROUTINE pw_poisson_solver
!!*****
!******************************************************************************
SUBROUTINE pw_greens_function ( gf, g )
IMPLICIT NONE
! Arguments
REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: g
REAL ( dbl ), INTENT ( OUT ) :: gf
! Locals
INTEGER :: dimensionality !TMPTMPTMP
REAL ( dbl ) :: g2
!------------------------------------------------------------------------------
dimensionality = SIZE ( g )
SELECT CASE ( dimensionality )
CASE ( 3 ) ! 3-dim
g2 = dotprod_3d ( g, g )
IF ( g2 > 1.0E-10_dbl ) THEN
gf = fourpi / g2
ELSE
gf = 0.0_dbl
END IF
CASE ( 2 ) ! 2-dim
stop "greens_function, no 2-dim function implemented yet"
CASE ( 1 ) ! 1-dim
stop "greens_function, no 1-dim function implemented yet"
CASE ( 0 ) ! 0-dim = cluster
stop "greens_function, no 0-dim function implemented yet"
END SELECT
END SUBROUTINE pw_greens_function
!******************************************************************************
!!****** pws/pw_integral [1.0] *
!!
@ -229,7 +211,7 @@ END SUBROUTINE pw_greens_function
!! apsi
!!
!! MODIFICATION HISTORY
!! none
!! JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
!!
!! SOURCE
!******************************************************************************
@ -243,6 +225,10 @@ FUNCTION pw_integral_ab ( pw1, pw2, flag ) RESULT ( integral_value )
!------------------------------------------------------------------------------
IF ( pw1 % pw_grid % identifier /= pw2 % pw_grid % identifier ) THEN
CALL stop_program ( "integral_ab", "grids incompatible" )
END IF
IF ( pw1 % in_use == REALDATA3D .AND. pw2 % in_use == REALDATA3D ) THEN
integral_value = SUM ( pw1 % cr3d ( :, :, : ) &
* pw2 % cr3d ( :, :, : ) )
@ -277,19 +263,25 @@ FUNCTION pw_integral_ab ( pw1, pw2, flag ) RESULT ( integral_value )
IF ( pw1 % in_use == REALDATA3D .OR. pw1 % in_use == COMPLEXDATA3D ) THEN
integral_value = integral_value * pw1 % pw_grid % dvol
ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN
integral_value = integral_value
ELSE
CALL stop_program ( "pw_integral_ab", "volume element not implemented" )
integral_value = integral_value * pw1 % pw_grid % vol
ENDIF
IF ( pw1 % in_use == COMPLEXDATA1D ) THEN
IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN
integral_value = 2._dbl * integral_value
IF ( pw1 % pw_grid % have_g0 ) integral_value = integral_value - &
CONJG ( pw1 % cc ( 1 ) ) * pw2 % cc ( 1 )
END IF
END IF
!tmptmp IF ( pw1 % group_id >= 0 ) CALL mp_sum ( integral_value, pw1 % group_id )
IF ( pw1 % pw_grid % para % mode == 1 ) &
CALL mp_sum ( integral_value, pw1 % pw_grid % para % group )
END FUNCTION pw_integral_ab
!******************************************************************************
FUNCTION pw_integral_a ( pw1, flag ) RESULT ( integral_value )
FUNCTION pw_integral_aa ( pw1, flag ) RESULT ( integral_value )
TYPE ( pw_type ), INTENT ( IN ) :: pw1
INTEGER, INTENT ( IN ), OPTIONAL :: flag
@ -310,6 +302,11 @@ FUNCTION pw_integral_a ( pw1, flag ) RESULT ( integral_value )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D ) THEN
integral_value = SUM ( CONJG ( pw1 % cc ( : ) ) &
* pw1 % cc ( : ) )
IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN
integral_value = 2._dbl * integral_value
IF ( pw1 % pw_grid % have_g0 ) integral_value = integral_value - &
CONJG ( pw1 % cc ( 1 ) ) * pw1 % cc ( 1 )
END IF
ELSE
CALL stop_program ( "integral_aa", "no possible SQUARE data" )
END IF
@ -332,12 +329,56 @@ FUNCTION pw_integral_a ( pw1, flag ) RESULT ( integral_value )
END IF
END IF
IF ( pw1 % in_use == REALDATA3D ) &
integral_value = integral_value * pw1 % pw_grid % dvol
IF ( pw1 % in_use == REALDATA3D .OR. pw1 % in_use == COMPLEXDATA3D ) THEN
integral_value = integral_value * pw1 % pw_grid % dvol
ELSE
integral_value = integral_value * pw1 % pw_grid % vol
END IF
!tmptmp IF ( pw1 % group_id >= 0 ) CALL mp_sum ( integral_value, pw1 % group_id )
IF ( pw1 % pw_grid % para % mode == 1 ) &
CALL mp_sum ( integral_value, pw1 % pw_grid % para % group )
END FUNCTION pw_integral_a
END FUNCTION pw_integral_aa
!******************************************************************************
FUNCTION pw_integral_a2b ( pw1, pw2 ) RESULT ( integral_value )
TYPE ( pw_type ), INTENT ( IN ) :: pw1
TYPE ( pw_type ), INTENT ( IN ) :: pw2
REAL ( dbl ) :: integral_value
!------------------------------------------------------------------------------
IF ( pw1 % pw_grid % identifier /= pw2 % pw_grid % identifier ) THEN
CALL stop_program ( "integral_a2b", "grids incompatible" )
END IF
IF ( pw1 % in_use == REALDATA1D .AND. &
pw2 % in_use == REALDATA1D ) THEN
integral_value = SUM ( pw1 % cr ( : ) * pw2 % cr ( : ) &
* pw1 % pw_grid % gsq ( : ) )
ELSE IF ( pw1 % in_use == COMPLEXDATA1D .AND. &
pw2 % in_use == COMPLEXDATA1D ) THEN
integral_value = SUM ( REAL ( CONJG ( pw1 % cc ( : ) ) &
* pw2 % cc ( : ), dbl ) * pw1 % pw_grid % gsq ( : ) )
IF ( pw1 % pw_grid % grid_span == HALFSPACE ) THEN
integral_value = 2._dbl * integral_value
END IF
ELSE
CALL stop_program ( "integral_a2b", "no possible data" )
END IF
IF ( pw1 % in_use == REALDATA3D .OR. pw1 % in_use == COMPLEXDATA3D ) THEN
integral_value = integral_value * pw1 % pw_grid % dvol
ELSE
integral_value = integral_value * pw1 % pw_grid % vol
END IF
IF ( pw1 % pw_grid % para % mode == 1 ) &
CALL mp_sum ( integral_value, pw1 % pw_grid % para % group )
END FUNCTION pw_integral_a2b
!!*****
!******************************************************************************
@ -522,6 +563,54 @@ END SUBROUTINE pw_stateset_density
!!*****
!******************************************************************************
SUBROUTINE pw_collect ( pw, label, op )
IMPLICIT NONE
! Arguments
TYPE ( pw_type ), INTENT ( IN ) :: pw
CHARACTER ( LEN = * ) :: label
CHARACTER ( LEN = * ), OPTIONAL :: op
! Local
REAL ( dbl ) :: xsum
!------------------------------------------------------------------------------
IF ( .NOT. PRESENT ( op ) ) THEN
IF ( pw % in_use == COMPLEXDATA1D ) THEN
xsum = ABS ( SUM ( pw % cc ) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
xsum = ABS ( SUM ( pw % cc3d ) )
ELSEIF ( pw % in_use == REALDATA1D ) THEN
xsum = SUM ( pw % cr )
ELSEIF ( pw % in_use == REALDATA3D ) THEN
xsum = SUM ( pw % cr3d )
END IF
ELSE
IF ( pw % in_use == COMPLEXDATA1D ) THEN
xsum = SUM ( ABS ( pw % cc ) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
xsum = SUM ( ABS ( pw % cc3d ) )
ELSEIF ( pw % in_use == REALDATA1D ) THEN
xsum = SUM ( ABS ( pw % cr ) )
ELSEIF ( pw % in_use == REALDATA3D ) THEN
xsum = SUM ( ABS ( pw % cr3d ) )
END IF
END IF
IF ( pw % pw_grid % para % mode == 1 ) THEN
CALL mp_sum ( xsum, pw % pw_grid % para % group )
IF ( pw % pw_grid % para % group_head ) &
WRITE ( *, '(A,A10,G20.8)' ) " COLLECT ",label,xsum
ELSE
WRITE ( *, '(A,A10,G20.8)' ) " COLLECT ",label,xsum
END IF
END SUBROUTINE pw_collect
!******************************************************************************
END MODULE pws
!******************************************************************************

108
src/qs_main.F Normal file
View file

@ -0,0 +1,108 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart !
!-----------------------------------------------------------------------------!
!!****** cp2k/qs_main [1.0] *
!!
!! NAME
!! qs_main
!!
!! FUNCTION
!! Perform a LCGTO-SCF-DF calculation using the Gaussian and plane wave
!! (GPW) method
!!
!! AUTHOR
!! Matthias Krack (03.04.2001)
!!
!! LITERATURE
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE qs_main
! *****************************************************************************
! Index:
! SUBROUTINE qs_main
! *****************************************************************************
USE kinds, ONLY: wp => dp
USE global_types, ONLY: global_environment_type
IMPLICIT NONE
PRIVATE
PUBLIC :: quickstep
! *****************************************************************************
CONTAINS
! *****************************************************************************
SUBROUTINE quickstep(globenv)
! Purpose: Main driver routine for a Quickstep calculation.
! History: - Creation (04.00.2001, Matthias Krack)
! ***************************************************************************
USE core_hamiltonian, ONLY: build_core_hamiltonian_matrix
USE nl, ONLY: build_neighbor_list_sets
USE qs_scf, ONLY: scf
USE readin, ONLY: read_files
USE start_program_run, ONLY: start_qs_program_run
USE timings, ONLY: timeset,timestop
TYPE(global_environment_type), INTENT(INOUT) :: globenv
! *** Local parameters ***
CHARACTER(LEN=*), PARAMETER :: routine =&
"SUBROUTINE quickstep (MODULE qs_main)"
! *** Local variables ***
INTEGER :: handle
! ---------------------------------------------------------------------------
CALL timeset("Quickstep","I","",handle)
! *** Initialize the Quickstep program run ***
CALL start_qs_program_run(globenv)
! *** Read the input and the database files ***
! *** and perform further initializations ***
CALL read_files(globenv)
! *** Build neighbor list sets ***
CALL build_neighbor_list_sets(globenv)
! *** Calculate the core Hamiltonian integral matrix ***
CALL build_core_hamiltonian_matrix(globenv)
! *** Perform SCF run ***
CALL scf(globenv)
CALL timestop(0.0_wp,handle)
END SUBROUTINE quickstep
! *****************************************************************************
END MODULE qs_main

1088
src/qs_scf.F Normal file
View file

File diff suppressed because it is too large Load diff

2
src/radial_solver.F
View file

@ -96,7 +96,7 @@ CONTAINS
ab ( 4, i ) = ab ( 4, i ) * ww
END DO
CALL DGBSV ( n, 1, 1, 1, ab, 4, ipiv, s, n, info )
CALL dgbsv ( n, 1, 1, 1, ab, 4, ipiv, s, n, info )
IF ( info /= 0 ) call stop_program ( "numerov", "DGBSV: info /= 0" )
g ( 1:n ) = s ( 1:n )

164
src/read_pimd.F Normal file
View file

@ -0,0 +1,164 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/read_pimd [1.0] *
!!
!! NAME
!! read_pimd
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE read_pimd
USE global_types, ONLY : global_environment_type
USE kinds, ONLY : dbl
USE message_passing, ONLY : mp_bcast
USE parser, ONLY : parser_init, parser_end, read_line, test_next, &
cfield, p_error, get_real, get_int, stop_parser
USE particle_types, ONLY : particle_type
USE string_utilities, ONLY : uppercase, xstring
USE util, ONLY : gasdev
USE termination, ONLY : stop_program
IMPLICIT NONE
PRIVATE
PUBLIC :: read_pimd_section, pimd_parameters_type
TYPE pimd_parameters_type
INTEGER :: beads
INTEGER :: ndelta
REAL ( dbl ) :: wp
REAL ( dbl ) :: beta
CHARACTER ( LEN = 20 ) :: transformation
END TYPE pimd_parameters_type
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** md/read_pimd_section [1.0] *
!!
!! NAME
!! read_pimd_section
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!I---------------------------------------------------------------------------I
!!I SECTION: &pimd ... &end I
!!I I
!!I beads : n Number of beads I
!!I ndelta: n Number of NHC+harmonic coupling integrations per I
!!I full time step dt I
!!I transformation: [none,normal,stage] coordinate transformation I
!!I I
!!I I
!!I---------------------------------------------------------------------------I
!! SOURCE
!******************************************************************************
SUBROUTINE read_pimd_section ( pimdpar, mdpar )
IMPLICIT NONE
! Arguments
TYPE ( pimd_parameters_type ), INTENT ( OUT ) :: pimdpar
TYPE ( global_environment_type ), INTENT( IN ) :: mdpar
! Locals
INTEGER :: ierror, ilen, iw
CHARACTER ( LEN = 20 ) :: string
CHARACTER ( LEN = 5 ) :: label
!------------------------------------------------------------------------------
!..defaults
pimdpar % beads = 1
pimdpar % ndelta = 2
pimdpar % transformation = 'NONE'
#if defined(__parallel)
CALL stop_program('read_pimd_section', &
'PIMD is not checked to work in parallel yet')
#endif
iw = mdpar % scr
!..parse the input section
label = '&PIMD'
CALL parser_init(mdpar % input_file_name,label,ierror,mdpar)
IF (ierror /= 0 ) THEN
IF( mdpar % ionode ) &
WRITE ( iw, '( a )' ) ' No input section &PIMD found '
ELSE
CALL read_line
DO WHILE ( test_next() /= 'X' )
ilen = 6
CALL cfield ( string, ilen )
CALL uppercase ( string )
SELECT CASE ( string )
CASE DEFAULT
CALL p_error()
CALL stop_parser ( 'read_pimd_section', 'unknown option' )
CASE ( 'BEADS' )
pimdpar % beads = get_int()
CASE ( 'NDELTA' )
pimdpar % ndelta = get_int()
CASE ( 'TRANSF' )
ilen = 0
CALL cfield ( string, ilen )
CALL uppercase ( string )
pimdpar % transformation = string ( 1:ilen )
END SELECT
CALL read_line
END DO
END IF
CALL parser_end
!..end of parsing the input section
!..write some information to output
IF (mdpar % ionode .AND. mdpar % print_level>=0) THEN
WRITE ( iw, '( A )' ) ' PIMD| Path Integral Molecular Dynamics Protocol'
WRITE ( iw, '( A,T71,I10 )' ) ' PIMD| Number of Beads ', &
pimdpar % beads
WRITE ( iw, '( A,T71,I10 )' ) &
' PIMD| Number of kinetic+NHC integrations ', pimdpar % ndelta
WRITE ( iw, '( A,T61,A )' ) ' PIMD| Transformation Type ', &
ADJUSTR ( pimdpar % transformation )
WRITE (iw,*)
END IF
END SUBROUTINE read_pimd_section
!!*****
!******************************************************************************
END MODULE read_pimd
!******************************************************************************

13
src/readin.F
View file

@ -25,7 +25,6 @@ MODULE readin
! Index:
! SUBROUTINE read_files(globenv)
! SUBROUTINE read_title(start_section,end_section,globenv)
! SUBROUTINE write_total_numbers(lunit)
! *****************************************************************************
@ -81,9 +80,11 @@ CONTAINS
read_method_specifications,&
write_method_specifications
USE orbital_transformation_matrices, ONLY: init_spherical_harmonics
USE qs_scf, ONLY: read_scf_parameters,&
write_scf_parameters
USE timings, ONLY: timeset,timestop
TYPE(global_environment_type), INTENT(IN) :: globenv
TYPE(global_environment_type), INTENT(INOUT) :: globenv
! *** Local variables ***
@ -219,6 +220,14 @@ CONTAINS
CALL init_interaction_radii(globenv)
! *** Read SCF parameters ***
CALL read_scf_parameters(section_character//"SCF",end_section,globenv)
IF (ionode.AND.globenv%print%scf) THEN
CALL write_scf_parameters(output_unit)
END IF
CALL timestop(0.0_wp,handle)
END SUBROUTINE read_files

798
src/realspace_grid_types.F Normal file
View file

@ -0,0 +1,798 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****s* cp2k/realspace_grid_types [1.0] *
!!
!! NAME
!! realspace_grid_types
!!
!! FUNCTION
!!
!! AUTHOR
!! JGH (18-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!! Basic type for real space grid methods
!!
!! SOURCE
!******************************************************************************
MODULE realspace_grid_types
USE kinds, ONLY : dbl
USE message_passing, ONLY : mp_cart_create, mp_comm_free, mp_comm_dup, &
mp_sum, mp_max, mp_min, mp_cart_sub, mp_cart_shift, mp_sendrecv, &
mp_bcast
USE pw_types, ONLY : pw_type, REALDATA1D, COMPLEXDATA1D, &
REALDATA3D, COMPLEXDATA3D
USE pw_grid_types, ONLY : pw_grid_type
USE simulation_cell, ONLY : cell_type
USE termination, ONLY : stop_memory, stop_program
USE util, ONLY : get_limit
IMPLICIT NONE
PRIVATE
PUBLIC :: realspace_grid_type, rs_grid_allocate, rs_grid_deallocate, &
rs_grid_setup, rs_pw_transfer
TYPE realspace_grid_type
INTEGER :: identifier ! tag of this grid
INTEGER :: ngpts ! # grid points
INTEGER, DIMENSION (3) :: npts ! # grid points per dimension
INTEGER, DIMENSION (3) :: lb ! lower bounds
INTEGER, DIMENSION (3) :: ub ! upper bounds
INTEGER, DIMENSION (:), POINTER :: px,py,pz ! index translators
REAL ( dbl ), DIMENSION ( :, :, : ),POINTER :: r ! the grid
INTEGER :: border ! border points
INTEGER :: ngpts_local ! local dimensions
INTEGER, DIMENSION (3) :: npts_local
INTEGER, DIMENSION (3) :: lb_local
INTEGER, DIMENSION (3) :: ub_local
LOGICAL :: parallel
INTEGER :: group
LOGICAL :: group_head
INTEGER, DIMENSION (2) :: group_dim
INTEGER, DIMENSION (2) :: group_coor
INTEGER, DIMENSION (3) :: perd ! periodicity enforced
INTEGER :: direction ! non-periodic direction
END TYPE realspace_grid_type
INTERFACE rs_grid_allocate
MODULE PROCEDURE rs_grid_allocate_1, rs_grid_allocate_n
END INTERFACE
INTERFACE rs_grid_deallocate
MODULE PROCEDURE rs_grid_deallocate_1, rs_grid_deallocate_n
END INTERFACE
INTERFACE rs_grid_setup
MODULE PROCEDURE rs_grid_setup_1, rs_grid_setup_n
END INTERFACE
!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** realspace_grid_types/rs_grid_allocate [1.0] *
!!
!! NAME
!! rs_grid_allocate
!!
!! FUNCTION
!! Allocate real space grids
!!
!! AUTHOR
!! JGH (18-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE rs_grid_allocate_1 ( rs )
! Arguments
TYPE ( realspace_grid_type ), TARGET, INTENT (INOUT) :: rs
! Local
INTEGER :: ierr
INTEGER, DIMENSION (:), POINTER :: lb, ub
!-----------------------------------------------------------------------------!
lb => rs % lb_local
ub => rs % ub_local
ALLOCATE ( rs % r (lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % r", &
rs % ngpts_local )
ALLOCATE ( rs % px ( rs % npts ( 1 ) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % px", &
rs % npts ( 1 ) )
ALLOCATE ( rs % py ( rs % npts ( 2 ) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % py", &
rs % npts ( 2 ) )
ALLOCATE ( rs % pz ( rs % npts ( 3 ) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % pz", &
rs % npts ( 3 ) )
END SUBROUTINE rs_grid_allocate_1
!******************************************************************************
SUBROUTINE rs_grid_allocate_n ( rs )
! Arguments
TYPE ( realspace_grid_type ), DIMENSION ( : ), INTENT (INOUT) :: rs
! Local
INTEGER :: n, i
!-----------------------------------------------------------------------------!
n = SIZE ( rs )
DO i = 1, n
CALL rs_grid_allocate_1 ( rs ( i ) )
END DO
END SUBROUTINE rs_grid_allocate_n
!*****
!******************************************************************************
!!****** realspace_grid_types/rs_grid_deallocate [1.0] *
!!
!! NAME
!! rs_grid_deallocate
!!
!! FUNCTION
!! Deallocate real space grids
!!
!! AUTHOR
!! JGH (18-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE rs_grid_deallocate_1 ( rs )
! Arguments
TYPE ( realspace_grid_type ), INTENT (INOUT) :: rs
! Local
INTEGER :: ierr
!-----------------------------------------------------------------------------!
DEALLOCATE ( rs % r, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % r" )
DEALLOCATE ( rs % px , STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % px" )
DEALLOCATE ( rs % py , STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % py" )
DEALLOCATE ( rs % pz , STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_grid_deallocate","rs % pz" )
rs % identifier = 0
IF ( rs % parallel ) THEN
! release the group communicator
CALL mp_comm_free ( rs % group )
END IF
END SUBROUTINE rs_grid_deallocate_1
!******************************************************************************
SUBROUTINE rs_grid_deallocate_n ( rs )
! Arguments
TYPE ( realspace_grid_type ), DIMENSION ( : ), INTENT (INOUT) :: rs
! Local
INTEGER :: n, i, ierr
!-----------------------------------------------------------------------------!
n = SIZE ( rs )
DO i = 1, n
CALL rs_grid_deallocate_1 ( rs ( i ) )
END DO
END SUBROUTINE rs_grid_deallocate_n
!*****
!******************************************************************************
!!****** realspace_grid_types/rs_grid_setup [1.0] *
!!
!! NAME
!! rs_grid_setup
!!
!! FUNCTION
!! Determine the setup of real space grids
!!
!! AUTHOR
!! JGH (18-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE rs_grid_setup_1 ( rs, pw_grid, nsmax, iounit )
! Arguments
TYPE ( realspace_grid_type ), INTENT (INOUT) :: rs
TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: nsmax
INTEGER, OPTIONAL, INTENT ( IN ) :: iounit
! Local
INTEGER :: dir, nmin, ngmax, ip, n_slices, pos ( 2 ), lb ( 2 ), nn, i
REAL ( dbl ) :: pp ( 3 )
!-----------------------------------------------------------------------------!
rs % identifier = pw_grid % identifier
IF ( pw_grid % para % mode == 0 ) THEN
! The corresponding group has dimension 1
! All operations will be done localy
rs % npts = pw_grid % npts
rs % ngpts = PRODUCT ( rs % npts )
rs % lb = pw_grid % bounds ( 1, : )
rs % ub = pw_grid % bounds ( 2, : )
rs % perd = 1
rs % direction = 0
rs % border = 0
rs % npts_local = pw_grid % npts
rs % ngpts_local = PRODUCT ( rs % npts )
rs % lb_local = pw_grid % bounds ( 1, : )
rs % ub_local = pw_grid % bounds ( 2, : )
rs % parallel = .FALSE.
rs % group = 0
rs % group_head = .TRUE.
rs % group_dim = 1
rs % group_coor = 0
ELSE
! x is the main distribution direction of pw grids in real space
! we distribute real space grids accordingly
dir = 1
rs % direction = 1
! the minimum slice thickness is half of the small box size
! this way there is only overlap with direct neighbors
nmin = ( nsmax ( dir ) + 1 ) / 2
! maximum number of slices
ngmax = pw_grid % npts ( dir ) / nmin
! now we reduce this number until we find a divisor of the total number
! of processors
!
!cdeb
!the code works currently only for this setting
ngmax=1
!cdeb
n_slices = 1
DO ip = ngmax, 1, -1
IF ( MOD ( pw_grid % para % group_size, ip ) == 0 ) THEN
n_slices = ip
EXIT
END IF
END DO
! global grid dimensions are still the same
rs % npts = pw_grid % npts
rs % ngpts = PRODUCT ( rs % npts )
rs % lb = pw_grid % bounds ( 1, : )
rs % ub = pw_grid % bounds ( 2, : )
rs % group_dim ( 1 ) = n_slices
rs % group_dim ( 2 ) = pw_grid % para % group_size / n_slices
IF ( n_slices == 1 ) THEN
! CASE 1 : only one slice: we do not need overlapping reagions and special
! recombination of the total density
rs % perd = 1
rs % border = 0
rs % npts_local = pw_grid % npts
rs % ngpts_local = PRODUCT ( rs % npts )
rs % lb_local = pw_grid % bounds ( 1, : )
rs % ub_local = pw_grid % bounds ( 2, : )
rs % parallel = .TRUE.
CALL mp_comm_dup( pw_grid % para % group , rs % group )
rs % group_head = pw_grid % para % group_head
rs % group_coor ( 1 ) = 0
rs % group_coor ( 2 ) = pw_grid % para % my_pos
ELSE
! CASE 2 : general case
! periodicity is no longer enforced along direction dir
rs % perd = 1
rs % perd ( dir ) = 0
! we keep a border on nmin points
rs % border = nmin
! we are going parallel on the real space grid
rs % parallel = .TRUE.
! the new cartesian group
CALL mp_cart_create ( pw_grid % para % group, 2, &
rs % group_dim, pos, rs % group )
rs % group_head = ALL ( pos == 0 )
rs % group_coor = pos
! local dimensions of the grid
rs % npts_local = pw_grid % npts
lb = get_limit ( pw_grid % npts ( dir ), rs % group_dim ( 1 ), pos ( 1 ) )
rs % npts_local ( dir ) = 2 * rs % border + ( lb ( 2 ) - lb ( 1 ) + 1 )
rs % ngpts_local = PRODUCT ( rs % npts_local )
rs % lb_local = pw_grid % bounds ( 1, : )
rs % ub_local = pw_grid % bounds ( 2, : )
rs % lb_local ( dir ) = lb ( 1 ) + pw_grid % bounds ( 1, dir ) - rs % border - 1
rs % ub_local ( dir ) = lb ( 2 ) + pw_grid % bounds ( 1, dir ) + rs % border - 1
END IF
END IF
IF ( PRESENT ( iounit ) ) THEN
IF ( iounit >= 0 ) THEN
IF ( rs % parallel ) THEN
IF ( rs % group_head ) THEN
WRITE ( iounit, '(/,A,T71,I10)' ) &
" RS_GRID: Information for grid number ", rs % identifier
DO i = 1, 3
WRITE ( iounit, '(A,I3,T30,2I8,T62,A,T71,I10)' ) " RS_GRID: Bounds ", &
i, rs % lb ( i ), rs % ub ( i ), "Points:", rs % npts ( i )
END DO
IF ( rs % group_dim ( 1 ) == 1 ) THEN
WRITE ( iounit, '(A,T72,I3,A)' ) &
" RS_GRID: Real space distribution over ", rs % group_dim ( 1 ), " group"
ELSE
WRITE ( iounit, '(A,T71,I3,A)' ) &
" RS_GRID: Real space distribution over ", rs % group_dim ( 1 ), " groups"
END IF
WRITE ( iounit, '(A,T71,I10)' ) &
" RS_GRID: Group size ", rs % group_dim ( 2 )
WRITE ( iounit, '(A,T71,I10)' ) &
" RS_GRID: Real space distribution along direction ", dir
WRITE ( iounit, '(A,T71,I10)' ) &
" RS_GRID: Border size ", rs % border
END IF
nn = rs % npts_local ( dir )
CALL mp_sum ( nn, rs % group )
pp ( 1 ) = REAL ( nn, dbl ) / REAL ( pw_grid % para % group_size, dbl )
nn = rs % npts_local ( dir )
CALL mp_max ( nn, pw_grid % para % group )
pp ( 2 ) = REAL ( nn, dbl )
nn = rs % npts_local ( dir )
CALL mp_min ( nn, pw_grid % para % group )
pp ( 3 ) = REAL ( nn, dbl )
IF ( rs % group_head ) THEN
WRITE ( iounit, '(A,T48,A)' ) " RS_GRID: Distribution", &
" Average Max Min"
WRITE ( iounit, '(A,T45,F12.1,2I12)' ) " RS_GRID: Planes ", &
pp ( 1 ), NINT ( pp ( 2 ) ), NINT ( pp ( 3 ) )
WRITE ( iounit, '(/)' )
END IF
ELSE
WRITE ( iounit, '(/,A,T71,I10)' ) &
" RS_GRID: Information for grid number ", rs % identifier
DO i = 1, 3
WRITE ( iounit, '(A,I3,T30,2I8,T62,A,T71,I10)' ) " RS_GRID: Bounds ", &
i, rs % lb ( i ), rs % ub ( i ), "Points:", rs % npts ( i )
END DO
WRITE ( iounit, '(/)' )
END IF
END IF
END IF
END SUBROUTINE rs_grid_setup_1
!******************************************************************************
SUBROUTINE rs_grid_setup_n ( rs, pw_grid, nsmax, iounit )
! Arguments
TYPE ( realspace_grid_type ), DIMENSION ( : ), INTENT (INOUT) :: rs
TYPE ( pw_grid_type ), INTENT ( IN ) :: pw_grid
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: nsmax
INTEGER, OPTIONAL, INTENT ( IN ) :: iounit
! Local
INTEGER :: i
!-----------------------------------------------------------------------------!
CALL rs_grid_setup_1 ( rs ( 1 ), pw_grid, nsmax, iounit )
DO i = 2, SIZE ( rs )
CALL rs_grid_setup_1 ( rs ( i ), pw_grid, nsmax )
END DO
END SUBROUTINE rs_grid_setup_n
!*****
!******************************************************************************
!!****** realspace_grid_types/rs_pw_transfer [1.0] *
!!
!! NAME
!! rs_pw_transfer
!!
!! FUNCTION
!! Copy a function from/to a PW grid type to/from a real
!! space type
!!
!! AUTHOR
!! JGH (18-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE rs_pw_transfer ( rs, pw, dir )
! Arguments
TYPE ( realspace_grid_type ), INTENT ( INOUT ) :: rs
TYPE ( pw_type ), TARGET, INTENT ( INOUT ) :: pw
CHARACTER ( LEN = * ), INTENT ( IN ) :: dir
! Local
INTEGER, DIMENSION ( :, : ), POINTER :: pbo
INTEGER, DIMENSION ( 3 ) :: lb, ub, lc, uc
INTEGER :: subgroup, source, dest, ierr, idir, nn
LOGICAL :: subdim ( 2 )
REAL ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: buffer
!-----------------------------------------------------------------------------!
IF ( rs % identifier /= pw % pw_grid % identifier ) THEN
CALL stop_program ( "rs_pw_transfer", &
"Real space grid and pw type not compatible" )
END IF
IF ( pw % in_use == REALDATA1D .OR. &
pw % in_use == COMPLEXDATA1D ) THEN
CALL stop_program ( "rs_pw_transfer", "PW type not compatible" )
END IF
IF ( rs % parallel ) THEN
IF ( rs % group_dim ( 1 ) == 1 ) THEN
!Only one type of grid, this is easy
pbo => pw % pw_grid % bounds_local
IF ( dir == "FORWARD" ) THEN
!We first sum the full array, this could be optimised
CALL mp_sum ( rs % r, rs % group )
!Now copy the local section from the RS Grid to the PW Grid
IF ( pw % in_use == REALDATA3D ) THEN
pw % cr3d ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ) = &
rs % r ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
pw % cc3d ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ) = &
CMPLX ( rs % r ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ), KIND = dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
ELSEIF ( dir == "BACKWARD" ) THEN
rs % r = 0._dbl
IF ( pw % in_use == REALDATA3D ) THEN
rs % r ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ) = &
pw % cr3d ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
rs % r ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ) = &
REAL ( pw % cr3d ( pbo(1,1):pbo(2,1), pbo(1,2):pbo(2,2), &
pbo(1,3):pbo(2,3) ), dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
!We sum the full array, this could be optimised
CALL mp_sum ( rs % r, rs % group )
ELSE
CALL stop_program ( "rs_pw_transfer", &
"Parameter dir ="//dir//" not allowed" )
END IF
ELSE
!Both grids are distributed, we have to do some reshuffling of data
IF ( dir == "FORWARD" ) THEN
! First we have to sum up the data within the RS groups
! we generate a subgroup that covers all processors with the same RS grid
subdim ( 1 ) = .FALSE.
subdim ( 2 ) = .TRUE.
CALL mp_cart_sub ( rs % group, subdim, subgroup )
! Now we do the sum
CALL mp_sum ( rs % r, subgroup )
! And we release the communicator again
CALL mp_comm_free ( subgroup )
! The border data has to be send/received from the neighbors
! First we calculate the source and destination processes for the shift
! The first shift is "downwards"
CALL mp_cart_shift ( rs % group, 0, -1, source, dest )
idir = rs % direction
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
ub ( idir ) = lb ( idir ) + rs % border - 1
! Allocate a scratch array to receive the data
nn = PRODUCT ( ub - lb + 1 )
ALLOCATE ( buffer ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), STAT=ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_pw_transfer","buffer",nn)
CALL mp_sendrecv ( rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), &
dest, buffer, source, rs % group )
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
ub ( idir ) = ub ( idir ) - rs % border
lb ( idir ) = ub ( idir ) - rs % border + 1
! Sum the data in the RS Grid
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) = &
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) + buffer ( :, :, : )
! Now for the other direction
CALL mp_cart_shift ( rs % group, 0, 1, source, dest )
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
lb ( idir ) = ub ( idir ) - rs % border + 1
CALL mp_sendrecv ( rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), &
dest, buffer, source, rs % group )
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
lb ( idir ) = lb ( idir ) + rs % border
ub ( idir ) = lb ( idir ) + rs % border - 1
! Sum the data in the RS Grid
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) = &
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) + buffer ( :, :, : )
! Get rid of the scratch space
DEALLOCATE ( buffer, STAT=ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_pw_transfer","buffer")
! This is the real redistribution
CALL send_forward ( rs, pw )
ELSEIF ( dir == "BACKWARD" ) THEN
! This is the real redistribution
CALL send_backward ( rs, pw )
! Redistribution of the border area
CALL mp_cart_shift ( rs % group, 0, -1, source, dest )
idir = rs % direction
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
lb ( idir ) = lb ( idir ) + rs % border
ub ( idir ) = lb ( idir ) + rs % border - 1
lc ( : ) = rs % lb_local ( : )
uc ( : ) = rs % ub_local ( : )
lc ( idir ) = uc ( idir ) - rs % border + 1
nn = PRODUCT ( uc - lc + 1 )
ALLOCATE ( buffer ( lc(1):uc(1), lc(2):uc(2), lc(3):uc(3) ), STAT=ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_pw_transfer","buffer",nn)
CALL mp_sendrecv ( rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), &
dest, buffer, source, rs % group )
rs % r ( lc(1):uc(1), lc(2):uc(2), lc(3):uc(3) ) = buffer ( :, :, : )
! Now for the other direction
CALL mp_cart_shift ( rs % group, 0, 1, source, dest )
lb ( : ) = rs % lb_local ( : )
ub ( : ) = rs % ub_local ( : )
ub ( idir ) = ub ( idir ) - rs % border
lb ( idir ) = ub ( idir ) - rs % border + 1
lc ( : ) = rs % lb_local ( : )
uc ( : ) = rs % ub_local ( : )
uc ( idir ) = lc ( idir ) + rs % border - 1
CALL mp_sendrecv ( rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), &
dest, buffer, source, rs % group )
rs % r ( lc(1):uc(1), lc(2):uc(2), lc(3):uc(3) ) = buffer ( :, :, : )
DEALLOCATE ( buffer, STAT=ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "rs_pw_transfer","buffer")
ELSE
CALL stop_program ( "rs_pw_transfer", &
"Parameter dir ="//dir//" not allowed" )
END IF
END IF
ELSE
! non parallel case
IF ( dir == "FORWARD" ) THEN
IF ( pw % in_use == REALDATA3D ) THEN
pw % cr3d = rs % r
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
pw % cc3d = CMPLX ( rs % r, KIND = dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
ELSEIF ( dir == "BACKWARD" ) THEN
IF ( pw % in_use == REALDATA3D ) THEN
rs % r = pw % cr3d
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
rs % r = REAL ( pw % cc3d, dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
ELSE
CALL stop_program ( "rs_pw_transfer", &
"Parameter dir ="//dir//" not allowed" )
END IF
END IF
END SUBROUTINE rs_pw_transfer
!******************************************************************************
SUBROUTINE send_forward ( rs, pw )
! Arguments
TYPE ( realspace_grid_type ), INTENT ( INOUT ) :: rs
TYPE ( pw_type ), INTENT ( INOUT ) :: pw
! Local
LOGICAL, DIMENSION ( 2 ) :: subdim
INTEGER :: subgroup, ierr, nn, idir, il, iu, source
INTEGER, DIMENSION ( 3 ) :: lb, ub, lbp, ubp, lz, uz
REAL ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: buffer
!-----------------------------------------------------------------------------!
! This code is for MPI only, and uses a lot of redunant communication
! Optimal code will use one-sided-communication features
!-----------------------------------------------------------------------------!
lbp ( : ) = pw % pw_grid % bounds_local ( 1, : )
ubp ( : ) = pw % pw_grid % bounds_local ( 2, : )
! We only have to do the communication within the subgroups along cartesian
! coordinates 1. These processors have the complete data available
subdim ( 1 ) = .TRUE.
subdim ( 2 ) = .FALSE.
CALL mp_cart_sub ( rs % group, subdim, subgroup )
idir = rs % direction
DO source = 0, rs % group_dim ( 1 ) - 1
! First send information on bounds
IF ( source == rs % group_coor ( 1 ) ) THEN
lb = rs % lb_local
ub = rs % ub_local
lb ( idir ) = lb ( idir ) + rs % border
ub ( idir ) = ub ( idir ) - rs % border
END IF
CALL mp_bcast ( lb, source, subgroup )
CALL mp_bcast ( ub, source, subgroup )
! allocate scratch array to hold the data
nn = PRODUCT ( ub - lb + 1 )
ALLOCATE ( buffer ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "send_forward", "buffer", nn )
! send the data to all other processors
IF ( source == rs % group_coor ( 1 ) ) THEN
buffer ( :,:,: ) = rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) )
END IF
CALL mp_bcast ( buffer, source, subgroup )
! Pick the data needed on this processor
! We only have to consider the special direction, on the other direction
! we know that all the data is in buffer
lz = lbp
uz = ubp
lz ( idir ) = MAX ( lb ( idir ), lbp ( idir ) )
uz ( idir ) = MIN ( ub ( idir ), ubp ( idir ) )
IF ( pw % in_use == REALDATA3D ) THEN
pw % cr3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = &
buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
pw % cc3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = &
CMPLX ( buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ), KIND = dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
! get rid of the scratch array
DEALLOCATE ( buffer, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "send_forward", "buffer" )
END DO
! Release the communicator
CALL mp_comm_free ( subgroup )
END SUBROUTINE send_forward
!******************************************************************************
SUBROUTINE send_backward ( rs, pw )
! Arguments
TYPE ( realspace_grid_type ), INTENT ( INOUT ) :: rs
TYPE ( pw_type ), INTENT ( INOUT ) :: pw
! Local
LOGICAL, DIMENSION ( 2 ) :: subdim
INTEGER :: subgroup, ierr, nn, idir, il, iu, source
INTEGER, DIMENSION ( 3 ) :: lb, ub, lbp, ubp, lz, uz
REAL ( dbl ), DIMENSION ( :, :, : ), ALLOCATABLE :: buffer
!-----------------------------------------------------------------------------!
! This code is for MPI only, and uses a lot of redunant communication
! Optimal code will use one-sided-communication features
!-----------------------------------------------------------------------------!
! initialize the rs grid to zero
rs % r = 0._dbl
lbp ( : ) = pw % pw_grid % bounds_local ( 1, : )
ubp ( : ) = pw % pw_grid % bounds_local ( 2, : )
! We only have to do the communication within the subgroups along cartesian
! coordinates 1. These processors have the complete data available
subdim ( 1 ) = .TRUE.
subdim ( 2 ) = .FALSE.
CALL mp_cart_sub ( rs % group, subdim, subgroup )
idir = rs % direction
DO source = 0, rs % group_dim ( 1 ) - 1
! First send information on bounds
IF ( source == rs % group_coor ( 1 ) ) THEN
lb = rs % lb_local
ub = rs % ub_local
lb ( idir ) = lb ( idir ) + rs % border
ub ( idir ) = ub ( idir ) - rs % border
END IF
CALL mp_bcast ( lb, source, subgroup )
CALL mp_bcast ( ub, source, subgroup )
! allocate scratch array to hold the data
nn = PRODUCT ( ub - lb + 1 )
ALLOCATE ( buffer ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "send_backward", "buffer", nn )
buffer = 0._dbl
! Pick the data needed on this processor
! We only have to consider the special direction
lz = lbp
uz = ubp
lz ( idir ) = MAX ( lb ( idir ), lbp ( idir ) )
uz ( idir ) = MIN ( ub ( idir ), ubp ( idir ) )
IF ( pw % in_use == REALDATA3D ) THEN
buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = &
pw % cr3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) )
ELSEIF ( pw % in_use == COMPLEXDATA3D ) THEN
buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = &
REAL ( pw % cc3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ), dbl )
ELSE
CALL stop_program ( "rs_pw_transfer", "Pw type not compatible" )
END IF
! collect the data from all other processors
CALL mp_sum ( buffer, source, subgroup )
IF ( source == rs % group_coor ( 1 ) ) THEN
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) = &
rs % r ( lb(1):ub(1), lb(2):ub(2), lb(3):ub(3) ) + buffer ( :, :, : )
END IF
! get rid of the scratch array
DEALLOCATE ( buffer, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "send_forward", "buffer" )
END DO
! Release the communicator
CALL mp_comm_free ( subgroup )
! We have to sum up the data in the second direction too
subdim ( 1 ) = .FALSE.
subdim ( 2 ) = .TRUE.
CALL mp_cart_sub ( rs % group, subdim, subgroup )
CALL mp_sum ( rs % r, subgroup )
CALL mp_comm_free ( subgroup )
END SUBROUTINE send_backward
!*****
!******************************************************************************
END MODULE realspace_grid_types
!******************************************************************************

184
src/simulation_cell.F
View file

@ -24,12 +24,14 @@ MODULE simulation_cell
USE mathconstants, ONLY : pi
USE termination, ONLY : stop_program
USE greens_fn, ONLY : greens_function_type
USE greens_fn, ONLY : greens_function_type, &
PERIODIC3D, ANALYTIC2D, ANALYTIC1D, ANALYTIC0D, &
MT2D, MT1D, MT0D, HOCKNEY2D, HOCKNEY1D, HOCKNEY0D
IMPLICIT NONE
PRIVATE
PUBLIC :: get_hinv, cell_type, pbc, get_cell_param
PUBLIC :: get_hinv, cell_type, pbc, get_cell_param, init_cell
TYPE cell_type
REAL ( dbl ), DIMENSION ( 3, 3 ) :: hmat
@ -44,6 +46,21 @@ MODULE simulation_cell
CONTAINS
!******************************************************************************
!!****** simulation_cell/get_hinv [1.0] *
!!
!! NAME
!! get_hinv
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE get_hinv ( box )
@ -81,6 +98,22 @@ SUBROUTINE get_hinv ( box )
END SUBROUTINE get_hinv
!!*****
!******************************************************************************
!!****** simulation_cell/pbc [1.0] *
!!
!! NAME
!! pbc
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
FUNCTION pbc ( rin, box, nl ) RESULT ( rout )
@ -110,6 +143,22 @@ FUNCTION pbc ( rin, box, nl ) RESULT ( rout )
END FUNCTION pbc
!!*****
!******************************************************************************
!!****** simulation_cell/get_cell_param [1.0] *
!!
!! NAME
!! get_cell_param
!!
!! FUNCTION
!!
!! AUTHOR
!! CJM
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE get_cell_param ( box, cell_length, cell_angle )
@ -157,6 +206,137 @@ SUBROUTINE get_cell_param ( box, cell_length, cell_angle )
END SUBROUTINE get_cell_param
!!*****
!******************************************************************************
!!****** simulation_cell/init_cell [1.0] *
!!
!! NAME
!! init_cell
!!
!! FUNCTION
!!
!! AUTHOR
!! JGH (12-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE init_cell ( box, hmat, periodic, poisson_solver )
IMPLICIT NONE
! Arguments
TYPE ( cell_type ), INTENT ( OUT ) :: box
REAL ( dbl ), DIMENSION ( 3, 3 ), INTENT ( IN ) :: hmat
INTEGER , DIMENSION ( 3 ), INTENT ( IN ) :: periodic
CHARACTER ( LEN = * ), INTENT ( IN ), OPTIONAL :: poisson_solver
! Locals
INTEGER :: dim
!------------------------------------------------------------------------------
box % hmat = hmat
box % perd = periodic
box % green % special_dimension = 0
box % green % radius = 0._dbl
box % green % slab_size = 0._dbl
box % green % alpha = 0._dbl
box % green % volume = 0._dbl
dim = COUNT ( box % perd == 1 )
SELECT CASE ( dim )
CASE ( 0 )
box % green % method = ANALYTIC0D
box % green % radius = 0._dbl
CASE ( 1 )
box % green % method = ANALYTIC1D
box % green % special_dimension = MAXLOC ( box % perd, 1 )
box % green % radius = 0._dbl
CASE ( 2 )
box % green % method = ANALYTIC2D
box % green % special_dimension = MINLOC ( box % perd, 1 )
box % green % slab_size = 0._dbl
CASE ( 3 )
box % green % method = PERIODIC3D
CASE DEFAULT
CALL stop_program ( "init_cell", "illegal perd values" )
END SELECT
NULLIFY ( box % green % influence_function )
IF ( PRESENT ( poisson_solver ) ) THEN
SELECT CASE ( poisson_solver )
CASE ( "PERIODIC" )
box % green % method = PERIODIC3D
IF ( dim /= 3 ) THEN
CALL stop_program ( "init_cell", &
"illegal combination of periodicity and Poisson solver (PERIODIC)" )
END IF
CASE ( "ANALYTIC" )
SELECT CASE ( dim )
CASE ( 0 )
box % green % method = ANALYTIC0D
CASE ( 1 )
box % green % method = ANALYTIC1D
CASE ( 2 )
box % green % method = ANALYTIC2D
CASE ( 3 )
box % green % method = PERIODIC3D
CASE DEFAULT
CALL stop_program ( "init_cell", "illegal perd values" )
END SELECT
CASE ( "HOCKNEY" )
SELECT CASE ( dim )
CASE ( 0 )
box % green % method = HOCKNEY0D
CASE ( 1 )
box % green % method = HOCKNEY1D
CASE ( 2 )
box % green % method = HOCKNEY2D
CASE ( 3 )
CALL stop_program ( "init_cell", &
"illegal combination of periodicity and Poisson solver (HOCKNEY)" )
CASE DEFAULT
CALL stop_program ( "init_cell", "illegal perd values" )
END SELECT
CASE ( "MT" )
SELECT CASE ( dim )
CASE ( 0 )
box % green % method = MT0D
CASE ( 1 )
box % green % method = MT1D
CASE ( 2 )
box % green % method = MT2D
CASE ( 3 )
CALL stop_program ( "init_cell", &
"illegal combination of periodicity and Poisson solver (MT)" )
CASE DEFAULT
CALL stop_program ( "init_cell", "illegal perd values" )
END SELECT
CASE DEFAULT
CALL stop_program ( "init_cell", "Unknown Poisson solver" )
END SELECT
END IF
END SUBROUTINE init_cell
!!*****
!******************************************************************************
END MODULE simulation_cell
!******************************************************************************

601
src/spme.F
View file

@ -8,21 +8,36 @@
!! spme
!!
!! FUNCTION
!! Calculate the electrostatic energy by the Smooth Particle Ewald method
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!! JGH (03-May-2001) : first correctly working version
!!
!! SOURCE
!******************************************************************************
MODULE spme
USE kinds, ONLY: dbl
USE coefficient_types, ONLY : coeff_type, coeff_allocate, &
coeff_deallocate, coeff_transform_space, &
PW_REALDATA3D, PW_COMPLEXDATA1D, &
PW_REALSPACE, PW_RECIPROCALSPACE
USE dg_types, ONLY : dg_type
USE dgs, ONLY : dg_sum_patch, dg_sum_patch_force
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE greens_fn, ONLY : greens_function_type
USE hartree, ONLY : calculate_hartree
USE kinds, ONLY : dbl
USE mathconstants, ONLY : fourpi
USE particle_types, ONLY : particle_type
USE pw_types, ONLY : pw_type
USE pw_grid_types, ONLY : pw_grid_type
USE pws, ONLY : pw_poisson_solver, init_pw_poisson_solver, pw_integral_a2b
USE realspace_grid_types, ONLY : realspace_grid_type, rs_grid_setup, &
rs_grid_allocate, rs_grid_deallocate, rs_pw_transfer
USE simulation_cell, ONLY : cell_type
USE termination, ONLY : stop_program, stop_memory
USE timings, ONLY: timeset, timestop
@ -30,23 +45,39 @@ MODULE spme
IMPLICIT NONE
PRIVATE
PUBLIC :: spme_evaluate
PUBLIC :: spme_evaluate, spme_coeff_calculate
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** spme/spme_evaluate [1.0] *
!!
!! NAME
!! spme_evaluate
!!
!! FUNCTION
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! JGH (03-May-2001) : SPME with charge definition
!!
!! SOURCE
!******************************************************************************
SUBROUTINE spme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
SUBROUTINE spme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_spme, ewald_param )
IMPLICIT NONE
! Arguments
TYPE ( dg_type ), INTENT ( IN ), TARGET :: dg
TYPE ( cell_type ), INTENT ( IN ) :: box
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( cell_type ), INTENT ( INOUT ) :: box
TYPE ( pw_grid_type ), INTENT ( IN ), TARGET :: grid_spme
TYPE ( ewald_parameters_type ), INTENT ( IN ) :: ewald_param
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: fg_coulomb
@ -54,16 +85,568 @@ SUBROUTINE spme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
REAL ( dbl ), DIMENSION ( :, : ), INTENT ( OUT ) :: pv_g
! Locals
INTEGER :: handle
INTEGER :: handle, i, j, p1, n, ierr, ndim ( 3 ), ipart, jpart, npart
INTEGER, DIMENSION ( :, : ), ALLOCATABLE :: centre
TYPE ( realspace_grid_type ) :: rden, drpot ( 3 )
TYPE ( coeff_type ) :: rhob_r, rhob_g, phi_g, dphi_g ( 3 )
REAL ( dbl ) :: inv_fourpi_eps0, dvols, ffa
REAL ( dbl ), DIMENSION ( 3 ) :: fat
REAL ( dbl ), DIMENSION ( 3, 3 ) :: h_stress, f_stress
REAL ( dbl ), DIMENSION ( :,:,: ), ALLOCATABLE :: rhos
!------------------------------------------------------------------------------
!-------------- INITIALISATION ---------------------
CALL timeset ( 'SPME', 'I', ' ', handle )
inv_fourpi_eps0 = 1.0_dbl / ( fourpi * ewald_param % eps0 )
npart = SIZE ( part )
n = ewald_param % o_spline
ALLOCATE ( rhos ( n, n, n ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "spme_evaluate", "rhos", n**3 )
ndim = n
CALL rs_grid_setup ( rden, grid_spme, ndim )
CALL rs_grid_allocate ( rden )
rden % r = 0._dbl
ALLOCATE ( centre ( 3, npart ), STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "spme_evaluate", "centre", 3*npart )
CALL get_center ( part, box, centre, grid_spme % npts, n )
!-------------- DENSITY CALCULATION ----------------
ipart = 0
jpart = 0
DO
CALL set_list ( part, npart, centre, p1, rden, ipart, jpart )
IF ( p1 == 0 ) EXIT
! calculate function on small boxes
CALL get_patch ( part, box, grid_spme % npts, p1, rhos )
! add boxes to real space grid (big box)
CALL dg_sum_patch ( rden, rhos, centre(:,p1) )
END DO
CALL coeff_allocate ( rhob_r, grid_spme, use_data = PW_REALDATA3D )
rhob_r % pw % in_space = PW_REALSPACE
CALL rs_pw_transfer ( rden, rhob_r % pw, "FORWARD" )
CALL rs_grid_deallocate ( rden )
! transform density to G space and add charge function
CALL coeff_allocate ( rhob_g, grid_spme, use_data = PW_COMPLEXDATA1D )
rhob_g % pw % in_space = PW_RECIPROCALSPACE
CALL coeff_transform_space ( rhob_r, rhob_g )
! update charge function
CALL p3m_update ( box % green )
rhob_g % pw % cc = rhob_g % pw % cc * box % green % p3m_charge % cr
!-------------- ELECTROSTATIC CALCULATION -----------
! allocate intermediate arrays
DO i = 1, 3
CALL coeff_allocate ( dphi_g ( i ), grid_spme, &
use_data = PW_COMPLEXDATA1D )
dphi_g ( i ) % pw % in_space = PW_RECIPROCALSPACE
END DO
CALL coeff_allocate ( phi_g, grid_spme, use_data = PW_COMPLEXDATA1D )
phi_g % pw % in_space = PW_RECIPROCALSPACE
CALL init_pw_poisson_solver ( box % green )
CALL calculate_hartree ( rhob_g, vg_coulomb, phi_g, dphi_g, h_stress )
CALL coeff_deallocate ( phi_g )
CALL coeff_deallocate ( rhob_g )
vg_coulomb = vg_coulomb * inv_fourpi_eps0
!---------- END OF ELECTROSTATIC CALCULATION --------
!------------- STRESS TENSOR CALCULATION ------------
DO i = 1, 3
DO j = i, 3
f_stress ( i, j ) = pw_integral_a2b ( dphi_g ( i ) % pw, &
dphi_g ( j ) % pw )
f_stress ( j, i ) = f_stress ( i, j )
END DO
END DO
ffa = ( grid_spme % vol / fourpi ) * &
( 0.5_dbl / ewald_param % alpha ) ** 2
f_stress = -ffa * f_stress
pv_g = inv_fourpi_eps0 * ( h_stress + f_stress )
!--------END OF STRESS TENSOR CALCULATION -----------
! move derivative of potential to real space grid and
! multiply by charge function in g-space
CALL rs_grid_setup ( drpot, grid_spme, ndim )
CALL rs_grid_allocate ( drpot ( 1 : 3 ) )
DO i = 1, 3
dphi_g ( i ) % pw % cc = dphi_g ( i ) % pw % cc * &
box % green % p3m_charge % cr
CALL coeff_transform_space ( dphi_g ( i ), rhob_r )
CALL coeff_deallocate ( dphi_g ( i ) )
CALL rs_pw_transfer ( drpot ( i ), rhob_r % pw, "BACKWARD" )
END DO
CALL coeff_deallocate ( rhob_r )
!----------------- FORCE CALCULATION ----------------
! initialize the forces
fg_coulomb = 0._dbl
dvols = grid_spme % dvol * inv_fourpi_eps0
ipart = 0
jpart = 0
DO
CALL set_list ( part, npart, centre, p1, rden, ipart, jpart )
IF ( p1 == 0 ) EXIT
! calculate function on small boxes
CALL get_patch ( part, box, grid_spme % npts, p1, rhos )
! add boxes to real space grid (big box)
CALL dg_sum_patch_force ( drpot, rhos, centre(:,p1), fat )
fg_coulomb ( 1, p1 ) = fg_coulomb ( 1, p1 ) - fat ( 1 ) * dvols
fg_coulomb ( 2, p1 ) = fg_coulomb ( 2, p1 ) - fat ( 2 ) * dvols
fg_coulomb ( 3, p1 ) = fg_coulomb ( 3, p1 ) - fat ( 3 ) * dvols
END DO
!--------------END OF FORCE CALCULATION -------------
!------------------CLEANING UP ----------------------
CALL rs_grid_deallocate ( drpot ( 1 : 3 ) )
DEALLOCATE ( rhos, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "spme_evaluate", "rhos" )
DEALLOCATE ( centre, STAT = ierr )
IF ( ierr /= 0 ) CALL stop_memory ( "spme_evaluate", "centre" )
CALL timestop ( 0.0_dbl, handle )
END SUBROUTINE spme_evaluate
!!*****
!******************************************************************************
SUBROUTINE p3m_update ( gf )
IMPLICIT NONE
! Arguments
TYPE ( greens_function_type ), TARGET, INTENT ( INOUT ) :: gf
! Locals
TYPE ( pw_grid_type ), POINTER :: grid
TYPE ( pw_type ), POINTER :: pc
REAL ( dbl ), DIMENSION ( :, : ), POINTER :: bm2
REAL ( dbl ) :: arg, novol
INTEGER :: ig, l, m, n
!------------------------------------------------------------------------------
grid => gf % influence_function % pw_grid
! check if charge function is consistent with current box volume
IF ( gf % volume /= grid % vol ) THEN
pc => gf % p3m_charge
bm2 => gf % p3m_bm2
arg = 1._dbl / ( 8._dbl * gf % p3m_alpha ** 2 )
novol = REAL ( grid % ngpts, dbl ) / grid % vol
DO ig = 1, grid % ngpts_cut_local
l = grid % g_hat ( 1, ig )
m = grid % g_hat ( 2, ig )
n = grid % g_hat ( 3, ig )
pc % cr ( ig ) = novol * exp ( -arg * grid % gsq ( ig ) ) * &
bm2 ( 1, l ) * bm2 ( 2, m ) * bm2 ( 3, n )
END DO
END IF
END SUBROUTINE p3m_update
!!*****
!******************************************************************************
!!****** spme/get_patch [1.0] *
!!
!! NAME
!! get_patch
!!
!! FUNCTION
!! Calculates local density in a small box
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE get_patch ( part, box, npts, p, rhos )
IMPLICIT NONE
! Arguments
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( cell_type ), INTENT ( IN ) :: box
INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: npts
INTEGER, INTENT ( IN ) :: p
REAL ( dbl ), DIMENSION ( :,:,: ), INTENT ( OUT ) :: rhos
! Local
REAL ( dbl ), DIMENSION ( 3 ) :: r, delta
REAL ( dbl ) :: q
INTEGER :: nbox
INTEGER, DIMENSION ( 3 ) :: center
!------------------------------------------------------------------------------
nbox = SIZE ( rhos, 1 )
r = part(p)% r
q = part(p)% prop % charge
CALL get_delta ( box, r, npts, delta, nbox )
CALL spme_get_patch ( rhos, nbox, delta, q, box % green % p3m_coeff )
END SUBROUTINE get_patch
!******************************************************************************
!!****** spme/spme_get_patch [1.0] *
!!
!! NAME
!! spme_get_patch
!!
!! FUNCTION
!! Calculates SPME charge assignment
!!
!! AUTHOR
!! JGH (22-Mar-2001)
!!
!! MODIFICATION HISTORY
!! DG (29-Mar-2001) : code implemented
!!
!! SOURCE
!******************************************************************************
SUBROUTINE spme_get_patch ( rhos, n, delta, q, coeff )
IMPLICIT NONE
! Arguments
REAL ( dbl ), DIMENSION ( :, :, : ), INTENT ( OUT ) :: rhos
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), DIMENSION ( 3 ), INTENT ( IN ) :: delta
REAL ( dbl ), INTENT ( IN ) :: q
REAL ( dbl ), DIMENSION (-(n-1):n-1, 0:n-1), INTENT ( IN ) :: coeff
! Local
INTEGER, PARAMETER :: nmax = 12
INTEGER :: dim, i, i1, i2, i3, ierr, j, l
REAL ( dbl ), DIMENSION ( 3, 0:nmax-1 ) :: deltal
REAL ( dbl ), DIMENSION ( 3, -nmax:nmax ) :: w_assign
REAL ( dbl ), DIMENSION ( 3, 1:nmax ) :: f_assign
REAL ( dbl ) :: x, r3, r2
!------------------------------------------------------------------------------
IF ( n > nmax ) THEN
CALL stop_program ( "spme_get_patch","nmax value too small" )
END IF
! calculate the assignment function values and
! the charges on the grid (small box)
deltal ( 1, 0 ) = 1._dbl
deltal ( 2, 0 ) = 1._dbl
deltal ( 3, 0 ) = 1._dbl
DO l = 1, n-1
deltal ( 1, l ) = deltal ( 1, l-1 ) * delta ( 1 )
deltal ( 2, l ) = deltal ( 2, l-1 ) * delta ( 2 )
deltal ( 3, l ) = deltal ( 3, l-1 ) * delta ( 3 )
END DO
w_assign = 0._dbl
DO j = -(n-1), n-1, 2
DO l = 0, n-1
w_assign ( 1, j ) = w_assign ( 1, j ) + coeff ( j, l ) * deltal ( 1, l )
w_assign ( 2, j ) = w_assign ( 2, j ) + coeff ( j, l ) * deltal ( 2, l )
w_assign ( 3, j ) = w_assign ( 3, j ) + coeff ( j, l ) * deltal ( 3, l )
END DO
END DO
DO i = 1, n
j = n + 1 - 2 * i
f_assign (1, i ) = w_assign ( 1, j )
f_assign (2, i ) = w_assign ( 2, j )
f_assign (3, i ) = w_assign ( 3, j )
END DO
DO i3 = 1, n
r3 = q * f_assign ( 3, i3 )
DO i2 = 1, n
r2 = r3 * f_assign ( 2, i2 )
DO i1 = 1, n
rhos ( i1, i2, i3 ) = r2 * f_assign ( 1, i1 )
END DO
END DO
END DO
END SUBROUTINE spme_get_patch
!!*****
!******************************************************************************
!!****** spme/set_list [1.0] *
!!
!! NAME
!! set_list
!!
!! FUNCTION
!! Advances in the link list of particles to the next to be calculated
!!
!! AUTHOR
!! JGH (21-Mar-2001)
!!
!! MODIFICATION HISTORY
!! JGH (30-Mar-2001) : spme version adapted from pme
!!
!! SOURCE
!******************************************************************************
SUBROUTINE set_list ( part, npart, center, p1, rs, ipart, jpart )
IMPLICIT NONE
! Arguments
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
INTEGER, INTENT ( IN ) :: npart
INTEGER, DIMENSION ( :, : ), INTENT ( IN ) :: center
INTEGER, INTENT ( OUT ) :: p1
TYPE ( realspace_grid_type ) :: rs
INTEGER, INTENT ( INOUT ) :: ipart, jpart
! Local
INTEGER :: dir, lb, ub, ndim, npos
!------------------------------------------------------------------------------
p1 = 0
IF ( rs % parallel .AND. rs % group_dim ( 1 ) /= 1 ) THEN
dir = rs % direction
lb = rs % lb_local ( dir ) + rs % border
ub = rs % ub_local ( dir ) - rs % border
END IF
IF ( rs % parallel ) THEN
ndim = rs % group_dim ( 2 )
npos = rs % group_coor ( 2 )
END IF
DO
ipart = ipart + 1
IF ( ipart > npart ) EXIT
IF ( part ( ipart ) % prop % charge == 0._dbl ) CYCLE
IF ( rs % parallel ) THEN
IF ( rs % group_dim ( 1 ) == 1 ) THEN
! All processor work on the same grid
IF ( MOD ( ipart, ndim ) == npos ) THEN
p1 = ipart
EXIT
END IF
ELSE
! First check if this atom is on my grid
IF ( in_slice ( center ( dir, ipart ), lb, ub ) ) THEN
jpart = jpart + 1
IF ( MOD ( jpart, ndim ) == npos ) THEN
p1 = ipart
EXIT
END IF
END IF
END IF
ELSE
p1 = ipart
EXIT
END IF
END DO
END SUBROUTINE set_list
!******************************************************************************
FUNCTION in_slice ( pos, lb, ub ) RESULT ( internal )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: pos, lb, ub
LOGICAL :: internal
IF ( pos >= lb .AND. pos <= ub ) THEN
internal = .TRUE.
ELSE
internal = .FALSE.
END IF
END FUNCTION in_slice
!******************************************************************************
SUBROUTINE get_center ( part, box, centre, npts, n )
IMPLICIT NONE
! Arguments
TYPE ( particle_type ), DIMENSION ( : ), INTENT ( IN ) :: part
TYPE ( cell_type ), INTENT ( IN ) :: box
INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts
INTEGER, DIMENSION ( :, : ), INTENT ( OUT ) :: centre
INTEGER, INTENT ( IN ) :: n
! Locals
REAL ( dbl ), DIMENSION ( 3 ) :: s, gp
REAL ( dbl ) :: rmp
INTEGER :: ipart, mp
!------------------------------------------------------------------------------
mp = MAXVAL ( npts )
rmp = REAL ( mp, dbl )
DO ipart = 1, SIZE ( part )
! compute the scaled coordinate of atomi
s = MATMUL ( box % h_inv, part ( ipart ) % r )
s = s - NINT ( s )
gp = REAL ( npts, dbl ) * s
! find the closest grid point (on big grid)
IF ( MOD ( n, 2 ) == 0 ) THEN
centre ( :, ipart ) = INT ( gp + rmp ) - mp
ELSE
centre ( :, ipart ) = NINT ( gp )
END IF
END DO
END SUBROUTINE get_center
!******************************************************************************
SUBROUTINE get_delta ( box, r, npts, delta, n )
IMPLICIT NONE
! Arguments
TYPE ( cell_type ), INTENT ( IN ) :: box
REAL ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: r
INTEGER, DIMENSION ( : ), INTENT ( IN ) :: npts
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: delta
! Locals
REAL ( dbl ), DIMENSION ( 3 ) :: s, grid_i, ca
INTEGER, DIMENSION ( 3 ) :: centre
REAL ( dbl ) :: rmp
INTEGER :: mp
!------------------------------------------------------------------------------
mp = MAXVAL ( npts )
rmp = REAL ( mp, dbl )
! compute the scaled coordinate of atomi
s = MATMUL ( box % h_inv, r )
s = s - REAL ( NINT ( s ), dbl )
! find the continuous ``grid'' point
grid_i ( 1:3 ) = REAL ( npts ( 1:3 ), dbl ) * s ( 1:3 )
! find the closest grid point
IF ( MOD ( n, 2 ) == 0 ) THEN
centre ( : ) = INT ( grid_i ( : ) + rmp ) - mp
ca ( : ) = REAL ( centre ( : ) ) + 0.5_dbl
ELSE
centre ( : ) = NINT ( grid_i ( : ) )
ca ( : ) = REAL ( centre ( : ) )
END IF
! find the distance vector
delta ( : ) = grid_i ( : ) - ca ( : )
END SUBROUTINE get_delta
!!*****
!******************************************************************************
!!****** spme/spme_coeff_calculate [1.0] *
!!
!! NAME
!! spme_coeff_calculate
!!
!! FUNCTION
!! Calculates the coefficients for the charge assignment function
!!
!! AUTHOR
!! DG (29-Mar-2001)
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
SUBROUTINE spme_coeff_calculate ( n, coeff )
IMPLICIT NONE
! Arguments
INTEGER, INTENT ( IN ) :: n
REAL ( dbl ), DIMENSION ( -(n-1):n-1, 0:n-1 ), INTENT ( OUT ) :: coeff
! Locals
INTEGER :: i, j, l, m
REAL ( dbl ), DIMENSION ( n, -(n-1):n-1, 0:n-1 ) :: a
REAL ( dbl ) :: b
!------------------------------------------------------------------------------
a = 0._dbl
a ( 1, 0, 0 ) = 1._dbl
DO i = 2, n
m = i-1
DO j = -m, m, 2
DO l = 0, m-1
b = ( a ( m, j-1, l ) + &
REAL ( (-1) ** l, dbl ) * a ( m, j+1, l ) ) / &
REAL ( ( l + 1 ) * 2 ** ( l + 1 ) , dbl )
a ( i, j, 0 ) = a ( i, j, 0 ) + b
END DO
DO l = 0, m-1
a ( i, j, l+1 ) = ( a ( m, j+1, l ) - &
a ( m, j-1, l ) ) / REAL ( l + 1, dbl )
END DO
END DO
END DO
coeff = 0._dbl
DO i = 0, n-1
DO j = -(n-1), n-1, 2
coeff ( j, i ) = a ( n, j, i )
END DO
END DO
!!!!!!!!!
!This seems to cause the SGI compiler to work correctly!!!!!
write(*,*)
!!!!!!!!!
END SUBROUTINE spme_coeff_calculate
!!*****
!******************************************************************************
END MODULE spme

76
src/start_program_run.F
View file

@ -171,7 +171,7 @@ CONTAINS
search,&
start_input_session,&
test_object
USE print_keys, ONLY: init_print_keys
USE print_keys, ONLY: DEBUG,HIGH,init_print_keys,LOW,MEDIUM,SILENT
USE string_utilities, ONLY: uppercase
USE termination, ONLY: stop_program
@ -210,15 +210,15 @@ CONTAINS
CALL uppercase(keyword)
SELECT CASE (TRIM(keyword))
CASE ("SILENT")
globenv%print%level = 0
globenv%print%level = SILENT
CASE ("LOW","DEFAULT")
globenv%print%level = 1
globenv%print%level = LOW
CASE ("MEDIUM")
globenv%print%level = 2
globenv%print%level = MEDIUM
CASE ("HIGH")
globenv%print%level = 3
globenv%print%level = HIGH
CASE ("DEBUG","ALL","FULL")
globenv%print%level = 4
globenv%print%level = DEBUG
CASE DEFAULT
CALL stop_program(routine,&
"Invalid keyword <"//TRIM(keyword)//&
@ -259,16 +259,18 @@ CONTAINS
globenv%print%cell_parameters = print_request
CASE ("CHARGE_DENSITY_MATRIX","G_MATRIX")
globenv%print%charge_density_matrix = print_request
CASE ("CORE_HAMILTONIAN_MATRIX","CORE_HAMILTONIAN","H_MATRIX")
CASE ("CORE_HAMILTONIAN_MATRIX","H_MATRIX")
globenv%print%core_hamiltonian_matrix = print_request
CASE ("CORE_CHARGE_RADII","CORE_RADII")
globenv%print%core_charge_radii = print_request
CASE ("DENSITY_MATRIX","P_MATRIX")
globenv%print%density_matrix = print_request
CASE ("DIIS_INFORMATION","DIIS_INFO","DIIS")
globenv%print%diis_information = print_request
CASE ("DISTRIBUTION")
globenv%print%distribution = print_request
CASE ("ERFC_RADII")
globenv%print%erfc_radii = print_request
CASE ("ERF_PPL_RADII")
globenv%print%erf_ppl_radii = print_request
CASE ("EXP_PPL_RADII")
globenv%print%exp_ppl_radii = print_request
CASE ("EACH_SCF_STEP")
globenv%print%each_scf_step = print_request
CASE ("HARTREE_MATRIX")
globenv%print%hartree_matrix = print_request
CASE ("INTERACTION_THRESHOLDS","THRESHOLDS")
@ -290,25 +292,27 @@ CONTAINS
globenv%print%method_specifications = print_request
CASE ("MO_EIGENVALUES")
globenv%print%mo_eigenvalues = print_request
CASE ("MO_EIGENVECTORS")
CASE ("MO_EIGENVECTORS","MOS")
globenv%print%mo_eigenvalues = print_request
globenv%print%mo_eigenvectors = print_request
globenv%print%mo_occupation_numbers = print_request
CASE ("MO_OCCUPATION_NUMBERS")
globenv%print%mo_eigenvalues = print_request
globenv%print%mo_occupation_numbers = print_request
CASE ("NEIGHBOR_LISTS")
globenv%print%nl_overlap = print_request
globenv%print%nl_verfc = print_request
globenv%print%nl_verf_ppl = print_request
globenv%print%nl_vexp_ppl = print_request
globenv%print%nl_vprj_ppnl = print_request
globenv%print%nl_vppl = print_request
globenv%print%nl_vppnl = print_request
CASE ("NL_OVERLAP")
globenv%print%nl_overlap = print_request
CASE ("NL_VERFC")
globenv%print%nl_verfc = print_request
CASE ("NL_VERF_PPL")
globenv%print%nl_verf_ppl = print_request
CASE ("NL_VEXP_PPL")
globenv%print%nl_vexp_ppl = print_request
CASE ("NL_VPRJ_PPNL")
globenv%print%nl_vprj_ppnl = print_request
CASE ("ORTHOGONALIZATION_MATRIX","ORTHO_MATRIX")
CASE ("NL_VPPL")
globenv%print%nl_vppl = print_request
CASE ("NL_VPPNL")
globenv%print%nl_vppnl = print_request
CASE ("ORTHOGONALISATION_MATRIX","ORTHO_MATRIX")
globenv%print%ortho_matrix = print_request
CASE ("OVERLAP_MATRIX","OVERLAP","S_MATRIX")
globenv%print%overlap_matrix = print_request
@ -318,22 +322,30 @@ CONTAINS
globenv%print%physcon = print_request
CASE ("POTENTIALS","POTENTIAL")
globenv%print%potential = print_request
CASE ("PPL_RADII")
globenv%print%ppl_radii = print_request
CASE ("PPNL_RADII")
globenv%print%ppnl_radii = print_request
CASE ("PROGRAM_BANNER","BANNER")
globenv%print%program_banner = print_request
CASE ("PROGRAM_RUN_INFORMATION","PROGRAM_RUN_INFO","RUN_INFO")
globenv%print%program_run_information = print_request
CASE ("PRJ_PPNL_RADII")
globenv%print%prj_ppnl_radii = print_request
CASE ("PROJECTORS")
globenv%print%projectors = print_request
CASE ("RADII")
globenv%print%erfc_radii = print_request
globenv%print%erf_ppl_radii = print_request
globenv%print%exp_ppl_radii = print_request
globenv%print%core_charge_radii = print_request
globenv%print%kind_radii = print_request
globenv%print%prj_ppnl_radii = print_request
globenv%print%ppl_radii = print_request
globenv%print%ppnl_radii = print_request
globenv%print%set_radii = print_request
globenv%print%pgf_radii = print_request
CASE ("PW_GRID_INFORMATION","PW_GRID_INFO","GRID_INFO")
globenv%print%pw_grid_information = print_request
CASE ("SCF")
globenv%print%scf = print_request
CASE ("SCF_ENERGIES")
globenv%print%scf = print_request
globenv%print%scf_energies = print_request
CASE ("SET_RADII")
globenv%print%set_radii = print_request
CASE ("SPHERICAL_HARMONICS")
@ -344,6 +356,8 @@ CONTAINS
globenv%print%title = print_request
CASE ("TOTAL_NUMBERS")
globenv%print%total_numbers = print_request
CASE ("TOTAL_DENSITIES")
globenv%print%total_densities = print_request
CASE DEFAULT
IF (keyword == end_section) THEN
EXIT
@ -394,7 +408,7 @@ CONTAINS
"** **",&
"** ... make the atoms dance **",&
"** **",&
"** Version 3.0 (Nov. 2000) **",&
"** Version 3.0 (May 2001) **",&
"** **",&
"** Copyright (C) by MPI fuer Festkoerperforschung, Stuttgart (2000) **",&
"** **",&

44
src/string_utilities.F
View file

@ -22,6 +22,8 @@
MODULE string_utilities
USE kinds, ONLY : dbl
IMPLICIT NONE
PRIVATE
@ -29,6 +31,10 @@ MODULE string_utilities
PUBLIC :: compress,uppercase,xstring,str_search,str_comp,make_tuple,&
integer_to_string,string_to_integer
INTERFACE integer_to_string
MODULE PROCEDURE integer_to_string_n, integer_to_string_1
END INTERFACE
!!*****
! *****************************************************************************
@ -75,7 +81,7 @@ CONTAINS
! *****************************************************************************
SUBROUTINE integer_to_string(nascii,string)
SUBROUTINE integer_to_string_n(nascii,string)
! Purpose: Convert a sequence of integer numbers to a string.
@ -102,7 +108,41 @@ CONTAINS
END IF
END DO
END SUBROUTINE integer_to_string
END SUBROUTINE integer_to_string_n
! *****************************************************************************
SUBROUTINE integer_to_string_1(zahl,string)
! Purpose: Convert an integer to a string.
! History: - Creation (29.4.2001, JGH)
! ***************************************************************************
CHARACTER(LEN=*), INTENT(OUT) :: string
INTEGER, INTENT(IN) :: zahl
! *** Local variables ***
INTEGER :: i, z, n
INTEGER,ALLOCATABLE,DIMENSION(:) :: nascii
! ---------------------------------------------------------------------------
string = ""
n = INT ( LOG ( REAL ( zahl, dbl ) ) / LOG ( 10._dbl ) ) + 1
ALLOCATE ( nascii ( n ) )
z = zahl
DO i = 1, n
nascii ( i ) = z / 10**(n-i)
z = z - nascii ( i )*10**(n-i)
nascii ( i ) = nascii ( i ) + ICHAR("0")
END DO
CALL integer_to_string_n(nascii,string)
DEALLOCATE ( nascii )
END SUBROUTINE integer_to_string_1
! *****************************************************************************

17
src/structure_factors.F
View file

@ -83,13 +83,13 @@ SUBROUTINE structure_factor_allocate ( bds, nparts, exp_igr, &
ALLOCATE ( exp_igr % ex ( bds ( 1, 1 ):bds ( 2, 1 ) + 1, nparts ), &
STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ( 'ewald_gaussian', 'ex', 0 )
IF ( isos /= 0 ) CALL stop_memory ( 'structure_factor_allocate', 'ex', 0 )
ALLOCATE ( exp_igr % ey ( bds ( 1, 2 ):bds ( 2, 2 ) + 1, nparts ), &
STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ('ewald_gaussian', 'ey', 0 )
IF ( isos /= 0 ) CALL stop_memory ('structure_factor_allocate', 'ey', 0 )
ALLOCATE ( exp_igr % ez ( bds ( 1, 3 ):bds ( 2, 3 ) + 1, nparts ), &
STAT = isos )
IF ( isos /= 0 ) CALL stop_memory ('ewald_gaussian', 'ez', 0 )
IF ( isos /= 0 ) CALL stop_memory ('structure_factor_allocate', 'ez', 0 )
NULLIFY ( exp_igr % centre )
exp_igr % lb(1) = LBOUND ( exp_igr % ex, 1 )
@ -100,7 +100,7 @@ SUBROUTINE structure_factor_allocate ( bds, nparts, exp_igr, &
IF ( allocate_centre ) THEN
ALLOCATE ( exp_igr % centre ( 3, nparts ), STAT = isos )
IF ( isos /= 0 ) &
CALL stop_memory ( 'ewald_gaussian', 'centre', 3 * nparts)
CALL stop_memory ( 'structure_factor_allocate', 'centre', 3 * nparts)
END IF
END IF
@ -144,19 +144,22 @@ SUBROUTINE structure_factor_evaluate ( delta, npts, lb, ex, ey, ez )
ey ( m1 ) = 1.0_dbl
ez ( n1 ) = 1.0_dbl
fp = CMPLX ( COS ( vec ( 1 ) ), -SIN ( vec ( 1 ) ) ); fm = CONJG ( fp )
fp = CMPLX ( COS ( vec ( 1 ) ), -SIN ( vec ( 1 ) ), dbl )
fm = CONJG ( fp )
DO j = 1, -l0
ex ( j + l0 ) = ex ( j + l0 - 1 ) * fp
ex ( -j + l1 ) = ex ( -j + l1 + 1 ) * fm
END DO
fp = CMPLX ( COS ( vec ( 2 ) ), -SIN ( vec ( 2 ) ) ); fm = CONJG ( fp )
fp = CMPLX ( COS ( vec ( 2 ) ), -SIN ( vec ( 2 ) ), dbl )
fm = CONJG ( fp )
DO j = 1, -m0
ey ( j + m0 ) = ey ( j + m0 - 1 ) * fp
ey ( -j + m1 ) = ey ( -j + m1 + 1 ) * fm
END DO
fp = CMPLX ( COS ( vec ( 3 ) ), -SIN ( vec ( 3 ) ) ); fm = CONJG ( fp )
fp = CMPLX ( COS ( vec ( 3 ) ), -SIN ( vec ( 3 ) ), dbl )
fm = CONJG ( fp )
DO j = 1, -n0
ez ( j + n0 ) = ez ( j + n0 - 1 ) * fp
ez ( -j + n1 ) = ez ( -j + n1 + 1 ) * fm

11
src/structure_types.F
View file

@ -35,8 +35,18 @@ MODULE structure_types
PUBLIC :: cell_type, particle_type, particle_node_type
PUBLIC :: molecule_structure_type
PUBLIC :: pimd_data_type
PUBLIC :: potentialparm_type, tbatom_param_type, tb_hopping_type
TYPE pimd_data_type
REAL ( dbl ), DIMENSION ( : , : ), POINTER :: u
REAL ( dbl ) :: lbd
REAL ( dbl ) :: slbd
REAL ( dbl ) :: meff
REAL ( dbl ) :: ismeff
REAL ( dbl ), DIMENSION ( 2 , 2 ) :: harmonic_prop
END TYPE pimd_data_type
TYPE structure_type
CHARACTER ( LEN = 30 ) :: name
TYPE ( cell_type ) :: box
@ -45,6 +55,7 @@ MODULE structure_types
TYPE ( particle_node_type ), POINTER :: pnode ( : )
TYPE ( molecule_structure_type ), POINTER :: molecule ( : )
TYPE ( linklist_internal_data_type) :: ll_data
TYPE ( pimd_data_type ) :: pimd_data
END TYPE structure_type
TYPE interaction_type

13
src/tbmd_debug.F
View file

@ -67,7 +67,7 @@ CONTAINS
!******************************************************************************
SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
box_ref, thermo, potparm, ensemble, lldata )
box_ref, thermo, potparm, lldata )
IMPLICIT NONE
@ -79,9 +79,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
TYPE ( potentialparm_type ), INTENT ( IN ), DIMENSION ( :, : ) :: potparm
TYPE ( molecule_structure_type ), INTENT ( IN ), DIMENSION ( : ) :: molecule
TYPE ( cell_type ), INTENT ( INOUT ) :: box
TYPE ( cell_type ), INTENT ( IN ) :: box_ref
TYPE ( cell_type ), INTENT ( INOUT ) :: box_ref
TYPE ( thermodynamic_type ), INTENT ( INOUT ) :: thermo
CHARACTER ( LEN = * ), INTENT ( IN ) :: ensemble
TYPE ( linklist_internal_data_type ) :: lldata
! Locals
@ -89,13 +88,14 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
TYPE ( pw_grid_type ) :: ewald_grid
INTEGER :: iflag, i, natoms, isos, iatom, iw, ir, npts_s(3), gmax
INTEGER, DIMENSION ( 2 ) :: dum
REAL ( dbl ) :: delta, energy_numer, cutoff
REAL ( dbl ) :: delta, energy_numer, cutoff, ecut
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
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: f_numer
REAL ( dbl ), DIMENSION ( :, : ), ALLOCATABLE :: rel, diff
LOGICAL, PARAMETER :: box_change = .FALSE.
!------------------------------------------------------------------------------
@ -124,7 +124,7 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
! call to analytical nonbond force routine:
CALL force_control ( molecule, pnode, part, box, box_ref, thermo, &
potparm, ewald_param, ensemble, globenv, lldata, dbg )
potparm, ewald_param, box_change, globenv, lldata, dbg )
! Debug real-space nonbond
WRITE ( iw, '( A )' ) &
@ -192,7 +192,8 @@ SUBROUTINE debug_control ( globenv, ewald_param, part, pnode, molecule, box, &
CALL pw_find_cutoff ( npts_s, box_ref, cutoff )
CALL pw_grid_setup( box_ref, ewald_grid, cutoff, fft_usage = .FALSE. )
ecut = 0.5_dbl * cutoff * cutoff
CALL pw_grid_setup( box_ref, ewald_grid, ecut, fft_usage = .FALSE. )
WRITE ( iw, '( A )' ) &
' DO YOU WANT TO DEBUG YOUR G-SPACE ENERGIES (1=yes)?'

40
src/tbmd_force.F
View file

@ -21,10 +21,12 @@
MODULE tbmd_force
USE dg_types, ONLY : dg_type
USE dgs, ONLY : dg_grid_change
USE ewald_parameters_types, ONLY : ewald_parameters_type
USE ewalds, ONLY : ewald_gaussian, ewald_initialize
USE ewalds, ONLY : ewald_evaluate, ewald_initialize, ewald_setup
USE fist_nonbond_force, ONLY : force_nonbond
USE global_types, ONLY : global_environment_type
USE greens_fn, ONLY : pw_green_fn_init
USE kinds, ONLY : dbl
USE linklist_control, ONLY : list_control
USE mathconstants, ONLY : pi, zero
@ -78,7 +80,7 @@ CONTAINS
!******************************************************************************
SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
potparm, ewald_param, ensemble, fc_global, lldata, debug )
potparm, ewald_param, box_change, fc_global, lldata, debug )
IMPLICIT NONE
@ -87,11 +89,11 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
TYPE ( particle_node_type ), DIMENSION ( : ), INTENT ( INOUT ) :: pnode
TYPE ( molecule_structure_type ), DIMENSION ( : ), INTENT ( IN ) :: molecule
TYPE ( cell_type ), INTENT ( INOUT ) :: box
TYPE ( cell_type ), INTENT ( IN ) :: box_ref
TYPE ( cell_type ), INTENT ( INOUT ) :: box_ref
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
LOGICAL, INTENT ( IN ) :: box_change
TYPE ( global_environment_type ), INTENT ( IN ) :: fc_global
TYPE ( linklist_internal_data_type ), INTENT ( INOUT ) :: lldata
TYPE ( debug_variables_type ), INTENT ( OUT ), OPTIONAL :: debug
@ -143,18 +145,30 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
END IF
! reinitialize the gspace for the new box
SELECT CASE ( ensemble ( 1:3 ) )
CASE ( 'NPT' )
IF ( box_change ) THEN
CALL get_hinv ( box )
SELECT CASE ( ewald_param % ewald_type )
CASE ( 'EWALD', 'SPME' )
CASE ( 'EWALD' )
CALL get_hinv ( box )
CALL pw_grid_change ( box, grid_ewald )
CALL ewald_setup ( grid_ewald, ewald_param, dg )
CASE ( 'PME' )
CALL stop_program ( 'force_control', &
'constant pressure with PME not implemented' )
CALL get_hinv ( box )
CALL pw_grid_change ( box, grid_b )
CALL pw_green_fn_init ( box % green, grid_b )
CALL dg_grid_change ( box, grid_b, grid_s )
CALL ewald_setup ( grid_s, ewald_param, dg )
CASE ( 'SPME' )
CALL get_hinv ( box )
CALL pw_grid_change ( box, grid_spme )
CALL pw_green_fn_init ( box % green, grid_spme, p3m=ewald_param%o_spline, &
alpha = ewald_param%alpha )
CALL ewald_setup ( grid_spme, ewald_param, dg )
END SELECT
END SELECT
END IF
!
! first check with list_control to update neighbor lists
@ -189,15 +203,15 @@ SUBROUTINE force_control ( molecule, pnode, part, box, box_ref, thermo, &
SELECT CASE ( ewald_param % ewald_type )
CASE ( "EWALD" )
CALL ewald_gaussian ( dg, ewald_param, fg_coulomb, vg_coulomb, &
CALL ewald_evaluate ( dg, ewald_param, fg_coulomb, vg_coulomb, &
pv_g, pnode, box )
CASE ( "PME" )
CALL pme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
CALL pme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_s, grid_b, ewald_param )
CASE ( "SPME" )
CALL spme_evaluate ( dg, fg_coulomb, vg_coulomb, pv_g, box, &
CALL spme_evaluate ( dg, part, fg_coulomb, vg_coulomb, pv_g, box, &
grid_spme, ewald_param )
CASE DEFAULT

123
src/timings.F
View file

@ -28,19 +28,20 @@ MODULE timings
USE termination, ONLY : stop_program
USE timesl, ONLY : cputime, walltime
USE util, ONLY : sort
USE message_passing, ONLY : mp_world_setup
PRIVATE
PUBLIC :: timeset, timestop, timeprint, trace_debug, print_stack
!!subroutine calling stack
! subroutine calling stack
INTEGER, PARAMETER :: max_stack = 100
INTEGER :: stack_size
CHARACTER ( LEN = 30 ) :: routine_stack ( max_stack ), routine_name
CHARACTER ( LEN = 31 ) :: routine_stack ( max_stack ), routine_name
!!subroutine timing and performance information
! subroutine timing and performance information
INTEGER, PARAMETER :: max_timer = 200
CHARACTER ( LEN = 30 ) :: clock_name ( max_timer )
CHARACTER ( LEN = 31 ) :: clock_name ( max_timer )
INTEGER :: routine_calls ( max_timer )
INTEGER :: clock_status ( max_timer )
REAL ( dbl ) :: clock_start ( max_timer )
@ -54,6 +55,7 @@ MODULE timings
INTEGER :: iod = 0
LOGICAL :: trace = .false.
CHARACTER ( LEN = 15 ) :: astring, bstring
!!*****
!******************************************************************************
@ -99,7 +101,7 @@ SUBROUTINE timeset ( name, ct, pu, handle )
!..if debug mode echo the subroutine name
IF ( trace ) write ( iod, '(A,A,A)') &
" >>>>> ",TRIM(name)," started ..."
astring,TRIM(name)," started ..."
!..is this a new timer or has this routine been called before
handle = 0
@ -186,7 +188,7 @@ SUBROUTINE timestop ( perf, handle )
!..if debug mode echo the subroutine name
IF ( trace ) write ( iod, '(A,A,A)') &
" <<<<< ",TRIM(routine_stack(stack_size))," ... ended"
bstring,TRIM(routine_stack(stack_size))," ... ended"
!..remove name from subroutine stack
stack_size = stack_size - 1
@ -213,84 +215,74 @@ END SUBROUTINE timestop
!! SOURCE
!******************************************************************************
SUBROUTINE timeprint ( iw, global_print_level )
SUBROUTINE timeprint(iw,global_print_level)
IMPLICIT NONE
! Arguments
INTEGER :: iw, global_print_level
INTEGER, INTENT(IN) :: global_print_level,iw
! Locals
INTEGER :: index ( max_timer ), i, j, ia, ie
REAL ( dbl ) :: maxtime, mintime, perf
CHARACTER ( LEN = 17 ) :: sname
CHARACTER ( LEN = 6 ) :: punit
CHARACTER ( LEN = 1 ) :: blank = ' ', ct ( 0 : 1 ) = (/ 'I', 'E' /)
REAL(dbl) :: maxtime,mintime,perf
INTEGER :: i,j
CHARACTER(LEN=1), DIMENSION(0:1) :: ct = (/"I","E"/)
INTEGER, DIMENSION(max_timer) :: index
!------------------------------------------------------------------------------
IF ( num_timer > 0 .AND. global_print_level >= 0 ) THEN
IF ((num_timer > 0).AND.(global_print_level >= 0)) THEN
CALL sort ( clock_accu, num_timer, index )
CALL sort(clock_accu,num_timer,index)
maxtime = clock_accu ( index ( num_timer ) )
maxtime = clock_accu(num_timer)
IF ( global_print_level > 10 ) THEN
IF (global_print_level > 10) THEN
mintime = zero
ELSE IF ( global_print_level > 5 ) THEN
mintime = maxtime * 0.002_dbl
ELSE IF (global_print_level > 5) THEN
mintime = maxtime*0.002_dbl
ELSE
mintime = maxtime * 0.02_dbl
mintime = maxtime*0.02_dbl
END IF
WRITE ( iw, '( /, 1X, 79("-") )' )
WRITE ( iw, '( " -", 77X, "-" )' )
WRITE ( iw, '( " -", 32X, A, 32X, "-" )' ) ' T I M I N G '
WRITE ( iw, '( " -", 77X, "-" )' )
WRITE ( iw, '( 1X, 79("-"), / )' )
WRITE ( iw, '( A, A, A )' ) ' SUBROUTINE', ' CALLS ', &
' CPU TIME T PERFORMANCE ELAPSED TIME'
WRITE (UNIT=iw,FMT="(/,T2,A)") REPEAT("-",78)
WRITE (UNIT=iw,FMT="(T2,A,T79,A)") "-","-"
WRITE (UNIT=iw,FMT="(T2,A,T35,A,T79,A)") "-","T I M I N G","-"
WRITE (UNIT=iw,FMT="(T2,A,T79,A)") "-","-"
WRITE (UNIT=iw,FMT="(T2,A)") REPEAT("-",78)
WRITE (UNIT=iw,FMT="(T2,A,T36,A,T43,A,T55,A,T68,A)")&
"SUBROUTINE","CALLS","CPU TIME T","PERFORMANCE","ELAPSED TIME"
DO i = num_timer, 1, -1
DO i=num_timer,1,-1
j = index ( i )
IF ( clock_accu ( j ) > mintime ) THEN
j = index(i)
IF ( clock_accu ( i ) > zero ) THEN
perf = perf_count ( j ) / clock_accu ( i )
ELSE
perf = zero
END IF
IF (clock_accu(i) > mintime) THEN
sname = blank
ia = 0
ie = 0
CALL xstring ( clock_name ( j ), ia, ie )
ie = min ( ia+16-1, ie )
sname ( 1 : ie-ia+1 ) = clock_name ( j ) ( ia : ie )
punit = blank
IF (clock_accu(i) > zero) THEN
perf = perf_count(j)/clock_accu(i)
ELSE
perf = zero
END IF
CALL xstring ( perf_unit ( j ), ia, ie )
IF (LEN_TRIM(perf_unit(j)) == 0) THEN
WRITE (UNIT=iw,&
FMT="(T2,A,T34,I7,T42,F9.2,T52,A,T60,A,T67,F13.2)")&
TRIM(clock_name(j)),routine_calls(j),clock_accu(i),&
ct(clock_type(j)),"---",wallclock_accu(j)
ELSE
WRITE (UNIT=iw,&
FMT="(T2,A,T34,I7,T42,F9.2,T52,A,T54,F5.1,T60,A,T67,F13.2)")&
TRIM(clock_name(j)),routine_calls(j),clock_accu(i),&
ct(clock_type(j)),perf,TRIM(perf_unit(j)),wallclock_accu(j)
END IF
END IF
IF ( ia > ie ) THEN
punit = '--- '
WRITE ( iw, &
'( 1X, A16, I7, F15.2, 1X, A1, 12X, 1X, A6, 5X, F15.2 )' ) &
sname, routine_calls ( j ), clock_accu ( i ), &
ct ( clock_type ( j ) ), punit, wallclock_accu ( j )
ELSE
ie = MIN ( ia+6-1, ie )
punit ( 6-ie+ia : 6 ) = perf_unit ( j ) ( ia : ie )
WRITE ( iw, &
'( 1X, A16, I7, F15.2, 1X, A1, F12.2, 1X, A6, 5X, F15.2 )' &
) &
sname, routine_calls ( j ), clock_accu ( i ), &
ct ( clock_type ( j ) ), perf, punit, wallclock_accu ( j )
END IF
END IF
END DO
WRITE ( iw, '( 1X, 79("-"), / )' )
WRITE (UNIT=iw,FMT="(T2,A,/)") REPEAT("-",78)
END IF
END SUBROUTINE timeprint
@ -324,6 +316,7 @@ SUBROUTINE trace_debug ( set, iw )
! Locals
INTEGER :: ia, ie
INTEGER :: numtask, taskid, groupid
CALL uppercase(set)
CALL xstring ( set, ia, ie )
@ -335,6 +328,16 @@ SUBROUTINE trace_debug ( set, iw )
call stop_program ("trace_debug","unknown action")
ENDIF
IF ( PRESENT ( iw ) ) iod = iw
#if defined (__parallel)
CALL mp_world_setup ( numtask, taskid, groupid )
astring = " >>>>>>>>>>>>> "
bstring = " >>>>>>>>>>>>> "
WRITE(astring(1:9),'(i4,a,i4)') taskid,":",numtask
WRITE(bstring(1:9),'(i4,a,i4)') taskid,":",numtask
#else
astring = " >>>>>>>>>>>>> "
bstring = " >>>>>>>>>>>>> "
#endif
END SUBROUTINE trace_debug

611
src/transformations.F Normal file
View file

@ -0,0 +1,611 @@
!-----------------------------------------------------------------------------!
! CP2K: A general program to perform molecular dynamics simulations !
! Copyright (C) 2000 CP2K developers group !
!-----------------------------------------------------------------------------!
!!****** cp2k/transformations [1.0] *
!!
!! NAME
!! transformations
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! SOURCE
!******************************************************************************
MODULE transformations
USE kinds, ONLY : dbl
USE termination, ONLY : stop_program, stop_memory
USE structure_types, ONLY : structure_type
USE md, ONLY : simulation_parameters_type
IMPLICIT NONE
PRIVATE
PUBLIC :: transformation_eigenvalues, transform, back_transform
PUBLIC :: force_transform
PUBLIC :: r2u, u2r, fr2fu
PUBLIC :: v2ud, ud2v
!!*****
!******************************************************************************
CONTAINS
!******************************************************************************
!!****** pimd/transformation_eigenvalues [1.0] *
!!
!! NAME
!! transformation_eigenvalues
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE transformation_eigenvalues( lamb, tran )
IMPLICIT NONE
! Arguments
REAL ( dbl ), DIMENSION ( : ), INTENT(OUT) :: lamb
CHARACTER ( LEN = 20 ), INTENT(IN) :: tran
! Locals
INTEGER :: i, beads
!------------------------------------------------------------------------------
beads = SIZE(lamb)
SELECT CASE ( tran )
CASE DEFAULT
CALL stop_program('transformation_eigenvalues', &
'That transformation not supported atm.')
CASE ( 'STAGE' )
lamb(1) = 0.0_dbl
DO i=2, beads
lamb(i) = i*(1.0_dbl/(i-1))
END DO
END SELECT
END SUBROUTINE transformation_eigenvalues
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/transform [1.0] *
!!
!! NAME
!! transform
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!! transform(tran,n,p,r,u) transforms a 2D array of dbl via
!! the transformation 'tran'. 'n' is the number of sets to transform
!! 'p' is the number of elements per set.
!! 'r' is the input (real coordinates) of dimension (1:n,1:p+1)
!! 'u' is the output of the transformed coordinates, if given.
!! If 'u' is ommitted, the output will be in 'r'.
!!
!! Periodic boundary conditions in the sets have to be put in
!! by duplicating r(:,p+1)=r(:,1). The idea is to be able to
!! use these routines for partial (staging) transformations also.
!!
!! SOURCE
!******************************************************************************
SUBROUTINE transform( tran, n, p, r, u )
IMPLICIT NONE
! Arguments
CHARACTER ( LEN = 20 ), INTENT(IN) :: tran ! which transform
INTEGER, INTENT(IN) :: n ! how many coordinate sets
INTEGER, INTENT(IN) :: p ! how many coordinates per set
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT) :: r
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT), OPTIONAL :: u
! Locals
INTEGER :: i
!------------------------------------------------------------------------------
SELECT CASE ( tran )
CASE DEFAULT
CALL stop_program('transform', 'That transformation not supported atm.')
CASE ( 'STAGE' )
IF ( PRESENT ( u ) ) THEN
u(1:n,1) = r(1:n,1)
DO i = 2, p
u(1:n,i) = r(1:n,i) - ((i-1) * r(1:n,i+1) + r(1:n,1))/i
END DO
ELSE
DO i = 2, p
r(1:n,i) = r(1:n,i) - ((i-1) * r(1:n,i+1) + r(1:n,1))/i
END DO
END IF
END SELECT
END SUBROUTINE transform
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/back_transform [1.0] *
!!
!! NAME
!! back_transform
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!! back_transform(tran,n,p,u,r) un-does transform(tran,n,p,r,u)
!! 'u' is the input ('normal' coordinates) of dimension (1:n,1:p+1)
!! 'r' is the output of the real coordinates, if given.
!! If 'r' is ommitted, the output will be in 'u'.
!!
!! Periodic boundary conditions in the sets have to be put in
!! by duplicating u(:,p+1)=u(:,1). The idea is to be able to
!! use these routines for partial (staging) transformations also.
!!
!! SOURCE
!******************************************************************************
SUBROUTINE back_transform( tran, n, p, u, r )
IMPLICIT NONE
! Arguments
CHARACTER ( LEN = 20 ), INTENT(IN) :: tran ! which transform
INTEGER, INTENT(IN) :: n ! how many coordinate sets
INTEGER, INTENT(IN) :: p ! how many coordinates per set
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT) :: u
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT), OPTIONAL :: r
! Locals
INTEGER :: i
!------------------------------------------------------------------------------
SELECT CASE ( tran )
CASE DEFAULT
CALL stop_program('back_transform', 'That transformation not supported atm.')
CASE ( 'STAGE' )
IF ( PRESENT ( r ) ) THEN
r(1:n,1) = u(1:n,1)
DO i = p , 2, -1
r(1:n,i) = u(1:n,i) + ((i-1) * r(1:n,i+1) + r(1:n,1))/i
END DO
ELSE
DO i = p , 2, -1
u(1:n,i) = u(1:n,i) + ((i-1) * u(1:n,i+1) + u(1:n,1))/i
END DO
END IF
END SELECT
END SUBROUTINE back_transform
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/force_transform [1.0] *
!!
!! NAME
!! force_transform
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!! force_transform(tran,n,p,fr,fu) transforms the forces calculated
!! in the real coordinate frame into the frame of the of 'normal'
!! coordinates according to the transformation 'tran'.
!! 'n' is the number of set to transform.
!! 'p' is the number of elements per set.
!! 'fr' is the input ('normal' coordinates forces) of dimension (1:n,1:p)
!! 'fu' is the output of the transformed forces, if given.
!! If 'fu' is ommitted, the output will be in 'fr'.
!!
!! Periodic boundary conditions in the sets are ASSUMED! You have to
!! post-process the "fu" in the following way to get non-periodic results
!! fu(:,1) = fu(:,1) + (p-1)*(fu(:,0)-fu(:,p))/p
!! where fu(:,0) is fu(:,p) of the previous segment
!!
!! SOURCE
!******************************************************************************
SUBROUTINE force_transform( tran, n, p, fr, fu )
IMPLICIT NONE
! Arguments
CHARACTER ( LEN = 20 ), INTENT(IN) :: tran ! which transform
INTEGER, INTENT(IN) :: n ! how many coordinate sets
INTEGER, INTENT(IN) :: p ! how many coordinates per set
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT) :: fr
REAL ( dbl ), DIMENSION ( : , : ), INTENT(INOUT), OPTIONAL :: fu
! Locals
INTEGER :: i, j
REAL (dbl) :: w
!------------------------------------------------------------------------------
SELECT CASE ( tran )
CASE DEFAULT
CALL stop_program('force_transform', 'That transformation not supported atm.')
CASE ( 'STAGE' )
IF ( PRESENT ( fu ) ) THEN
fu(1:n,1) = 0.0_dbl
DO i = 1, p
fu(1:n,1) = fu(1:n,1) + fr(1:n,i)
END DO
DO i = 2, p
w = (i - 2.0_dbl) / (i - 1.0_dbl)
fu(1:n,i) = w*fu(1:n,i-1) + fr(1:n,i)
END DO
ELSE
DO i = 2, p
fr(1:n,1) = fr(1:n,1) + fr(1:n,i)
w = (i - 2.0_dbl) / (i - 1.0_dbl)
fr(1:n,i) = fr(1:n,i) + w*fr(1:n,i-1)
END DO
END IF
END SELECT
END SUBROUTINE force_transform
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/r2u [1.0] *
!!
!! NAME
!! r2u
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE r2u( struc, simpar )
TYPE ( structure_type ), DIMENSION ( : ), INTENT(INOUT) :: struc
TYPE ( simulation_parameters_type ), INTENT(IN) :: simpar
REAL (dbl), ALLOCATABLE, DIMENSION ( : , : ) :: rtmp
INTEGER :: beads, natoms, ios
INTEGER :: i,j,k
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(rtmp(3*natoms,beads+1), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'r2u', 'rtmp', 3*natoms*(beads+1))
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
rtmp(3*k+i-3,j)= struc(j)%part(k)%r(i)
END DO
END DO
END DO
rtmp(:,beads+1)=rtmp(:,1)
CALL transform( simpar%pimd_params%transformation, 3*natoms, beads, rtmp)
DO j= 1, beads
DO k=1, natoms
DO i= 1, 3
struc(j)%pimd_data%u(i,k)=rtmp(3*k+i-3,j)
END DO
END DO
END DO
DEALLOCATE( rtmp , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'r2u', 'rtmp' )
END SUBROUTINE r2u
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/u2r [1.0] *
!!
!! NAME
!! u2r
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE u2r( struc, simpar )
TYPE ( structure_type ), DIMENSION ( : ), INTENT(INOUT) :: struc
TYPE ( simulation_parameters_type ), INTENT(IN) :: simpar
REAL (dbl), ALLOCATABLE, DIMENSION ( : , : ) :: utmp
INTEGER :: beads, natoms, ios
INTEGER :: i,j,k
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(utmp(3*natoms,beads+1), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'u2r', 'utmp', 3*natoms*(beads+1))
DO j= 1, beads
DO k=1, natoms
DO i= 1, 3
utmp(3*k+i-3,j) = struc(j)%pimd_data%u(i,k)
END DO
END DO
END DO
utmp(:,beads+1)=utmp(:,1)
CALL back_transform( simpar%pimd_params%transformation,3*natoms, beads, utmp)
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
struc(j)%part(k)%r(i) = utmp(3*k+i-3,j)
END DO
END DO
END DO
DEALLOCATE( utmp , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'u2r', 'utmp' )
END SUBROUTINE u2r
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/fr2fu [1.0] *
!!
!! NAME
!! fr2fu
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE fr2fu( struc, simpar )
TYPE ( structure_type ), DIMENSION ( : ), INTENT(INOUT) :: struc
TYPE ( simulation_parameters_type ), INTENT(IN) :: simpar
REAL (dbl), ALLOCATABLE, DIMENSION ( : , : ) :: ftmp
INTEGER :: beads, natoms, ios
INTEGER :: i,j,k
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(ftmp(3*natoms,beads+1), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'fr2fu', 'ftmp', 3*natoms*(beads+1))
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
ftmp(3*k+i-3,j) = struc(j)%part(k)%f(i)
END DO
END DO
END DO
CALL force_transform( simpar%pimd_params%transformation,3*natoms,beads, ftmp)
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
struc(j)%part(k)%f(i) = ftmp(3*k+i-3,j)
END DO
END DO
END DO
DEALLOCATE( ftmp , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'fr2fu', 'ftmp' )
END SUBROUTINE fr2fu
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/v2ud [1.0] *
!!
!! NAME
!! v2ud
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE v2ud( struc, simpar )
TYPE ( structure_type ), DIMENSION ( : ), INTENT(INOUT) :: struc
TYPE ( simulation_parameters_type ), INTENT(IN) :: simpar
REAL (dbl), ALLOCATABLE, DIMENSION ( : , : ) :: rtmp
REAL (dbl) :: factor
INTEGER :: beads, natoms, ios
INTEGER :: i,j,k
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(rtmp(3*natoms,beads+1), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'v2ud', 'rtmp', 3*natoms*(beads+1))
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
rtmp(3*k+i-3,j)= struc(j)%part(k)%v(i)
END DO
END DO
END DO
rtmp(:,beads+1)=rtmp(:,1)
CALL transform( simpar%pimd_params%transformation, 3*natoms, beads, rtmp)
DO j= 1, beads
factor = 1.0_dbl/struc(j)%pimd_data%ismeff
DO k=1, natoms
DO i= 1, 3
struc(j)%part(k)%v(i)=factor*rtmp(3*k+i-3,j)
END DO
END DO
END DO
DEALLOCATE( rtmp , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'v2ud', 'rtmp' )
END SUBROUTINE v2ud
!!*****
!******************************************************************************
!******************************************************************************
!!****** pimd/ud2v [1.0] *
!!
!! NAME
!! ud2v
!!
!! FUNCTION
!!
!! AUTHOR
!! HAF
!!
!! MODIFICATION HISTORY
!! none
!!
!! NOTES
!!
!! SOURCE
!******************************************************************************
SUBROUTINE ud2v( struc, simpar )
TYPE ( structure_type ), DIMENSION ( : ), INTENT(INOUT) :: struc
TYPE ( simulation_parameters_type ), INTENT(IN) :: simpar
REAL (dbl), ALLOCATABLE, DIMENSION ( : , : ) :: utmp
INTEGER :: beads, natoms, ios
INTEGER :: i,j,k
beads = SIZE(struc)
natoms = SIZE(struc(1) % part)
ALLOCATE(utmp(3*natoms,beads+1), STAT=ios)
IF (ios /= 0) CALL stop_memory ( 'ud2v', 'utmp', 3*natoms*(beads+1))
DO j= 1, beads
DO k=1, natoms
DO i= 1, 3
utmp(3*k+i-3,j) = struc(j)%part(k)%v(i)*struc(j)%pimd_data%ismeff
END DO
END DO
END DO
utmp(:,beads+1)=utmp(:,1)
CALL back_transform( simpar%pimd_params%transformation,3*natoms, beads, utmp)
DO j=1, beads
DO k=1, natoms
DO i= 1, 3
struc(j)%part(k)%v(i) = utmp(3*k+i-3,j)
END DO
END DO
END DO
DEALLOCATE( utmp , STAT = ios)
IF (ios /= 0) CALL stop_memory ( 'ud2v', 'utmp' )
END SUBROUTINE ud2v
!!*****
!******************************************************************************
END MODULE transformations
!******************************************************************************

2
src/xc.F
View file

@ -103,7 +103,7 @@ SUBROUTINE calculate_xc ( density, exc, vxc, &
IMPLICIT NONE
! Arguments
TYPE ( density_type ), INTENT ( IN ) :: density
TYPE ( density_type ), INTENT ( IN ), TARGET :: density
REAL ( dbl ), INTENT ( OUT ) :: exc
REAL ( dbl ), OPTIONAL, INTENT ( OUT ) :: vxc
INTEGER, OPTIONAL, INTENT ( IN ) :: alpha_spin, beta_spin