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

Read SOC parameters for GTH PP database file

Browse source 
- Add SOC keyword for spin-orbit coupling to database file as a new extension of GTH PP format
- Rename database file from GTH_POTENTIALS_SOC to GTH_SOC_POTENTIALS
- Improve proper indentation and spacing in restart file dump
- Add quotes for char_t variables in restart file
- Replace spaces in the project name with underscores
This commit is contained in:
Matthias Krack 2023-07-02 13:40:24 +02:00
parent e112afaa9c
commit a7c7cb152c
15 changed files with 970 additions and 2967 deletions
Download patch file Download diff file Expand all files Collapse all files

864
data/GTH_POTENTIALS_SOC → data/GTH_SOC_POTENTIALS
View file

File diff suppressed because it is too large Load diff

1
src/CMakeLists.txt
View file

@ -1180,7 +1180,6 @@ list(
subsys/cp_subsys_types.F
subsys/damping_dipole_types.F
subsys/external_potential_types.F
subsys/external_potential_soc_parameters.F
subsys/force_field_kind_types.F
subsys/molecule_kind_list_types.F
subsys/molecule_kind_types.F

99
src/core_ppnl.F
View file

@ -119,7 +119,7 @@ CONTAINS
INTEGER, DIMENSION(:), POINTER :: la_max, la_min, npgfa, nprj_ppnl, &
nsgf_seta
INTEGER, DIMENSION(:, :), POINTER :: first_sgfa
LOGICAL :: do_dR, do_soc, dogth, dokp, found, &
LOGICAL :: do_dR, do_gth, do_kp, do_soc, found, &
ppnl_present
LOGICAL, DIMENSION(0:9) :: is_nonlocal
REAL(KIND=dp) :: dac, f0, ppnl_radius
@ -171,9 +171,9 @@ CONTAINS
nkind = SIZE(atomic_kind_set)
natom = SIZE(particle_set)
dokp = (nimages > 1)
do_kp = (nimages > 1)
IF (dokp) THEN
IF (do_kp) THEN
CPASSERT(PRESENT(cell_to_index) .AND. ASSOCIATED(cell_to_index))
END IF
@ -204,14 +204,14 @@ CONTAINS
ldsab = MAX(maxco, ncoset(maxlppnl), maxsgf, maxppnl)
ldai = ncoset(maxl + nder + 1)
!sap_int needs to be shared as multiple threads need to access this
! sap_int needs to be shared as multiple threads need to access this
ALLOCATE (sap_int(nkind*nkind))
DO i = 1, nkind*nkind
NULLIFY (sap_int(i)%alist, sap_int(i)%asort, sap_int(i)%aindex)
sap_int(i)%nalist = 0
END DO
!set up direct access to basis and potential
! Set up direct access to basis and potential
ALLOCATE (basis_set(nkind), gpotential(nkind), spotential(nkind))
DO ikind = 1, nkind
CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type=basis_type)
@ -225,12 +225,15 @@ CONTAINS
NULLIFY (spotential(ikind)%sgp_potential)
IF (ASSOCIATED(gth_potential)) THEN
gpotential(ikind)%gth_potential => gth_potential
IF (do_soc .AND. (.NOT. gth_potential%soc)) THEN
CPWARN("Spin-orbit coupling selected, but GTH potential without SOC parameters provided")
END IF
ELSE IF (ASSOCIATED(sgp_potential)) THEN
spotential(ikind)%sgp_potential => sgp_potential
END IF
END DO
!allocate sap int
! Allocate sap int
DO slot = 1, sap_ppnl(1)%nl_size
ikind = sap_ppnl(1)%nlist_task(slot)%ikind
@ -266,7 +269,7 @@ CONTAINS
END IF
END DO
!calculate the overlap integrals <a|p>
! Calculate the overlap integrals <a|p>
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP SHARED (basis_set, gpotential, spotential, maxder, ncoset, &
@ -275,7 +278,7 @@ CONTAINS
!$OMP cell_c, rac, iac, first_sgfa, la_max, la_min, npgfa, nseta, nsgfa, nsgf_seta, &
!$OMP slot, sphi_a, zeta, cprj, hprj, lppnl, nppnl, nprj_ppnl, &
!$OMP clist, iset, ncoa, sgfa, prjc, work, work_l, sab, lab, ai_work, nprjc, &
!$OMP ppnl_radius, ncoc, rpgfa, first_col, vprj_ppnl, wprj_ppnl, i, j, l, dogth, &
!$OMP ppnl_radius, ncoc, rpgfa, first_col, vprj_ppnl, wprj_ppnl, i, j, l, do_gth, &
!$OMP set_radius_a, rprjc, dac, lc_max, lc_min, zetc, alpha_ppnl, &
!$OMP na, nb, np, nnl, is_nonlocal, a_nl, h_nl, c_nl, radp, i_dim, ib, jb)
@ -304,7 +307,7 @@ CONTAINS
iac = ikind + nkind*(kkind - 1)
IF (.NOT. ASSOCIATED(basis_set(ikind)%gto_basis_set)) CYCLE
! get definition of basis set
! Get definition of basis set
first_sgfa => basis_set(ikind)%gto_basis_set%first_sgf
la_max => basis_set(ikind)%gto_basis_set%lmax
la_min => basis_set(ikind)%gto_basis_set%lmin
@ -316,10 +319,10 @@ CONTAINS
set_radius_a => basis_set(ikind)%gto_basis_set%set_radius
sphi_a => basis_set(ikind)%gto_basis_set%sphi
zeta => basis_set(ikind)%gto_basis_set%zet
! get definition of PP projectors
! Get definition of PP projectors
IF (ASSOCIATED(gpotential(kkind)%gth_potential)) THEN
! GTH potential
dogth = .TRUE.
do_gth = .TRUE.
alpha_ppnl => gpotential(kkind)%gth_potential%alpha_ppnl
cprj => gpotential(kkind)%gth_potential%cprj
lppnl = gpotential(kkind)%gth_potential%lppnl
@ -330,7 +333,7 @@ CONTAINS
wprj_ppnl => gpotential(kkind)%gth_potential%wprj_ppnl
ELSE IF (ASSOCIATED(spotential(kkind)%sgp_potential)) THEN
! SGP potential
dogth = .FALSE.
do_gth = .FALSE.
nprjc = spotential(kkind)%sgp_potential%nppnl
IF (nprjc == 0) CYCLE
nnl = spotential(kkind)%sgp_potential%n_nonlocal
@ -359,20 +362,20 @@ CONTAINS
clist%achint(nsgfa, nppnl, maxder), &
clist%alint(nsgfa, nppnl, 3), &
clist%alkint(nsgfa, nppnl, 3))
clist%acint = 0._dp
clist%achint = 0._dp
clist%alint = 0._dp
clist%alkint = 0._dp
clist%acint = 0.0_dp
clist%achint = 0.0_dp
clist%alint = 0.0_dp
clist%alkint = 0.0_dp
clist%nsgf_cnt = 0
NULLIFY (clist%sgf_list)
DO iset = 1, nseta
ncoa = npgfa(iset)*ncoset(la_max(iset))
sgfa = first_sgfa(1, iset)
IF (dogth) THEN
IF (do_gth) THEN
! GTH potential
prjc = 1
work = 0._dp
work = 0.0_dp
DO l = 0, lppnl
nprjc = nprj_ppnl(l)*nco(l)
IF (nprjc == 0) CYCLE
@ -383,23 +386,23 @@ CONTAINS
zetc(1) = alpha_ppnl(l)
ncoc = ncoset(lc_max)
! *** Calculate the primitive overlap integrals ***
! Calculate the primitive overlap integrals
CALL overlap(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
lc_max, lc_min, 1, rprjc, zetc, rac, dac, sab, nder, .TRUE., ai_work, ldai)
! *** Transformation step projector functions (cartesian->spherical) ***
! Transformation step projector functions (Cartesian -> spherical)
na = ncoa
nb = nprjc
np = ncoc
DO i = 1, maxder
first_col = (i - 1)*ldsab
! CALL dgemm("N", "N", ncoa, nprjc, ncoc, 1.0_dp, sab(1, first_col + 1), SIZE(sab, 1), &
! cprj(1, prjc), SIZE(cprj, 1), 0.0_dp, work(1, first_col + prjc), ldsab)
! CALL dgemm("N", "N", ncoa, nprjc, ncoc, 1.0_dp, sab(1, first_col + 1), SIZE(sab, 1), &
! cprj(1, prjc), SIZE(cprj, 1), 0.0_dp, work(1, first_col + prjc), ldsab)
work(1:na, first_col + prjc:first_col + prjc + nb - 1) = &
MATMUL(sab(1:na, first_col + 1:first_col + np), cprj(1:np, prjc:prjc + nb - 1))
END DO
IF (do_soc) THEN
! *** Calculate the primitive angular momentum integrals needed for spin-orbit coupling ***
! Calculate the primitive angular momentum integrals needed for spin-orbit coupling
lab = 0.0_dp
CALL angmom(la_max(iset), npgfa(iset), zeta(:, iset), rpgfa(:, iset), la_min(iset), &
lc_max, 1, zetc, rprjc, -rac, (/0._dp, 0._dp, 0._dp/), lab)
@ -417,18 +420,16 @@ CONTAINS
np = ncoa
DO i = 1, maxder
first_col = (i - 1)*ldsab + 1
! *** Contraction step (basis functions) ***
! CALL dgemm("T", "N", nsgf_seta(iset), nppnl, ncoa, 1.0_dp, sphi_a(1, sgfa), SIZE(sphi_a, 1), &
! work(1, first_col), ldsab, 0.0_dp, clist%acint(sgfa, 1, i), nsgfa)
! Contraction step (basis functions)
! CALL dgemm("T", "N", nsgf_seta(iset), nppnl, ncoa, 1.0_dp, sphi_a(1, sgfa), SIZE(sphi_a, 1), &
! work(1, first_col), ldsab, 0.0_dp, clist%acint(sgfa, 1, i), nsgfa)
clist%acint(sgfa:sgfa + na - 1, 1:nb, i) = &
MATMUL(TRANSPOSE(sphi_a(1:np, sgfa:sgfa + na - 1)), work(1:np, first_col:first_col + nb - 1))
! *** Multiply with interaction matrix(h) ***
! CALL dgemm("N", "N", nsgf_seta(iset), nppnl, nppnl, 1.0_dp, clist%acint(sgfa, 1, i), nsgfa, &
! vprj_ppnl(1, 1), SIZE(vprj_ppnl, 1), 0.0_dp, clist%achint(sgfa, 1, i), nsgfa)
! Multiply with interaction matrix(h)
! CALL dgemm("N", "N", nsgf_seta(iset), nppnl, nppnl, 1.0_dp, clist%acint(sgfa, 1, i), nsgfa, &
! vprj_ppnl(1, 1), SIZE(vprj_ppnl, 1), 0.0_dp, clist%achint(sgfa, 1, i), nsgfa)
clist%achint(sgfa:sgfa + na - 1, 1:nb, i) = &
MATMUL(clist%acint(sgfa:sgfa + na - 1, 1:nb, i), vprj_ppnl(1:nb, 1:nb))
END DO
IF (do_soc) THEN
DO i_dim = 1, 3
@ -440,7 +441,7 @@ CONTAINS
END IF
ELSE
! SGP potential
! *** Calculate the primitive overlap integrals ***
! Calculate the primitive overlap integrals
CALL overlap(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
lppnl, 0, nnl, radp, a_nl, rac, dac, sab, nder, .TRUE., ai_work, ldai)
na = nsgf_seta(iset)
@ -448,13 +449,13 @@ CONTAINS
np = ncoa
DO i = 1, maxder
first_col = (i - 1)*ldsab + 1
! *** Transformation step projector functions (cartesian->spherical) ***
! CALL dgemm("N", "N", ncoa, nppnl, nprjc, 1.0_dp, sab(1, first_col), ldsab, &
! cprj(1, 1), SIZE(cprj, 1), 0.0_dp, work(1, 1), ldsab)
! Transformation step projector functions (cartesian->spherical)
! CALL dgemm("N", "N", ncoa, nppnl, nprjc, 1.0_dp, sab(1, first_col), ldsab, &
! cprj(1, 1), SIZE(cprj, 1), 0.0_dp, work(1, 1), ldsab)
work(1:np, 1:nb) = MATMUL(sab(1:np, first_col:first_col + nprjc - 1), cprj(1:nprjc, 1:nb))
! *** Contraction step (basis functions) ***
! CALL dgemm("T", "N", nsgf_seta(iset), nppnl, ncoa, 1.0_dp, sphi_a(1, sgfa), SIZE(sphi_a, 1), &
! work(1, 1), ldsab, 0.0_dp, clist%acint(sgfa, 1, i), nsgfa)
! Contraction step (basis functions)
! CALL dgemm("T", "N", nsgf_seta(iset), nppnl, ncoa, 1.0_dp, sphi_a(1, sgfa), SIZE(sphi_a, 1), &
! work(1, 1), ldsab, 0.0_dp, clist%acint(sgfa, 1, i), nsgfa)
clist%acint(sgfa:sgfa + na - 1, 1:nb, i) = &
MATMUL(TRANSPOSE(sphi_a(1:np, sgfa:sgfa + na - 1)), work(1:np, 1:nb))
! *** Multiply with interaction matrix(h) ***
@ -467,24 +468,24 @@ CONTAINS
END DO
clist%maxac = MAXVAL(ABS(clist%acint(:, :, 1)))
clist%maxach = MAXVAL(ABS(clist%achint(:, :, 1)))
IF (.NOT. dogth) DEALLOCATE (radp)
IF (.NOT. do_gth) DEALLOCATE (radp)
END DO
DEALLOCATE (sab, ai_work, work)
IF (do_soc) DEALLOCATE (lab, work_l)
!$OMP END PARALLEL
! *** Set up a sorting index
! Set up a sorting index
CALL sap_sort(sap_int)
! *** All integrals needed have been calculated and stored in sap_int
! *** We now calculate the Hamiltonian matrix elements
! All integrals needed have been calculated and stored in sap_int
! We now calculate the Hamiltonian matrix elements
force_thread = 0.0_dp
pv_thread = 0.0_dp
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP SHARED (dokp, basis_set, matrix_h, matrix_l, cell_to_index,&
!$OMP SHARED (do_kp, basis_set, matrix_h, matrix_l, cell_to_index,&
!$OMP sab_orb, matrix_p, sap_int, nkind, eps_ppnl, force, &
!$OMP do_dR, deltaR, maxder, nder, &
!$OMP locks, virial, use_virial, calculate_forces, do_soc) &
@ -523,20 +524,20 @@ CONTAINS
iab = ikind + nkind*(jkind - 1)
! *** Use the symmetry of the first derivatives ***
! Use the symmetry of the first derivatives
IF (iatom == jatom) THEN
f0 = 1.0_dp
ELSE
f0 = 2.0_dp
END IF
IF (dokp) THEN
IF (do_kp) THEN
img = cell_to_index(cell_b(1), cell_b(2), cell_b(3))
ELSE
img = 1
END IF
! *** Create matrix blocks for a new matrix block column ***
! Create matrix blocks for a new matrix block column
IF (iatom <= jatom) THEN
irow = iatom
icol = jatom
@ -753,8 +754,8 @@ CONTAINS
END IF
IF (calculate_forces) THEN
! *** If LSD, then recover alpha density and beta density ***
! *** from the total density (1) and the spin density (2) ***
! If LSD, then recover alpha density and beta density
! from the total density (1) and the spin density (2)
IF (SIZE(matrix_p, 1) == 2) THEN
DO img = 1, nimages
CALL dbcsr_add(matrix_p(1, img)%matrix, matrix_p(2, img)%matrix, &
@ -771,6 +772,4 @@ CONTAINS
END SUBROUTINE build_core_ppnl
! **************************************************************************************************
END MODULE core_ppnl

21
src/environment.F
View file

@ -70,7 +70,7 @@ MODULE environment
USE input_section_types, ONLY: &
section_get_ival, section_get_keyword, section_get_lval, section_get_rval, &
section_release, section_type, section_vals_get, section_vals_get_subs_vals, &
section_vals_get_subs_vals3, section_vals_type, section_vals_val_get
section_vals_get_subs_vals3, section_vals_type, section_vals_val_get, section_vals_val_set
USE kinds, ONLY: default_path_length,&
default_string_length,&
dp,&
@ -340,8 +340,9 @@ CONTAINS
TYPE(mp_para_env_type), POINTER :: para_env
TYPE(global_environment_type), POINTER :: globenv
CHARACTER(LEN=3*default_string_length) :: message
CHARACTER(len=default_string_length) :: c_val
INTEGER :: iw
INTEGER :: i, iw
TYPE(cp_logger_type), POINTER :: logger
! Read the input/output section
@ -355,11 +356,24 @@ CONTAINS
CALL cp_logger_set(logger, &
local_filename=TRIM(c_val)//"_localLog")
END IF
! Process project name
CALL section_vals_val_get(root_section, "GLOBAL%PROJECT", c_val=c_val)
IF (INDEX(c_val(:LEN_TRIM(c_val)), " ") > 0) THEN
message = "Project name <"//TRIM(c_val)// &
"> contains spaces which will be replaced with underscores"
CPWARN(TRIM(message))
DO i = 1, LEN_TRIM(c_val)
! Replace space with underscore
IF (c_val(i:i) == " ") c_val(i:i) = "_"
END DO
CALL section_vals_val_set(root_section, "GLOBAL%PROJECT", c_val=TRIM(c_val))
END IF
IF (c_val /= "") THEN
CALL cp_logger_set(logger, local_filename=TRIM(c_val)//"_localLog")
END IF
logger%iter_info%project_name = c_val
CALL section_vals_val_get(root_section, "GLOBAL%PRINT_LEVEL", i_val=logger%iter_info%print_level)
! Read the CP2K section
@ -487,7 +501,7 @@ CONTAINS
CHARACTER(len=default_path_length) :: basis_set_file_name, coord_file_name, &
mm_potential_file_name, &
potential_file_name
CHARACTER(len=default_string_length) :: env_num, model_name, project_name
CHARACTER(LEN=default_string_length) :: env_num, model_name, project_name
CHARACTER(LEN=default_string_length), &
DIMENSION(:), POINTER :: trace_routines
INTEGER :: cpuid, cpuid_static, i_dgemm, i_diag, i_fft, i_grid_backend, iforce_eval, &
@ -529,7 +543,6 @@ CONTAINS
IF (unit_nr > 0) globenv%elpa_print = .TRUE.
CALL cp_print_key_finished_output(unit_nr, logger, global_section, "PRINT_ELPA")
CALL section_vals_val_get(global_section, "PREFERRED_FFT_LIBRARY", i_val=i_fft)
CALL section_vals_val_get(global_section, "PRINT_LEVEL", i_val=print_level)
CALL section_vals_val_get(global_section, "PROGRAM_NAME", i_val=globenv%prog_name_id)
CALL section_vals_val_get(global_section, "FFT_POOL_SCRATCH_LIMIT", i_val=globenv%fft_pool_scratch_limit)

114
src/input/input_section_types.F
View file

@ -13,11 +13,13 @@
!> \author fawzi
! **************************************************************************************************
MODULE input_section_types
USE cp_linked_list_input, ONLY: &
cp_sll_val_create, cp_sll_val_dealloc, cp_sll_val_get_el_at, cp_sll_val_get_length, &
cp_sll_val_get_rest, cp_sll_val_insert_el_at, cp_sll_val_next, cp_sll_val_p_type, &
cp_sll_val_rm_el_at, cp_sll_val_set_el_at, cp_sll_val_type
USE cp_log_handling, ONLY: cp_to_string
USE cp_parser_types, ONLY: default_section_character
USE input_keyword_types, ONLY: keyword_describe,&
keyword_p_type,&
keyword_release,&
@ -39,7 +41,6 @@ MODULE input_section_types
USE print_messages, ONLY: print_message
USE reference_manager, ONLY: get_citation_key
USE string_utilities, ONLY: a2s,&
compress,&
substitute_special_xml_tokens,&
typo_match,&
uppercase
@ -152,6 +153,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE section_create(section, location, name, description, n_keywords, &
n_subsections, repeats, citations)
TYPE(section_type), POINTER :: section
CHARACTER(len=*), INTENT(in) :: location, name, description
INTEGER, INTENT(in), OPTIONAL :: n_keywords, n_subsections
@ -202,6 +204,7 @@ CONTAINS
DO i = 1, my_n_subsections
NULLIFY (section%subsections(i)%section)
END DO
END SUBROUTINE section_create
! **************************************************************************************************
@ -210,11 +213,13 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_retain(section)
TYPE(section_type), POINTER :: section
CPASSERT(ASSOCIATED(section))
CPASSERT(section%ref_count > 0)
section%ref_count = section%ref_count + 1
END SUBROUTINE section_retain
! **************************************************************************************************
@ -223,6 +228,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
RECURSIVE SUBROUTINE section_release(section)
TYPE(section_type), POINTER :: section
INTEGER :: i
@ -252,6 +258,7 @@ CONTAINS
END IF
NULLIFY (section)
END IF
END SUBROUTINE section_release
! **************************************************************************************************
@ -261,6 +268,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
FUNCTION get_section_info(section) RESULT(message)
TYPE(section_type), INTENT(IN) :: section
CHARACTER(LEN=default_path_length) :: message
@ -293,6 +301,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
RECURSIVE SUBROUTINE section_describe(section, unit_nr, level, hide_root, recurse)
TYPE(section_type), INTENT(IN), POINTER :: section
INTEGER, INTENT(in) :: unit_nr, level
LOGICAL, INTENT(in), OPTIONAL :: hide_root
@ -311,7 +320,7 @@ CONTAINS
CPASSERT(section%ref_count > 0)
IF (.NOT. my_hide_root) &
WRITE (unit_nr, "('*** section &',a,' ***')") TRIM(section%name)
WRITE (UNIT=unit_nr, FMT="('*** section &',A,' ***')") TRIM(ADJUSTL(section%name))
IF (level > 1) THEN
message = get_section_info(section)
CALL print_message(TRIM(a2s(section%description))//TRIM(message), unit_nr, 0, 0, 0)
@ -332,22 +341,23 @@ CONTAINS
END IF
IF (section%n_subsections > 0 .AND. my_recurse >= 0) THEN
IF (.NOT. my_hide_root) &
WRITE (unit_nr, "('** subsections **')")
WRITE (UNIT=unit_nr, FMT="('** subsections **')")
DO isub = 1, section%n_subsections
IF (my_recurse > 0) THEN
CALL section_describe(section%subsections(isub)%section, unit_nr, &
level, recurse=my_recurse - 1)
ELSE
WRITE (unit_nr, "(' ',a)") section%subsections(isub)%section%name
WRITE (UNIT=unit_nr, FMT="(1X,A)") section%subsections(isub)%section%name
END IF
END DO
END IF
IF (.NOT. my_hide_root) &
WRITE (unit_nr, "('*** &end section ',a,' ***')") TRIM(section%name)
WRITE (UNIT=unit_nr, FMT="('*** &end section ',A,' ***')") TRIM(ADJUSTL(section%name))
ELSE
WRITE (unit_nr, "(a)") '<section *null*>'
END IF
END IF
END SUBROUTINE section_describe
! **************************************************************************************************
@ -360,6 +370,7 @@ CONTAINS
!> private utility function
! **************************************************************************************************
FUNCTION section_get_subsection_index(section, subsection_name) RESULT(res)
TYPE(section_type), INTENT(IN) :: section
CHARACTER(len=*), INTENT(IN) :: subsection_name
INTEGER :: res
@ -378,6 +389,7 @@ CONTAINS
EXIT
END IF
END DO
END FUNCTION section_get_subsection_index
! **************************************************************************************************
@ -388,6 +400,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
FUNCTION section_get_subsection(section, subsection_name) RESULT(res)
TYPE(section_type), INTENT(IN) :: section
CHARACTER(len=*), INTENT(IN) :: subsection_name
TYPE(section_type), POINTER :: res
@ -400,6 +413,7 @@ CONTAINS
ELSE
NULLIFY (res)
END IF
END FUNCTION section_get_subsection
! **************************************************************************************************
@ -412,6 +426,7 @@ CONTAINS
!> private utility function
! **************************************************************************************************
FUNCTION section_get_keyword_index(section, keyword_name) RESULT(res)
TYPE(section_type), INTENT(IN) :: section
CHARACTER(len=*), INTENT(IN) :: keyword_name
INTEGER :: res
@ -442,6 +457,7 @@ CONTAINS
END DO
END DO k_search_loop
END IF
END FUNCTION section_get_keyword_index
! **************************************************************************************************
@ -452,6 +468,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
RECURSIVE FUNCTION section_get_keyword(section, keyword_name) RESULT(res)
TYPE(section_type), INTENT(IN) :: section
CHARACTER(len=*), INTENT(IN) :: keyword_name
TYPE(keyword_type), POINTER :: res
@ -474,6 +491,7 @@ CONTAINS
res => section%keywords(ik)%keyword
END IF
END IF
END FUNCTION section_get_keyword
! **************************************************************************************************
@ -483,6 +501,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_add_keyword(section, keyword)
TYPE(section_type), INTENT(INOUT) :: section
TYPE(keyword_type), INTENT(IN), POINTER :: keyword
@ -528,6 +547,7 @@ CONTAINS
section%n_keywords = section%n_keywords + 1
section%keywords(section%n_keywords)%keyword => keyword
END IF
END SUBROUTINE section_add_keyword
! **************************************************************************************************
@ -537,6 +557,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_add_subsection(section, subsection)
TYPE(section_type), INTENT(INOUT) :: section
TYPE(section_type), INTENT(IN), POINTER :: subsection
@ -567,6 +588,7 @@ CONTAINS
CALL section_retain(subsection)
section%n_subsections = section%n_subsections + 1
section%subsections(section%n_subsections)%section => subsection
END SUBROUTINE section_add_subsection
! **************************************************************************************************
@ -576,6 +598,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
RECURSIVE SUBROUTINE section_vals_create(section_vals, section)
TYPE(section_vals_type), POINTER :: section_vals
TYPE(section_type), POINTER :: section
@ -594,7 +617,9 @@ CONTAINS
CALL section_vals_create(section_vals%subs_vals(i, 1)%section_vals, &
section=section%subsections(i)%section)
END DO
NULLIFY (section_vals%ibackup)
END SUBROUTINE section_vals_create
! **************************************************************************************************
@ -603,11 +628,13 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_vals_retain(section_vals)
TYPE(section_vals_type), POINTER :: section_vals
CPASSERT(ASSOCIATED(section_vals))
CPASSERT(section_vals%ref_count > 0)
section_vals%ref_count = section_vals%ref_count + 1
END SUBROUTINE section_vals_retain
! **************************************************************************************************
@ -616,6 +643,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
RECURSIVE SUBROUTINE section_vals_release(section_vals)
TYPE(section_vals_type), POINTER :: section_vals
INTEGER :: i, j
@ -649,6 +677,7 @@ CONTAINS
DEALLOCATE (section_vals)
END IF
END IF
END SUBROUTINE section_vals_release
! **************************************************************************************************
@ -665,6 +694,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE section_vals_get(section_vals, ref_count, n_repetition, &
n_subs_vals_rep, section, explicit)
TYPE(section_vals_type), INTENT(IN) :: section_vals
INTEGER, INTENT(out), OPTIONAL :: ref_count, n_repetition, n_subs_vals_rep
TYPE(section_type), OPTIONAL, POINTER :: section
@ -676,6 +706,7 @@ CONTAINS
IF (PRESENT(n_repetition)) n_repetition = SIZE(section_vals%values, 2)
IF (PRESENT(n_subs_vals_rep)) n_subs_vals_rep = SIZE(section_vals%subs_vals, 2)
IF (PRESENT(explicit)) explicit = (SIZE(section_vals%values, 2) > 0)
END SUBROUTINE section_vals_get
! **************************************************************************************************
@ -690,6 +721,7 @@ CONTAINS
! **************************************************************************************************
RECURSIVE FUNCTION section_vals_get_subs_vals(section_vals, subsection_name, &
i_rep_section, can_return_null) RESULT(res)
TYPE(section_vals_type), INTENT(IN) :: section_vals
CHARACTER(len=*), INTENT(IN) :: subsection_name
INTEGER, INTENT(IN), OPTIONAL :: i_rep_section
@ -744,6 +776,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
FUNCTION section_vals_get_subs_vals2(section_vals, i_section, i_rep_section) RESULT(res)
TYPE(section_vals_type), POINTER :: section_vals
INTEGER, INTENT(in) :: i_section
INTEGER, INTENT(in), OPTIONAL :: i_rep_section
@ -781,6 +814,7 @@ CONTAINS
! **************************************************************************************************
FUNCTION section_vals_get_subs_vals3(section_vals, subsection_name, &
i_rep_section) RESULT(res)
TYPE(section_vals_type), INTENT(IN) :: section_vals
CHARACTER(LEN=*), INTENT(IN) :: subsection_name
INTEGER, INTENT(in), OPTIONAL :: i_rep_section
@ -795,6 +829,7 @@ CONTAINS
CPASSERT(irep <= SIZE(section_vals%subs_vals, 2))
i_section = section_get_subsection_index(section_vals%section, subsection_name)
res => section_vals%subs_vals(i_section, irep)%section_vals
END FUNCTION section_vals_get_subs_vals3
! **************************************************************************************************
@ -803,6 +838,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_vals_add_values(section_vals)
TYPE(section_vals_type), INTENT(INOUT) :: section_vals
INTEGER :: i, j
@ -841,6 +877,7 @@ CONTAINS
section=section_vals%section%subsections(i)%section)
END DO
END IF
END SUBROUTINE section_vals_add_values
! **************************************************************************************************
@ -849,6 +886,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_vals_remove_values(section_vals)
TYPE(section_vals_type), POINTER :: section_vals
INTEGER :: i, j
@ -874,12 +912,8 @@ CONTAINS
DEALLOCATE (section_vals%values)
section_vals%values => new_values
END IF
END SUBROUTINE section_vals_remove_values
! These accessor functions can be used instead of passing a variable
! in the parameter list of a subroutine call. This should make the
! code a lot simpler. See xc_rho_set_and_dset_create in xc.F as
! an example.
END SUBROUTINE section_vals_remove_values
! **************************************************************************************************
!> \brief ...
@ -1003,6 +1037,7 @@ CONTAINS
SUBROUTINE section_vals_val_get(section_vals, keyword_name, i_rep_section, &
i_rep_val, n_rep_val, val, l_val, i_val, r_val, c_val, l_vals, i_vals, r_vals, &
c_vals, explicit)
TYPE(section_vals_type), INTENT(IN), TARGET :: section_vals
CHARACTER(len=*), INTENT(in) :: keyword_name
INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val
@ -1111,6 +1146,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE section_vals_list_get(section_vals, keyword_name, i_rep_section, &
list)
TYPE(section_vals_type), INTENT(IN), POINTER :: section_vals
CHARACTER(len=*), INTENT(in) :: keyword_name
INTEGER, OPTIONAL :: i_rep_section
@ -1177,6 +1213,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE section_vals_val_set(section_vals, keyword_name, i_rep_section, i_rep_val, &
val, l_val, i_val, r_val, c_val, l_vals_ptr, i_vals_ptr, r_vals_ptr, c_vals_ptr)
TYPE(section_vals_type), POINTER :: section_vals
CHARACTER(len=*), INTENT(in) :: keyword_name
INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val
@ -1306,8 +1343,8 @@ CONTAINS
!> (defaults to 1)
!> \author fawzi
! **************************************************************************************************
SUBROUTINE section_vals_val_unset(section_vals, keyword_name, i_rep_section, &
i_rep_val)
SUBROUTINE section_vals_val_unset(section_vals, keyword_name, i_rep_section, i_rep_val)
TYPE(section_vals_type), POINTER :: section_vals
CHARACTER(len=*), INTENT(in) :: keyword_name
INTEGER, INTENT(in), OPTIONAL :: i_rep_section, i_rep_val
@ -1379,10 +1416,13 @@ CONTAINS
!> skips required sections which weren't read
! **************************************************************************************************
RECURSIVE SUBROUTINE section_vals_write(section_vals, unit_nr, hide_root, hide_defaults)
TYPE(section_vals_type), INTENT(IN) :: section_vals
INTEGER, INTENT(in) :: unit_nr
LOGICAL, INTENT(in), OPTIONAL :: hide_root, hide_defaults
INTEGER, PARAMETER :: incr = 2
CHARACTER(len=default_string_length) :: myfmt
INTEGER :: i_rep_s, ik, isec, ival, nr, nval
INTEGER, SAVE :: indent = 1
@ -1405,19 +1445,19 @@ CONTAINS
IF (explicit .OR. (.NOT. my_hide_defaults)) THEN
DO i_rep_s = 1, nr
IF (.NOT. my_hide_root) THEN
WRITE (myfmt, *) indent, "X"
CALL compress(myfmt, full=.TRUE.)
WRITE (UNIT=myfmt, FMT="(I0,A1)") indent, "X"
IF (ASSOCIATED(section%keywords(-1)%keyword)) THEN
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//",'&',a,' ')", advance="NO") TRIM(section%name)
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//",A)", ADVANCE="NO") &
default_section_character//TRIM(ADJUSTL(section%name))
ELSE
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//",'&',a)") TRIM(section%name)
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//",A)") &
default_section_character//TRIM(ADJUSTL(section%name))
END IF
END IF
defaultSection = (SIZE(section_vals%values, 2) == 0)
IF (.NOT. defaultSection) THEN
IF (.NOT. my_hide_root) indent = indent + 2
WRITE (myfmt, *) indent, "X"
CALL compress(myfmt, full=.TRUE.)
IF (.NOT. my_hide_root) indent = indent + incr
WRITE (UNIT=myfmt, FMT="(I0,A1)") indent, "X"
DO ik = -1, section%n_keywords
keyword => section%keywords(ik)%keyword
IF (ASSOCIATED(keyword)) THEN
@ -1444,29 +1484,27 @@ CONTAINS
END IF
IF (keyword%names(1) /= '_DEFAULT_KEYWORD_' .AND. &
keyword%names(1) /= '_SECTION_PARAMETERS_') THEN
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//",a,' ')", advance="NO") &
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//",A)", ADVANCE="NO") &
TRIM(keyword%names(1))
ELSEIF (keyword%names(1) == '_DEFAULT_KEYWORD_' .AND. &
keyword%type_of_var /= lchar_t) THEN
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
ELSE IF (keyword%names(1) == '_DEFAULT_KEYWORD_' .AND. &
keyword%type_of_var /= lchar_t) THEN
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
END IF
CALL val_write(val, unit_nr=unit_nr, unit=keyword%unit, &
fmt=myfmt)
CALL val_write(val, unit_nr=unit_nr, unit=keyword%unit, fmt=myfmt)
END DO
ELSEIF (ASSOCIATED(keyword%default_value)) THEN
ELSE IF (ASSOCIATED(keyword%default_value)) THEN
! Section was not parsed but default for the keywords may exist
IF (my_hide_defaults) CYCLE
val => keyword%default_value
IF (keyword%names(1) /= '_DEFAULT_KEYWORD_' .AND. &
keyword%names(1) /= '_SECTION_PARAMETERS_') THEN
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//",a,' ')", advance="NO") &
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//",A)", ADVANCE="NO") &
TRIM(keyword%names(1))
ELSEIF (keyword%names(1) == '_DEFAULT_KEYWORD_' .AND. &
keyword%type_of_var /= lchar_t) THEN
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
ELSE IF (keyword%names(1) == '_DEFAULT_KEYWORD_' .AND. &
keyword%type_of_var /= lchar_t) THEN
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
END IF
CALL val_write(val, unit_nr=unit_nr, unit=keyword%unit, &
fmt=myfmt)
CALL val_write(val, unit_nr=unit_nr, unit=keyword%unit, fmt=myfmt)
END IF
END IF
END IF
@ -1481,9 +1519,10 @@ CONTAINS
END IF
END IF
IF (.NOT. my_hide_root) THEN
indent = indent - 2
WRITE (UNIT=unit_nr, FMT="(A)") &
REPEAT(" ", indent)//"&END "//TRIM(section%name)
indent = indent - incr
WRITE (UNIT=myfmt, FMT="(I0,A1)") indent, "X"
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//",A)") &
default_section_character//"END "//TRIM(ADJUSTL(section%name))
END IF
END DO
END IF
@ -1588,7 +1627,9 @@ CONTAINS
imatch = typo_match(TRIM(section%name), TRIM(unknown_string))
IF (imatch > 0) THEN
imatch = imatch + bonus
WRITE (line, '(T2,A)') " subsection "//TRIM(section%name)//" in section "//TRIM(location_string)
WRITE (UNIT=line, FMT='(T2,A)') &
" subsection "//TRIM(ADJUSTL(section%name))// &
" in section "//TRIM(ADJUSTL(location_string))
imax = SIZE(matching_rank, 1)
irank = imax + 1
DO I = imax, 1, -1
@ -1761,6 +1802,7 @@ CONTAINS
section_vals_out%subs_vals(isec, irep - istart + 1)%section_vals)
END DO
END DO
END SUBROUTINE section_vals_copy
END MODULE input_section_types

100
src/input/input_val_types.F
View file

@ -12,6 +12,7 @@
!> \author fawzi
! **************************************************************************************************
MODULE input_val_types
USE cp_parser_types, ONLY: default_continuation_character
USE cp_units, ONLY: cp_unit_create,&
cp_unit_desc,&
@ -36,7 +37,6 @@ MODULE input_val_types
PUBLIC :: val_p_type, val_type
PUBLIC :: val_create, val_retain, val_release, val_get, val_write, &
val_write_internal, val_duplicate
!***
INTEGER, PARAMETER, PUBLIC :: no_t = 0, logical_t = 1, &
integer_t = 2, real_t = 3, char_t = 4, enum_t = 5, lchar_t = 6
@ -100,6 +100,7 @@ CONTAINS
SUBROUTINE val_create(val, l_val, l_vals, l_vals_ptr, i_val, i_vals, i_vals_ptr, &
r_val, r_vals, r_vals_ptr, c_val, c_vals, c_vals_ptr, lc_val, lc_vals, &
lc_vals_ptr, enum)
TYPE(val_type), POINTER :: val
LOGICAL, INTENT(in), OPTIONAL :: l_val
LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL :: l_vals
@ -247,7 +248,9 @@ CONTAINS
END IF
END IF
END IF
CPASSERT(ASSOCIATED(val%enum) .EQV. val%type_of_var == enum_t)
END SUBROUTINE val_create
! **************************************************************************************************
@ -256,6 +259,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE val_release(val)
TYPE(val_type), POINTER :: val
IF (ASSOCIATED(val)) THEN
@ -279,7 +283,9 @@ CONTAINS
DEALLOCATE (val)
END IF
END IF
NULLIFY (val)
END SUBROUTINE val_release
! **************************************************************************************************
@ -288,11 +294,13 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE val_retain(val)
TYPE(val_type), POINTER :: val
CPASSERT(ASSOCIATED(val))
CPASSERT(val%ref_count > 0)
val%ref_count = val%ref_count + 1
END SUBROUTINE val_retain
! **************************************************************************************************
@ -323,6 +331,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE val_get(val, has_l, has_i, has_r, has_lc, has_c, l_val, l_vals, i_val, &
i_vals, r_val, r_vals, c_val, c_vals, len_c, type_of_var, enum)
TYPE(val_type), POINTER :: val
LOGICAL, INTENT(out), OPTIONAL :: has_l, has_i, has_r, has_lc, has_c, l_val
LOGICAL, DIMENSION(:), OPTIONAL, POINTER :: l_vals
@ -453,7 +462,7 @@ CONTAINS
END SUBROUTINE val_get
! **************************************************************************************************
!> \brief writes out the valuse stored in the val
!> \brief writes out the values stored in the val
!> \param val the val to write
!> \param unit_nr the number of the unit to write to
!> \param unit the unit of mesure in which the output should be written
@ -465,6 +474,7 @@ CONTAINS
!> unit of mesure used only for reals
! **************************************************************************************************
SUBROUTINE val_write(val, unit_nr, unit, unit_str, fmt)
TYPE(val_type), POINTER :: val
INTEGER, INTENT(in) :: unit_nr
TYPE(cp_unit_type), OPTIONAL, POINTER :: unit
@ -478,6 +488,7 @@ CONTAINS
NULLIFY (my_unit)
myfmt = ""
owns_unit = .FALSE.
IF (PRESENT(fmt)) myfmt = fmt
IF (PRESENT(unit)) my_unit => unit
IF (.NOT. ASSOCIATED(my_unit) .AND. PRESENT(unit_str)) THEN
@ -485,20 +496,21 @@ CONTAINS
CALL cp_unit_create(my_unit, unit_str)
owns_unit = .TRUE.
END IF
IF (ASSOCIATED(val)) THEN
SELECT CASE (val%type_of_var)
CASE (logical_t)
IF (ASSOCIATED(val%l_val)) THEN
DO i = 1, SIZE(val%l_val)
IF (MODULO(i, 20) == 0) THEN
WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
WRITE (UNIT=unit_nr, FMT="(1X,A1)") default_continuation_character
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
END IF
WRITE (unit=unit_nr, fmt="(' ',l1)", advance="NO") &
WRITE (UNIT=unit_nr, FMT="(1X,L1)", ADVANCE="NO") &
val%l_val(i)
END DO
ELSE
CPABORT("")
CPABORT("Input value of type <logical_t> not associated")
END IF
CASE (integer_t)
IF (ASSOCIATED(val%i_val)) THEN
@ -529,59 +541,65 @@ CONTAINS
i = i + 1
END DO loop_i
ELSE
CPABORT("")
CPABORT("Input value of type <integer_t> not associated")
END IF
CASE (real_t)
IF (ASSOCIATED(val%r_val)) THEN
DO i = 1, SIZE(val%r_val)
IF (MODULO(i, 5) == 0) THEN
WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
END IF
IF (ASSOCIATED(my_unit)) THEN
WRITE (rcval, "(ES25.16)") cp_unit_from_cp2k1(val%r_val(i), my_unit)
WRITE (UNIT=rcval, FMT="(ES25.16E3)") &
cp_unit_from_cp2k1(val%r_val(i), my_unit)
ELSE
WRITE (rcval, "(ES25.16)") val%r_val(i)
WRITE (UNIT=rcval, FMT="(ES25.16E3)") val%r_val(i)
END IF
WRITE (unit=unit_nr, fmt="(' ',A)", advance="NO") TRIM(rcval)
WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") TRIM(rcval)
END DO
ELSE
CPABORT("")
CPABORT("Input value of type <real_t> not associated")
END IF
CASE (char_t)
IF (ASSOCIATED(val%c_val)) THEN
l = 0
DO i = 1, SIZE(val%c_val)
IF (i > 1) WRITE (unit=unit_nr, fmt="(' ')", advance="NO")
l = l + 1
IF (l > 10 .AND. l + LEN_TRIM(val%c_val(i)) > 76) THEN
WRITE (unit=unit_nr, fmt="('\')")
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
WRITE (UNIT=unit_nr, FMT="(A1)") default_continuation_character
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
l = 0
WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(i))
WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
l = l + LEN_TRIM(val%c_val(i)) + 3
ELSE IF (LEN_TRIM(val%c_val(i)) > 0) THEN
l = l + LEN_TRIM(val%c_val(i))
WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(i))
WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") """"//TRIM(val%c_val(i))//""""
ELSE
l = l + 3
WRITE (unit=unit_nr, fmt="(a)", advance="NO") '" "'
WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") '""'
END IF
END DO
ELSE
CPABORT("")
CPABORT("Input value of type <char_t> not associated")
END IF
CASE (lchar_t)
IF (ASSOCIATED(val%c_val)) THEN
l = 0
DO i = 1, SIZE(val%c_val) - 1
WRITE (unit=unit_nr, fmt='(a)', advance="NO") val%c_val(i)
END DO
IF (SIZE(val%c_val) > 0) THEN
WRITE (unit=unit_nr, fmt='(a)', advance="NO") TRIM(val%c_val(SIZE(val%c_val)))
END IF
SELECT CASE (SIZE(val%c_val))
CASE (1)
WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") TRIM(val%c_val(1))
CASE (2)
WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(2))
CASE (3:)
WRITE (UNIT=unit_nr, FMT='(1X,A)', ADVANCE="NO") val%c_val(1)
DO i = 2, SIZE(val%c_val) - 1
WRITE (UNIT=unit_nr, FMT="(A)", ADVANCE="NO") val%c_val(i)
END DO
WRITE (UNIT=unit_nr, FMT='(A)', ADVANCE="NO") TRIM(val%c_val(SIZE(val%c_val)))
END SELECT
ELSE
CPABORT("")
CPABORT("Input value of type <lchar_t> not associated")
END IF
CASE (enum_t)
IF (ASSOCIATED(val%i_val)) THEN
@ -589,31 +607,33 @@ CONTAINS
DO i = 1, SIZE(val%i_val)
c_string = enum_i2c(val%enum, val%i_val(i))
IF (l > 10 .AND. l + LEN_TRIM(c_string) > 76) THEN
WRITE (unit=unit_nr, fmt="(' ',A)") default_continuation_character
WRITE (unit=unit_nr, fmt="("//TRIM(myfmt)//")", advance="NO")
WRITE (UNIT=unit_nr, FMT="(1X,A)") default_continuation_character
WRITE (UNIT=unit_nr, FMT="("//TRIM(myfmt)//")", ADVANCE="NO")
l = 0
ELSE
l = l + LEN_TRIM(c_string) + 3
END IF
WRITE (unit=unit_nr, fmt="(' ',a)", advance="NO") TRIM(c_string)
WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") TRIM(c_string)
END DO
ELSE
CPABORT("")
CPABORT("Input value of type <enum_t> not associated")
END IF
CASE (no_t)
WRITE (unit=unit_nr, fmt="(' *empty*')", advance="NO")
WRITE (UNIT=unit_nr, FMT="(' *empty*')", ADVANCE="NO")
CASE default
CPABORT("unexpected type_of_var for val ")
CPABORT("Unexpected type_of_var for val")
END SELECT
ELSE
WRITE (unit=unit_nr, fmt="(' *null*')", advance="NO")
WRITE (UNIT=unit_nr, FMT="(1X,A)", ADVANCE="NO") "NULL()"
END IF
IF (owns_unit) THEN
CALL cp_unit_release(my_unit)
DEALLOCATE (my_unit)
END IF
WRITE (unit=unit_nr, fmt="()")
WRITE (UNIT=unit_nr, FMT="()")
END SUBROUTINE val_write
! **************************************************************************************************
@ -637,8 +657,6 @@ CONTAINS
INTEGER :: i, ipos
REAL(KIND=dp) :: value
! -------------------------------------------------------------------------
string = ""
IF (ASSOCIATED(val)) THEN
@ -647,7 +665,7 @@ CONTAINS
CASE (logical_t)
IF (ASSOCIATED(val%l_val)) THEN
DO i = 1, SIZE(val%l_val)
WRITE (UNIT=string(2*i - 1:), FMT="(L2)") val%l_val(i)
WRITE (UNIT=string(2*i - 1:), FMT="(1X,L1)") val%l_val(i)
END DO
ELSE
CPABORT("")
@ -716,6 +734,7 @@ CONTAINS
!> \author fawzi
! **************************************************************************************************
SUBROUTINE val_duplicate(val_in, val_out)
TYPE(val_type), POINTER :: val_in, val_out
CPASSERT(ASSOCIATED(val_in))
@ -743,6 +762,7 @@ CONTAINS
ALLOCATE (val_out%c_val(SIZE(val_in%c_val)))
val_out%c_val = val_in%c_val
END IF
END SUBROUTINE val_duplicate
END MODULE input_val_types

2
src/input_cp2k_restarts_util.F
View file

@ -112,9 +112,11 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
velocity_section%values(ik, 1)%list => vals
CALL timestop(handle)
END SUBROUTINE section_velocity_val_set
END MODULE input_cp2k_restarts_util

32
src/input_restart_force_eval.F
View file

@ -6,6 +6,7 @@
!--------------------------------------------------------------------------------------------------!
MODULE input_restart_force_eval
USE atomic_kind_list_types, ONLY: atomic_kind_list_type
USE atomic_kind_types, ONLY: get_atomic_kind
USE cell_types, ONLY: cell_type,&
@ -82,6 +83,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE update_force_eval(force_env, root_section, &
write_binary_restart_file, respa)
TYPE(force_env_type), POINTER :: force_env
TYPE(section_vals_type), POINTER :: root_section
LOGICAL, INTENT(IN) :: write_binary_restart_file
@ -200,6 +202,7 @@ CONTAINS
!> \author Teodoro Laino
! **************************************************************************************************
SUBROUTINE update_qmmm(qmmm_section, force_env)
TYPE(section_vals_type), POINTER :: qmmm_section
TYPE(force_env_type), POINTER :: force_env
@ -288,6 +291,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE update_subsys(subsys_section, force_env, skip_vel_section, &
write_binary_restart_file)
TYPE(section_vals_type), POINTER :: subsys_section
TYPE(force_env_type), POINTER :: force_env
LOGICAL, INTENT(IN) :: skip_vel_section, &
@ -429,7 +433,9 @@ CONTAINS
CALL update_quadrupoles_section(multipoles%quadrupoles, work_section)
END IF
END IF
CALL timestop(handle)
END SUBROUTINE update_subsys
! **************************************************************************************************
@ -439,6 +445,7 @@ CONTAINS
!> \author Ole Schuett
! **************************************************************************************************
SUBROUTINE update_cell_section(cell, cell_section)
TYPE(cell_type), POINTER :: cell
TYPE(section_vals_type), POINTER :: cell_section
@ -476,6 +483,7 @@ CONTAINS
CALL section_vals_val_unset(cell_section, "ALPHA_BETA_GAMMA")
CALL timestop(handle)
END SUBROUTINE update_cell_section
! **************************************************************************************************
@ -493,6 +501,7 @@ CONTAINS
! **************************************************************************************************
SUBROUTINE section_coord_val_set(coord_section, particles, molecules, conv_factor, &
scale, cell, shell)
TYPE(section_vals_type), POINTER :: coord_section
TYPE(particle_list_type), POINTER :: particles
TYPE(molecule_list_type), POINTER :: molecules
@ -548,8 +557,8 @@ CONTAINS
ELSE
s = s*conv_factor
END IF
WRITE (UNIT=line, FMT="(A,3(1X,ES25.16),1X,I0)") &
TRIM(name), s(1:3), particles%els(irk)%atom_index
WRITE (UNIT=line, FMT="(T7,A,3ES25.16E3,1X,I0)") &
TRIM(ADJUSTL(name)), s(1:3), particles%els(irk)%atom_index
CALL val_create(my_val, lc_val=line)
IF (Nlist /= 0) THEN
IF (irk == 1) THEN
@ -591,11 +600,11 @@ CONTAINS
s = s*conv_factor
END IF
IF (LEN_TRIM(my_tag) > 0) THEN
WRITE (UNIT=line, FMT="(A,3(1X,ES25.16),1X,A,1X,I0)") &
TRIM(name), s(1:3), TRIM(my_tag), imol
WRITE (UNIT=line, FMT="(T7,A,3ES25.16E3,1X,A,1X,I0)") &
TRIM(ADJUSTL(name)), s(1:3), TRIM(my_tag), imol
ELSE
WRITE (UNIT=line, FMT="(A,3(1X,ES25.16))") &
TRIM(name), s(1:3)
WRITE (UNIT=line, FMT="(T7,A,3ES25.16E3)") &
TRIM(ADJUSTL(name)), s(1:3)
END IF
CALL val_create(my_val, lc_val=line)
@ -622,9 +631,11 @@ CONTAINS
NULLIFY (my_val)
END IF
END DO
coord_section%values(ik, 1)%list => vals
CALL timestop(handle)
END SUBROUTINE section_coord_val_set
! **************************************************************************************************
@ -701,6 +712,7 @@ CONTAINS
dipoles_section%values(ik, 1)%list => vals
CALL timestop(handle)
END SUBROUTINE update_dipoles_section
! **************************************************************************************************
@ -780,9 +792,11 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
quadrupoles_section%values(ik, 1)%list => vals
CALL timestop(handle)
END SUBROUTINE update_quadrupoles_section
! **************************************************************************************************
@ -855,14 +869,14 @@ CONTAINS
r(1:3) = particles%els(iparticle)%r(1:3)*conv_factor
END IF
IF (core_or_shell) THEN
WRITE (UNIT=output_unit, FMT="(A,3(1X,ES25.16),1X,I0)") &
WRITE (UNIT=output_unit, FMT="(A,3ES25.16E3,1X,I0)") &
TRIM(ADJUSTL(kind_name)), r(1:3), particles%els(iparticle)%atom_index
ELSE
IF (LEN_TRIM(tag) > 0) THEN
WRITE (UNIT=output_unit, FMT="(A,3(1X,ES25.16),1X,A,1X,I0)") &
WRITE (UNIT=output_unit, FMT="(A,3ES25.16E3,1X,A,1X,I0)") &
TRIM(ADJUSTL(kind_name)), r(1:3), TRIM(tag), imolecule
ELSE
WRITE (UNIT=output_unit, FMT="(A,3(1X,ES25.16))") &
WRITE (UNIT=output_unit, FMT="(A,3ES25.16E3)") &
TRIM(ADJUSTL(kind_name)), r(1:3)
END IF
END IF

16
src/motion/input_cp2k_restarts.F
View file

@ -11,6 +11,7 @@
!> 01.2006 [created] Teodoro Laino
! **************************************************************************************************
MODULE input_cp2k_restarts
USE al_system_types, ONLY: al_system_type
USE atomic_kind_list_types, ONLY: atomic_kind_list_type
USE averages_types, ONLY: average_quantities_type
@ -497,6 +498,7 @@ CONTAINS
SUBROUTINE update_motion(motion_section, md_env, force_env, logger, &
coords, vels, pint_env, helium_env, save_mem, &
write_binary_restart_file)
TYPE(section_vals_type), POINTER :: motion_section
TYPE(md_environment_type), OPTIONAL, POINTER :: md_env
TYPE(force_env_type), POINTER :: force_env
@ -1511,6 +1513,7 @@ CONTAINS
!> \author Teodoro Laino
! **************************************************************************************************
SUBROUTINE dump_csvr_restart_info(csvr, para_env, csvr_section)
TYPE(csvr_system_type), POINTER :: csvr
TYPE(mp_para_env_type), POINTER :: para_env
TYPE(section_vals_type), POINTER :: csvr_section
@ -1575,6 +1578,7 @@ CONTAINS
!> \author Teodoro Laino
! **************************************************************************************************
SUBROUTINE dump_al_restart_info(al, para_env, al_section)
TYPE(al_system_type), POINTER :: al
TYPE(mp_para_env_type), POINTER :: para_env
TYPE(section_vals_type), POINTER :: al_section
@ -1629,6 +1633,7 @@ CONTAINS
!> \author MI
! **************************************************************************************************
SUBROUTINE dump_gle_restart_info(gle, para_env, gle_section)
TYPE(gle_type), POINTER :: gle
TYPE(mp_para_env_type), POINTER :: para_env
TYPE(section_vals_type), POINTER :: gle_section
@ -1747,6 +1752,7 @@ CONTAINS
!> \author Teodoro Laino
! **************************************************************************************************
SUBROUTINE collect_nose_restart_info(nhc, para_env, eta, veta, fnhc, mnhc)
TYPE(lnhc_parameters_type), POINTER :: nhc
TYPE(mp_para_env_type), POINTER :: para_env
REAL(KIND=dp), DIMENSION(:), POINTER :: eta, veta, fnhc, mnhc
@ -1976,7 +1982,9 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
coord_section%values(ik, 1)%list => vals
END SUBROUTINE section_neb_coord_val_set
! **************************************************************************************************
@ -1991,6 +1999,7 @@ CONTAINS
!> \author Teodoro Laino
! **************************************************************************************************
SUBROUTINE set_template_restart(work_section, eta, veta, fnhc, mnhc)
TYPE(section_vals_type), POINTER :: work_section
REAL(KIND=dp), DIMENSION(:), OPTIONAL, POINTER :: eta, veta, fnhc, mnhc
@ -2097,7 +2106,9 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
ss_section%values(ik, 1)%list => vals
END SUBROUTINE meta_hills_val_set_ss
! **************************************************************************************************
@ -2165,7 +2176,9 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
ds_section%values(ik, 1)%list => vals
END SUBROUTINE meta_hills_val_set_ds
! **************************************************************************************************
@ -2229,7 +2242,9 @@ CONTAINS
END IF
NULLIFY (my_val)
END DO
ww_section%values(ik, 1)%list => vals
END SUBROUTINE meta_hills_val_set_ww
! **************************************************************************************************
@ -2850,6 +2865,7 @@ CONTAINS
!> unit_number: Logical unit number of the file written to
! **************************************************************************************************
SUBROUTINE stop_write(object, unit_number)
CHARACTER(LEN=*), INTENT(IN) :: object
INTEGER, INTENT(IN) :: unit_number

2
src/qs_kind_types.F
View file

@ -1847,7 +1847,7 @@ CONTAINS
END IF
END IF
END IF
!Beta spin
! Beta spin
NULLIFY (spin_section)
spin_section => section_vals_get_subs_vals(bs_section, "BETA")
CALL section_vals_get(spin_section, explicit=explicit)

56
src/rpa_gw.F
View file

@ -67,8 +67,6 @@ MODULE rpa_gw
dbt_get_block, dbt_get_info, dbt_iterator_blocks_left, dbt_iterator_next_block, &
dbt_iterator_start, dbt_iterator_stop, dbt_iterator_type, dbt_nblks_total, &
dbt_pgrid_create, dbt_pgrid_destroy, dbt_pgrid_type, dbt_type
USE external_potential_soc_parameters,ONLY: get_kprj_SOC_parameters
USE external_potential_types, ONLY: gth_potential_type
USE hfx_types, ONLY: block_ind_type,&
dealloc_containers,&
hfx_compression_type
@ -77,9 +75,7 @@ MODULE rpa_gw
ri_rpa_g0w0_crossing_bisection,&
ri_rpa_g0w0_crossing_newton,&
ri_rpa_g0w0_crossing_z_shot,&
soc_lda,&
soc_none,&
soc_pbe
soc_none
USE input_section_types, ONLY: section_vals_get_subs_vals,&
section_vals_type
USE kinds, ONLY: default_path_length,&
@ -1525,9 +1521,9 @@ CONTAINS
END IF
! decide whether to add spin-orbit splitting of bands, spin-orbit coupling strength comes from
! Decide whether to add spin-orbit splitting of bands, spin-orbit coupling strength comes from
! Hartwigsen parametrization (1999) of GTH pseudopotentials
IF (mp2_env%ri_g0w0%soc_type .NE. soc_none) THEN
IF (mp2_env%ri_g0w0%soc_type /= soc_none) THEN
CALL calculate_and_print_soc(qs_env, Eigenval_scf, Eigenval_scf, gw_corr_lev_occ, gw_corr_lev_virt, &
homo, unit_nr, do_soc_gw=.FALSE., do_soc_scf=.TRUE.)
CALL calculate_and_print_soc(qs_env, Eigenval, Eigenval_scf, gw_corr_lev_occ, gw_corr_lev_virt, &
@ -1589,9 +1585,8 @@ CONTAINS
CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_and_print_soc'
CHARACTER(LEN=2) :: element_symbol
INTEGER :: handle, i_dim, i_glob, i_row, ikind, ikp, j_col, j_glob, n_level_gw, nao, &
ncol_local, nder, nkind, nkp_self_energy, nrow_local, periodic(3), size_real_space
INTEGER :: handle, i_dim, i_glob, i_row, ikp, j_col, j_glob, n_level_gw, nao, ncol_local, &
nder, nkind, nkp_self_energy, nrow_local, periodic(3), size_real_space
INTEGER, ALLOCATABLE, DIMENSION(:) :: index0
INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
LOGICAL :: calculate_forces, use_virial
@ -1611,7 +1606,6 @@ CONTAINS
matrix_dummy, matrix_l, &
matrix_pot_dummy
TYPE(dft_control_type), POINTER :: dft_control
TYPE(gth_potential_type), POINTER :: gth_potential
TYPE(kpoint_type), POINTER :: kpoints_Sigma
TYPE(mp_para_env_type), POINTER :: para_env
TYPE(neighbor_list_set_p_type), DIMENSION(:), &
@ -1639,30 +1633,6 @@ CONTAINS
nkind=nkind, &
scf_control=scf_control)
DO ikind = 1, nkind
CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, element_symbol=element_symbol)
IF (.NOT. ASSOCIATED(gth_potential%kprj_ppnl)) THEN
! write SOC parameters to gth_potential%kprj_ppnl
ALLOCATE (gth_potential%kprj_ppnl(0:6, 0:6, 0:6))
gth_potential%kprj_ppnl(:, :, :) = 0.0_dp
ALLOCATE (gth_potential%wprj_ppnl(0:100, 0:100))
gth_potential%wprj_ppnl(:, :) = 0.0_dp
END IF
SELECT CASE (qs_env%mp2_env%ri_g0w0%soc_type)
CASE (soc_lda)
CALL get_kprj_SOC_parameters(gth_potential, "LDA", element_symbol)
CASE (soc_pbe)
CALL get_kprj_SOC_parameters(gth_potential, "PBE", element_symbol)
CASE DEFAULT
CPABORT("Unknown SOC type.")
END SELECT
END DO
calculate_forces = .FALSE.
use_virial = .FALSE.
nder = 0
@ -1911,22 +1881,6 @@ CONTAINS
CALL cp_cfm_release(cfm_mat_work_double)
DEALLOCATE (eigenvalues)
! JW FOR LATER: READING SOC PARAMETERS FROM FILE
!
! CALL init_potential(qs_kind%gth_potential)
! CALL allocate_potential(qs_kind%gth_potential)
! CALL read_potential(qs_kind%element_symbol, potential_name, &
! qs_kind%gth_potential, zeff_correction, para_env, &
! potential_file_name, potential_section, update_input)
!
! nkind = SIZE(qs_kind_set)
!
! DO ikind = 1, nkind
! IF (ASSOCIATED(qs_kind_set(ikind)%gth_potential)) THEN
! CALL deallocate_potential(qs_kind_set(ikind)%gth_potential)
! END IF
! END DO
CALL timestop(handle)
END SUBROUTINE calculate_and_print_soc

2157
src/subsys/external_potential_soc_parameters.F
View file

File diff suppressed because it is too large Load diff

465
src/subsys/external_potential_types.F
View file

File diff suppressed because it is too large Load diff

4
tests/QS/regtest-gpw-1/H2O-geoopt.inp
View file

@ -2,7 +2,7 @@
EPS_CHECK_DIAG 1.0E-14
PREFERRED_DIAG_LIBRARY ScaLAPACK
PRINT_LEVEL low
PROJECT H2O-geoopt
PROJECT " H2O geoopt " # check digestion of spaces
RUN_TYPE GEO_OPT
&END GLOBAL
&MOTION
@ -35,7 +35,7 @@
STRESS_TENSOR ANALYTICAL
&DFT
BASIS_SET_FILE_NAME BASIS_SET
POTENTIAL_FILE_NAME POTENTIAL
POTENTIAL_FILE_NAME "GTH_SOC_POTENTIALS" # quotes needed to allow for this comment
&MGRID
CUTOFF 200
&END MGRID

4
tests/QS/regtest-gw-kpoints/G0W0_IH_SOC.inp
View file

@ -1,5 +1,5 @@
&GLOBAL
PROJECT IH
PROJECT IH
PRINT_LEVEL MEDIUM
RUN_TYPE ENERGY
&TIMINGS
@ -13,7 +13,7 @@
BASIS_SET_FILE_NAME HFX_BASIS
BASIS_SET_FILE_NAME ./REGTEST_BASIS_I
SORT_BASIS EXP
POTENTIAL_FILE_NAME GTH_POTENTIALS
POTENTIAL_FILE_NAME GTH_SOC_POTENTIALS
&MGRID
CUTOFF 100
REL_CUTOFF 20