diff --git a/src/Makefile b/src/Makefile index 685e83ba32..13d2920efd 100644 --- a/src/Makefile +++ b/src/Makefile @@ -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 diff --git a/src/Makefile.absoft b/src/Makefile.absoft index 3b0c267e8b..54b1fe5604 100644 --- a/src/Makefile.absoft +++ b/src/Makefile.absoft @@ -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 ### diff --git a/src/OBJECTDEFS b/src/OBJECTDEFS index 4582d73fa7..e9ed32844b 100644 --- a/src/OBJECTDEFS +++ b/src/OBJECTDEFS @@ -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\ diff --git a/src/atomic_kinds.F b/src/atomic_kinds.F index dd4467032c..2ebea1c3b2 100644 --- a/src/atomic_kinds.F +++ b/src/atomic_kinds.F @@ -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)) diff --git a/src/atoms_input.F b/src/atoms_input.F index f15744acbf..1c7e618e52 100644 --- a/src/atoms_input.F +++ b/src/atoms_input.F @@ -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 ' ) diff --git a/src/basis_set_types.F b/src/basis_set_types.F index 6ce2c218bd..75773f8dc1 100644 --- a/src/basis_set_types.F +++ b/src/basis_set_types.F @@ -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 diff --git a/src/cell_parameters.F b/src/cell_parameters.F index 8daccd516e..c486edddce 100644 --- a/src/cell_parameters.F +++ b/src/cell_parameters.F @@ -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:",& diff --git a/src/cntl_input.F b/src/cntl_input.F index 78528ec8d0..ab07c3a956 100644 --- a/src/cntl_input.F +++ b/src/cntl_input.F @@ -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') diff --git a/src/coefficient_types.F b/src/coefficient_types.F index e90db9c352..a1dd7e62cd 100644 --- a/src/coefficient_types.F +++ b/src/coefficient_types.F @@ -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 diff --git a/src/coefficients.F b/src/coefficients.F index 105ab66cbf..d83712bf69 100644 --- a/src/coefficients.F +++ b/src/coefficients.F @@ -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 + +!****************************************************************************** diff --git a/src/collocate_density.F b/src/collocate_density.F new file mode 100644 index 0000000000..77cc073422 --- /dev/null +++ b/src/collocate_density.F @@ -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 diff --git a/src/control_module.F b/src/control_module.F index 3bdd292710..59f5dd5f75 100644 --- a/src/control_module.F +++ b/src/control_module.F @@ -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 + +!****************************************************************************** diff --git a/src/convert_units.F b/src/convert_units.F index 29ea2c593d..b92e7ce29f 100644 --- a/src/convert_units.F +++ b/src/convert_units.F @@ -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') diff --git a/src/core_energies.F b/src/core_energies.F new file mode 100644 index 0000000000..7f92db5033 --- /dev/null +++ b/src/core_energies.F @@ -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 diff --git a/src/core_hamiltonian.F b/src/core_hamiltonian.F index 68f4bace47..d72d44ea5e 100644 --- a/src/core_hamiltonian.F +++ b/src/core_hamiltonian.F @@ -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 ! ***************************************************************************** diff --git a/src/cp2k.F b/src/cp2k.F index 6942429c3c..7d6edcfef6 100644 --- a/src/cp2k.F +++ b/src/cp2k.F @@ -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 diff --git a/src/cp2k_input.F b/src/cp2k_input.F index 6bc1aacc40..8208a9a00d 100644 --- a/src/cp2k_input.F +++ b/src/cp2k_input.F @@ -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 ', & diff --git a/src/dft_structure_control.F b/src/dft_structure_control.F index fc7bed7b83..b76a09758f 100644 --- a/src/dft_structure_control.F +++ b/src/dft_structure_control.F @@ -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 diff --git a/src/dg_rho0s.F b/src/dg_rho0s.F index 4a891f3c02..81135ac856 100644 --- a/src/dg_rho0s.F +++ b/src/dg_rho0s.F @@ -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 diff --git a/src/dgs.F b/src/dgs.F index 939f6b486a..067d2c4eef 100644 --- a/src/dgs.F +++ b/src/dgs.F @@ -12,7 +12,8 @@ !! AUTHOR !! !! MODIFICATION HISTORY -!! none +!! JGH (15-Mar-2001) : Update small grid when cell changes +!! with dg_grid_change !! !! SOURCE !****************************************************************************** @@ -27,19 +28,40 @@ MODULE dgs USE kinds, ONLY : dbl, sgl USE mathconstants, ONLY : twopi, pi USE pw_grid_types, ONLY : pw_grid_type, HALFSPACE - USE pw_grids, ONLY : pw_grid_setup, pw_find_cutoff + USE pw_grids, ONLY : pw_grid_setup, pw_find_cutoff, pw_grid_change USE pw_types, ONLY : pw_fft_wrap, COMPLEXDATA3D + USE realspace_grid_types, ONLY : realspace_grid_type USE simulation_cell, ONLY : cell_type, get_hinv, get_cell_param USE structure_factors, ONLY : structure_factor_evaluate - USE termination, ONLY : stop_program + USE termination, ONLY : stop_program, stop_memory USE util, ONLY : dotprod_3d IMPLICIT NONE PRIVATE + PUBLIC :: dg_get_patch, dg_get_delta PUBLIC :: dg_grid_setup, dg_find_max_cutoff, dg_sum_patch, & - dg_sum_patch_force, dg_get_1x_patch, dg_get_2x_patch, & - dg_get_strucfac, dg_get_rho_tot + dg_sum_patch_force, dg_get_strucfac, dg_grid_change + + INTERFACE dg_sum_patch + MODULE PROCEDURE dg_sum_patch_coef, dg_sum_patch_arr + END INTERFACE + + INTERFACE dg_sum_patch_force + MODULE PROCEDURE dg_sum_patch_force_coef, dg_sum_patch_force_arr + END INTERFACE + + INTERFACE dg_get_patch + MODULE PROCEDURE dg_get_patch_1, dg_get_patch_2 + END INTERFACE + + INTERFACE dg_add_patch + MODULE PROCEDURE dg_add_patch_simple, dg_add_patch_folded + END INTERFACE + + INTERFACE dg_int_patch + MODULE PROCEDURE dg_int_patch_simple, dg_int_patch_folded + END INTERFACE !!***** !****************************************************************************** @@ -65,7 +87,7 @@ SUBROUTINE dg_grid_setup ( box_b, npts_s, epsilon, alpha, grid_s, grid_b, & ! Locals INTEGER :: nout ( 3 ) - REAL ( dbl ) :: dr ( 3 ), cutoff + REAL ( dbl ) :: dr ( 3 ), cutoff, ecut REAL ( dbl ) :: cell_lengths ( 3 ) TYPE ( cell_type ) :: unit_box, box_s @@ -96,18 +118,45 @@ SUBROUTINE dg_grid_setup ( box_b, npts_s, epsilon, alpha, grid_s, grid_b, & CALL pw_find_cutoff ( grid_b % npts, box_b, cutoff ) - CALL pw_grid_setup ( box_b, grid_b, cutoff, dg_glopar % group ) + ecut = 0.5_dbl * cutoff * cutoff + CALL pw_grid_setup ( box_b, grid_b, cutoff = ecut, & + pe_group = dg_glopar % group, info = dg_glopar % scr, & + fft_usage = .TRUE. ) CALL dg_find_basis ( grid_b % npts, box_b, unit_box ) CALL dg_set_cell ( grid_s % npts, unit_box, box_s ) - CALL pw_grid_setup ( box_s, grid_s ) + CALL pw_grid_setup ( box_s, grid_s, symm_usage=.FALSE. ) END SUBROUTINE dg_grid_setup !****************************************************************************** +SUBROUTINE dg_grid_change ( box_b, grid_b, grid_s ) + + IMPLICIT NONE + +! Arguments + TYPE ( cell_type ), INTENT ( IN ) :: box_b + TYPE ( pw_grid_type ), INTENT ( IN ) :: grid_b + TYPE ( pw_grid_type ), INTENT ( INOUT ) :: grid_s + +! Locals + TYPE ( cell_type ) :: unit_box, box_s + +!------------------------------------------------------------------------------ + + CALL dg_find_basis ( grid_b % npts, box_b, unit_box ) + + CALL dg_set_cell ( grid_s % npts, unit_box, box_s ) + + CALL pw_grid_change ( box_s, grid_s ) + +END SUBROUTINE dg_grid_change + +!****************************************************************************** + SUBROUTINE dg_get_spacing ( npts, epsilon, alpha, dg_gaussian_type, dr ) IMPLICIT NONE @@ -304,7 +353,7 @@ SUBROUTINE dg_get_strucfac ( box, r, npts_s, npts_b, centre, lb, ex, ey, ez ) !------------------------------------------------------------------------------ - CALL get_delta ( box, r, npts_s, npts_b, centre, delta) + CALL dg_get_delta ( box, r, npts_s, npts_b, centre, delta) CALL structure_factor_evaluate ( delta, npts_s, lb, ex, ey, ez ) @@ -312,7 +361,7 @@ END SUBROUTINE dg_get_strucfac !****************************************************************************** -SUBROUTINE get_delta ( box, r, npts_s, npts_b, centre, delta ) +SUBROUTINE dg_get_delta ( box, r, npts_s, npts_b, centre, delta ) IMPLICIT NONE ! Arguments @@ -341,461 +390,566 @@ SUBROUTINE get_delta ( box, r, npts_s, npts_b, centre, delta ) ! find the distance vector delta ( : ) = ( grid_i ( : ) - centre ( : ) ) / REAL ( npts_s ( : ), dbl ) -END SUBROUTINE get_delta +END SUBROUTINE dg_get_delta !****************************************************************************** -SUBROUTINE dg_get_1x_patch ( rho0, rhos_r, charge1, & - lb, ex1, ey1, ez1 ) +SUBROUTINE dg_sum_patch_coef ( rs, rhos, center ) IMPLICIT NONE ! Arguments - REAL ( dbl ), INTENT ( IN ) :: charge1 - TYPE ( coeff_type ), INTENT ( IN ) :: rho0 - INTEGER, INTENT ( IN ) :: lb ( 3 ) - COMPLEX ( dbl ), DIMENSION ( lb(1): ), INTENT ( IN ) :: ex1 - COMPLEX ( dbl ), DIMENSION ( lb(2): ), INTENT ( IN ) :: ey1 - COMPLEX ( dbl ), DIMENSION ( lb(3): ), INTENT ( IN ) :: ez1 - - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos_r + TYPE ( realspace_grid_type ), TARGET, INTENT ( INOUT ) :: rs + TYPE ( coeff_type ), TARGET, INTENT ( IN ) :: rhos + INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: center ! Locals - INTEGER :: i1, i2, i3 - COMPLEX ( dbl ) :: temp1a, temp2a, temp3a - INTEGER, DIMENSION ( :, : ), POINTER :: bds - INTEGER, DIMENSION ( : ), POINTER :: npts - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos + INTEGER, DIMENSION ( :, : ), POINTER :: bs + INTEGER, DIMENSION ( : ), POINTER :: nb + INTEGER, DIMENSION ( : ), POINTER :: ns + INTEGER, DIMENSION ( 3 ) :: nc + INTEGER :: i, j, k, ii, ia + LOGICAL :: folded + +!------------------------------------------------------------------------------ + bs => rhos % pw % pw_grid % bounds + nb => rs % npts_local + ns => rhos % pw % pw_grid % npts + folded = .FALSE. + + DO i = bs ( 1, 1 ), bs ( 2, 1 ) + ia = i - bs ( 1, 1 ) + 1 + ii = center ( 1 ) + i - rs % lb_local ( 1 ) + IF ( ii < 0 ) THEN + rs % px ( ia ) = ii + nb ( 1 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 1 ) ) THEN + rs % px ( ia ) = ii - nb ( 1 ) + 1 + folded = .TRUE. + ELSE + rs % px ( ia ) = ii + 1 + ENDIF + END DO + DO i = bs ( 1, 2 ), bs ( 2, 2 ) + ia = i - bs ( 1, 2 ) + 1 + ii = center ( 2 ) + i - rs % lb_local ( 2 ) + IF ( ii < 0 ) THEN + rs % py ( ia ) = ii + nb ( 2 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 2 ) ) THEN + rs % py ( ia ) = ii - nb ( 2 ) + 1 + folded = .TRUE. + ELSE + rs % py ( ia ) = ii + 1 + ENDIF + END DO + DO i = bs ( 1, 3 ), bs ( 2, 3 ) + ia = i - bs ( 1, 3 ) + 1 + ii = center ( 3 ) + i - rs % lb_local ( 3 ) + IF ( ii < 0 ) THEN + rs % pz ( ia ) = ii + nb ( 3 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 3 ) ) THEN + rs % pz ( ia ) = ii - nb ( 3 ) + 1 + folded = .TRUE. + ELSE + rs % pz ( ia ) = ii + 1 + ENDIF + END DO + + IF ( folded ) THEN + CALL dg_add_patch ( rs % r, rhos % pw % cr3d, ns, rs % px, rs % py, rs % pz ) + ELSE + nc ( 1 ) = rs % px ( 1 ) - 1 + nc ( 2 ) = rs % py ( 1 ) - 1 + nc ( 3 ) = rs % pz ( 1 ) - 1 + CALL dg_add_patch ( rs % r, rhos % pw % cr3d, ns, nc ) + END IF + +END SUBROUTINE dg_sum_patch_coef + +!****************************************************************************** + +SUBROUTINE dg_sum_patch_arr ( rs, rhos, center ) + + IMPLICIT NONE + +! Arguments + TYPE ( realspace_grid_type ), TARGET, INTENT ( INOUT ) :: rs + REAL ( dbl ), DIMENSION ( :,:,: ), INTENT ( IN ) :: rhos + INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: center + +! Locals + INTEGER, DIMENSION ( : ), POINTER :: nb + INTEGER, DIMENSION ( 3 ) :: ns, lb, ub + INTEGER, DIMENSION ( 3 ) :: nc + INTEGER :: i, ii, ia + LOGICAL :: folded !------------------------------------------------------------------------------ - rhos => rhos_r % pw % cc3d - rho => rho0 % pw % cr3d - bds => rhos_r % pw % pw_grid % bounds - npts => rhos_r % pw % pw_grid % npts + nb => rs % npts + ns ( 1 ) = SIZE ( rhos, 1 ) + ns ( 2 ) = SIZE ( rhos, 2 ) + ns ( 3 ) = SIZE ( rhos, 3 ) + lb = -(ns-1) / 2 + ub = lb + ns - 1 + folded = .FALSE. - DO i3 = bds ( 1, 3 ), bds ( 2, 3 ) - temp3a = ez1 ( i3 ) * charge1 - - DO i2 = bds ( 1, 2 ), bds ( 2, 2 ) - temp2a = temp3a * ey1 ( i2 ) - - DO i1 = bds ( 1, 1 ), bds ( 2, 1 ) - temp1a = temp2a * ex1 ( i1 ) - - rhos ( i1, i2, i3 ) = temp1a * rho ( i1, i2, i3 ) - END DO - END DO + DO i = lb ( 1 ), ub ( 1 ) + ia = i - lb ( 1 ) + 1 + ii = center ( 1 ) + i - rs % lb ( 1 ) + IF ( ii < 0 ) THEN + rs % px ( ia ) = ii + nb ( 1 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 1 ) ) THEN + rs % px ( ia ) = ii - nb ( 1 ) + 1 + folded = .TRUE. + ELSE + rs % px ( ia ) = ii + 1 + ENDIF + END DO + DO i = lb ( 2 ), ub ( 2 ) + ia = i - lb ( 2 ) + 1 + ii = center ( 2 ) + i - rs % lb ( 2 ) + IF ( ii < 0 ) THEN + rs % py ( ia ) = ii + nb ( 2 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 2 ) ) THEN + rs % py ( ia ) = ii - nb ( 2 ) + 1 + folded = .TRUE. + ELSE + rs % py ( ia ) = ii + 1 + ENDIF + END DO + DO i = lb ( 3 ), ub ( 3 ) + ia = i - lb ( 3 ) + 1 + ii = center ( 3 ) + i - rs % lb ( 3 ) + IF ( ii < 0 ) THEN + rs % pz ( ia ) = ii + nb ( 3 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 3 ) ) THEN + rs % pz ( ia ) = ii - nb ( 3 ) + 1 + folded = .TRUE. + ELSE + rs % pz ( ia ) = ii + 1 + ENDIF END DO -! compute rho_s(r) for the current atoms - CALL fft3d ( BWFFT, npts, rhos ) + IF ( folded ) THEN + CALL dg_add_patch ( rs % r, rhos, ns, rs % px, rs % py, rs % pz ) + ELSE + nc ( 1 ) = rs % px ( 1 ) - 1 + nc ( 2 ) = rs % py ( 1 ) - 1 + nc ( 3 ) = rs % pz ( 1 ) - 1 + CALL dg_add_patch ( rs % r, rhos, ns, nc ) + END IF -END SUBROUTINE dg_get_1x_patch +END SUBROUTINE dg_sum_patch_arr !****************************************************************************** -!! The output comes in the real and imag parts of 'rhos_r' - -SUBROUTINE dg_get_2x_patch ( rho0, rhos_r, charge1, charge2, & - lb, ex1, ey1, ez1, ex2, ey2, ez2 ) +SUBROUTINE dg_sum_patch_force_arr ( drpot, rhos, center, force ) + + IMPLICIT NONE + +! Arguments + TYPE ( realspace_grid_type ), DIMENSION ( 3 ), TARGET, & + INTENT ( INOUT ) :: drpot + REAL ( dbl ), DIMENSION ( :,:,: ), INTENT ( IN ) :: rhos + INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: center + REAL ( dbl ), DIMENSION ( 3 ), INTENT ( OUT ) :: force + +! Locals + INTEGER, DIMENSION ( : ), POINTER :: nb + INTEGER, DIMENSION ( 3 ) :: ns, lb, ub + INTEGER, DIMENSION ( 3 ) :: nc + INTEGER :: i, ii, ia + LOGICAL :: folded + +!------------------------------------------------------------------------------ + + nb => drpot ( 1 ) % npts + ns ( 1 ) = SIZE ( rhos, 1 ) + ns ( 2 ) = SIZE ( rhos, 2 ) + ns ( 3 ) = SIZE ( rhos, 3 ) + lb = -(ns-1) / 2 + ub = lb + ns - 1 + folded = .FALSE. + + DO i = lb ( 1 ), ub ( 1 ) + ia = i - lb ( 1 ) + 1 + ii = center ( 1 ) + i - drpot ( 1 ) % lb ( 1 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % px ( ia ) = ii + nb ( 1 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 1 ) ) THEN + drpot ( 1 ) % px ( ia ) = ii - nb ( 1 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % px ( ia ) = ii + 1 + ENDIF + END DO + DO i = lb ( 2 ), ub ( 2 ) + ia = i - lb ( 2 ) + 1 + ii = center ( 2 ) + i - drpot ( 1 ) % lb ( 2 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % py ( ia ) = ii + nb ( 2 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 2 ) ) THEN + drpot ( 1 ) % py ( ia ) = ii - nb ( 2 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % py ( ia ) = ii + 1 + ENDIF + END DO + DO i = lb ( 3 ), ub ( 3 ) + ia = i - lb ( 3 ) + 1 + ii = center ( 3 ) + i - drpot ( 1 ) % lb ( 3 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % pz ( ia ) = ii + nb ( 3 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 3 ) ) THEN + drpot ( 1 ) % pz ( ia ) = ii - nb ( 3 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % pz ( ia ) = ii + 1 + ENDIF + END DO + + IF ( folded ) THEN + CALL dg_int_patch ( drpot ( 1 ) % r, drpot ( 2 ) % r, drpot ( 3 ) % r, & + rhos, force, ns, & + drpot ( 1 ) % px, drpot ( 1 ) % py, drpot ( 1 ) % pz ) + ELSE + nc ( 1 ) = drpot ( 1 ) % px ( 1 ) - 1 + nc ( 2 ) = drpot ( 1 ) % py ( 1 ) - 1 + nc ( 3 ) = drpot ( 1 ) % pz ( 1 ) - 1 + CALL dg_int_patch ( drpot ( 1 ) % r, drpot ( 2 ) % r, drpot ( 3 ) % r, & + rhos, force, ns, nc ) + END IF + +END SUBROUTINE dg_sum_patch_force_arr + +!****************************************************************************** + +SUBROUTINE dg_sum_patch_force_coef ( drpot, rhos, center, force ) + + IMPLICIT NONE + +! Arguments + TYPE ( realspace_grid_type ), DIMENSION ( 3 ), TARGET, INTENT ( INOUT ) :: drpot + TYPE ( coeff_type ), TARGET, INTENT ( IN ) :: rhos + INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: center + REAL ( dbl ), DIMENSION ( 3 ), INTENT ( OUT ) :: force + +! Locals + INTEGER, DIMENSION ( :, : ), POINTER :: bs + INTEGER, DIMENSION ( : ), POINTER :: nb + INTEGER, DIMENSION ( : ), POINTER :: ns + INTEGER, DIMENSION ( 3 ) :: nc + INTEGER :: i, j, k, ii, ia + LOGICAL :: folded + +!------------------------------------------------------------------------------ + bs => rhos % pw % pw_grid % bounds + nb => drpot ( 1 ) % npts + ns => rhos % pw % pw_grid % npts + folded = .FALSE. + + DO i = bs ( 1, 1 ), bs ( 2, 1 ) + ia = i - bs ( 1, 1 ) + 1 + ii = center ( 1 ) + i - drpot ( 1 ) % lb_local ( 1 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % px ( ia ) = ii + nb ( 1 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 1 ) ) THEN + drpot ( 1 ) % px ( ia ) = ii - nb ( 1 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % px ( ia ) = ii + 1 + ENDIF + END DO + DO i = bs ( 1, 2 ), bs ( 2, 2 ) + ia = i - bs ( 1, 2 ) + 1 + ii = center ( 2 ) + i - drpot ( 1 ) % lb_local ( 2 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % py ( ia ) = ii + nb ( 2 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 2 ) ) THEN + drpot ( 1 ) % py ( ia ) = ii - nb ( 2 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % py ( ia ) = ii + 1 + ENDIF + END DO + DO i = bs ( 1, 3 ), bs ( 2, 3 ) + ia = i - bs ( 1, 3 ) + 1 + ii = center ( 3 ) + i - drpot ( 1 ) % lb_local ( 3 ) + IF ( ii < 0 ) THEN + drpot ( 1 ) % pz ( ia ) = ii + nb ( 3 ) + 1 + folded = .TRUE. + ELSEIF ( ii >= nb ( 3 ) ) THEN + drpot ( 1 ) % pz ( ia ) = ii - nb ( 3 ) + 1 + folded = .TRUE. + ELSE + drpot ( 1 ) % pz ( ia ) = ii + 1 + ENDIF + END DO + + IF ( folded ) THEN + CALL dg_int_patch ( drpot ( 1 ) % r, drpot ( 2 ) % r, drpot ( 3 ) % r, & + rhos % pw % cr3d, force, ns, & + drpot ( 1 ) % px, drpot ( 1 ) % py, drpot ( 1 ) % pz ) + ELSE + nc ( 1 ) = drpot ( 1 ) % px ( 1 ) - 1 + nc ( 2 ) = drpot ( 1 ) % py ( 1 ) - 1 + nc ( 3 ) = drpot ( 1 ) % pz ( 1 ) - 1 + CALL dg_int_patch ( drpot ( 1 ) % r, drpot ( 2 ) % r, drpot ( 3 ) % r, & + rhos % pw % cr3d, force, ns, nc ) + END IF + +END SUBROUTINE dg_sum_patch_force_coef + +!****************************************************************************** + +SUBROUTINE dg_get_patch_1 ( rho0, rhos1, charge1, ex1, ey1, ez1 ) IMPLICIT NONE ! Arguments - REAL ( dbl ), INTENT ( IN ) :: charge1, charge2 TYPE ( coeff_type ), INTENT ( IN ), TARGET :: rho0 - INTEGER, INTENT ( IN ) :: lb ( 3 ) - COMPLEX ( dbl ), DIMENSION ( lb(1): ), INTENT ( IN ) :: ex1, ex2 - COMPLEX ( dbl ), DIMENSION ( lb(2): ), INTENT ( IN ) :: ey1, ey2 - COMPLEX ( dbl ), DIMENSION ( lb(3): ), INTENT ( IN ) :: ez1, ez2 - - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos_r + TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos1 + REAL ( dbl ), INTENT ( IN ) :: charge1 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ex1 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ey1 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ez1 ! Locals - INTEGER :: i1, i2, i3 - COMPLEX ( dbl ) :: temp1a, temp2a, temp3a, temp1b, temp2b, temp3b - COMPLEX ( dbl ) :: ci - INTEGER, DIMENSION ( :, : ), POINTER :: bds_s - INTEGER, DIMENSION ( : ), POINTER :: npts_s - REAL ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rhos + INTEGER :: n, nd ( 3 ), ierr, n1, n2, n3 + COMPLEX ( dbl ) :: za, zb + COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE :: zs + COMPLEX ( dbl ), DIMENSION ( :,:,: ), ALLOCATABLE :: cd !------------------------------------------------------------------------------ - rhos => rhos_r % pw % cc3d - rho => rho0 % pw % cr3d - bds_s => rhos_r % pw % pw_grid % bounds - npts_s => rhos_r % pw % pw_grid % npts + nd = rhos1 % pw % pw_grid % npts + n = PRODUCT ( nd ) - ci = CMPLX ( 0.0_dbl, 1.0_dbl ) + IF ( ALLOCATED ( cd ) ) THEN + n1 = SIZE ( cd, 1 ) + n2 = SIZE ( cd, 2 ) + n3 = SIZE ( cd, 3 ) + IF ( n1 /= nd(1) .OR. n1 /= nd(1) .OR. n1 /= nd(1) ) THEN + DEALLOCATE ( zs, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","zs") + DEALLOCATE ( cd, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","cd") + ENDIF + ENDIF + IF ( .NOT. ALLOCATED ( cd ) ) THEN + ALLOCATE ( zs ( nd(1)*nd(2) ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","zs",nd(1)*nd(2)) + zs = 0._dbl + ALLOCATE ( cd ( nd(1),nd(2),nd(3) ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","cd",n) + cd = 0._dbl + ENDIF - DO i3 = bds_s ( 1, 3 ), bds_s ( 2, 3 ) - temp3a = ez1 ( i3 ) * charge1 - temp3b = ez2 ( i3 ) * charge2 + za = CMPLX ( 0._dbl, 0._dbl, dbl ) + zb = CMPLX ( charge1, 0._dbl, dbl ) + CALL rankup ( nd, za, cd, zb, ex1, ey1, ez1, zs ) + CALL vr_x_vc ( n, rho0 % pw % cr3d, cd ) + CALL fft3d ( BWFFT, nd, cd ) + CALL copy_cr ( n, cd, rhos1%pw%cr3d ) - DO i2 = bds_s ( 1, 2 ), bds_s ( 2, 2 ) - temp2a = temp3a * ey1 ( i2 ) - temp2b = temp3b * ey2 ( i2 ) +END SUBROUTINE dg_get_patch_1 - DO i1 = bds_s ( 1, 1 ), bds_s ( 2, 1 ) - temp1a = temp2a * ex1 ( i1 ) - temp1b = temp2b * ex2 ( i1 ) +!****************************************************************************** - rhos ( i1, i2, i3 ) = ( temp1a + ci * temp1b ) * rho ( i1, i2, i3 ) - END DO - END DO +SUBROUTINE dg_get_patch_2 ( rho0, rhos1, rhos2, charge1, charge2, & + ex1, ey1, ez1, ex2, ey2, ez2 ) + + IMPLICIT NONE + +! Arguments + TYPE ( coeff_type ), INTENT ( IN ), TARGET :: rho0 + TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhos1, rhos2 + REAL ( dbl ), INTENT ( IN ) :: charge1, charge2 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ex1, ex2 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ey1, ey2 + COMPLEX ( dbl ), DIMENSION ( : ), INTENT ( IN ) :: ez1, ez2 + +! Locals + INTEGER :: n, nd ( 3 ), ierr, n1, n2, n3 + COMPLEX ( dbl ) :: za, zb + COMPLEX ( dbl ), DIMENSION ( : ), ALLOCATABLE, SAVE :: zs + COMPLEX ( dbl ), DIMENSION ( :,:,: ), ALLOCATABLE, SAVE :: cd + +!------------------------------------------------------------------------------ + + nd = rhos1 % pw % pw_grid % npts + n = PRODUCT ( nd ) + + IF ( ALLOCATED ( cd ) ) THEN + n1 = SIZE ( cd, 1 ) + n2 = SIZE ( cd, 2 ) + n3 = SIZE ( cd, 3 ) + IF ( n1 /= nd(1) .OR. n1 /= nd(1) .OR. n1 /= nd(1) ) THEN + DEALLOCATE ( zs, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","zs") + DEALLOCATE ( cd, STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","cd") + ENDIF + ENDIF + IF ( .NOT. ALLOCATED ( cd ) ) THEN + ALLOCATE ( zs ( nd(1)*nd(2) ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","zs",nd(1)*nd(2)) + zs = 0._dbl + ALLOCATE ( cd ( nd(1),nd(2),nd(3) ), STAT = ierr ) + IF ( ierr /= 0 ) call stop_memory ( "dg_get_patch","cd",n) + cd = 0._dbl + ENDIF + + za = CMPLX ( 0._dbl, 0._dbl, dbl ) + zb = CMPLX ( charge2, 0._dbl, dbl ) + CALL rankup ( nd, za, cd, zb, ex2, ey2, ez2, zs ) + za = CMPLX ( 0._dbl, 1._dbl, dbl ) + zb = CMPLX ( charge1, 0._dbl, dbl ) + CALL rankup ( nd, za, cd, zb, ex1, ey1, ez1, zs ) + CALL vr_x_vc ( n, rho0 % pw % cr3d, cd ) + CALL fft3d ( BWFFT, nd, cd ) + CALL copy_cri ( n, cd, rhos1%pw%cr3d, rhos2%pw%cr3d ) + +END SUBROUTINE dg_get_patch_2 + +!****************************************************************************** + +SUBROUTINE dg_add_patch_simple ( rb, rs, ns, nc ) + + IMPLICIT NONE + +! Arguments + REAL ( dbl ), INTENT ( INOUT ) :: rb ( :, :, : ) + REAL ( dbl ), INTENT ( IN ) :: rs ( :, :, : ) + INTEGER, INTENT ( IN ) :: ns ( 3 ), nc ( 3 ) + +! LOCAL + INTEGER :: i, j, k, ii, jj, kk + +!------------------------------------------------------------------------------ + + DO k = 1, ns ( 3 ) + kk = nc ( 3 ) + k + DO j = 1, ns ( 2 ) + jj = nc ( 2 ) + j + DO i = 1, ns ( 1 ) + ii = nc ( 1 ) + i + rb ( ii, jj, kk ) = rb ( ii, jj, kk ) + rs ( i, j, k ) + END DO + END DO END DO -! compute rho_s(r) for the current atoms - CALL fft3d ( BWFFT, npts_s, rhos ) - -END SUBROUTINE dg_get_2x_patch +END SUBROUTINE dg_add_patch_simple !****************************************************************************** -SUBROUTINE dg_sum_patch ( rhos, rhob, bounds_s, centre, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) +SUBROUTINE dg_add_patch_folded ( rb, rs, ns, px, py, pz ) IMPLICIT NONE ! Arguments - INTEGER, DIMENSION ( 2, 3 ), INTENT ( IN ) :: bounds_s - REAL ( dbl ), DIMENSION ( bounds_s(1,1):bounds_s(2,1), & - bounds_s(1,2):bounds_s(2,2), bounds_s(1,3):bounds_s(2,3) ), & - INTENT ( IN ) :: rhos - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: centre - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_pbc, lb_rhob - INTEGER, DIMENSION ( lb_pbc ( 1 ) : ), INTENT ( IN ) :: pbc1_b - INTEGER, DIMENSION ( lb_pbc ( 2 ) : ), INTENT ( IN ) :: pbc2_b - INTEGER, DIMENSION ( lb_pbc ( 3 ) : ), INTENT ( IN ) :: pbc3_b + REAL ( dbl ), INTENT ( INOUT ) :: rb ( :, :, : ) + REAL ( dbl ), INTENT ( IN ) :: rs ( :, :, : ) + INTEGER, INTENT ( IN ) :: ns ( : ) + INTEGER, DIMENSION ( : ), INTENT ( IN ) :: px, py, pz - REAL ( dbl ), DIMENSION ( lb_rhob(1):, lb_rhob(2):, lb_rhob(3): ), & - INTENT ( INOUT ) :: rhob - -! Locals - INTEGER :: i1, i2, i3, ii1, ii2, ii3 - INTEGER :: lb1, lb2, lb3, ub1, ub2, ub3 +! LOCAL + INTEGER :: i, j, k, ii, jj, kk !------------------------------------------------------------------------------ - lb1 = pbc1_b ( bounds_s ( 1, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - lb2 = pbc2_b ( bounds_s ( 1, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - lb3 = pbc3_b ( bounds_s ( 1, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - ub1 = pbc1_b ( bounds_s ( 2, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - ub2 = pbc2_b ( bounds_s ( 2, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - ub3 = pbc3_b ( bounds_s ( 2, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - - IF ( lb3 < ub3 .AND. lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, lb2+i2, lb3+i3 ) & - = rhob ( lb1+i1, lb2+i2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, lb2+i2, ii3 ) = rhob ( lb1+i1, lb2+i2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, ii2, lb3+i3 ) = rhob ( lb1+i1, ii2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, lb2+i2, lb3+i3 ) = rhob ( ii1, lb2+i2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - rhob ( lb1+i1, ii2, ii3 ) = rhob ( lb1+i1, ii2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, lb2+i2, ii3 ) = rhob ( ii1, lb2+i2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, ii2, lb3+i3 ) = rhob ( ii1, ii2, lb3+i3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - ELSE - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - rhob ( ii1, ii2, ii3 ) = rhob ( ii1, ii2, ii3 ) & - + rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END IF - -END SUBROUTINE dg_sum_patch - -!****************************************************************************** - -SUBROUTINE dg_sum_patch_force ( rhos, rhob, f_xyz, bounds_s, centre, & - lb_pbc, pbc1_b, pbc2_b, pbc3_b, lb_rhob ) - - IMPLICIT NONE - -! Arguments - INTEGER, DIMENSION ( 2, 3 ), INTENT ( IN ) :: bounds_s - REAL ( dbl ), DIMENSION ( bounds_s(1,1):bounds_s(2,1), & - bounds_s(1,2):bounds_s(2,2), bounds_s(1,3):bounds_s(2,3) ), & - INTENT ( IN ) :: rhos - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_rhob - REAL ( dbl ), & - DIMENSION ( 1:, lb_rhob ( 1 ) :, lb_rhob ( 2 ) :, lb_rhob ( 3 ) : ), & - INTENT ( IN ) :: rhob - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: centre - INTEGER, DIMENSION ( 3 ), INTENT ( IN ) :: lb_pbc - INTEGER, DIMENSION ( lb_pbc ( 1 ) : ), INTENT ( IN ) :: pbc1_b - INTEGER, DIMENSION ( lb_pbc ( 2 ) : ), INTENT ( IN ) :: pbc2_b - INTEGER, DIMENSION ( lb_pbc ( 3 ) : ), INTENT ( IN ) :: pbc3_b - - REAL ( dbl ), DIMENSION ( : ), INTENT ( OUT ) :: f_xyz - -! Locals - INTEGER :: i1, i2, i3, ii1, ii2, ii3, ic - INTEGER :: lb1, lb2, lb3, ub1, ub2, ub3 - -!------------------------------------------------------------------------------ - - f_xyz ( : ) = 0.0_dbl - - lb1 = pbc1_b ( bounds_s ( 1, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - lb2 = pbc2_b ( bounds_s ( 1, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - lb3 = pbc3_b ( bounds_s ( 1, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - ub1 = pbc1_b ( bounds_s ( 2, 1 ) + centre ( 1 ) ) - bounds_s ( 1, 1 ) - ub2 = pbc2_b ( bounds_s ( 2, 2 ) + centre ( 2 ) ) - bounds_s ( 1, 2 ) - ub3 = pbc3_b ( bounds_s ( 2, 3 ) + centre ( 3 ) ) - bounds_s ( 1, 3 ) - - IF ( lb3 < ub3 .AND. lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, lb2+i2, lb3+i3 ) & - * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, lb2+i2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, ii2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb3 < ub3 .AND. lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, lb2+i2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, lb1+i1, ii2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb2 < ub2 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, lb2+i2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE IF ( lb1 < ub1 ) THEN - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, ii2, lb3+i3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - ELSE - DO i3 = bounds_s ( 1, 3 ), bounds_s ( 2, 3 ) - ii3 = pbc3_b ( i3 + centre ( 3 ) ) - DO i2 = bounds_s ( 1, 2 ), bounds_s ( 2, 2 ) - ii2 = pbc2_b ( i2 + centre ( 2 ) ) - DO i1 = bounds_s ( 1, 1 ), bounds_s ( 2, 1 ) - ii1 = pbc1_b ( i1 + centre ( 1 ) ) - DO ic = 1, 3 - f_xyz ( ic ) = f_xyz ( ic ) & - + rhob ( ic, ii1, ii2, ii3 ) * rhos ( i1, i2, i3 ) - END DO - END DO - END DO - END DO - END IF - -END SUBROUTINE dg_sum_patch_force - -!****************************************************************************** - -SUBROUTINE dg_get_rho_tot ( rho_r, rhob_r ) - - IMPLICIT NONE - -! Arguments - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rhob_r - TYPE ( coeff_type ), INTENT ( INOUT ), TARGET :: rho_r - -! Locals - INTEGER :: lp1,mp1,np1,ln1,mn1,nn1 - INTEGER :: lp2,mp2,np2,ln2,mn2,nn2 - INTEGER :: gpt - INTEGER, DIMENSION ( :, : ), POINTER :: bds1, bds2 - INTEGER, DIMENSION ( : ), POINTER :: ghat - COMPLEX ( dbl ), DIMENSION ( :, :, : ), POINTER :: rho, rhob - TYPE ( pw_grid_type ), POINTER :: grid1, grid2 - -!------------------------------------------------------------------------------ - - grid1 => rhob_r % pw % pw_grid - grid2 => rho_r % pw % pw_grid - bds1 => grid1 % bounds - bds2 => grid2 % bounds - rhob => rhob_r % pw % cc3d - rho => rho_r % pw % cc3d - -!..FWFFT (real to g space) - CALL pw_fft_wrap ( rhob_r % pw ) - - rho = 0.0_dbl - - DO gpt = 1, grid1 % ngpts_cut - ghat => grid1 % g_hat ( :, gpt ) - - lp1 = grid1 % mapl % pos ( ghat ( 1 ) ) - ln1 = grid1 % mapl % neg ( ghat ( 1 ) ) - mp1 = grid1 % mapm % pos ( ghat ( 2 ) ) - mn1 = grid1 % mapm % neg ( ghat ( 2 ) ) - np1 = grid1 % mapn % pos ( ghat ( 3 ) ) - nn1 = grid1 % mapn % neg ( ghat ( 3 ) ) - - lp2 = grid2 % mapl % pos ( ghat ( 1 ) ) - ln2 = grid2 % mapl % neg ( ghat ( 1 ) ) - mp2 = grid2 % mapm % pos ( ghat ( 2 ) ) - mn2 = grid2 % mapm % neg ( ghat ( 2 ) ) - np2 = grid2 % mapn % pos ( ghat ( 3 ) ) - nn2 = grid2 % mapn % neg ( ghat ( 3 ) ) - - !*apsi - lp1 = lp1 + bds1 ( 1, 1 ) - mp1 = mp1 + bds1 ( 1, 2 ) - np1 = np1 + bds1 ( 1, 3 ) - ln1 = ln1 + bds1 ( 1, 1 ) - mn1 = mn1 + bds1 ( 1, 2 ) - nn1 = nn1 + bds1 ( 1, 3 ) - !*apsi - lp2 = lp2 + bds1 ( 1, 1 ) - mp2 = mp2 + bds1 ( 1, 2 ) - np2 = np2 + bds1 ( 1, 3 ) - ln2 = ln2 + bds1 ( 1, 1 ) - mn2 = mn2 + bds1 ( 1, 2 ) - nn2 = nn2 + bds1 ( 1, 3 ) - - rho ( lp2, mp2, np2 ) = rho ( lp2, mp2, np2 ) + rhob ( lp1, mp1, np1 ) - rho ( ln2, mn2, nn2 ) = rho ( ln2, mn2, nn2 ) + rhob ( ln1, mn1, nn1 ) - + DO k = 1, ns ( 3 ) + kk = pz ( k ) + DO j = 1, ns ( 2 ) + jj = py ( j ) + DO i = 1, ns ( 1 ) + ii = px ( i ) + rb ( ii, jj, kk ) = rb ( ii, jj, kk ) + rs ( i, j, k ) + END DO + END DO END DO - rho = rho * grid1 % vol +END SUBROUTINE dg_add_patch_folded -!..BWFFT ( g to real space ) - CALL pw_fft_wrap ( rho_r % pw ) +!****************************************************************************** -END SUBROUTINE dg_get_rho_tot +SUBROUTINE dg_int_patch_simple ( rbx, rby, rbz, rs, f, ns, nc ) + + IMPLICIT NONE + +! Arguments + REAL ( dbl ), DIMENSION (:,:,:), INTENT ( IN ) :: rbx, rby, rbz, rs + REAL ( dbl ), DIMENSION ( 3 ), INTENT ( OUT ) :: f + INTEGER, INTENT ( IN ) :: ns ( 3 ), nc ( 3 ) + +! LOCAL + INTEGER :: i, j, k, ii, jj, kk + REAL ( dbl ) :: s + +!------------------------------------------------------------------------------ + + f = 0._dbl + DO k = 1, ns ( 3 ) + kk = nc ( 3 ) + k + DO j = 1, ns ( 2 ) + jj = nc ( 2 ) + j + DO i = 1, ns ( 1 ) + ii = nc ( 1 ) + i + s = rs ( i, j, k ) + f ( 1 ) = f ( 1 ) + s * rbx ( ii, jj, kk ) + f ( 2 ) = f ( 2 ) + s * rby ( ii, jj, kk ) + f ( 3 ) = f ( 3 ) + s * rbz ( ii, jj, kk ) + END DO + END DO + END DO + +END SUBROUTINE dg_int_patch_simple + +!****************************************************************************** + +SUBROUTINE dg_int_patch_folded ( rbx, rby, rbz, rs, f, ns, px, py, pz ) + + IMPLICIT NONE + +! Arguments + REAL ( dbl ), DIMENSION (:,:,:), INTENT ( IN ) :: rbx, rby, rbz, rs + REAL ( dbl ), DIMENSION ( 3 ), INTENT ( INOUT ) :: f + INTEGER, INTENT ( IN ) :: ns ( 3 ) + INTEGER, DIMENSION ( : ), INTENT ( IN ) :: px, py, pz + +! LOCAL + INTEGER :: i, j, k, ii, jj, kk + REAL ( dbl ) :: s + +!------------------------------------------------------------------------------ + + f = 0._dbl + DO k = 1, ns ( 3 ) + kk = pz ( k ) + DO j = 1, ns ( 2 ) + jj = py ( j ) + DO i = 1, ns ( 1 ) + ii = px ( i ) + s = rs ( i, j, k ) + f ( 1 ) = f ( 1 ) + s * rbx ( ii, jj, kk ) + f ( 2 ) = f ( 2 ) + s * rby ( ii, jj, kk ) + f ( 3 ) = f ( 3 ) + s * rbz ( ii, jj, kk ) + END DO + END DO + END DO + +END SUBROUTINE dg_int_patch_folded !****************************************************************************** diff --git a/src/diis.F b/src/diis.F new file mode 100644 index 0000000000..dd0f3977b2 --- /dev/null +++ b/src/diis.F @@ -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 diff --git a/src/dump.F b/src/dump.F index 7f6a64c274..21daf3e9a5 100644 --- a/src/dump.F +++ b/src/dump.F @@ -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 diff --git a/src/eigenvalueproblems.F b/src/eigenvalueproblems.F index e7760df164..42e9196cc9 100644 --- a/src/eigenvalueproblems.F +++ b/src/eigenvalueproblems.F @@ -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 + +!****************************************************************************** diff --git a/src/ewald_parameters_types.F b/src/ewald_parameters_types.F index cc8a2ee569..3e4af816ac 100644 --- a/src/ewald_parameters_types.F +++ b/src/ewald_parameters_types.F @@ -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 diff --git a/src/ewalds.F b/src/ewalds.F index bbe8bd5698..22f691dc31 100644 --- a/src/ewalds.F +++ b/src/ewalds.F @@ -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 + !!***** !****************************************************************************** diff --git a/src/external_potential_types.F b/src/external_potential_types.F index 7e35fc7f6a..12ff4a676c 100644 --- a/src/external_potential_types.F +++ b/src/external_potential_types.F @@ -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) diff --git a/src/fft_tools.F b/src/fft_tools.F index 1a301f99ef..67281a8832 100644 --- a/src/fft_tools.F +++ b/src/fft_tools.F @@ -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 diff --git a/src/fist_debug.F b/src/fist_debug.F index df5051806c..bf5ca33557 100644 --- a/src/fist_debug.F +++ b/src/fist_debug.F @@ -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)?' diff --git a/src/fist_force.F b/src/fist_force.F index 723d6e0c39..deb58b15e1 100644 --- a/src/fist_force.F +++ b/src/fist_force.F @@ -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 ) diff --git a/src/fist_force_numer.F b/src/fist_force_numer.F index fae3253442..a89a0af13d 100644 --- a/src/fist_force_numer.F +++ b/src/fist_force_numer.F @@ -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 ) diff --git a/src/fist_input.F b/src/fist_input.F deleted file mode 100644 index 2800004938..0000000000 --- a/src/fist_input.F +++ /dev/null @@ -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 - -!****************************************************************************** diff --git a/src/fist_nonbond_force.F b/src/fist_nonbond_force.F index 2bc0b8c939..8cb34e17ff 100644 --- a/src/fist_nonbond_force.F +++ b/src/fist_nonbond_force.F @@ -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 ) diff --git a/src/force_control.F b/src/force_control.F index e74dcb0234..2386e61740 100644 --- a/src/force_control.F +++ b/src/force_control.F @@ -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 !!***** !****************************************************************************** diff --git a/src/global_types.F b/src/global_types.F index b53880d0be..ab4773f2a5 100644 --- a/src/global_types.F +++ b/src/global_types.F @@ -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 diff --git a/src/greens_fn.F b/src/greens_fn.F index 8c47b7ddd1..24fe869494 100644 --- a/src/greens_fn.F +++ b/src/greens_fn.F @@ -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 + !!***** !****************************************************************************** diff --git a/src/hartree.F b/src/hartree.F index 3cb82b506a..2747ca5c56 100644 --- a/src/hartree.F +++ b/src/hartree.F @@ -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 + +!****************************************************************************** diff --git a/src/initialize_pimd_types.F b/src/initialize_pimd_types.F new file mode 100644 index 0000000000..bff67f35a3 --- /dev/null +++ b/src/initialize_pimd_types.F @@ -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 + +!****************************************************************************** diff --git a/src/input_utilities.F b/src/input_utilities.F index a527fe9c4e..249389ce71 100644 --- a/src/input_utilities.F +++ b/src/input_utilities.F @@ -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,& diff --git a/src/integrate_potential.F b/src/integrate_potential.F new file mode 100644 index 0000000000..db336e0984 --- /dev/null +++ b/src/integrate_potential.F @@ -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 diff --git a/src/integrator.F b/src/integrator.F index c7dc0c716e..39d495bda7 100644 --- a/src/integrator.F +++ b/src/integrator.F @@ -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 diff --git a/src/interactions.F b/src/interactions.F index 60dbc29f62..c96fc4ae25 100644 --- a/src/interactions.F +++ b/src/interactions.F @@ -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 diff --git a/src/lapack.F b/src/lapack.F index d4299396da..9df4cb36d5 100644 --- a/src/lapack.F +++ b/src/lapack.F @@ -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 + !!***** +!****************************************************************************** diff --git a/src/lib/fast.F b/src/lib/fast.F new file mode 100644 index 0000000000..b2355d3758 --- /dev/null +++ b/src/lib/fast.F @@ -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 + +!-----------------------------------------------------------------------------! + diff --git a/src/lib/fftpre.F b/src/lib/fftpre.F index ac0fb978c8..7819455585 100644 --- a/src/lib/fftpre.F +++ b/src/lib/fftpre.F @@ -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 diff --git a/src/lib/fftrot.F b/src/lib/fftrot.F index 6d8434e84b..a389b84d3d 100644 --- a/src/lib/fftrot.F +++ b/src/lib/fftrot.F @@ -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 diff --git a/src/lib/fftstp.F b/src/lib/fftstp.F index b2d8df15ff..8810697e28 100644 --- a/src/lib/fftstp.F +++ b/src/lib/fftstp.F @@ -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 diff --git a/src/lib/mltfftsg.F b/src/lib/mltfftsg.F index cad4e920cc..60b6ddd3b4 100644 --- a/src/lib/mltfftsg.F +++ b/src/lib/mltfftsg.F @@ -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 diff --git a/src/library_tests.F b/src/library_tests.F index e7f50201b9..a49fc15734 100644 --- a/src/library_tests.F +++ b/src/library_tests.F @@ -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 ) diff --git a/src/linear_systems.F b/src/linear_systems.F new file mode 100644 index 0000000000..221d17cc33 --- /dev/null +++ b/src/linear_systems.F @@ -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 + +!****************************************************************************** diff --git a/src/linklist_cell_list.F b/src/linklist_cell_list.F index 88b5954a9f..61fdba0421 100644 --- a/src/linklist_cell_list.F +++ b/src/linklist_cell_list.F @@ -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) diff --git a/src/machine_t3e.F b/src/machine_t3e.F index f5ecc0bab1..fb907fbb99 100644 --- a/src/machine_t3e.F +++ b/src/machine_t3e.F @@ -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 diff --git a/src/mathlib.F b/src/mathlib.F index d18d0b403b..e128e4f141 100644 --- a/src/mathlib.F +++ b/src/mathlib.F @@ -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 ! ***************************************************************************** diff --git a/src/matrix_types.F b/src/matrix_types.F index 21facc749b..380ecc8e0d 100644 --- a/src/matrix_types.F +++ b/src/matrix_types.F @@ -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 diff --git a/src/md.F b/src/md.F index 62fb0ab811..62eebf27ae 100644 --- a/src/md.F +++ b/src/md.F @@ -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 diff --git a/src/memory_utilities.F b/src/memory_utilities.F index 804cc113e8..0220de39cb 100644 --- a/src/memory_utilities.F +++ b/src/memory_utilities.F @@ -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) diff --git a/src/message_passing.F b/src/message_passing.F index 544ce092d2..823b058034 100644 --- a/src/message_passing.F +++ b/src/message_passing.F @@ -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 !****************************************************************************** diff --git a/src/mo_types.F b/src/mo_types.F new file mode 100644 index 0000000000..962b5956b5 --- /dev/null +++ b/src/mo_types.F @@ -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 diff --git a/src/nl.F b/src/nl.F index 8ac815f0ee..15a4c13eb0 100644 --- a/src/nl.F +++ b/src/nl.F @@ -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 diff --git a/src/nl_utilities.F b/src/nl_utilities.F index b2ff0e1a7e..1f5f61f463 100644 --- a/src/nl_utilities.F +++ b/src/nl_utilities.F @@ -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) diff --git a/src/om_utilities.F b/src/om_utilities.F index 747b0ecd37..6c86faa9d6 100644 --- a/src/om_utilities.F +++ b/src/om_utilities.F @@ -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,& diff --git a/src/orbital_pointers.F b/src/orbital_pointers.F index c2d26d2d1b..164a875bd9 100644 --- a/src/orbital_pointers.F +++ b/src/orbital_pointers.F @@ -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) diff --git a/src/pme.F b/src/pme.F index edc585f6e4..1f9bfeab6d 100644 --- a/src/pme.F +++ b/src/pme.F @@ -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 + +!****************************************************************************** diff --git a/src/print_keys.F b/src/print_keys.F index 8e431ddd2a..aaed287470 100644 --- a/src/print_keys.F +++ b/src/print_keys.F @@ -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 diff --git a/src/pw_grid_types.F b/src/pw_grid_types.F index 1ad8d5e74e..c9e231deaa 100644 --- a/src/pw_grid_types.F +++ b/src/pw_grid_types.F @@ -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 diff --git a/src/pw_grids.F b/src/pw_grids.F index 751f9e747d..c780782a87 100644 --- a/src/pw_grids.F +++ b/src/pw_grids.F @@ -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 ) diff --git a/src/pw_types.F b/src/pw_types.F index 5f808578e9..251d23a2a0 100644 --- a/src/pw_types.F +++ b/src/pw_types.F @@ -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 !****************************************************************************** diff --git a/src/pw_xc.F b/src/pw_xc.F index 28219c3d91..1292c2960c 100644 --- a/src/pw_xc.F +++ b/src/pw_xc.F @@ -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 ) diff --git a/src/pws.F b/src/pws.F index 19f39d473b..ed70f7bf4f 100644 --- a/src/pws.F +++ b/src/pws.F @@ -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 !****************************************************************************** diff --git a/src/qs_main.F b/src/qs_main.F new file mode 100644 index 0000000000..3ec9ae82e1 --- /dev/null +++ b/src/qs_main.F @@ -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 diff --git a/src/qs_scf.F b/src/qs_scf.F new file mode 100644 index 0000000000..ba4820ffd4 --- /dev/null +++ b/src/qs_scf.F @@ -0,0 +1,1088 @@ +!-----------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright (C) 1999 MPI fuer Festkoerperforschung, Stuttgart ! +!-----------------------------------------------------------------------------! +!!****** cp2k/qs_scf [1.0] * +!! +!! NAME +!! qs_scf +!! +!! FUNCTION +!! Routines for the Quickstep SCF run. +!! +!! AUTHOR +!! Matthias Krack (30.04.2001) +!! +!! MODIFICATION HISTORY +!! none +!! +!! SOURCE +!****************************************************************************** + +MODULE qs_scf + +! ***************************************************************************** + + 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,maxlcgf + USE coefficient_types, ONLY: coeff_allocate,& + coeff_type,& + coeff_zero + USE core_hamiltonian, ONLY: build_core_hamiltonian_matrix,h,s + USE diis, ONLY: eps_diis,max_diis,scf_diis + USE functionals, ONLY: init_functionals,vwn_c,vwn_x + USE global_types, ONLY: global_environment_type + USE input_utilities, ONLY: finish_input_session,& + read_object,& + search,& + start_input_session + USE mathlib, ONLY: diagonalize_matrix,& + power_matrix,& + symmetrize_matrix + USE matrix_types, ONLY: allocate_matrix,& + copy_matrix,& + first_block_node,& + get_block_node,& + get_matrix_info,& + next_block_node,& + real_block_node_type,& + real_matrix_set_type,& + replicate_matrix_structure + USE memory_utilities, ONLY: reallocate + USE mo_types, ONLY: allocate_mo_set,& + mo_set_type,& + read_mo_set,& + write_mo_set + USE om_utilities, ONLY: write_spherical_matrix + USE pw_grid_types, ONLY: HALFSPACE,pw_grid_type + USE pw_grids, ONLY: pw_find_cutoff,& + pw_grid_construct,& + pw_grid_setup + USE pw_types, ONLY: COMPLEXDATA3D,REALDATA3D,REALSPACE,& + RECIPROCALSPACE,pw_fft_wrap,pw_type + USE string_utilities, ONLY: uppercase + USE termination, ONLY: stop_program + USE timings, ONLY: timeset,timestop + USE timesl, ONLY: cputime + + IMPLICIT NONE + + PRIVATE + + TYPE(coeff_type) :: rho_gspace,rho_rspace,v_rspace + TYPE(mo_set_type) :: alpha_mo + TYPE(real_matrix_set_type) :: ks,ortho,p,scf_work1,scf_work2 + TYPE(pw_grid_type) :: pw_grid + + CHARACTER(LEN=10) :: density_guess = "CORE" + REAL(wp) :: ec = 0.0_wp,& + ecore = 0.0_wp,& + ecore_overlap = 0.0_wp,& + ecore_self = 0.0_wp,& + ehartree = 0.0_wp,& + eps_scf = 1.0E-5_wp,& + etotal = 0.0_wp,& + ex = 0.0_wp,& + p_mix = 0.4_wp,& + total_rho_core_rspace = 0.0_wp,& + total_rho_elec_rspace = 0.0_wp,& + total_rho_gspace = 0.0_wp,& + total_rho_rspace = 0.0_wp + INTEGER :: max_scf = 50,& + nelectron = 0 + +! *** Public variables *** + + PUBLIC :: nelectron + +! *** Public subroutines *** + + PUBLIC :: read_scf_parameters,& + scf,& + write_scf_parameters + +! ***************************************************************************** + +CONTAINS + +! ***************************************************************************** + + SUBROUTINE scf(globenv) + + TYPE(global_environment_type), INTENT(IN) :: globenv + +! *** Local parameters *** + + CHARACTER(LEN=*), PARAMETER :: routine =& + "SUBROUTINE scf (MODULE qs_scf)" + +! *** Local variables *** + + REAL(wp) :: delta,diis_error,t1,t2 + INTEGER :: handle,iscf,output_unit + LOGICAL :: diis_step + + REAL(wp), DIMENSION(:,:), POINTER :: scf_work1_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("scf","I","",handle) + + output_unit = globenv%scr + +! *** Quick return, if no SCF iteration is requested *** + + IF (max_scf < 1) RETURN + + CALL init_functionals() + + CALL init_grid(globenv) + + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,FMT="(/,/,T2,A)")& + "SCF WAVEFUNCTION OPTIMIZATION" + END IF + + CALL init_scf_run(globenv,alpha_mo) + + CALL get_block_node(matrix=scf_work1%matrix,& + block_row=1,& + block_col=1,& + block=scf_work1_matrix) + + etotal = 0.0_wp + iscf = 0 + diis_step = .FALSE. + + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,& + FMT="(/,T3,A,T9,A,T34,A,T49,A,T68,A,/,T3,A)")& + "Step","Update method","Time","Convergence","Total energy",& + REPEAT("-",77) + END IF + + DO + + iscf = iscf + 1 + + t1 = cputime() + + IF (globenv%print%density_matrix.AND.globenv%print%each_scf_step) THEN + CALL write_spherical_matrix(p%matrix,4,6,globenv) + END IF + + CALL build_kohn_sham_matrix(globenv) + + IF (globenv%print%kohn_sham_matrix.AND.globenv%print%each_scf_step) THEN + CALL write_spherical_matrix(ks%matrix,4,6,globenv) + END IF + + scf_work1_matrix(:,:) = 0.0_wp + CALL copy_matrix(ks%matrix,scf_work1%matrix) + CALL symmetrize_matrix(scf_work1_matrix,"upper_to_lower") + + IF (iscf > 1) THEN + CALL scf_diis(globenv,alpha_mo,scf_work1,scf_work2,delta,diis_error,& + diis_step) + END IF + + CALL orthogonalize_matrix(ortho,scf_work1,scf_work2) + + CALL eigensolver(scf_work1,alpha_mo,ortho) + + IF (globenv%print%each_scf_step) THEN + CALL write_mo_set(alpha_mo,4,6,globenv) + END IF + + CALL calculate_density_matrix(alpha_mo,scf_work1) + + CALL copy_matrix(scf_work1%matrix,ks%matrix) + + t2 = cputime() + + IF (diis_step) THEN + CALL density_mixing(ks,p,1.0_wp,delta) + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,& + FMT="(T2,I5,2X,A,T15,E10.2,T30,F8.2,T40,2F20.10)")& + iscf,"DIIS",diis_error,t2 - t1,delta,etotal + END IF + ELSE + CALL density_mixing(ks,p,p_mix,delta) + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,& + FMT="(T2,I5,2X,A,T15,F6.2,T30,F8.2,T40,2F20.10)")& + iscf,"Mixing",p_mix,t2 - t1,delta,etotal + END IF + END IF + + IF (delta < eps_scf) THEN + IF (globenv%print%scf) THEN + WRITE(UNIT=output_unit,FMT="(/,T3,A,/)")& + "*** SCF run converged ***" + END IF + IF (.NOT.diis_step) CALL copy_matrix(ks%matrix,p%matrix) + EXIT + ELSE IF (iscf == max_scf) THEN + IF (globenv%print%scf) THEN + WRITE(UNIT=output_unit,FMT="(/,T3,A,/)")& + "*** SCF run NOT converged ***" + END IF + EXIT + END IF + + END DO + + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,FMT="(/,(T3,A,T40,2F20.10))")& + "Total electronic density (r-space): ",& + total_rho_elec_rspace,total_rho_elec_rspace + REAL(nelectron,wp),& + "Total core charge density (r-space):",& + total_rho_core_rspace,total_rho_core_rspace - REAL(nelectron,wp) + WRITE (UNIT=output_unit,FMT="(T3,A,T60,F20.10)")& + "Total charge density (r-space): ",total_rho_rspace,& + "Total charge density (g-space): ",total_rho_gspace + WRITE (UNIT=output_unit,FMT="(/,(T3,A,T60,F20.10))")& + "Overlap energy of the core charge distribution:",ecore_overlap,& + "Self energy of the core charge distribution: ",ecore_self,& + "Core Hamiltonian energy: ",ecore,& + "Hartree energy: ",ehartree,& + "Exchange-correlation energy: ",ex + ec,& + "Total energy: ",etotal + END IF + +! *** Undo mixing of the density matrix (restore original density) *** + + IF (.NOT.diis_step) CALL copy_matrix(ks%matrix,p%matrix) + + CALL write_mo_set(alpha_mo,4,6,globenv) + + IF (globenv%print%density_matrix) THEN + CALL write_spherical_matrix(p%matrix,4,6,globenv) + END IF + + IF (globenv%print%kohn_sham_matrix) THEN + CALL build_kohn_sham_matrix(globenv) + CALL write_spherical_matrix(ks%matrix,4,6,globenv) + END IF + +! *** Write restart file *** + + CALL write_mo_set(alpha_mo,globenv) + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE scf + +! ***************************************************************************** + + SUBROUTINE build_kohn_sham_matrix(globenv) + + USE collocate_density, ONLY: calculate_rho_core,& + calculate_rho_elec,& + calculate_total_rho + USE core_energies, ONLY: calculate_ecore + USE integrate_potential, ONLY: integrate_v_rspace + USE print_keys, ONLY: DEBUG + + TYPE(global_environment_type), INTENT(IN) :: globenv + +! *** Local variables *** + + INTEGER :: handle,nproduct,output_unit + +! --------------------------------------------------------------------------- + + CALL timeset("build_kohn_sham_matrix","I","",handle) + + output_unit = globenv%scr + + CALL calculate_ecore(h,p,ecore) + + CALL coeff_zero(rho_rspace) + + CALL calculate_rho_elec(p,rho_rspace,total_rho_elec_rspace,nproduct) + + IF (globenv%print%total_densities) THEN + WRITE (UNIT=output_unit,FMT="(/,T3,A,I10)")& + "Number of collocated products (r-space):",nproduct + END IF + + CALL coeff_zero(v_rspace) + + CALL calculate_xc_potential(rho_rspace%pw,v_rspace%pw) + + CALL calculate_rho_core(rho_rspace,total_rho_rspace) + + total_rho_core_rspace = total_rho_rspace - total_rho_elec_rspace + + CALL pw_fft_wrap(rho_rspace%pw,rho_gspace%pw,& + debug=(globenv%print%level == DEBUG)) + + total_rho_gspace = calculate_total_rho(rho_gspace) + + IF (globenv%print%total_densities) THEN + WRITE (UNIT=output_unit,FMT="(/,(T3,A,T40,2F20.10))")& + "Total electronic density (r-space): ",& + total_rho_elec_rspace,total_rho_elec_rspace + REAL(nelectron,wp),& + "Total core charge density (r-space):",& + total_rho_core_rspace,total_rho_core_rspace - REAL(nelectron,wp) + WRITE (UNIT=output_unit,FMT="(T3,A,T60,F20.10)")& + "Total charge density (r-space): ",total_rho_rspace,& + "Total charge density (g-space): ",total_rho_gspace + END IF + + CALL calculate_hartree_potential(rho_gspace) + + etotal = ecore_overlap + ecore_self + ecore + ehartree + ex + ec + + IF (globenv%print%scf_energies) THEN + WRITE (UNIT=output_unit,FMT="(/,(T3,A,T60,F20.10))")& + "Overlap energy of the core charge distribution:",ecore_overlap,& + "Self energy of the core charge distribution: ",ecore_self,& + "Core Hamiltonian energy: ",ecore,& + "Hartree energy: ",ehartree,& + "Exchange-correlation energy: ",ex + ec + END IF + + CALL pw_fft_wrap(rho_gspace%pw,rho_rspace%pw,& + debug=(globenv%print%level == DEBUG)) + + v_rspace%pw%cr3d(:,:,:) = v_rspace%pw%pw_grid%dvol*& + (v_rspace%pw%cr3d(:,:,:) +& + rho_rspace%pw%cr3d(:,:,:)) + + CALL copy_matrix(h%matrix,ks%matrix) + + CALL integrate_v_rspace(v_rspace,ks,nproduct) + + IF (globenv%print%total_densities) THEN + WRITE (UNIT=output_unit,FMT="(/,T3,A,I10)")& + "Number of integrated products (r-space):",nproduct + END IF + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE build_kohn_sham_matrix + +! ***************************************************************************** + + SUBROUTINE init_grid(globenv) + + USE cell_parameters, ONLY: abc,cell,cutoff + + TYPE(global_environment_type), INTENT(IN) :: globenv + +! *** Local variables *** + + INTEGER :: handle,output_unit + +! --------------------------------------------------------------------------- + + CALL timeset("init_grid","I","",handle) + + output_unit = globenv%scr + + CALL pw_grid_construct(pw_grid) + + pw_grid%grid_span = HALFSPACE + + IF (globenv%print%pw_grid_information) THEN + CALL pw_grid_setup(cell,pw_grid,cutoff,info=output_unit,& + orthorhombic=.TRUE.) + ELSE + CALL pw_grid_setup(cell,pw_grid,cutoff,orthorhombic=.TRUE.) + END IF + + CALL coeff_allocate(rho_rspace,pw_grid,REALDATA3D) + rho_rspace%pw%in_space = REALSPACE + + CALL coeff_allocate(rho_gspace,pw_grid,COMPLEXDATA3D) + rho_gspace%pw%in_space = RECIPROCALSPACE + + CALL coeff_allocate(v_rspace,pw_grid,REALDATA3D) + v_rspace%pw%in_space = REALSPACE + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE init_grid + +! ***************************************************************************** + + SUBROUTINE init_scf_run(globenv,mo) + +! Purpose: Initialize a SCF run. + +! History: - Creation (30.04.2001, Matthias Krack) + +! *************************************************************************** + + USE core_energies, ONLY: calculate_ecore_overlap,& + calculate_ecore_self + + TYPE(global_environment_type), INTENT(IN) :: globenv + TYPE(mo_set_type), INTENT(OUT) :: mo + +! *** Local parameters *** + + CHARACTER(LEN=*), PARAMETER :: routine =& + "SUBROUTINE init_scf_run (MODULE qs_scf)" + +! *** Local variables *** + + CHARACTER(LEN=40) :: symmetry + INTEGER :: handle,homo,ikind,nao,ndep,nmo,output_unit + +! --------------------------------------------------------------------------- + + CALL timeset("init_scf_run","I","",handle) + + output_unit = globenv%scr + + nelectron = 0 + + DO ikind=1,nkind + nelectron = nelectron + kind_info(ikind)%natom*kind_info(ikind)%zeff + END DO + + IF (MODULO(nelectron,2) == 0) THEN + homo = nelectron/2 + ELSE + CALL stop_program(routine,"Odd number of electrons") + END IF + +! *** Get the dimension of the full SCF matrices, *** +! *** i.e. the total number of atomic orbitals *** + + CALL get_matrix_info(matrix=h%matrix,& + nrow=nao,& + matrix_symmetry=symmetry) + + nmo = nao +!MK nmo = homo + + CALL allocate_mo_set(mo,nao,nmo) + + mo%homo = homo + mo%occupation_numbers(1:homo) = 2.0_wp + +! *** Allocate the full SCF matrices *** + + NULLIFY (ortho%matrix) + CALL allocate_matrix(matrix=ortho%matrix,& + nrow=nao,& + ncol=nao,& + matrix_name="ORTHOGONALIZATION MATRIX",& + matrix_symmetry=symmetry) + + NULLIFY (scf_work1%matrix) + CALL allocate_matrix(matrix=scf_work1%matrix,& + nrow=nao,& + ncol=nao,& + matrix_name="SCF WORK MATRIX 1",& + matrix_symmetry="none") + + NULLIFY (scf_work2%matrix) + CALL allocate_matrix(matrix=scf_work2%matrix,& + nrow=nao,& + ncol=nao,& + matrix_name="SCF WORK MATRIX 2",& + matrix_symmetry="none") + + NULLIFY (ks%matrix) + CALL replicate_matrix_structure(h%matrix,ks%matrix,"KOHN-SHAM MATRIX") + NULLIFY (p%matrix) + CALL replicate_matrix_structure(h%matrix,p%matrix,"DENSITY MATRIX") + + CALL calculate_ecore_self(ecore_self) + CALL calculate_ecore_overlap(ecore_overlap) + + IF (globenv%print%scf_energies) THEN + WRITE (UNIT=output_unit,FMT="(/,(T3,A,T60,F20.10))")& + "Self energy of the core charge distribution: ",ecore_self,& + "Overlap energy of the core charge distribution:",ecore_overlap + END IF + + CALL calculate_ortho_matrix(ortho,scf_work1,ndep) + + IF (globenv%print%scf) THEN + WRITE (UNIT=output_unit,FMT="(/,(T3,A,I10))")& + "Number of electrons: ",nelectron,& + "Number of occupied orbitals: ",homo,& + "Number of orbital functions: ",nao,& + "Number of independent orbital functions:",nao - ndep + END IF + + IF (globenv%print%ortho_matrix) THEN + CALL write_spherical_matrix(ortho%matrix,4,6,globenv) + END IF + + CALL calculate_first_density_matrix(ortho,mo,p,scf_work1,scf_work2,globenv) + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE init_scf_run + +! ***************************************************************************** + + SUBROUTINE calculate_ortho_matrix(ortho,work,ndep) + + TYPE(real_matrix_set_type), INTENT(OUT) :: ortho + TYPE(real_matrix_set_type), INTENT(INOUT) :: work + INTEGER, INTENT(OUT) :: ndep + +! *** Local variables *** + + INTEGER :: handle,nao + + REAL(wp), DIMENSION(:,:), POINTER :: ortho_matrix,work_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("calculate_ortho_matrix","I","",handle) + + CALL get_matrix_info(matrix=ortho%matrix,nrow=nao) + + CALL get_block_node(matrix=ortho%matrix,& + block_row=1,& + block_col=1,& + block=ortho_matrix) + + CALL get_block_node(matrix=work%matrix,& + block_row=1,& + block_col=1,& + block=work_matrix) + +! *** Calculate the orthogonalization matrix (S**(-1/2)) *** + + work_matrix(:,:) = 0.0_wp + + CALL copy_matrix(s%matrix,work%matrix) + + CALL symmetrize_matrix(work_matrix,"upper_to_lower") + + CALL power_matrix(work_matrix,ortho_matrix,-0.5_wp,1.0E-5_wp,ndep,.FALSE.) + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE calculate_ortho_matrix + +! ***************************************************************************** + + SUBROUTINE orthogonalize_matrix(ortho,ks,work) + + TYPE(real_matrix_set_type), INTENT(IN) :: ortho + TYPE(real_matrix_set_type), INTENT(INOUT) :: ks,work + +! *** Local variables *** + + INTEGER :: handle,nao + + REAL(wp), DIMENSION(:,:), POINTER :: ks_matrix,ortho_matrix,work_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("orthogonalize_matrix","I","",handle) + + CALL get_matrix_info(matrix=ks%matrix,nrow=nao) + + CALL get_block_node(matrix=ks%matrix,& + block_row=1,& + block_col=1,& + block=ks_matrix) + + CALL get_block_node(matrix=ortho%matrix,& + block_row=1,& + block_col=1,& + block=ortho_matrix) + + CALL get_block_node(matrix=work%matrix,& + block_row=1,& + block_col=1,& + block=work_matrix) + + CALL dgemm("T","N",nao,nao,nao,1.0_wp,ks_matrix,nao,ortho_matrix,nao,& + 0.0_wp,work_matrix,nao) + + CALL dgemm("N","N",nao,nao,nao,1.0_wp,ortho_matrix,nao,work_matrix,nao,& + 0.0_wp,ks_matrix,nao) + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE orthogonalize_matrix + +! ***************************************************************************** + + SUBROUTINE eigensolver(ks,mo,ortho) + + TYPE(real_matrix_set_type), INTENT(IN) :: ortho + TYPE(real_matrix_set_type), INTENT(INOUT) :: ks + TYPE(mo_set_type), INTENT(INOUT) :: mo + +! *** Local variables *** + + INTEGER :: handle,nao,nmo + + REAL(wp), DIMENSION(:,:), POINTER :: ks_matrix,mo_eigenvectors,ortho_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("eigensolver","I","",handle) + + CALL get_matrix_info(matrix=mo%eigenvectors%matrix,nrow=nao,ncol=nmo) + + CALL get_block_node(matrix=ks%matrix,& + block_row=1,& + block_col=1,& + block=ks_matrix) + + CALL get_block_node(matrix=mo%eigenvectors%matrix,& + block_row=1,& + block_col=1,& + block=mo_eigenvectors) + + CALL get_block_node(matrix=ortho%matrix,& + block_row=1,& + block_col=1,& + block=ortho_matrix) + +! CALL diagonalize_matrix(ks_matrix,mo_eigenvectors,mo%eigenvalues) +! CALL dgemm("N","N",nao,nmo,nao,1.0_wp,ortho_matrix,nao,mo_eigenvectors,& +! nao,0.0_wp,ks_matrix,nao) +! mo_eigenvectors(:,:) = ks_matrix(:,:) + + CALL diagonalize_matrix(ks_matrix,mo%eigenvalues,.FALSE.) + + CALL dgemm("N","N",nao,nmo,nao,1.0_wp,ortho_matrix,nao,ks_matrix,& + nao,0.0_wp,mo_eigenvectors,nao) + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE eigensolver + +! ***************************************************************************** + + SUBROUTINE calculate_density_matrix(mo,density) + + TYPE(real_matrix_set_type), INTENT(OUT) :: density + TYPE(mo_set_type), INTENT(IN) :: mo + +! *** Local variables *** + + INTEGER :: handle,nao + + REAL(wp), DIMENSION(:,:), POINTER :: mo_eigenvectors,density_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("calculate_density_matrix","I","",handle) + + CALL get_matrix_info(matrix=mo%eigenvectors%matrix,nrow=nao) + + CALL get_block_node(matrix=mo%eigenvectors%matrix,& + block_row=1,& + block_col=1,& + block=mo_eigenvectors) + + CALL get_block_node(matrix=density%matrix,& + block_row=1,& + block_col=1,& + block=density_matrix) + + CALL dsyrk("U","N",nao,mo%homo,2.0_wp,mo_eigenvectors,nao,0.0_wp,& + density_matrix,nao) + + CALL symmetrize_matrix(density_matrix,"upper_to_lower") + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE calculate_density_matrix + +! ***************************************************************************** + + SUBROUTINE density_mixing(new_density,old_density,p_mix,delta) + + TYPE(real_matrix_set_type), INTENT(INOUT) :: new_density,old_density + REAL(wp), INTENT(IN) :: p_mix + REAL(wp), INTENT(OUT) :: delta + +! *** Local variables *** + + TYPE(real_block_node_type), POINTER :: new_p_block_node,old_p_block_node + REAL(wp) :: r_mix + INTEGER :: handle,i,iblock_row,j,nblock_row + + REAL(wp), DIMENSION(:,:), POINTER :: new_p_block,old_p_block + +! --------------------------------------------------------------------------- + + CALL timeset("density_mixing","I","",handle) + + delta = 0.0_wp + + r_mix = 1.0_wp - p_mix + + CALL get_matrix_info(matrix=old_density%matrix,nblock_row=nblock_row) + + DO iblock_row=1,nblock_row + + new_p_block_node => first_block_node(matrix=new_density%matrix,& + block_row=iblock_row) + old_p_block_node => first_block_node(matrix=old_density%matrix,& + block_row=iblock_row) + + DO WHILE (ASSOCIATED(old_p_block_node)) + + CALL get_block_node(block_node=new_p_block_node,& + block=new_p_block) + CALL get_block_node(block_node=old_p_block_node,& + block=old_p_block) + + DO j=1,SIZE(new_p_block,2) + DO i=1,SIZE(new_p_block,1) + new_p_block(i,j) = new_p_block(i,j) - old_p_block(i,j) + delta = MAX(delta,ABS(new_p_block(i,j))) + old_p_block(i,j) = old_p_block(i,j) + p_mix*new_p_block(i,j) + new_p_block(i,j) = old_p_block(i,j) + r_mix*new_p_block(i,j) + END DO + END DO + + new_p_block_node => next_block_node(new_p_block_node) + old_p_block_node => next_block_node(old_p_block_node) + + END DO + + END DO + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE density_mixing + +! ***************************************************************************** + + SUBROUTINE calculate_hartree_potential(rho) + + USE mathconstants, ONLY: fourpi,twopi + + TYPE(coeff_type), TARGET, INTENT(INOUT) :: rho + +! *** Local variables *** + + COMPLEX(wp) :: vhartree + REAL(wp) :: g2,gx,gy,gz + INTEGER :: handle,i,ig,j,jg,k,kg + + REAL(wp), DIMENSION(3) :: dg + + REAL(wp), DIMENSION(:), POINTER :: dr + INTEGER, DIMENSION(:), POINTER :: lb_grid,ng,ub_grid + + COMPLEX(wp), DIMENSION(:,:,:), POINTER :: grid + +! --------------------------------------------------------------------------- + + CALL timeset("calculate_hartree_potential","I","",handle) + + dr => rho%pw%pw_grid%dr(:) + ng => rho%pw%pw_grid%npts(:) + lb_grid => rho%pw%pw_grid%bounds(1,:) + ub_grid => rho%pw%pw_grid%bounds(2,:) + + dg(:) = twopi/(ng(:)*dr(:)) + + grid => rho%pw%cc3d(:,:,:) + + ehartree = 0.0_wp + + DO kg=lb_grid(3),ub_grid(3) + gz = REAL(kg,wp)*dg(3) + IF (kg < 0) THEN + k = kg + 1 + ng(3) + ELSE + k = kg + 1 + END IF + DO jg=lb_grid(2),ub_grid(2) + gy = REAL(jg,wp)*dg(2) + IF (jg < 0) THEN + j = jg + 1 + ng(2) + ELSE + j = jg + 1 + END IF + DO ig=lb_grid(1),ub_grid(1) + gx = REAL(ig,wp)*dg(1) + IF (ig < 0) THEN + i = ig + 1 + ng(1) + ELSE + i = ig + 1 + END IF + g2 = gx*gx + gy*gy + gz*gz + IF (g2 > 1.0E-12_wp) THEN +!!!write (*,"(3I6,2F15.6)") i,j,k,grid(i,j,k) + vhartree = fourpi*grid(i,j,k)/g2 + ehartree = ehartree + REAL(grid(i,j,k))*REAL(vhartree) +& + AIMAG(grid(i,j,k))*AIMAG(vhartree) + grid(i,j,k) = vhartree + END IF + END DO + END DO + END DO + + ehartree = 0.5_wp*rho%pw%pw_grid%vol*ehartree + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE calculate_hartree_potential + +! ***************************************************************************** + + SUBROUTINE calculate_xc_potential(rho,vxc) + + TYPE(pw_type), INTENT(IN) :: rho + TYPE(pw_type), INTENT(INOUT) :: vxc + +! *** Local variables *** + + INTEGER :: handle + +! --------------------------------------------------------------------------- + + CALL timeset("calculate_xc_potential","I","",handle) + + ex = 0.0_wp + ec = 0.0_wp + + CALL vwn_x(rho%cr3d,ex,vxc%cr3d) + CALL vwn_c(rho%cr3d,ec,vxc%cr3d) + + ex = rho%pw_grid%dvol*ex + ec = rho%pw_grid%dvol*ec + + CALL timestop(0.0_wp,handle) + + END SUBROUTINE calculate_xc_potential + +! ***************************************************************************** + + SUBROUTINE calculate_first_density_matrix(ortho,mo,p,work1,work2,globenv) + + TYPE(global_environment_type), INTENT(IN) :: globenv + TYPE(real_matrix_set_type), INTENT(IN) :: ortho + TYPE(real_matrix_set_type), INTENT(INOUT) :: p,work1,work2 + TYPE(mo_set_type), INTENT(INOUT) :: mo + +! *** Local variables *** + + TYPE(gto_basis_set_type), POINTER :: basis_set_a + + REAL(wp) :: paa + INTEGER :: atoma,first_sgfa,handle,iatom,ikind,iset,isgf,isgfa,ishell,la,& + last_sgfa,nelec,restart_unit + + INTEGER, DIMENSION(:), POINTER :: elec_conf + + REAL(wp), DIMENSION(:,:), POINTER :: work1_matrix,work2_matrix + +! --------------------------------------------------------------------------- + + CALL timeset("calculate_first_density_matrix","I","",handle) + +! *** Calculate an initial density guess (core Hamiltonian guess) *** + + CALL get_block_node(matrix=work1%matrix,& + block_row=1,& + block_col=1,& + block=work1_matrix) + + work1_matrix(:,:) = 0.0_wp + + IF (density_guess == "RESTART") THEN + + CALL read_mo_set(mo,globenv) + CALL calculate_density_matrix(mo,work1) + + ELSE IF (density_guess == "CORE") THEN + + CALL copy_matrix(h%matrix,work1%matrix) + CALL symmetrize_matrix(work1_matrix,"upper_to_lower") + CALL orthogonalize_matrix(ortho,work1,work2) + CALL eigensolver(work1,mo,ortho) + CALL calculate_density_matrix(mo,work1) + + ELSE IF (density_guess == "ATOMIC") THEN + + NULLIFY (elec_conf) + + elec_conf => reallocate(elec_conf,0,maxlcgf) + + DO ikind=1,nkind + + IF (ASSOCIATED(kind_info(ikind)%all_potential)) THEN + DO la=0,SIZE(kind_info(ikind)%elec_conf)-1 + elec_conf(la) = kind_info(ikind)%elec_conf(la) + END DO + ELSE IF (ASSOCIATED(kind_info(ikind)%gth_potential)) THEN + DO la=0,SIZE(kind_info(ikind)%gth_potential%elec_conf)-1 + elec_conf(la) = kind_info(ikind)%gth_potential%elec_conf(la) + END DO + END IF + + basis_set_a => kind_info(ikind)%orb_basis_set + + DO iset=1,basis_set_a%nset + DO ishell=1,basis_set_a%nshell(iset) + la = basis_set_a%l(ishell,iset) + nelec = 4*la + 2 + IF (elec_conf(la) > 0) THEN + IF (elec_conf(la) >= nelec) THEN + paa = 2.0_wp + elec_conf(la) = elec_conf(la) - nelec + ELSE + paa = REAL(2*elec_conf(la),wp)/REAL(nelec,wp) + elec_conf(la) = 0 + END IF + first_sgfa = basis_set_a%first_sgf(ishell,iset) + last_sgfa = basis_set_a%last_sgf(ishell,iset) + DO isgfa=first_sgfa,last_sgfa + DO iatom=1,kind_info(ikind)%natom + atoma = kind_info(ikind)%atom_list(iatom) + isgf = atom_info(atoma)%first_sgf + isgfa - 1 + work1_matrix(isgf,isgf) = paa + END DO + END DO + END IF + END DO + END DO + + END DO + + ELSE + + STOP "qs_scf: wrong keyword for guess" + + END IF + + CALL copy_matrix(work1%matrix,p%matrix) + + END SUBROUTINE calculate_first_density_matrix + +! ***************************************************************************** + + SUBROUTINE read_scf_parameters(start_section,end_section,globenv) + +! Purpose: Read the parameters for the SCF run. + +! History: - Creation (15.05.2001, Matthias Krack) + +! *************************************************************************** + + TYPE(global_environment_type), INTENT(INOUT) :: globenv + CHARACTER(LEN=*), INTENT(IN) :: start_section,end_section + +! *** Local parameters *** + + CHARACTER(LEN=*), PARAMETER :: routine =& + "SUBROUTINE read_scf_parameters (MODULE qs_scf)" + +! *** Local variables *** + + CHARACTER(LEN=40) :: keyword + LOGICAL :: found + +! --------------------------------------------------------------------------- + +! *** Load the default values *** + + density_guess = "CORE" + eps_scf = 1.0E-5_wp + eps_diis = 0.1_wp + max_diis = 4 + max_scf = 50 + p_mix = 0.4_wp + globenv%restart_file_name = "RESTART" + + CALL start_input_session(globenv%input_file_name,globenv) + +! *** Search for the requested input section *** + + CALL search(start_section,.TRUE.,found) + + IF (found) THEN + + DO + + CALL read_object(keyword,skip_lines=1) + + CALL uppercase(keyword) + + SELECT CASE (TRIM(keyword)) + CASE ("DENSITY_GUESS","SCF_GUESS","GUESS") + CALL read_object(density_guess) + CALL uppercase(density_guess) + CASE ("DENSITY_MIXING","MIXING") + CALL read_object(p_mix) + CASE ("EPS_DIIS") + CALL read_object(eps_diis) + CASE ("EPS_SCF") + CALL read_object(eps_scf) + CASE ("MAX_DIIS") + CALL read_object(max_diis) + CASE ("MAX_SCF") + CALL read_object(max_scf) + CASE ("RESTART_FILE_NAME","RESTART_FILE","RESTART") + CALL read_object(globenv%restart_file_name) + CASE DEFAULT + IF (keyword == end_section) THEN + EXIT + ELSE + CALL stop_program(routine,& + "Invalid keyword <"//TRIM(keyword)//& + "> found in the input section <"//& + TRIM(start_section)//">") + END IF + END SELECT + + END DO + + END IF + + CALL finish_input_session + + END SUBROUTINE read_scf_parameters + +! ***************************************************************************** + + SUBROUTINE write_scf_parameters(lunit) + +! Purpose: Write the parameters for the SCF run to the logical unit number +! "lunit". + +! *************************************************************************** + + INTEGER, INTENT(IN) :: lunit + +! --------------------------------------------------------------------------- + + IF (max_scf < 1) RETURN + + WRITE (lunit,"(/,/,T2,A,/)") "SCF PARAMETERS" + + WRITE (lunit,"(T3,A,/,T3,A,I5,/,T3,A,ES9.2,/,T3,A,F5.2)")& + "density guess: "//TRIM(density_guess),& + "max_scf: ",max_scf,& + "eps_scf: ",eps_scf,& + "p_mix: ",p_mix + + IF (max_diis > 0) THEN + WRITE (lunit,"(T3,A,I5,/,T3,A,ES9.2)")& + "max_diis: ",max_diis,& + "eps_diis: ",eps_diis + END IF + + END SUBROUTINE write_scf_parameters + +! ***************************************************************************** + +END MODULE qs_scf diff --git a/src/radial_solver.F b/src/radial_solver.F index bdf4f5e231..70f098bd98 100644 --- a/src/radial_solver.F +++ b/src/radial_solver.F @@ -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 ) diff --git a/src/read_pimd.F b/src/read_pimd.F new file mode 100644 index 0000000000..909b5f3d35 --- /dev/null +++ b/src/read_pimd.F @@ -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 + +!****************************************************************************** diff --git a/src/readin.F b/src/readin.F index 55cd772537..9520fc245b 100644 --- a/src/readin.F +++ b/src/readin.F @@ -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 diff --git a/src/realspace_grid_types.F b/src/realspace_grid_types.F new file mode 100644 index 0000000000..2871e68e97 --- /dev/null +++ b/src/realspace_grid_types.F @@ -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 + +!****************************************************************************** diff --git a/src/simulation_cell.F b/src/simulation_cell.F index cd866c8810..d8c3ee7134 100644 --- a/src/simulation_cell.F +++ b/src/simulation_cell.F @@ -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 + +!****************************************************************************** diff --git a/src/spme.F b/src/spme.F index 20764820c9..bb05cb4e7d 100644 --- a/src/spme.F +++ b/src/spme.F @@ -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 diff --git a/src/start_program_run.F b/src/start_program_run.F index c9f946d428..1701727ebc 100644 --- a/src/start_program_run.F +++ b/src/start_program_run.F @@ -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) **",& "** **",& diff --git a/src/string_utilities.F b/src/string_utilities.F index 65341838e0..0cdff938d9 100644 --- a/src/string_utilities.F +++ b/src/string_utilities.F @@ -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 ! ***************************************************************************** diff --git a/src/structure_factors.F b/src/structure_factors.F index 87ae9ef788..6c4bd4ef71 100644 --- a/src/structure_factors.F +++ b/src/structure_factors.F @@ -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 diff --git a/src/structure_types.F b/src/structure_types.F index e318c8f767..33d8c084ff 100644 --- a/src/structure_types.F +++ b/src/structure_types.F @@ -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 diff --git a/src/tbmd_debug.F b/src/tbmd_debug.F index 7611c35909..4391c595c1 100644 --- a/src/tbmd_debug.F +++ b/src/tbmd_debug.F @@ -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)?' diff --git a/src/tbmd_force.F b/src/tbmd_force.F index c2a87b1ce4..cd56db50d0 100644 --- a/src/tbmd_force.F +++ b/src/tbmd_force.F @@ -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 diff --git a/src/timings.F b/src/timings.F index daebbfce3e..e0f26e1a87 100644 --- a/src/timings.F +++ b/src/timings.F @@ -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 diff --git a/src/transformations.F b/src/transformations.F new file mode 100644 index 0000000000..b91866d1ee --- /dev/null +++ b/src/transformations.F @@ -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 + +!****************************************************************************** diff --git a/src/xc.F b/src/xc.F index 46070e7e45..ec873d261f 100644 --- a/src/xc.F +++ b/src/xc.F @@ -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