diff --git a/data/Allegro/gra-water-deployed-neq060sp.pth b/data/Allegro/gra-water-deployed-neq060sp.pth index fa9b13d997..9fa9c440d4 100644 Binary files a/data/Allegro/gra-water-deployed-neq060sp.pth and b/data/Allegro/gra-water-deployed-neq060sp.pth differ diff --git a/data/Allegro/si-deployed-neq060dp.pth b/data/Allegro/si-deployed-neq060dp.pth index 394640d74e..65dc3e481d 100644 Binary files a/data/Allegro/si-deployed-neq060dp.pth and b/data/Allegro/si-deployed-neq060dp.pth differ diff --git a/data/NequIP/water-deployed-neq060dp.pth b/data/NequIP/water-deployed-neq060dp.pth index a481aca10c..1ff3cb5934 100644 Binary files a/data/NequIP/water-deployed-neq060dp.pth and b/data/NequIP/water-deployed-neq060dp.pth differ diff --git a/data/NequIP/water-deployed-neq060sp.pth b/data/NequIP/water-deployed-neq060sp.pth index 1fdda1f2dc..397b3e6a2d 100644 Binary files a/data/NequIP/water-deployed-neq060sp.pth and b/data/NequIP/water-deployed-neq060sp.pth differ diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 3691791c9f..e2899e4edd 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -209,10 +209,14 @@ list( grrm_utils.F gapw_1c_basis_set.F gw_communication.F - gw_methods.F + gw_main.F + gw_large_cell_gamma.F + gw_small_cell_full_kp.F post_scf_bandstructure_types.F post_scf_bandstructure_utils.F gw_utils.F + gw_integrals.F + gw_kp_to_real_space_and_back.F hartree_local_methods.F hartree_local_types.F header.F diff --git a/src/common/bibliography.F b/src/common/bibliography.F index 61fa46fca1..5642df6be4 100644 --- a/src/common/bibliography.F +++ b/src/common/bibliography.F @@ -4901,6 +4901,9 @@ SUBROUTINE add_all_references() " dichalcogenide heterobilayers", & "SO Journal of Chemical Theory and Computation", & "PY 2024", & + "VL 20", & + "BP 2202", & + "EP 2208", & "ER"), & DOI="10.1021/acs.jctc.3c01230") diff --git a/src/gw_communication.F b/src/gw_communication.F index f944baba5d..b3cd7d65e6 100644 --- a/src/gw_communication.F +++ b/src/gw_communication.F @@ -16,10 +16,20 @@ MODULE gw_communication dbcsr_get_stored_coordinates, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_release, & dbcsr_reserve_all_blocks, dbcsr_reserve_blocks, dbcsr_set, dbcsr_type + USE cp_dbcsr_operations, ONLY: copy_fm_to_dbcsr + USE cp_fm_types, ONLY: cp_fm_type + USE dbt_api, ONLY: dbt_clear,& + dbt_copy,& + dbt_copy_matrix_to_tensor,& + dbt_copy_tensor_to_matrix,& + dbt_create,& + dbt_destroy,& + dbt_type USE kinds, ONLY: dp USE message_passing, ONLY: mp_para_env_type,& mp_request_type,& mp_waitall + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type #include "./base/base_uses.f90" IMPLICIT NONE @@ -28,7 +38,7 @@ MODULE gw_communication CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_communication' - PUBLIC :: global_matrix_to_local_matrix, local_matrix_to_global_matrix + PUBLIC :: local_dbt_to_global_mat, fm_to_local_tensor TYPE buffer_type REAL(KIND=dp), DIMENSION(:), POINTER :: msg => NULL() @@ -40,6 +50,81 @@ MODULE gw_communication CONTAINS +! ************************************************************************************************** +!> \brief ... +!> \param fm_global ... +!> \param mat_global ... +!> \param mat_local ... +!> \param tensor ... +!> \param bs_env ... +!> \param atom_ranges ... +! ************************************************************************************************** + SUBROUTINE fm_to_local_tensor(fm_global, mat_global, mat_local, tensor, bs_env, atom_ranges) + + TYPE(cp_fm_type) :: fm_global + TYPE(dbcsr_type) :: mat_global, mat_local + TYPE(dbt_type) :: tensor + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER, DIMENSION(:, :), OPTIONAL :: atom_ranges + + CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_to_local_tensor' + + INTEGER :: handle + TYPE(dbt_type) :: tensor_tmp + + CALL timeset(routineN, handle) + + CALL dbt_clear(tensor) + CALL copy_fm_to_dbcsr(fm_global, mat_global, keep_sparsity=.FALSE.) + CALL dbcsr_filter(mat_global, bs_env%eps_filter) + IF (PRESENT(atom_ranges)) THEN + CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, & + bs_env%para_env_tensor%num_pe, atom_ranges) + ELSE + CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, & + bs_env%para_env_tensor%num_pe) + END IF + CALL dbt_create(mat_local, tensor_tmp) + CALL dbt_copy_matrix_to_tensor(mat_local, tensor_tmp) + CALL dbt_copy(tensor_tmp, tensor, move_data=.TRUE.) + CALL dbt_destroy(tensor_tmp) + CALL dbcsr_set(mat_local, 0.0_dp) + CALL dbcsr_filter(mat_local, 1.0_dp) + + CALL timestop(handle) + + END SUBROUTINE fm_to_local_tensor + +! ************************************************************************************************** +!> \brief ... +!> \param tensor ... +!> \param mat_tensor ... +!> \param mat_global ... +!> \param para_env ... +! ************************************************************************************************** + SUBROUTINE local_dbt_to_global_mat(tensor, mat_tensor, mat_global, para_env) + + TYPE(dbt_type) :: tensor + TYPE(dbcsr_type) :: mat_tensor, mat_global + TYPE(mp_para_env_type), POINTER :: para_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'local_dbt_to_global_mat' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbt_copy_tensor_to_matrix(tensor, mat_tensor) + CALL dbt_clear(tensor) + ! the next para_env%sync is not mandatory, but it makes the timing output + ! of local_matrix_to_global_matrix correct + CALL para_env%sync() + CALL local_matrix_to_global_matrix(mat_tensor, mat_global, para_env) + + CALL timestop(handle) + + END SUBROUTINE local_dbt_to_global_mat + ! ************************************************************************************************** !> \brief ... !> \param mat_global ... diff --git a/src/gw_integrals.F b/src/gw_integrals.F new file mode 100644 index 0000000000..ed463139ba --- /dev/null +++ b/src/gw_integrals.F @@ -0,0 +1,452 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2024 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief Utility method to build 3-center integrals for small cell GW +! ************************************************************************************************** +MODULE gw_integrals + USE OMP_LIB, ONLY: omp_get_thread_num + USE ai_contraction_sphi, ONLY: abc_contract_xsmm + USE atomic_kind_types, ONLY: atomic_kind_type,& + get_atomic_kind_set + USE basis_set_types, ONLY: get_gto_basis_set,& + gto_basis_set_p_type,& + gto_basis_set_type + USE cell_types, ONLY: cell_type,& + get_cell,& + pbc + USE cp_array_utils, ONLY: cp_2d_r_p_type + USE cp_control_types, ONLY: dft_control_type + USE cp_files, ONLY: close_file,& + open_file + USE gamma, ONLY: init_md_ftable + USE input_constants, ONLY: do_potential_coulomb,& + do_potential_id,& + do_potential_short,& + do_potential_truncated + USE kinds, ONLY: dp + USE libint_2c_3c, ONLY: cutoff_screen_factor,& + eri_3center,& + libint_potential_type + USE libint_wrapper, ONLY: cp_libint_cleanup_3eri,& + cp_libint_init_3eri,& + cp_libint_set_contrdepth,& + cp_libint_t + USE message_passing, ONLY: mp_para_env_type + USE orbital_pointers, ONLY: ncoset + USE particle_types, ONLY: particle_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE qs_kind_types, ONLY: qs_kind_type + USE t_c_g0, ONLY: get_lmax_init,& + init + +!$ USE OMP_LIB, ONLY: omp_get_max_threads, omp_get_thread_num +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_integrals' + + PUBLIC :: build_3c_integral_block + +CONTAINS + +! ************************************************************************************************** +!> \brief ... +!> \param int_3c ... +!> \param qs_env ... +!> \param potential_parameter ... +!> \param basis_j ... +!> \param basis_k ... +!> \param basis_i ... +!> \param cell_j ... +!> \param cell_k ... +!> \param cell_i ... +!> \param atom_j ... +!> \param atom_k ... +!> \param atom_i ... +!> \param j_bf_start_from_atom ... +!> \param k_bf_start_from_atom ... +!> \param i_bf_start_from_atom ... +! ************************************************************************************************** + SUBROUTINE build_3c_integral_block(int_3c, qs_env, potential_parameter, & + basis_j, basis_k, basis_i, & + cell_j, cell_k, cell_i, atom_j, atom_k, atom_i, & + j_bf_start_from_atom, k_bf_start_from_atom, & + i_bf_start_from_atom) + + REAL(KIND=dp), DIMENSION(:, :, :) :: int_3c + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(libint_potential_type), INTENT(IN) :: potential_parameter + TYPE(gto_basis_set_p_type), DIMENSION(:) :: basis_j, basis_k, basis_i + INTEGER, DIMENSION(3), INTENT(IN), OPTIONAL :: cell_j, cell_k, cell_i + INTEGER, INTENT(IN), OPTIONAL :: atom_j, atom_k, atom_i + INTEGER, DIMENSION(:), OPTIONAL :: j_bf_start_from_atom, & + k_bf_start_from_atom, & + i_bf_start_from_atom + + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_3c_integral_block' + + INTEGER :: at_i, at_j, at_k, block_end_i, block_end_j, block_end_k, block_start_i, & + block_start_j, block_start_k, egfi, handle, i, i_offset, ibasis, ikind, ilist, imax, is, & + iset, j_offset, jkind, js, jset, k_offset, kkind, ks, kset, m_max, max_ncoi, max_ncoj, & + max_ncok, max_nset, max_nsgfi, max_nsgfj, max_nsgfk, maxli, maxlj, maxlk, natom, nbasis, & + ncoi, ncoj, ncok, nseti, nsetj, nsetk, op_ij, op_jk, sgfi, sgfj, sgfk, unit_id + INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of + INTEGER, DIMENSION(3) :: my_cell_i, my_cell_j, my_cell_k + INTEGER, DIMENSION(:), POINTER :: lmax_i, lmax_j, lmax_k, lmin_i, lmin_j, & + lmin_k, npgfi, npgfj, npgfk, nsgfi, & + nsgfj, nsgfk + INTEGER, DIMENSION(:, :), POINTER :: first_sgf_i, first_sgf_j, first_sgf_k + REAL(KIND=dp) :: dij, dik, djk, dr_ij, dr_ik, dr_jk, & + kind_radius_i, kind_radius_j, & + kind_radius_k, sijk_ext + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ccp_buffer, cpp_buffer, & + max_contraction_i, max_contraction_j, & + max_contraction_k + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: sijk, sijk_contr + REAL(KIND=dp), DIMENSION(3) :: ri, rij, rik, rj, rjk, rk + REAL(KIND=dp), DIMENSION(3, 3) :: hmat + REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_i, set_radius_j, set_radius_k + REAL(KIND=dp), DIMENSION(:, :), POINTER :: rpgf_i, rpgf_j, rpgf_k, sphi_i, sphi_j, & + sphi_k, zeti, zetj, zetk + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(cell_type), POINTER :: cell + TYPE(cp_2d_r_p_type), DIMENSION(:, :), POINTER :: spi, spk, tspj + TYPE(cp_libint_t) :: lib + TYPE(dft_control_type), POINTER :: dft_control + TYPE(gto_basis_set_type), POINTER :: basis_set + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + + CALL timeset(routineN, handle) + + op_ij = potential_parameter%potential_type + op_jk = do_potential_id + + dr_ij = 0.0_dp; dr_jk = 0.0_dp; dr_ik = 0.0_dp + + IF (op_ij == do_potential_truncated .OR. op_ij == do_potential_short) THEN + dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor + dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor + ELSEIF (op_ij == do_potential_coulomb) THEN + dr_ij = 1000000.0_dp + dr_ik = 1000000.0_dp + END IF + + NULLIFY (qs_kind_set, atomic_kind_set) + + ! get stuff + CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, cell=cell, & + natom=natom, dft_control=dft_control, para_env=para_env, & + particle_set=particle_set) + CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of) + CALL get_cell(cell=cell, h=hmat) + + !Need the max l for each basis for libint and max nset, nco and nsgf for LIBXSMM contraction + nbasis = SIZE(basis_i) + max_nsgfi = 0 + max_ncoi = 0 + max_nset = 0 + maxli = 0 + DO ibasis = 1, nbasis + CALL get_gto_basis_set(gto_basis_set=basis_i(ibasis)%gto_basis_set, maxl=imax, & + nset=iset, nsgf_set=nsgfi, npgf=npgfi) + maxli = MAX(maxli, imax) + max_nset = MAX(max_nset, iset) + max_nsgfi = MAX(max_nsgfi, MAXVAL(nsgfi)) + max_ncoi = MAX(max_ncoi, MAXVAL(npgfi)*ncoset(maxli)) + END DO + max_nsgfj = 0 + max_ncoj = 0 + maxlj = 0 + DO ibasis = 1, nbasis + CALL get_gto_basis_set(gto_basis_set=basis_j(ibasis)%gto_basis_set, maxl=imax, & + nset=jset, nsgf_set=nsgfj, npgf=npgfj) + maxlj = MAX(maxlj, imax) + max_nset = MAX(max_nset, jset) + max_nsgfj = MAX(max_nsgfj, MAXVAL(nsgfj)) + max_ncoj = MAX(max_ncoj, MAXVAL(npgfj)*ncoset(maxlj)) + END DO + max_nsgfk = 0 + max_ncok = 0 + maxlk = 0 + DO ibasis = 1, nbasis + CALL get_gto_basis_set(gto_basis_set=basis_k(ibasis)%gto_basis_set, maxl=imax, & + nset=kset, nsgf_set=nsgfk, npgf=npgfk) + maxlk = MAX(maxlk, imax) + max_nset = MAX(max_nset, kset) + max_nsgfk = MAX(max_nsgfk, MAXVAL(nsgfk)) + max_ncok = MAX(max_ncok, MAXVAL(npgfk)*ncoset(maxlk)) + END DO + m_max = maxli + maxlj + maxlk + + !To minimize expensive memory opsand generally optimize contraction, pre-allocate + !contiguous sphi arrays (and transposed in the cas of sphi_i) + + NULLIFY (tspj, spi, spk) + ALLOCATE (spi(max_nset, nbasis), tspj(max_nset, nbasis), spk(max_nset, nbasis)) + + DO ibasis = 1, nbasis + DO iset = 1, max_nset + NULLIFY (spi(iset, ibasis)%array) + NULLIFY (tspj(iset, ibasis)%array) + + NULLIFY (spk(iset, ibasis)%array) + END DO + END DO + + DO ilist = 1, 3 + DO ibasis = 1, nbasis + IF (ilist == 1) basis_set => basis_i(ibasis)%gto_basis_set + IF (ilist == 2) basis_set => basis_j(ibasis)%gto_basis_set + IF (ilist == 3) basis_set => basis_k(ibasis)%gto_basis_set + + DO iset = 1, basis_set%nset + + ncoi = basis_set%npgf(iset)*ncoset(basis_set%lmax(iset)) + sgfi = basis_set%first_sgf(1, iset) + egfi = sgfi + basis_set%nsgf_set(iset) - 1 + + IF (ilist == 1) THEN + ALLOCATE (spi(iset, ibasis)%array(ncoi, basis_set%nsgf_set(iset))) + spi(iset, ibasis)%array(:, :) = basis_set%sphi(1:ncoi, sgfi:egfi) + + ELSE IF (ilist == 2) THEN + ALLOCATE (tspj(iset, ibasis)%array(basis_set%nsgf_set(iset), ncoi)) + tspj(iset, ibasis)%array(:, :) = TRANSPOSE(basis_set%sphi(1:ncoi, sgfi:egfi)) + + ELSE + ALLOCATE (spk(iset, ibasis)%array(ncoi, basis_set%nsgf_set(iset))) + spk(iset, ibasis)%array(:, :) = basis_set%sphi(1:ncoi, sgfi:egfi) + END IF + + END DO !iset + END DO !ibasis + END DO !ilist + + !Init the truncated Coulomb operator + IF (op_ij == do_potential_truncated .OR. op_jk == do_potential_truncated) THEN + + IF (m_max > get_lmax_init()) THEN + IF (para_env%mepos == 0) THEN + CALL open_file(unit_number=unit_id, file_name=potential_parameter%filename) + END IF + CALL init(m_max, unit_id, para_env%mepos, para_env) + IF (para_env%mepos == 0) THEN + CALL close_file(unit_id) + END IF + END IF + END IF + + CALL init_md_ftable(nmax=m_max) + + CALL cp_libint_init_3eri(lib, MAX(maxli, maxlj, maxlk)) + CALL cp_libint_set_contrdepth(lib, 1) + + !pre-allocate contraction buffers + ALLOCATE (cpp_buffer(max_nsgfj*max_ncok), ccp_buffer(max_nsgfj*max_nsgfk*max_ncoi)) + int_3c(:, :, :) = 0.0_dp + + ! loop over all RI atoms + DO at_i = 1, natom + + ! loop over all AO atoms + DO at_j = 1, natom + + ! loop over all AO atoms + DO at_k = 1, natom + + IF (PRESENT(atom_i)) THEN + IF (at_i .NE. atom_i) CYCLE + END IF + IF (PRESENT(atom_j)) THEN + IF (at_j .NE. atom_j) CYCLE + END IF + IF (PRESENT(atom_k)) THEN + IF (at_k .NE. atom_k) CYCLE + END IF + + my_cell_i(1:3) = 0 + IF (PRESENT(cell_i)) my_cell_i(1:3) = cell_i(1:3) + my_cell_j(1:3) = 0 + IF (PRESENT(cell_j)) my_cell_j(1:3) = cell_j(1:3) + my_cell_k(1:3) = 0 + IF (PRESENT(cell_k)) my_cell_k(1:3) = cell_k(1:3) + + ri = pbc(particle_set(at_i)%r(1:3), cell) + MATMUL(hmat, REAL(my_cell_i, dp)) + rj = pbc(particle_set(at_j)%r(1:3), cell) + MATMUL(hmat, REAL(my_cell_j, dp)) + rk = pbc(particle_set(at_k)%r(1:3), cell) + MATMUL(hmat, REAL(my_cell_k, dp)) + + rjk(1:3) = rk(1:3) - rj(1:3) + rij(1:3) = rj(1:3) - ri(1:3) + rik(1:3) = rk(1:3) - ri(1:3) + + djk = NORM2(rjk) + dij = NORM2(rij) + dik = NORM2(rik) + + ikind = kind_of(at_i) + jkind = kind_of(at_j) + kkind = kind_of(at_k) + + CALL get_gto_basis_set(basis_i(ikind)%gto_basis_set, first_sgf=first_sgf_i, & + lmax=lmax_i, lmin=lmin_i, npgf=npgfi, nset=nseti, & + nsgf_set=nsgfi, pgf_radius=rpgf_i, set_radius=set_radius_i, & + sphi=sphi_i, zet=zeti, kind_radius=kind_radius_i) + + CALL get_gto_basis_set(basis_j(jkind)%gto_basis_set, first_sgf=first_sgf_j, & + lmax=lmax_j, lmin=lmin_j, npgf=npgfj, nset=nsetj, & + nsgf_set=nsgfj, pgf_radius=rpgf_j, set_radius=set_radius_j, & + sphi=sphi_j, zet=zetj, kind_radius=kind_radius_j) + + CALL get_gto_basis_set(basis_k(kkind)%gto_basis_set, first_sgf=first_sgf_k, & + lmax=lmax_k, lmin=lmin_k, npgf=npgfk, nset=nsetk, & + nsgf_set=nsgfk, pgf_radius=rpgf_k, set_radius=set_radius_k, & + sphi=sphi_k, zet=zetk, kind_radius=kind_radius_k) + + IF (kind_radius_j + kind_radius_i + dr_ij < dij) CYCLE + IF (kind_radius_j + kind_radius_k + dr_jk < djk) CYCLE + IF (kind_radius_k + kind_radius_i + dr_ik < dik) CYCLE + + ALLOCATE (max_contraction_i(nseti)) + max_contraction_i = 0.0_dp + DO iset = 1, nseti + sgfi = first_sgf_i(1, iset) + max_contraction_i(iset) = MAXVAL((/(SUM(ABS(sphi_i(:, i))), i=sgfi, & + sgfi + nsgfi(iset) - 1)/)) + END DO + + ALLOCATE (max_contraction_j(nsetj)) + max_contraction_j = 0.0_dp + DO jset = 1, nsetj + sgfj = first_sgf_j(1, jset) + max_contraction_j(jset) = MAXVAL((/(SUM(ABS(sphi_j(:, i))), i=sgfj, & + sgfj + nsgfj(jset) - 1)/)) + END DO + + ALLOCATE (max_contraction_k(nsetk)) + max_contraction_k = 0.0_dp + DO kset = 1, nsetk + sgfk = first_sgf_k(1, kset) + max_contraction_k(kset) = MAXVAL((/(SUM(ABS(sphi_k(:, i))), i=sgfk, & + sgfk + nsgfk(kset) - 1)/)) + END DO + + DO iset = 1, nseti + + DO jset = 1, nsetj + + IF (set_radius_j(jset) + set_radius_i(iset) + dr_ij < dij) CYCLE + + DO kset = 1, nsetk + + IF (set_radius_j(jset) + set_radius_k(kset) + dr_jk < djk) CYCLE + IF (set_radius_k(kset) + set_radius_i(iset) + dr_ik < dik) CYCLE + + ncoi = npgfi(iset)*ncoset(lmax_i(iset)) + ncoj = npgfj(jset)*ncoset(lmax_j(jset)) + ncok = npgfk(kset)*ncoset(lmax_k(kset)) + + sgfi = first_sgf_i(1, iset) + sgfj = first_sgf_j(1, jset) + sgfk = first_sgf_k(1, kset) + + IF (ncoj*ncok*ncoi .LE. 0) CYCLE + ALLOCATE (sijk(ncoj, ncok, ncoi)) + sijk(:, :, :) = 0.0_dp + + is = iset + js = jset + ks = kset + + CALL eri_3center(sijk, & + lmin_j(js), lmax_j(js), npgfj(js), zetj(:, js), & + rpgf_j(:, js), rj, & + lmin_k(ks), lmax_k(ks), npgfk(ks), zetk(:, ks), & + rpgf_k(:, ks), rk, & + lmin_i(is), lmax_i(is), npgfi(is), zeti(:, is), & + rpgf_i(:, is), ri, & + djk, dij, dik, lib, potential_parameter, & + int_abc_ext=sijk_ext) + + ALLOCATE (sijk_contr(nsgfj(jset), nsgfk(kset), nsgfi(iset))) + CALL abc_contract_xsmm(sijk_contr, sijk, tspj(jset, jkind)%array, & + spk(kset, kkind)%array, spi(iset, ikind)%array, & + ncoj, ncok, ncoi, nsgfj(jset), nsgfk(kset), & + nsgfi(iset), cpp_buffer, ccp_buffer) + DEALLOCATE (sijk) + + IF (PRESENT(atom_j)) THEN + j_offset = 0 + ELSE + CPASSERT(PRESENT(j_bf_start_from_atom)) + j_offset = j_bf_start_from_atom(at_j) - 1 + END IF + IF (PRESENT(atom_k)) THEN + k_offset = 0 + ELSE + CPASSERT(PRESENT(k_bf_start_from_atom)) + k_offset = k_bf_start_from_atom(at_k) - 1 + END IF + IF (PRESENT(atom_i)) THEN + i_offset = 0 + ELSE + CPASSERT(PRESENT(i_bf_start_from_atom)) + i_offset = i_bf_start_from_atom(at_i) - 1 + END IF + + block_start_j = sgfj + j_offset + block_end_j = sgfj + nsgfj(jset) - 1 + j_offset + block_start_k = sgfk + k_offset + block_end_k = sgfk + nsgfk(kset) - 1 + k_offset + block_start_i = sgfi + i_offset + block_end_i = sgfi + nsgfi(iset) - 1 + i_offset + + int_3c(block_start_j:block_end_j, & + block_start_k:block_end_k, & + block_start_i:block_end_i) = & + int_3c(block_start_j:block_end_j, & + block_start_k:block_end_k, & + block_start_i:block_end_i) + & + sijk_contr(:, :, :) + DEALLOCATE (sijk_contr) + + END DO + + END DO + + END DO + + DEALLOCATE (max_contraction_i, max_contraction_j, max_contraction_k) + + END DO ! atom_k (AO) + END DO ! atom_j (AO) + END DO ! atom_i (RI) + + CALL cp_libint_cleanup_3eri(lib) + + DO iset = 1, max_nset + DO ibasis = 1, nbasis + IF (ASSOCIATED(spi(iset, ibasis)%array)) DEALLOCATE (spi(iset, ibasis)%array) + IF (ASSOCIATED(tspj(iset, ibasis)%array)) DEALLOCATE (tspj(iset, ibasis)%array) + + IF (ASSOCIATED(spk(iset, ibasis)%array)) DEALLOCATE (spk(iset, ibasis)%array) + END DO + END DO + DEALLOCATE (spi, tspj, spk) + + CALL timestop(handle) + + END SUBROUTINE build_3c_integral_block + +END MODULE + diff --git a/src/gw_kp_to_real_space_and_back.F b/src/gw_kp_to_real_space_and_back.F new file mode 100644 index 0000000000..73438ab58b --- /dev/null +++ b/src/gw_kp_to_real_space_and_back.F @@ -0,0 +1,292 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2024 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief +!> \author Jan Wilhelm +!> \date 05.2024 +! ************************************************************************************************** +MODULE gw_kp_to_real_space_and_back + USE cp_cfm_types, ONLY: cp_cfm_type + USE cp_fm_types, ONLY: cp_fm_set_all,& + cp_fm_type + USE kinds, ONLY: dp + USE kpoint_types, ONLY: kpoint_type + USE mathconstants, ONLY: gaussi,& + twopi,& + z_one,& + z_zero +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_kp_to_real_space_and_back' + + PUBLIC :: fm_trafo_rs_to_ikp, trafo_rs_to_ikp, trafo_ikp_to_rs, fm_add_ikp_to_rs, & + add_ikp_to_all_rs + +CONTAINS + +! ************************************************************************************************** +!> \brief ... +!> \param cfm_ikp ... +!> \param fm_rs ... +!> \param kpoints ... +!> \param ikp ... +! ************************************************************************************************** + SUBROUTINE fm_trafo_rs_to_ikp(cfm_ikp, fm_rs, kpoints, ikp) + TYPE(cp_cfm_type) :: cfm_ikp + TYPE(cp_fm_type), DIMENSION(:) :: fm_rs + TYPE(kpoint_type), POINTER :: kpoints + INTEGER :: ikp + + CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_trafo_rs_to_ikp' + + INTEGER :: handle, img, nimages, nimages_fm_rs + + CALL timeset(routineN, handle) + + nimages = SIZE(kpoints%index_to_cell, 1) + nimages_fm_rs = SIZE(fm_rs) + + CPASSERT(nimages == nimages_fm_rs) + + cfm_ikp%local_data(:, :) = z_zero + DO img = 1, nimages + + CALL add_rs_to_ikp(fm_rs(img)%local_data, cfm_ikp%local_data, kpoints%index_to_cell, & + kpoints%xkp(1:3, ikp), img) + + END DO + + CALL timestop(handle) + + END SUBROUTINE fm_trafo_rs_to_ikp + +! ************************************************************************************************** +!> \brief ... +!> \param array_rs ... +!> \param array_kp ... +!> \param index_to_cell ... +!> \param xkp ... +! ************************************************************************************************** + SUBROUTINE trafo_rs_to_ikp(array_rs, array_kp, index_to_cell, xkp) + REAL(KIND=dp), DIMENSION(:, :, :) :: array_rs + COMPLEX(KIND=dp), DIMENSION(:, :) :: array_kp + INTEGER, DIMENSION(:, :) :: index_to_cell + REAL(KIND=dp) :: xkp(3) + + CHARACTER(LEN=*), PARAMETER :: routineN = 'trafo_rs_to_ikp' + + INTEGER :: handle, i_cell, nimages + + CALL timeset(routineN, handle) + + nimages = SIZE(index_to_cell, 1) + + CPASSERT(nimages == SIZE(array_rs, 3)) + + array_kp(:, :) = 0.0_dp + DO i_cell = 1, nimages + + CALL add_rs_to_ikp(array_rs(:, :, i_cell), array_kp, index_to_cell, xkp, i_cell) + + END DO + + CALL timestop(handle) + + END SUBROUTINE trafo_rs_to_ikp + +! ************************************************************************************************** +!> \brief ... +!> \param array_rs ... +!> \param array_kp ... +!> \param index_to_cell ... +!> \param xkp ... +!> \param i_cell ... +! ************************************************************************************************** + SUBROUTINE add_rs_to_ikp(array_rs, array_kp, index_to_cell, xkp, i_cell) + REAL(KIND=dp), DIMENSION(:, :) :: array_rs + COMPLEX(KIND=dp), DIMENSION(:, :) :: array_kp + INTEGER, DIMENSION(:, :) :: index_to_cell + REAL(KIND=dp) :: xkp(3) + INTEGER :: i_cell + + CHARACTER(LEN=*), PARAMETER :: routineN = 'add_rs_to_ikp' + + COMPLEX(KIND=dp) :: expikR + INTEGER :: handle + REAL(KIND=dp) :: arg + + CALL timeset(routineN, handle) + + arg = REAL(index_to_cell(i_cell, 1), dp)*xkp(1) + & + REAL(index_to_cell(i_cell, 2), dp)*xkp(2) + & + REAL(index_to_cell(i_cell, 3), dp)*xkp(3) + + expikR = z_one*COS(twopi*arg) + gaussi*SIN(twopi*arg) + + array_kp(:, :) = array_kp(:, :) + expikR*array_rs(:, :) + + CALL timestop(handle) + + END SUBROUTINE add_rs_to_ikp + +! ************************************************************************************************** +!> \brief ... +!> \param array_kp ... +!> \param array_rs ... +!> \param cell ... +!> \param kpoints ... +! ************************************************************************************************** + SUBROUTINE trafo_ikp_to_rs(array_kp, array_rs, cell, kpoints) + COMPLEX(KIND=dp), DIMENSION(:, :, :) :: array_kp + REAL(KIND=dp), DIMENSION(:, :) :: array_rs + INTEGER :: cell(3) + TYPE(kpoint_type), POINTER :: kpoints + + CHARACTER(LEN=*), PARAMETER :: routineN = 'trafo_ikp_to_rs' + + INTEGER :: handle, ikp + + CALL timeset(routineN, handle) + + CPASSERT(kpoints%nkp == SIZE(array_kp, 3)) + + array_rs(:, :) = 0.0_dp + + DO ikp = 1, kpoints%nkp + + CALL add_ikp_to_rs(array_kp(:, :, ikp), array_rs, cell, kpoints, ikp) + + END DO + + CALL timestop(handle) + + END SUBROUTINE trafo_ikp_to_rs + +! ************************************************************************************************** +!> \brief ... +!> \param cfm_ikp ... +!> \param fm_rs ... +!> \param kpoints ... +!> \param ikp ... +! ************************************************************************************************** + SUBROUTINE fm_add_ikp_to_rs(cfm_ikp, fm_rs, kpoints, ikp) + TYPE(cp_cfm_type) :: cfm_ikp + TYPE(cp_fm_type), DIMENSION(:) :: fm_rs + TYPE(kpoint_type), POINTER :: kpoints + INTEGER :: ikp + + CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_add_ikp_to_rs' + + INTEGER :: handle, img, nimages, nimages_fm_rs + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: index_to_cell + + CALL timeset(routineN, handle) + + nimages = SIZE(kpoints%index_to_cell, 1) + nimages_fm_rs = SIZE(fm_rs) + + CPASSERT(nimages == nimages_fm_rs) + + ALLOCATE (index_to_cell(nimages, 3)) + index_to_cell(1:nimages, 1:3) = kpoints%index_to_cell(1:nimages, 1:3) + + DO img = 1, nimages + + IF (ikp == 1) CALL cp_fm_set_all(fm_rs(img), 0.0_dp) + + CALL add_ikp_to_rs(cfm_ikp%local_data(:, :), fm_rs(img)%local_data, & + index_to_cell(img, 1:3), kpoints, ikp) + + END DO + + CALL timestop(handle) + + END SUBROUTINE fm_add_ikp_to_rs + +! ************************************************************************************************** +!> \brief ... +!> \param array_kp ... +!> \param array_rs ... +!> \param kpoints ... +!> \param ikp ... +!> \param index_to_cell_ext ... +! ************************************************************************************************** + SUBROUTINE add_ikp_to_all_rs(array_kp, array_rs, kpoints, ikp, index_to_cell_ext) + COMPLEX(KIND=dp), DIMENSION(:, :) :: array_kp + REAL(KIND=dp), DIMENSION(:, :, :) :: array_rs + TYPE(kpoint_type), POINTER :: kpoints + INTEGER :: ikp + INTEGER, DIMENSION(:, :), OPTIONAL, POINTER :: index_to_cell_ext + + CHARACTER(LEN=*), PARAMETER :: routineN = 'add_ikp_to_all_rs' + + INTEGER :: cell(3), handle, img, nimages + INTEGER, DIMENSION(:, :), POINTER :: index_to_cell + + CALL timeset(routineN, handle) + + IF (PRESENT(index_to_cell_ext)) THEN + index_to_cell => index_to_cell_ext + ELSE + index_to_cell => kpoints%index_to_cell + END IF + + nimages = SIZE(index_to_cell, 1) + CPASSERT(SIZE(array_rs, 3) == nimages) + DO img = 1, nimages + + cell(1:3) = index_to_cell(img, 1:3) + + CALL add_ikp_to_rs(array_kp, array_rs(:, :, img), cell, kpoints, ikp) + + END DO + + CALL timestop(handle) + + END SUBROUTINE add_ikp_to_all_rs + +! ************************************************************************************************** +!> \brief ... +!> \param array_kp ... +!> \param array_rs ... +!> \param cell ... +!> \param kpoints ... +!> \param ikp ... +! ************************************************************************************************** + SUBROUTINE add_ikp_to_rs(array_kp, array_rs, cell, kpoints, ikp) + COMPLEX(KIND=dp), DIMENSION(:, :) :: array_kp + REAL(KIND=dp), DIMENSION(:, :) :: array_rs + INTEGER :: cell(3) + TYPE(kpoint_type), POINTER :: kpoints + INTEGER :: ikp + + CHARACTER(LEN=*), PARAMETER :: routineN = 'add_ikp_to_rs' + + INTEGER :: handle + REAL(KIND=dp) :: arg, im, re + + CALL timeset(routineN, handle) + + arg = REAL(cell(1), dp)*kpoints%xkp(1, ikp) + & + REAL(cell(2), dp)*kpoints%xkp(2, ikp) + & + REAL(cell(3), dp)*kpoints%xkp(3, ikp) + + re = COS(twopi*arg)*kpoints%wkp(ikp) + im = SIN(twopi*arg)*kpoints%wkp(ikp) + + array_rs(:, :) = array_rs(:, :) + re*REAL(array_kp(:, :)) + im*AIMAG(array_kp(:, :)) + + CALL timestop(handle) + + END SUBROUTINE add_ikp_to_rs + +END MODULE gw_kp_to_real_space_and_back diff --git a/src/gw_methods.F b/src/gw_large_cell_gamma.F similarity index 84% rename from src/gw_methods.F rename to src/gw_large_cell_gamma.F index 764d0c2c16..10c166af61 100644 --- a/src/gw_methods.F +++ b/src/gw_large_cell_gamma.F @@ -6,11 +6,11 @@ !--------------------------------------------------------------------------------------------------! ! ************************************************************************************************** -!> \brief +!> \brief Routines from paper [Graml2024] !> \author Jan Wilhelm !> \date 07.2023 ! ************************************************************************************************** -MODULE gw_methods +MODULE gw_large_cell_gamma USE atomic_kind_types, ONLY: atomic_kind_type USE cell_types, ONLY: cell_type,& get_cell,& @@ -27,10 +27,10 @@ MODULE gw_methods cp_cfm_type,& cp_fm_to_cfm USE cp_dbcsr_api, ONLY: & - dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_deallocate_matrix, dbcsr_filter, & - dbcsr_get_block_p, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & - dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_p_type, & - dbcsr_release, dbcsr_reserve_all_blocks, dbcsr_set, dbcsr_type + dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_deallocate_matrix, dbcsr_get_block_p, & + dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, dbcsr_iterator_start, & + dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_p_type, dbcsr_release, & + dbcsr_reserve_all_blocks, dbcsr_set, dbcsr_type USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& copy_fm_to_dbcsr,& dbcsr_deallocate_matrix_set @@ -49,16 +49,15 @@ MODULE gw_methods USE dbt_api, ONLY: dbt_clear,& dbt_contract,& dbt_copy,& - dbt_copy_matrix_to_tensor,& - dbt_copy_tensor_to_matrix,& dbt_create,& dbt_destroy,& dbt_type - USE gw_communication, ONLY: global_matrix_to_local_matrix,& - local_matrix_to_global_matrix - USE gw_utils, ONLY: create_and_init_bs_env_for_gw,& - de_init_bs_env - USE input_constants, ONLY: ri_rpa_g0w0_crossing_newton + USE gw_communication, ONLY: fm_to_local_tensor,& + local_dbt_to_global_mat + USE gw_utils, ONLY: analyt_conti_and_print,& + de_init_bs_env,& + get_VBM_CBM_bandgaps,& + time_to_freq USE input_section_types, ONLY: section_vals_type USE kinds, ONLY: default_string_length,& dp,& @@ -66,25 +65,20 @@ MODULE gw_methods USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp USE kpoint_types, ONLY: kpoint_type USE machine, ONLY: m_walltime - USE mathconstants, ONLY: gaussi,& - twopi,& + USE mathconstants, ONLY: twopi,& z_one,& z_zero - USE message_passing, ONLY: mp_file_delete,& - mp_para_env_type + USE message_passing, ONLY: mp_file_delete USE mp2_ri_2c, ONLY: RI_2c_integral_mat USE parallel_gemm_api, ONLY: parallel_gemm USE particle_types, ONLY: particle_type - USE physcon, ONLY: evolt USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type USE post_scf_bandstructure_utils, ONLY: MIC_contribution_from_ikp,& - cfm_ikp_from_fm_Gamma,& - get_fname + cfm_ikp_from_fm_Gamma USE qs_environment_types, ONLY: get_qs_env,& qs_environment_type USE qs_kind_types, ONLY: qs_kind_type USE qs_tensors, ONLY: build_3c_integrals - USE rpa_gw, ONLY: continuation_pade USE rpa_gw_kpoints_util, ONLY: cp_cfm_power,& cp_cfm_upper_to_full #include "./base/base_uses.f90" @@ -93,9 +87,9 @@ MODULE gw_methods PRIVATE - CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_methods' + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_large_cell_gamma' - PUBLIC :: gw + PUBLIC :: gw_calc_large_cell_Gamma CONTAINS @@ -103,28 +97,21 @@ MODULE gw_methods !> \brief Perform GW band structure calculation !> \param qs_env ... !> \param bs_env ... -!> \param post_scf_bandstructure_section ... !> \par History !> * 07.2023 created [Jan Wilhelm] ! ************************************************************************************************** - SUBROUTINE gw(qs_env, bs_env, post_scf_bandstructure_section) + SUBROUTINE gw_calc_large_cell_Gamma(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env - TYPE(section_vals_type), POINTER :: post_scf_bandstructure_section - CHARACTER(LEN=*), PARAMETER :: routineN = 'gw' + CHARACTER(LEN=*), PARAMETER :: routineN = 'gw_calc_large_cell_Gamma' INTEGER :: handle TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_Sigma_x_Gamma, fm_W_MIC_time TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :, :) :: fm_Sigma_c_Gamma_time - TYPE(mp_para_env_type), POINTER :: para_env CALL timeset(routineN, handle) - CALL get_qs_env(qs_env, para_env=para_env) - - CALL create_and_init_bs_env_for_gw(qs_env, bs_env, post_scf_bandstructure_section) - ! G^occ_µλ(i|τ|,k=0) = sum_n^occ C_µn(k=0) e^(-|(ϵ_nk=0-ϵ_F)τ|) C_λn(k=0) ! G^vir_µλ(i|τ|,k=0) = sum_n^vir C_µn(k=0) e^(-|(ϵ_nk=0-ϵ_F)τ|) C_λn(k=0) ! χ_PQ(iτ,k=0) = sum_λν [sum_µ (µν|P) G^occ_µλ(i|τ|)] [sum_σ (σλ|Q) G^vir_σν(i|τ|)] @@ -148,7 +135,7 @@ SUBROUTINE gw(qs_env, bs_env, post_scf_bandstructure_section) CALL timestop(handle) - END SUBROUTINE gw + END SUBROUTINE gw_calc_large_cell_Gamma ! ************************************************************************************************** !> \brief ... @@ -166,7 +153,7 @@ SUBROUTINE get_mat_chi_Gamma_tau(bs_env, qs_env, mat_chi_Gamma_tau) INTEGER :: handle, i_intval_idx, i_t, inner_loop_atoms_interval_index, ispin, j_intval_idx INTEGER, DIMENSION(2) :: i_atoms, IL_atoms, j_atoms LOGICAL :: dist_too_long_i, dist_too_long_j - REAL(KIND=dp) :: tau + REAL(KIND=dp) :: t1, tau TYPE(dbt_type) :: t_2c_Gocc, t_2c_Gvir, t_3c_for_Gocc, & t_3c_for_Gvir, t_3c_x_Gocc, & t_3c_x_Gocc_2, t_3c_x_Gvir, & @@ -176,11 +163,12 @@ SUBROUTINE get_mat_chi_Gamma_tau(bs_env, qs_env, mat_chi_Gamma_tau) DO i_t = 1, bs_env%num_time_freq_points - bs_env%t1 = m_walltime() + t1 = m_walltime() IF (bs_env%read_chi(i_t)) THEN CALL fm_read(bs_env%fm_RI_RI, bs_env, bs_env%chi_name, i_t) + CALL copy_fm_to_dbcsr(bs_env%fm_RI_RI, mat_chi_Gamma_tau(i_t)%matrix, & keep_sparsity=.FALSE.) @@ -188,7 +176,7 @@ SUBROUTINE get_mat_chi_Gamma_tau(bs_env, qs_env, mat_chi_Gamma_tau) WRITE (bs_env%unit_nr, '(T2,A,I5,A,I3,A,F7.1,A)') & 'Read χ(iτ,k=0) from file for time point ', i_t, ' /', & bs_env%num_time_freq_points, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF CYCLE @@ -209,6 +197,7 @@ SUBROUTINE get_mat_chi_Gamma_tau(bs_env, qs_env, mat_chi_Gamma_tau) DO ispin = 1, bs_env%n_spin CALL G_occ_vir(bs_env, tau, bs_env%fm_Gocc, ispin, occ=.TRUE., vir=.FALSE.) CALL G_occ_vir(bs_env, tau, bs_env%fm_Gvir, ispin, occ=.FALSE., vir=.TRUE.) + CALL fm_to_local_tensor(bs_env%fm_Gocc, bs_env%mat_ao_ao%matrix, & bs_env%mat_ao_ao_tensor%matrix, t_2c_Gocc, bs_env, & bs_env%atoms_j_t_group) @@ -278,7 +267,7 @@ SUBROUTINE get_mat_chi_Gamma_tau(bs_env, qs_env, mat_chi_Gamma_tau) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,I13,A,I3,A,F7.1,A)') & 'Computed χ(iτ,k=0) for time point', i_t, ' /', bs_env%num_time_freq_points, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF END DO ! i_t @@ -410,148 +399,6 @@ SUBROUTINE destroy_tensors_chi(t_2c_Gocc, t_2c_Gvir, t_3c_for_Gocc, t_3c_for_Gvi END SUBROUTINE destroy_tensors_chi -! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... -!> \param tau ... -!> \param fm_GGamma ... -!> \param ispin ... -!> \param occ ... -!> \param vir ... -! ************************************************************************************************** - SUBROUTINE G_occ_vir(bs_env, tau, fm_GGamma, ispin, occ, vir) - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp) :: tau - TYPE(cp_fm_type) :: fm_GGamma - INTEGER :: ispin - LOGICAL :: occ, vir - - CHARACTER(LEN=*), PARAMETER :: routineN = 'G_occ_vir' - - INTEGER :: handle, homo, i_row_local, j_col, & - j_col_local, n_mo, ncol_local, & - nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices - REAL(KIND=dp) :: tau_E - - CALL timeset(routineN, handle) - - CPASSERT(occ .NEQV. vir) - - CALL cp_fm_get_info(matrix=bs_env%fm_work_mo(1), & - nrow_local=nrow_local, & - ncol_local=ncol_local, & - col_indices=col_indices) - - n_mo = bs_env%n_ao - homo = bs_env%n_occ(ispin) - - CALL cp_fm_to_fm(bs_env%fm_mo_coeff_Gamma(ispin), bs_env%fm_work_mo(1)) - - DO i_row_local = 1, nrow_local - DO j_col_local = 1, ncol_local - - j_col = col_indices(j_col_local) - - tau_E = ABS(tau*0.5_dp*(bs_env%eigenval_scf_Gamma(j_col, ispin) - bs_env%e_fermi(ispin))) - - IF (tau_E < bs_env%stabilize_exp) THEN - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = & - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local)*EXP(-tau_E) - ELSE - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = 0.0_dp - END IF - - IF ((occ .AND. j_col > homo) .OR. (vir .AND. j_col <= homo)) THEN - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = 0.0_dp - END IF - - END DO - END DO - - CALL parallel_gemm(transa="N", transb="T", m=n_mo, n=n_mo, k=n_mo, alpha=1.0_dp, & - matrix_a=bs_env%fm_work_mo(1), matrix_b=bs_env%fm_work_mo(1), & - beta=0.0_dp, matrix_c=fm_GGamma) - - CALL timestop(handle) - - END SUBROUTINE G_occ_vir - -! ************************************************************************************************** -!> \brief ... -!> \param fm_global ... -!> \param mat_global ... -!> \param mat_local ... -!> \param tensor ... -!> \param bs_env ... -!> \param atom_ranges ... -! ************************************************************************************************** - SUBROUTINE fm_to_local_tensor(fm_global, mat_global, mat_local, tensor, bs_env, atom_ranges) - - TYPE(cp_fm_type) :: fm_global - TYPE(dbcsr_type) :: mat_global, mat_local - TYPE(dbt_type) :: tensor - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER, DIMENSION(:, :), OPTIONAL :: atom_ranges - - CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_to_local_tensor' - - INTEGER :: handle - TYPE(dbt_type) :: tensor_tmp - - CALL timeset(routineN, handle) - - CALL dbt_clear(tensor) - CALL copy_fm_to_dbcsr(fm_global, mat_global, keep_sparsity=.FALSE.) - CALL dbcsr_filter(mat_global, bs_env%eps_filter) - IF (PRESENT(atom_ranges)) THEN - CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, & - bs_env%para_env_tensor%num_pe, atom_ranges) - ELSE - CALL global_matrix_to_local_matrix(mat_global, mat_local, bs_env%para_env, & - bs_env%para_env_tensor%num_pe) - END IF - CALL dbt_create(mat_local, tensor_tmp) - CALL dbt_copy_matrix_to_tensor(mat_local, tensor_tmp) - CALL dbt_copy(tensor_tmp, tensor, move_data=.TRUE.) - CALL dbt_destroy(tensor_tmp) - CALL dbcsr_set(mat_local, 0.0_dp) - CALL dbcsr_filter(mat_local, 1.0_dp) - - CALL timestop(handle) - - END SUBROUTINE fm_to_local_tensor - -! ************************************************************************************************** -!> \brief ... -!> \param tensor ... -!> \param mat_tensor ... -!> \param mat_global ... -!> \param para_env ... -! ************************************************************************************************** - SUBROUTINE local_dbt_to_global_mat(tensor, mat_tensor, mat_global, para_env) - - TYPE(dbt_type) :: tensor - TYPE(dbcsr_type) :: mat_tensor, mat_global - TYPE(mp_para_env_type), POINTER :: para_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'local_dbt_to_global_mat' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL dbt_copy_tensor_to_matrix(tensor, mat_tensor) - CALL dbt_clear(tensor) - ! the next para_env%sync is not mandatory, but it makes the timing output - ! of local_matrix_to_global_matrix correct - CALL para_env%sync() - CALL local_matrix_to_global_matrix(mat_tensor, mat_global, para_env) - - CALL timestop(handle) - - END SUBROUTINE local_dbt_to_global_mat - ! ************************************************************************************************** !> \brief ... !> \param matrix ... @@ -634,6 +481,73 @@ SUBROUTINE fm_write(fm, matrix_index, matrix_name, qs_env) END SUBROUTINE fm_write +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param tau ... +!> \param fm_G_Gamma ... +!> \param ispin ... +!> \param occ ... +!> \param vir ... +! ************************************************************************************************** + SUBROUTINE G_occ_vir(bs_env, tau, fm_G_Gamma, ispin, occ, vir) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp) :: tau + TYPE(cp_fm_type) :: fm_G_Gamma + INTEGER :: ispin + LOGICAL :: occ, vir + + CHARACTER(LEN=*), PARAMETER :: routineN = 'G_occ_vir' + + INTEGER :: handle, homo, i_row_local, j_col, & + j_col_local, n_mo, ncol_local, & + nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices + REAL(KIND=dp) :: tau_E + + CALL timeset(routineN, handle) + + CPASSERT(occ .NEQV. vir) + + CALL cp_fm_get_info(matrix=bs_env%fm_work_mo(1), & + nrow_local=nrow_local, & + ncol_local=ncol_local, & + col_indices=col_indices) + + n_mo = bs_env%n_ao + homo = bs_env%n_occ(ispin) + + CALL cp_fm_to_fm(bs_env%fm_mo_coeff_Gamma(ispin), bs_env%fm_work_mo(1)) + + DO i_row_local = 1, nrow_local + DO j_col_local = 1, ncol_local + + j_col = col_indices(j_col_local) + + tau_E = ABS(tau*0.5_dp*(bs_env%eigenval_scf_Gamma(j_col, ispin) - bs_env%e_fermi(ispin))) + + IF (tau_E < bs_env%stabilize_exp) THEN + bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = & + bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local)*EXP(-tau_E) + ELSE + bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = 0.0_dp + END IF + + IF ((occ .AND. j_col > homo) .OR. (vir .AND. j_col <= homo)) THEN + bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = 0.0_dp + END IF + + END DO + END DO + + CALL parallel_gemm(transa="N", transb="T", m=n_mo, n=n_mo, k=n_mo, alpha=1.0_dp, & + matrix_a=bs_env%fm_work_mo(1), matrix_b=bs_env%fm_work_mo(1), & + beta=0.0_dp, matrix_c=fm_G_Gamma) + + CALL timestop(handle) + + END SUBROUTINE G_occ_vir + ! ************************************************************************************************** !> \brief ... !> \param qs_env ... @@ -683,7 +597,7 @@ SUBROUTINE compute_3c_integrals(qs_env, bs_env, t_3c, atoms_AO_1, atoms_AO_2, at bs_env%eps_filter, & qs_env, & bs_env%nl_3c, & - int_eps=bs_env%eps_3c_int, & + int_eps=bs_env%eps_filter, & basis_i=bs_env%basis_set_RI, & basis_j=bs_env%basis_set_AO, & basis_k=bs_env%basis_set_AO, & @@ -951,11 +865,12 @@ SUBROUTINE compute_MinvVsqrt_Vsqrt(bs_env, qs_env, fm_V_kp, cfm_V_sqrt_ikp, & n_RI = bs_env%n_RI - ! get here M(k) and write it to fm_M + ! get here M(k) and write it to fm_M_ikp CALL RI_2c_integral_mat(qs_env, fm_M_ikp, fm_V_kp(ikp, 1), & - bs_env%n_RI, bs_env%ri_metric, do_kpoints=.TRUE., & + n_RI, bs_env%ri_metric, do_kpoints=.TRUE., & kpoints=bs_env%kpoints_chi_eps_W, & - regularization_RI=bs_env%regularization_RI, ikp_ext=ikp) + regularization_RI=bs_env%regularization_RI, ikp_ext=ikp, & + do_build_cell_index=(ikp == 1)) IF (ikp == 1) THEN CALL cp_cfm_create(cfm_V_sqrt_ikp, fm_V_kp(ikp, 1)%matrix_struct) @@ -1021,6 +936,7 @@ SUBROUTINE read_W_MIC_time(bs_env, mat_chi_Gamma_tau, fm_W_MIC_time) CHARACTER(LEN=*), PARAMETER :: routineN = 'read_W_MIC_time' INTEGER :: handle, i_t + REAL(KIND=dp) :: t1 CALL timeset(routineN, handle) @@ -1029,14 +945,14 @@ SUBROUTINE read_W_MIC_time(bs_env, mat_chi_Gamma_tau, fm_W_MIC_time) DO i_t = 1, bs_env%num_time_freq_points - bs_env%t1 = m_walltime() + t1 = m_walltime() CALL fm_read(fm_W_MIC_time(i_t), bs_env, bs_env%W_time_name, i_t) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,I5,A,I3,A,F7.1,A)') & 'Read W^MIC(iτ) from file for time point ', i_t, ' /', bs_env%num_time_freq_points, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF END DO @@ -1064,6 +980,7 @@ SUBROUTINE compute_W_MIC(bs_env, qs_env, mat_chi_Gamma_tau, fm_W_MIC_time) INTEGER :: handle, i_t, ikp, ikp_batch, & ikp_in_batch, j_w + REAL(KIND=dp) :: t1 TYPE(cp_cfm_type) :: cfm_M_inv_V_sqrt_ikp, cfm_V_sqrt_ikp TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_V_kp @@ -1073,7 +990,7 @@ SUBROUTINE compute_W_MIC(bs_env, qs_env, mat_chi_Gamma_tau, fm_W_MIC_time) DO ikp_batch = 1, bs_env%num_chi_eps_W_batches - bs_env%t1 = m_walltime() + t1 = m_walltime() ! Compute V_PQ(k) = sum_R e^(ikR) CALL compute_V_k_by_lattice_sum(bs_env, qs_env, fm_V_kp, ikp_batch) @@ -1115,7 +1032,7 @@ SUBROUTINE compute_W_MIC(bs_env, qs_env, mat_chi_Gamma_tau, fm_W_MIC_time) WRITE (bs_env%unit_nr, '(T2,A,I12,A,I3,A,F7.1,A)') & 'Computed W(iτ,k) for k-point batch', & ikp_batch, ' /', bs_env%num_chi_eps_W_batches, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF END DO ! ikp_batch @@ -1629,10 +1546,9 @@ SUBROUTINE multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_W_MIC_time) CALL cp_fm_create(fm_work, fm_W_MIC_time(1)%matrix_struct) - ! compute Gamma-only RI-metric matrix M(k=0) + ! compute Gamma-only RI-metric matrix M(k=0); no regularization CALL RI_2c_integral_mat(qs_env, fm_Minv_Gamma, fm_W_MIC_time(1), n_RI, & - bs_env%ri_metric, do_kpoints=.FALSE., & - regularization_RI=bs_env%regularization_RI) + bs_env%ri_metric, do_kpoints=.FALSE.) CALL cp_fm_power(fm_Minv_Gamma(1, 1), fm_work, -1.0_dp, 0.0_dp, ndep) @@ -1703,13 +1619,14 @@ SUBROUTINE compute_Sigma_x(bs_env, qs_env, fm_Sigma_x_Gamma) INTEGER :: handle, i_intval_idx, ispin, j_intval_idx INTEGER, DIMENSION(2) :: i_atoms, j_atoms + REAL(KIND=dp) :: t1 TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_Vtr_Gamma TYPE(dbcsr_type) :: mat_Sigma_x_Gamma TYPE(dbt_type) :: t_2c_D, t_2c_Sigma_x, t_2c_V, t_3c_x_V CALL timeset(routineN, handle) - bs_env%t1 = m_walltime() + t1 = m_walltime() CALL dbt_create(bs_env%t_G, t_2c_D) CALL dbt_create(bs_env%t_W, t_2c_V) @@ -1719,8 +1636,7 @@ SUBROUTINE compute_Sigma_x(bs_env, qs_env, fm_Sigma_x_Gamma) ! 1. Compute truncated Coulomb operator matrix V^tr(k=0) (cutoff rad: cellsize/2) CALL RI_2c_integral_mat(qs_env, fm_Vtr_Gamma, bs_env%fm_RI_RI, bs_env%n_RI, & - bs_env%trunc_coulomb, do_kpoints=.FALSE., & - regularization_RI=bs_env%regularization_RI) + bs_env%trunc_coulomb, do_kpoints=.FALSE.) ! 2. Compute M^-1(k=0) and get M^-1(k=0)*V^tr(k=0)*M^-1(k=0) CALL multiply_fm_W_MIC_time_with_Minv_Gamma(bs_env, qs_env, fm_Vtr_Gamma(:, 1)) @@ -1729,6 +1645,7 @@ SUBROUTINE compute_Sigma_x(bs_env, qs_env, fm_Sigma_x_Gamma) ! 3. Compute density matrix D_µν CALL G_occ_vir(bs_env, 0.0_dp, bs_env%fm_work_mo(2), ispin, occ=.TRUE., vir=.FALSE.) + CALL fm_to_local_tensor(bs_env%fm_work_mo(2), bs_env%mat_ao_ao%matrix, & bs_env%mat_ao_ao_tensor%matrix, t_2c_D, bs_env, & bs_env%atoms_i_t_group) @@ -1764,11 +1681,11 @@ SUBROUTINE compute_Sigma_x(bs_env, qs_env, fm_Sigma_x_Gamma) CALL copy_dbcsr_to_fm(mat_Sigma_x_Gamma, fm_Sigma_x_Gamma(ispin)) - END DO + END DO ! ispin IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & - 'Computed Σ^x(k=0),', ' Execution time', m_walltime() - bs_env%t1, ' s' + 'Computed Σ^x(k=0),', ' Execution time', m_walltime() - t1, ' s' WRITE (bs_env%unit_nr, '(A)') ' ' END IF @@ -1801,7 +1718,7 @@ SUBROUTINE get_Sigma_c(bs_env, qs_env, fm_W_MIC_time, fm_Sigma_c_Gamma_time) INTEGER :: handle, i_intval_idx, i_t, ispin, & j_intval_idx, read_write_index INTEGER, DIMENSION(2) :: i_atoms, j_atoms - REAL(KIND=dp) :: tau + REAL(KIND=dp) :: t1, tau TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_Sigma_neg_tau, mat_Sigma_pos_tau TYPE(dbt_type) :: t_2c_Gocc, t_2c_Gvir, & t_2c_Sigma_neg_tau, & @@ -1817,7 +1734,7 @@ SUBROUTINE get_Sigma_c(bs_env, qs_env, fm_W_MIC_time, fm_Sigma_c_Gamma_time) DO ispin = 1, bs_env%n_spin - bs_env%t1 = m_walltime() + t1 = m_walltime() read_write_index = i_t + (ispin - 1)*bs_env%num_time_freq_points @@ -1832,7 +1749,7 @@ SUBROUTINE get_Sigma_c(bs_env, qs_env, fm_W_MIC_time, fm_Sigma_c_Gamma_time) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,2A,I3,A,I3,A,F7.1,A)') 'Read Σ^c(iτ,k=0) ', & 'from file for time point ', i_t, ' /', bs_env%num_time_freq_points, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF CYCLE @@ -1898,7 +1815,7 @@ SUBROUTINE get_Sigma_c(bs_env, qs_env, fm_W_MIC_time, fm_Sigma_c_Gamma_time) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A,I10,A,I3,A,F7.1,A)') & 'Computed Σ^c(iτ,k=0) for time point ', i_t, ' /', bs_env%num_time_freq_points, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + ', Execution time', m_walltime() - t1, ' s' END IF END DO ! ispin @@ -2299,66 +2216,6 @@ SUBROUTINE safe_delete(filename, bs_env) END SUBROUTINE safe_delete -! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... -!> \param Sigma_c_n_time ... -!> \param Sigma_c_n_freq ... -!> \param ispin ... -! ************************************************************************************************** - SUBROUTINE time_to_freq(bs_env, Sigma_c_n_time, Sigma_c_n_freq, ispin) - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Sigma_c_n_time, Sigma_c_n_freq - INTEGER :: ispin - - CHARACTER(LEN=*), PARAMETER :: routineN = 'time_to_freq' - - INTEGER :: handle, i_t, j_w, n_occ - REAL(KIND=dp) :: freq_j, time_i, w_cos_ij, w_sin_ij - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Sigma_c_n_cos_time, Sigma_c_n_sin_time - - CALL timeset(routineN, handle) - - ALLOCATE (Sigma_c_n_cos_time(bs_env%n_ao, bs_env%num_time_freq_points)) - ALLOCATE (Sigma_c_n_sin_time(bs_env%n_ao, bs_env%num_time_freq_points)) - - Sigma_c_n_cos_time(:, :) = 0.5_dp*(Sigma_c_n_time(:, :, 1) + Sigma_c_n_time(:, :, 2)) - Sigma_c_n_sin_time(:, :) = 0.5_dp*(Sigma_c_n_time(:, :, 1) - Sigma_c_n_time(:, :, 2)) - - Sigma_c_n_freq(:, :, :) = 0.0_dp - - DO i_t = 1, bs_env%num_time_freq_points - - DO j_w = 1, bs_env%num_time_freq_points - - freq_j = bs_env%imag_freq_points(j_w) - time_i = bs_env%imag_time_points(i_t) - ! integration weights for cosine and sine transform - w_cos_ij = bs_env%weights_cos_t_to_w(j_w, i_t)*COS(freq_j*time_i) - w_sin_ij = bs_env%weights_sin_t_to_w(j_w, i_t)*SIN(freq_j*time_i) - - ! 1. Re(Σ^c_nn(k_i,iω)) from cosine transform - Sigma_c_n_freq(:, j_w, 1) = Sigma_c_n_freq(:, j_w, 1) + & - w_cos_ij*Sigma_c_n_cos_time(:, i_t) - - ! 2. Im(Σ^c_nn(k_i,iω)) from sine transform - Sigma_c_n_freq(:, j_w, 2) = Sigma_c_n_freq(:, j_w, 2) + & - w_sin_ij*Sigma_c_n_sin_time(:, i_t) - - END DO - - END DO - - ! for occupied levels, we need the correlation self-energy for negative omega. - ! Therefore, weight_sin should be computed with -omega, which results in an - ! additional minus for the imaginary part: - n_occ = bs_env%n_occ(ispin) - Sigma_c_n_freq(1:n_occ, :, 2) = -Sigma_c_n_freq(1:n_occ, :, 2) - - CALL timestop(handle) - - END SUBROUTINE time_to_freq - ! ************************************************************************************************** !> \brief ... !> \param bs_env ... @@ -2392,7 +2249,7 @@ SUBROUTINE compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamm DO ispin = 1, bs_env%n_spin - DO ikp = 1, bs_env%kpoints_DOS%nkp + DO ikp = 1, bs_env%nkp_bs_and_DOS ! 1. get H^KS_µν(k_i) from H^KS_µν(k=0) CALL cfm_ikp_from_fm_Gamma(cfm_ks_ikp, bs_env%fm_ks_Gamma(ispin), & @@ -2430,7 +2287,7 @@ SUBROUTINE compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamm ! 8. Analytic continuation Σ^c_nn(k_i,iω) -> Σ^c_nn(k_i,ϵ) and ! ϵ_nk_i^GW = ϵ_nk_i^DFT + Σ^c_nn(k_i,ϵ) + Σ^x_nn(k_i) - v^xc_nn(k_i) CALL analyt_conti_and_print(bs_env, Sigma_c_ikp_n_freq, Sigma_x_ikp_n, V_xc_ikp_n, & - ikp, ispin) + bs_env%eigenval_scf(:, ikp, ispin), ikp, ispin) END DO ! ikp_DOS @@ -2438,9 +2295,6 @@ SUBROUTINE compute_QP_energies(bs_env, qs_env, fm_Sigma_x_Gamma, fm_Sigma_c_Gamm CALL get_VBM_CBM_bandgaps(bs_env) - ! compute H^G0W0(k=0) = S(k=0)*C(k=0)ϵ^G0W0(k=0)*C(k=0)*S(k=0) - CALL G0W0_hamiltonian(bs_env) - CALL cp_fm_release(fm_Sigma_x_Gamma) CALL cp_fm_release(fm_Sigma_c_Gamma_time) CALL cp_cfm_release(cfm_ks_ikp) @@ -2534,225 +2388,4 @@ SUBROUTINE fm_Gamma_ao_to_cfm_ikp_mo(fm_Gamma, fm_ikp_mo_re, ikp, qs_env, bs_env END SUBROUTINE fm_Gamma_ao_to_cfm_ikp_mo -! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... -!> \param Sigma_c_ikp_n_freq ... -!> \param Sigma_x_ikp_n ... -!> \param V_xc_ikp_n ... -!> \param ikp ... -!> \param ispin ... -! ************************************************************************************************** - SUBROUTINE analyt_conti_and_print(bs_env, Sigma_c_ikp_n_freq, Sigma_x_ikp_n, V_xc_ikp_n, ikp, ispin) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Sigma_c_ikp_n_freq - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Sigma_x_ikp_n, V_xc_ikp_n - INTEGER :: ikp, ispin - - CHARACTER(LEN=*), PARAMETER :: routineN = 'analyt_conti_and_print' - - CHARACTER(len=3) :: occ_vir - CHARACTER(len=default_string_length) :: fname - INTEGER :: handle, i_mo, iunit, n_mo - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dummy, Sigma_c_ikp_n_qp - - CALL timeset(routineN, handle) - - n_mo = bs_env%n_ao - ALLOCATE (dummy(n_mo), Sigma_c_ikp_n_qp(n_mo)) - Sigma_c_ikp_n_qp(:) = 0.0_dp - - DO i_mo = 1, n_mo - - IF (MODULO(i_mo, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE - - CALL continuation_pade(Sigma_c_ikp_n_qp, & - bs_env%imag_freq_points_fit, dummy, dummy, & - Sigma_c_ikp_n_freq(:, 1:bs_env%num_freq_points_fit, 1)*z_one + & - Sigma_c_ikp_n_freq(:, 1:bs_env%num_freq_points_fit, 2)*gaussi, & - Sigma_x_ikp_n(:) - V_xc_ikp_n(:), & - bs_env%eigenval_scf(:, ikp, ispin), & - bs_env%eigenval_scf(:, ikp, ispin), & - i_mo, bs_env%n_occ(ispin), bs_env%nparam_pade, & - bs_env%num_freq_points_fit, & - ri_rpa_g0w0_crossing_newton, bs_env%n_occ(ispin), & - 0.0_dp, .TRUE., .FALSE., 1) - - END DO - - CALL bs_env%para_env%sum(Sigma_c_ikp_n_qp) - - bs_env%eigenval_G0W0(:, ikp, ispin) = bs_env%eigenval_scf(:, ikp, ispin) + & - Sigma_c_ikp_n_qp(:) + & - Sigma_x_ikp_n(:) - & - V_xc_ikp_n(:) - - CALL get_fname(fname, bs_env, ikp, "SCF_and_G0W0", ispin=ispin) - - IF (bs_env%para_env%is_source()) THEN - - CALL open_file(TRIM(fname), unit_number=iunit, file_status="REPLACE", file_action="WRITE") - - WRITE (iunit, "(A)") " " - WRITE (iunit, "(A10,3F10.4)") "kpoint: ", bs_env%kpoints_DOS%xkp(:, ikp) - WRITE (iunit, "(A)") " " - WRITE (iunit, "(A5,A24,2A17,A16,A18)") "n", "ϵ_nk^DFT (eV)", "Σ^c_nk (eV)", & - "Σ^x_nk (eV)", "v_n^xc (eV)", "ϵ_nk^G0W0 (eV)" - WRITE (iunit, "(A)") " " - - DO i_mo = 1, n_mo - IF (i_mo .LE. bs_env%n_occ(ispin)) occ_vir = 'occ' - IF (i_mo > bs_env%n_occ(ispin)) occ_vir = 'vir' - WRITE (iunit, "(I5,3A,4F16.3,F17.3)") i_mo, ' (', occ_vir, ') ', & - bs_env%eigenval_scf(i_mo, ikp, ispin)*evolt, & - Sigma_c_ikp_n_qp(i_mo)*evolt, & - Sigma_x_ikp_n(i_mo)*evolt, & - V_xc_ikp_n(i_mo)*evolt, & - bs_env%eigenval_G0W0(i_mo, ikp, ispin)*evolt - END DO - - CALL close_file(iunit) - - END IF - - CALL timestop(handle) - - END SUBROUTINE analyt_conti_and_print - -! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE get_VBM_CBM_bandgaps(bs_env) - - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'get_VBM_CBM_bandgaps' - - INTEGER :: handle, homo, homo_1, homo_2, ikp, & - ispin, lumo, lumo_1, lumo_2, n_mo - REAL(KIND=dp) :: E_DBG_G0W0_at_ikp, E_DBG_scf_at_ikp - - CALL timeset(routineN, handle) - - n_mo = bs_env%n_ao - - bs_env%band_edges_scf%DBG = 1000.0_dp - bs_env%band_edges_G0W0%DBG = 1000.0_dp - - SELECT CASE (bs_env%n_spin) - CASE (1) - homo = bs_env%n_occ(1) - lumo = homo + 1 - bs_env%band_edges_scf%VBM = MAXVAL(bs_env%eigenval_scf(1:homo, :, 1)) - bs_env%band_edges_scf%CBM = MINVAL(bs_env%eigenval_scf(homo + 1:n_mo, :, 1)) - bs_env%band_edges_G0W0%VBM = MAXVAL(bs_env%eigenval_G0W0(1:homo, :, 1)) - bs_env%band_edges_G0W0%CBM = MINVAL(bs_env%eigenval_G0W0(homo + 1:n_mo, :, 1)) - CASE (2) - homo_1 = bs_env%n_occ(1) - lumo_1 = homo_1 + 1 - homo_2 = bs_env%n_occ(2) - lumo_2 = homo_2 + 1 - bs_env%band_edges_scf%VBM = MAX(MAXVAL(bs_env%eigenval_scf(1:homo_1, :, 1)), & - MAXVAL(bs_env%eigenval_scf(1:homo_2, :, 2))) - bs_env%band_edges_scf%CBM = MIN(MINVAL(bs_env%eigenval_scf(homo_1 + 1:n_mo, :, 1)), & - MINVAL(bs_env%eigenval_scf(homo_2 + 1:n_mo, :, 2))) - bs_env%band_edges_G0W0%VBM = MAX(MAXVAL(bs_env%eigenval_G0W0(1:homo_1, :, 1)), & - MAXVAL(bs_env%eigenval_G0W0(1:homo_2, :, 2))) - bs_env%band_edges_G0W0%CBM = MIN(MINVAL(bs_env%eigenval_G0W0(homo_1 + 1:n_mo, :, 1)), & - MINVAL(bs_env%eigenval_G0W0(homo_2 + 1:n_mo, :, 2))) - CASE DEFAULT - CPABORT("Error with number of spins.") - END SELECT - - bs_env%band_edges_scf%IDBG = bs_env%band_edges_scf%CBM - bs_env%band_edges_scf%VBM - bs_env%band_edges_G0W0%IDBG = bs_env%band_edges_G0W0%CBM - bs_env%band_edges_G0W0%VBM - - DO ispin = 1, bs_env%n_spin - - homo = bs_env%n_occ(ispin) - - DO ikp = 1, bs_env%kpoints_DOS%nkp - E_DBG_scf_at_ikp = -MAXVAL(bs_env%eigenval_scf(1:homo, ikp, ispin)) + & - MINVAL(bs_env%eigenval_scf(homo + 1:n_mo, ikp, ispin)) - IF (E_DBG_scf_at_ikp < bs_env%band_edges_scf%DBG) THEN - bs_env%band_edges_scf%DBG = E_DBG_scf_at_ikp - END IF - - E_DBG_G0W0_at_ikp = -MAXVAL(bs_env%eigenval_G0W0(1:homo, ikp, ispin)) + & - MINVAL(bs_env%eigenval_G0W0(homo + 1:n_mo, ikp, ispin)) - IF (E_DBG_G0W0_at_ikp < bs_env%band_edges_G0W0%DBG) THEN - bs_env%band_edges_G0W0%DBG = E_DBG_G0W0_at_ikp - END IF - END DO - END DO - - CALL timestop(handle) - - END SUBROUTINE get_VBM_CBM_bandgaps - -! ************************************************************************************************** -!> \brief compute H^G0W0(k=0) = S(k=0)*C(k=0)ϵ^G0W0(k=0)*C(k=0)*S(k=0) -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE G0W0_hamiltonian(bs_env) - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'G0W0_hamiltonian' - - INTEGER :: handle, i_row_local, j_col, j_col_local, & - n_mo, ncol_local, nrow_local - INTEGER, DIMENSION(:), POINTER :: col_indices - REAL(KIND=dp) :: E_j - - CALL timeset(routineN, handle) - - ! JW TODO in whole routine: open-shell - - CALL cp_fm_get_info(matrix=bs_env%fm_work_mo(1), & - nrow_local=nrow_local, & - ncol_local=ncol_local, & - col_indices=col_indices) - - CALL cp_fm_to_fm(bs_env%fm_mo_coeff_Gamma(1), bs_env%fm_work_mo(1)) - - ! compute ϵ_n(k=0)^G0W0 C_νn(k=0) - DO i_row_local = 1, nrow_local - DO j_col_local = 1, ncol_local - - j_col = col_indices(j_col_local) - - ! the last k-point of eigenvalues_G0W0 is the Γ-point - E_j = bs_env%eigenval_G0W0(j_col, bs_env%nkp_DOS, 1) - - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local) = & - bs_env%fm_work_mo(1)%local_data(i_row_local, j_col_local)*E_j - - END DO - END DO - - n_mo = bs_env%n_ao - - ! compute H^G0W0(k=0) = S(k=0)*C(k=0)ϵ^G0W0(k=0)*C^T(k=0)*S(k=0) - - ! 1. C(k=0)*ϵ^G0W0(k=0)*C^T(k=0) - CALL parallel_gemm(transa="N", transb="T", m=n_mo, n=n_mo, k=n_mo, alpha=1.0_dp, & - matrix_a=bs_env%fm_mo_coeff_Gamma(1), matrix_b=bs_env%fm_work_mo(1), & - beta=0.0_dp, matrix_c=bs_env%fm_work_mo(2)) - - ! 2. S(k=0)*C(k=0)*ϵ^G0W0(k=0)*C^T(k=0) - CALL parallel_gemm(transa="N", transb="N", m=n_mo, n=n_mo, k=n_mo, alpha=1.0_dp, & - matrix_a=bs_env%fm_s_Gamma, matrix_b=bs_env%fm_work_mo(2), & - beta=0.0_dp, matrix_c=bs_env%fm_work_mo(1)) - - ! 3. S(k=0)*C(k=0)*ϵ^G0W0(k=0)*C^T(k=0)*S(k=0) - CALL parallel_gemm(transa="N", transb="N", m=n_mo, n=n_mo, k=n_mo, alpha=1.0_dp, & - matrix_a=bs_env%fm_work_mo(1), matrix_b=bs_env%fm_s_Gamma, & - beta=0.0_dp, matrix_c=bs_env%fm_h_G0W0_Gamma) - - CALL timestop(handle) - - END SUBROUTINE G0W0_hamiltonian - -END MODULE gw_methods +END MODULE gw_large_cell_gamma diff --git a/src/gw_main.F b/src/gw_main.F new file mode 100644 index 0000000000..16ac4ef817 --- /dev/null +++ b/src/gw_main.F @@ -0,0 +1,72 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2024 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief +!> \author Jan Wilhelm +!> \date 07.2023 +! ************************************************************************************************** +MODULE gw_main + USE gw_large_cell_Gamma, ONLY: gw_calc_large_cell_Gamma + USE gw_small_cell_full_kp, ONLY: gw_calc_small_cell_full_kp + USE gw_utils, ONLY: create_and_init_bs_env_for_gw + USE input_constants, ONLY: large_cell_Gamma,& + small_cell_full_kp + USE input_section_types, ONLY: section_vals_type + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: qs_environment_type +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_main' + + PUBLIC :: gw + +CONTAINS + +! ************************************************************************************************** +!> \brief Perform GW band structure calculation +!> \param qs_env ... +!> \param bs_env ... +!> \param post_scf_bandstructure_section ... +!> \par History +!> * 07.2023 created [Jan Wilhelm] +! ************************************************************************************************** + SUBROUTINE gw(qs_env, bs_env, post_scf_bandstructure_section) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(section_vals_type), POINTER :: post_scf_bandstructure_section + + CHARACTER(LEN=*), PARAMETER :: routineN = 'gw' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL create_and_init_bs_env_for_gw(qs_env, bs_env, post_scf_bandstructure_section) + + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + + CASE (small_cell_full_kp) + + CALL gw_calc_small_cell_full_kp(qs_env, bs_env) + + CASE (large_cell_Gamma) + + CALL gw_calc_large_cell_Gamma(qs_env, bs_env) + + END SELECT + + CALL timestop(handle) + + END SUBROUTINE gw + +END MODULE gw_main + diff --git a/src/gw_small_cell_full_kp.F b/src/gw_small_cell_full_kp.F new file mode 100644 index 0000000000..b24cd5d10d --- /dev/null +++ b/src/gw_small_cell_full_kp.F @@ -0,0 +1,1851 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2024 CP2K developers group ! +! ! +! SPDX-License-Identifier: GPL-2.0-or-later ! +!--------------------------------------------------------------------------------------------------! + +! ************************************************************************************************** +!> \brief +!> \author Jan Wilhelm +!> \date 05.2024 +! ************************************************************************************************** +MODULE gw_small_cell_full_kp + USE cp_blacs_env, ONLY: cp_blacs_env_type + USE cp_cfm_types, ONLY: cp_cfm_create,& + cp_cfm_get_info,& + cp_cfm_release,& + cp_cfm_to_fm,& + cp_cfm_type,& + cp_fm_to_cfm + USE cp_dbcsr_api, ONLY: dbcsr_create,& + dbcsr_distribution_release,& + dbcsr_distribution_type,& + dbcsr_p_type,& + dbcsr_release,& + dbcsr_set,& + dbcsr_type,& + dbcsr_type_no_symmetry + USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& + cp_dbcsr_dist2d_to_dist + USE cp_fm_types, ONLY: cp_fm_create,& + cp_fm_get_diag,& + cp_fm_get_info,& + cp_fm_release,& + cp_fm_set_all,& + cp_fm_type + USE dbt_api, ONLY: dbt_clear,& + dbt_contract,& + dbt_copy,& + dbt_create,& + dbt_destroy,& + dbt_type + USE distribution_2d_types, ONLY: distribution_2d_type + USE gw_communication, ONLY: fm_to_local_tensor,& + local_dbt_to_global_mat + USE gw_kp_to_real_space_and_back, ONLY: add_ikp_to_all_rs,& + fm_add_ikp_to_rs,& + fm_trafo_rs_to_ikp,& + trafo_rs_to_ikp + USE gw_utils, ONLY: add_R,& + analyt_conti_and_print,& + de_init_bs_env,& + get_VBM_CBM_bandgaps,& + is_cell_in_index_to_cell,& + time_to_freq + USE kinds, ONLY: dp + USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp_small_cell + USE libint_2c_3c, ONLY: libint_potential_type + USE machine, ONLY: m_walltime + USE mathconstants, ONLY: z_one,& + z_zero + USE parallel_gemm_api, ONLY: parallel_gemm + USE particle_methods, ONLY: get_particle_set + USE particle_types, ONLY: particle_type + USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE qs_kind_types, ONLY: qs_kind_type + USE qs_neighbor_list_types, ONLY: neighbor_list_set_p_type,& + release_neighbor_list_sets + USE qs_tensors, ONLY: build_2c_integrals,& + build_2c_neighbor_lists +#include "./base/base_uses.f90" + + IMPLICIT NONE + + PRIVATE + + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_small_cell_full_kp' + + PUBLIC :: gw_calc_small_cell_full_kp + +CONTAINS + +! ************************************************************************************************** +!> \brief Perform GW band structure calculation +!> \param qs_env ... +!> \param bs_env ... +!> \par History +!> * 05.2024 created [Jan Wilhelm] +! ************************************************************************************************** + SUBROUTINE gw_calc_small_cell_full_kp(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'gw_calc_small_cell_full_kp' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ! G^occ_µλ(i|τ|,k) = sum_n^occ C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k) + ! G^vir_µλ(i|τ|,k) = sum_n^vir C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k) + ! k-point k -> cell S: G^occ/vir_µλ^S(i|τ|) = sum_k w_k G^occ/vir_µλ(i|τ|,k) e^(ikS) + ! χ_PQ^R(iτ) = sum_λR1νR2 [ sum_µS (µR1-S νR2 | P0) G^vir_µλ^S(i|τ|) ] + ! [ sum_σS (σR2-S λR1 | QR) G^occ_σν^S(i|τ|) ] + CALL compute_chi(bs_env) + + ! χ_PQ^R(iτ) -> χ_PQ(iω,k) -> ε_PQ(iω,k) -> W_PQ(iω,k) -> Ŵ(iω,k) = M^-1(k)*W(iω,k)*M^-1(k) + ! -> Ŵ_PQ^R(iτ) + CALL compute_W_real_space(bs_env, qs_env) + + ! D_µν(k) = sum_n^occ C^*_µn(k) C_νn(k), V^tr_PQ^R = + ! V^tr(k) = sum_R e^ikR V^tr^R, M(k) = sum_R e^ikR M^R, M(k) -> M^-1(k) + ! -> Ṽ^tr(k) = M^-1(k) * V^tr(k) * M^-1(k) -> Ṽ^tr_PQ^R = sum_k w_k e^-ikR Ṽ^tr_PQ(k) + ! Σ^x_λσ^R = sum_PR1νS1 [ sum_µS2 (λ0 µS1-S2 | PR1 ) D_µν^S2 ] + ! [ sum_QR2 (σR νS1 | QR1-R2) Ṽ^tr_PQ^R2 ] + CALL compute_Sigma_x(bs_env, qs_env) + + ! Σ^c_λσ^R(iτ) = sum_PR1νS1 [ sum_µS2 (λ0 µS1-S2 | PR1 ) G^occ/vir_µν^S2(i|τ|) ] + ! [ sum_QR2 (σR νS1 | QR1-R2) Ŵ_PQ^R2(iτ) ] + CALL compute_Sigma_c(bs_env) + + ! Σ^c_λσ^R(iτ,k=0) -> Σ^c_nn(ϵ,k); ϵ_nk^GW = ϵ_nk^DFT + Σ^c_nn(ϵ,k) + Σ^x_nn(k) - v^xc_nn(k) + CALL compute_QP_energies(bs_env) + + CALL de_init_bs_env(bs_env) + + CALL timestop(handle) + + END SUBROUTINE gw_calc_small_cell_full_kp + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE compute_chi(bs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_chi' + + INTEGER :: cell_DR(3), cell_R1(3), cell_R2(3), & + handle, i_cell_Delta_R, i_cell_R1, & + i_cell_R2, i_t, i_task_Delta_R_local, & + ispin + LOGICAL :: cell_found + REAL(KIND=dp) :: t1, tau + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: Gocc_S, Gvir_S, t_chi_R + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_Gocc, t_Gvir + + CALL timeset(routineN, handle) + + DO i_t = 1, bs_env%num_time_freq_points + + CALL dbt_create_2c_R(Gocc_S, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(Gvir_S, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(t_chi_R, bs_env%t_chi, bs_env%nimages_scf_desymm) + CALL dbt_create_3c_R1_R2(t_Gocc, bs_env%t_RI_AO__AO, bs_env%nimages_3c, bs_env%nimages_3c) + CALL dbt_create_3c_R1_R2(t_Gvir, bs_env%t_RI_AO__AO, bs_env%nimages_3c, bs_env%nimages_3c) + + t1 = m_walltime() + tau = bs_env%imag_time_points(i_t) + + DO ispin = 1, bs_env%n_spin + + ! 1. compute G^occ,S(iτ) and G^vir^S(iτ) in imaginary time for cell S + ! Background: G^σ,S(iτ) = G^occ,S,σ(iτ) * Θ(-τ) + G^vir,S,σ(iτ) * Θ(τ), σ ∈ {↑,↓} + ! G^occ_µλ(i|τ|,k) = sum_n^occ C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k) + ! G^vir_µλ(i|τ|,k) = sum_n^vir C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k) + ! k-point k -> cell S: G^occ/vir_µλ^S(i|τ|) = sum_k w_k G^occ/vir_µλ(i|τ|,k) e^(ikS) + CALL G_occ_vir(bs_env, tau, Gocc_S, ispin, occ=.TRUE., vir=.FALSE.) + CALL G_occ_vir(bs_env, tau, Gvir_S, ispin, occ=.FALSE., vir=.TRUE.) + + ! loop over ΔR = R_1 - R_2 which are local in the tensor subgroup + DO i_task_Delta_R_local = 1, bs_env%n_tasks_Delta_R_local + + i_cell_Delta_R = bs_env%task_Delta_R(i_task_Delta_R_local) + + DO i_cell_R2 = 1, bs_env%nimages_3c + + cell_R2(1:3) = bs_env%index_to_cell_3c(i_cell_R2, 1:3) + cell_DR(1:3) = bs_env%index_to_cell_Delta_R(i_cell_Delta_R, 1:3) + + ! R_1 = R_2 + ΔR (from ΔR = R_2 - R_1) + CALL add_R(cell_R2, cell_DR, bs_env%index_to_cell_3c, cell_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_R1) + + ! 3-cells check because in M^vir_νR2,λR1,QR (step 3.): R2 is index on ν + IF (.NOT. cell_found) CYCLE + + ! 2. M^occ/vir_λR1,νR2,P0 = sum_µS (λR1 µR2-S | P0) G^occ/vir_νµ^S(iτ) + CALL G_times_3c(Gocc_S, t_Gocc, bs_env, i_cell_R1, i_cell_R2) + CALL G_times_3c(Gvir_S, t_Gvir, bs_env, i_cell_R2, i_cell_R1) + + END DO ! i_cell_R2 + + ! 3. χ_PQ^R(iτ) = sum_λR1,νR2 M^occ_λR1,νR2,P0 M^vir_νR2,λR1,QR + CALL contract_M_occ_vir_to_chi(t_Gocc, t_Gvir, t_chi_R, & + bs_env, i_cell_Delta_R) + + END DO ! i_cell_Delta_R_local + + END DO ! ispin + + CALL bs_env%para_env%sync() + + CALL local_dbt_to_global_fm(t_chi_R, bs_env%fm_chi_R_t(:, i_t), bs_env%mat_RI_RI, & + bs_env%mat_RI_RI_tensor, bs_env) + + CALL destroy_t_1d(Gocc_S) + CALL destroy_t_1d(Gvir_S) + CALL destroy_t_1d(t_chi_R) + CALL destroy_t_2d(t_Gocc) + CALL destroy_t_2d(t_Gvir) + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,I13,A,I3,A,F7.1,A)') & + 'Computed χ^R(iτ) for time point', i_t, ' /', bs_env%num_time_freq_points, & + ', Execution time', m_walltime() - t1, ' s' + END IF + + END DO ! i_t + + CALL timestop(handle) + + END SUBROUTINE compute_chi + +! ************************************************************************************************** +!> \brief ... +!> \param R ... +!> \param template ... +!> \param nimages ... +! ************************************************************************************************** + SUBROUTINE dbt_create_2c_R(R, template, nimages) + + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: R + TYPE(dbt_type) :: template + INTEGER :: nimages + + CHARACTER(LEN=*), PARAMETER :: routineN = 'dbt_create_2c_R' + + INTEGER :: handle, i_cell_S + + CALL timeset(routineN, handle) + + ALLOCATE (R(nimages)) + DO i_cell_S = 1, nimages + CALL dbt_create(template, R(i_cell_S)) + END DO + + CALL timestop(handle) + + END SUBROUTINE dbt_create_2c_R + +! ************************************************************************************************** +!> \brief ... +!> \param t_3c_R1_R2 ... +!> \param t_3c_template ... +!> \param nimages_1 ... +!> \param nimages_2 ... +! ************************************************************************************************** + SUBROUTINE dbt_create_3c_R1_R2(t_3c_R1_R2, t_3c_template, nimages_1, nimages_2) + + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_R1_R2 + TYPE(dbt_type) :: t_3c_template + INTEGER :: nimages_1, nimages_2 + + CHARACTER(LEN=*), PARAMETER :: routineN = 'dbt_create_3c_R1_R2' + + INTEGER :: handle, i_cell, j_cell + + CALL timeset(routineN, handle) + + ALLOCATE (t_3c_R1_R2(nimages_1, nimages_2)) + DO i_cell = 1, nimages_1 + DO j_cell = 1, nimages_2 + CALL dbt_create(t_3c_template, t_3c_R1_R2(i_cell, j_cell)) + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE dbt_create_3c_R1_R2 + +! ************************************************************************************************** +!> \brief ... +!> \param t_G_S ... +!> \param t_M ... +!> \param bs_env ... +!> \param i_cell_R1 ... +!> \param i_cell_R2 ... +! ************************************************************************************************** + SUBROUTINE G_times_3c(t_G_S, t_M, bs_env, i_cell_R1, i_cell_R2) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_G_S + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_M + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i_cell_R1, i_cell_R2 + + CHARACTER(LEN=*), PARAMETER :: routineN = 'G_times_3c' + + INTEGER :: handle, i_cell_R1_p_S, i_cell_S + INTEGER, DIMENSION(3) :: cell_R1, cell_R1_plus_cell_S, cell_R2, & + cell_S + LOGICAL :: cell_found + TYPE(dbt_type) :: t_3c_int + + CALL timeset(routineN, handle) + + CALL dbt_create(bs_env%t_RI_AO__AO, t_3c_int) + + cell_R1(1:3) = bs_env%index_to_cell_3c(i_cell_R1, 1:3) + cell_R2(1:3) = bs_env%index_to_cell_3c(i_cell_R2, 1:3) + + DO i_cell_S = 1, bs_env%nimages_scf_desymm + + cell_S(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_S, 1:3) + cell_R1_plus_cell_S(1:3) = cell_R1(1:3) + cell_S(1:3) + + CALL is_cell_in_index_to_cell(cell_R1_plus_cell_S, bs_env%index_to_cell_3c, cell_found) + + IF (.NOT. cell_found) CYCLE + + i_cell_R1_p_S = bs_env%cell_to_index_3c(cell_R1_plus_cell_S(1), cell_R1_plus_cell_S(2), & + cell_R1_plus_cell_S(3)) + + IF (bs_env%nblocks_3c(i_cell_R2, i_cell_R1_p_S) == 0) CYCLE + + CALL get_t_3c_int(t_3c_int, bs_env, i_cell_R2, i_cell_R1_p_S) + + CALL dbt_contract(alpha=1.0_dp, & + tensor_1=t_3c_int, & + tensor_2=t_G_S(i_cell_S), & + beta=1.0_dp, & + tensor_3=t_M(i_cell_R1, i_cell_R2), & + contract_1=[3], notcontract_1=[1, 2], map_1=[1, 2], & + contract_2=[2], notcontract_2=[1], map_2=[3], & + filter_eps=bs_env%eps_filter) + END DO + + CALL dbt_destroy(t_3c_int) + + CALL timestop(handle) + + END SUBROUTINE G_times_3c + +! ************************************************************************************************** +!> \brief ... +!> \param t_3c_int ... +!> \param bs_env ... +!> \param j_cell ... +!> \param k_cell ... +! ************************************************************************************************** + SUBROUTINE get_t_3c_int(t_3c_int, bs_env, j_cell, k_cell) + + TYPE(dbt_type) :: t_3c_int + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: j_cell, k_cell + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_t_3c_int' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL dbt_clear(t_3c_int) + IF (j_cell < k_cell) THEN + CALL dbt_copy(bs_env%t_3c_int(k_cell, j_cell), t_3c_int, order=[1, 3, 2]) + ELSE + CALL dbt_copy(bs_env%t_3c_int(j_cell, k_cell), t_3c_int) + END IF + + CALL timestop(handle) + + END SUBROUTINE get_t_3c_int + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param tau ... +!> \param G_S ... +!> \param ispin ... +!> \param occ ... +!> \param vir ... +! ************************************************************************************************** + SUBROUTINE G_occ_vir(bs_env, tau, G_S, ispin, occ, vir) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp) :: tau + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: G_S + INTEGER :: ispin + LOGICAL :: occ, vir + + CHARACTER(LEN=*), PARAMETER :: routineN = 'G_occ_vir' + + INTEGER :: handle, homo, i_cell_S, ikp, j, & + j_col_local, n_mo, ncol_local, & + nimages, nkp + INTEGER, DIMENSION(:), POINTER :: col_indices + REAL(KIND=dp) :: tau_E + + CALL timeset(routineN, handle) + + CPASSERT(occ .NEQV. vir) + + CALL cp_cfm_get_info(matrix=bs_env%cfm_work_mo, & + ncol_local=ncol_local, & + col_indices=col_indices) + + nkp = bs_env%nkp_scf_desymm + nimages = bs_env%nimages_scf_desymm + n_mo = bs_env%n_ao + homo = bs_env%n_occ(ispin) + + DO i_cell_S = 1, bs_env%nimages_scf_desymm + CALL cp_fm_set_all(bs_env%fm_G_S(i_cell_S), 0.0_dp) + END DO + + DO ikp = 1, nkp + + ! get C_µn(k) + CALL cp_fm_to_cfm(bs_env%fm_mo_coeff_kp(ikp, ispin, 1), & + bs_env%fm_mo_coeff_kp(ikp, ispin, 2), bs_env%cfm_work_mo) + + ! G^occ/vir_µλ(i|τ|,k) = sum_n^occ/vir C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k) + DO j_col_local = 1, ncol_local + + j = col_indices(j_col_local) + + ! 0.5 * |(ϵ_nk-ϵ_F)τ| + tau_E = ABS(tau*0.5_dp*(bs_env%eigenval_scf(j, ikp, ispin) - bs_env%e_fermi(ispin))) + + IF (tau_E < bs_env%stabilize_exp) THEN + bs_env%cfm_work_mo%local_data(:, j_col_local) = & + bs_env%cfm_work_mo%local_data(:, j_col_local)*EXP(-tau_E) + ELSE + bs_env%cfm_work_mo%local_data(:, j_col_local) = z_zero + END IF + + IF ((occ .AND. j > homo) .OR. (vir .AND. j <= homo)) THEN + bs_env%cfm_work_mo%local_data(:, j_col_local) = z_zero + END IF + + END DO + + CALL parallel_gemm(transa="N", transb="C", m=n_mo, n=n_mo, k=n_mo, alpha=z_one, & + matrix_a=bs_env%cfm_work_mo, matrix_b=bs_env%cfm_work_mo, & + beta=z_zero, matrix_c=bs_env%cfm_work_mo_2) + + ! trafo k-point k -> cell S: G^occ/vir_µλ(i|τ|,k) -> G^occ/vir,S_µλ(i|τ|) + CALL fm_add_ikp_to_rs(bs_env%cfm_work_mo_2, bs_env%fm_G_S, & + bs_env%kpoints_scf_desymm, ikp) + + END DO ! ikp + + ! replicate to tensor from local tensor group + DO i_cell_S = 1, bs_env%nimages_scf_desymm + CALL fm_to_local_tensor(bs_env%fm_G_S(i_cell_S), bs_env%mat_ao_ao%matrix, & + bs_env%mat_ao_ao_tensor%matrix, G_S(i_cell_S), bs_env) + END DO + + CALL timestop(handle) + + END SUBROUTINE G_occ_vir + +! ************************************************************************************************** +!> \brief ... +!> \param t_R ... +!> \param fm_R ... +!> \param mat_global ... +!> \param mat_local ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE local_dbt_to_global_fm(t_R, fm_R, mat_global, mat_local, bs_env) + TYPE(dbt_type), DIMENSION(:) :: t_R + TYPE(cp_fm_type), DIMENSION(:) :: fm_R + TYPE(dbcsr_p_type) :: mat_global, mat_local + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'local_dbt_to_global_fm' + + INTEGER :: handle, i_cell, n_images + + CALL timeset(routineN, handle) + + n_images = SIZE(t_R) + + CPASSERT(n_images == SIZE(fm_R)) + + DO i_cell = 1, n_images + CALL dbcsr_set(mat_global%matrix, 0.0_dp) + CALL dbcsr_set(mat_local%matrix, 0.0_dp) + CALL local_dbt_to_global_mat(t_R(i_cell), mat_local%matrix, mat_global%matrix, & + bs_env%para_env) + CALL copy_dbcsr_to_fm(mat_global%matrix, fm_R(i_cell)) + END DO + + CALL timestop(handle) + + END SUBROUTINE local_dbt_to_global_fm + +! ************************************************************************************************** +!> \brief ... +!> \param fm_S ... +!> \param array_S ... +!> \param weight ... +!> \param add ... +! ************************************************************************************************** + SUBROUTINE fm_to_local_array(fm_S, array_S, weight, add) + + TYPE(cp_fm_type), DIMENSION(:) :: fm_S + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_S + REAL(KIND=dp), OPTIONAL :: weight + LOGICAL, OPTIONAL :: add + + CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_to_local_array' + + INTEGER :: handle, i, i_row_local, img, j, & + j_col_local, n_basis, ncol_local, & + nimages, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: my_add + REAL(KIND=dp) :: my_weight + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_tmp + + CALL timeset(routineN, handle) + + my_weight = 1.0_dp + IF (PRESENT(weight)) my_weight = weight + + my_add = .FALSE. + IF (PRESENT(add)) my_add = add + + n_basis = SIZE(array_S, 1) + nimages = SIZE(array_S, 3) + + ! checks + CPASSERT(SIZE(array_S, 2) == n_basis) + CPASSERT(SIZE(fm_S) == nimages) + CPASSERT(LBOUND(array_S, 1) == 1) + CPASSERT(LBOUND(array_S, 2) == 1) + CPASSERT(LBOUND(array_S, 3) == 1) + + CALL cp_fm_get_info(matrix=fm_S(1), & + nrow_local=nrow_local, & + ncol_local=ncol_local, & + row_indices=row_indices, & + col_indices=col_indices) + + IF (.NOT. my_add) array_S(:, :, :) = 0.0_dp + ALLOCATE (array_tmp(SIZE(array_S, 1), SIZE(array_S, 2), SIZE(array_S, 3))) + array_tmp(:, :, :) = 0.0_dp + + DO img = 1, nimages + DO i_row_local = 1, nrow_local + + i = row_indices(i_row_local) + + DO j_col_local = 1, ncol_local + + j = col_indices(j_col_local) + + array_tmp(i, j, img) = fm_S(img)%local_data(i_row_local, j_col_local) + + END DO ! j_col_local + END DO ! i_row_local + END DO ! img + + CALL fm_S(1)%matrix_struct%para_env%sync() + CALL fm_S(1)%matrix_struct%para_env%sum(array_tmp) + CALL fm_S(1)%matrix_struct%para_env%sync() + + array_S(:, :, :) = array_S(:, :, :) + my_weight*array_tmp(:, :, :) + + CALL timestop(handle) + + END SUBROUTINE fm_to_local_array + +! ************************************************************************************************** +!> \brief ... +!> \param array_S ... +!> \param fm_S ... +!> \param weight ... +!> \param add ... +! ************************************************************************************************** + SUBROUTINE local_array_to_fm(array_S, fm_S, weight, add) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: array_S + TYPE(cp_fm_type), DIMENSION(:) :: fm_S + REAL(KIND=dp), OPTIONAL :: weight + LOGICAL, OPTIONAL :: add + + CHARACTER(LEN=*), PARAMETER :: routineN = 'local_array_to_fm' + + INTEGER :: handle, i, i_row_local, img, j, & + j_col_local, n_basis, ncol_local, & + nimages, nrow_local + INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices + LOGICAL :: my_add + REAL(KIND=dp) :: my_weight, S_ij + + CALL timeset(routineN, handle) + + my_weight = 1.0_dp + IF (PRESENT(weight)) my_weight = weight + + my_add = .FALSE. + IF (PRESENT(add)) my_add = add + + n_basis = SIZE(array_S, 1) + nimages = SIZE(array_S, 3) + + ! checks + CPASSERT(SIZE(array_S, 2) == n_basis) + CPASSERT(SIZE(fm_S) == nimages) + CPASSERT(LBOUND(array_S, 1) == 1) + CPASSERT(LBOUND(array_S, 2) == 1) + CPASSERT(LBOUND(array_S, 3) == 1) + + CALL cp_fm_get_info(matrix=fm_S(1), & + nrow_local=nrow_local, & + ncol_local=ncol_local, & + row_indices=row_indices, & + col_indices=col_indices) + + DO img = 1, nimages + + DO i_row_local = 1, nrow_local + + i = row_indices(i_row_local) + + DO j_col_local = 1, ncol_local + + j = col_indices(j_col_local) + + IF (my_add) THEN + S_ij = fm_S(img)%local_data(i_row_local, j_col_local) + & + array_S(i, j, img)*my_weight + ELSE + S_ij = array_S(i, j, img)*my_weight + END IF + fm_S(img)%local_data(i_row_local, j_col_local) = S_ij + + END DO ! j_col_local + + END DO ! i_row_local + + END DO ! img + + CALL timestop(handle) + + END SUBROUTINE local_array_to_fm + +! ************************************************************************************************** +!> \brief ... +!> \param t_Gocc ... +!> \param t_Gvir ... +!> \param t_chi_R ... +!> \param bs_env ... +!> \param i_cell_Delta_R ... +! ************************************************************************************************** + SUBROUTINE contract_M_occ_vir_to_chi(t_Gocc, t_Gvir, t_chi_R, bs_env, i_cell_Delta_R) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_Gocc, t_Gvir + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_chi_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i_cell_Delta_R + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_M_occ_vir_to_chi' + + INTEGER :: handle, i_cell_R, i_cell_R1, & + i_cell_R1_minus_R, i_cell_R2, & + i_cell_R2_minus_R + INTEGER, DIMENSION(3) :: cell_DR, cell_R, cell_R1, & + cell_R1_minus_R, cell_R2, & + cell_R2_minus_R + LOGICAL :: cell_found + TYPE(dbt_type) :: t_Gocc_2, t_Gvir_2 + + CALL timeset(routineN, handle) + + CALL dbt_create(bs_env%t_RI__AO_AO, t_Gocc_2) + CALL dbt_create(bs_env%t_RI__AO_AO, t_Gvir_2) + + ! χ_PQ^R(iτ) = sum_λR1,νR2 M^occ_λR1,νR2,P0 M^vir_νR2,λR1,QR + DO i_cell_R = 1, bs_env%nimages_scf_desymm + + DO i_cell_R2 = 1, bs_env%nimages_3c + + cell_R(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_R, 1:3) + cell_R2(1:3) = bs_env%index_to_cell_3c(i_cell_R2, 1:3) + cell_DR(1:3) = bs_env%index_to_cell_Delta_R(i_cell_Delta_R, 1:3) + + ! R_1 = R_2 + ΔR (from ΔR = R_2 - R_1) + CALL add_R(cell_R2, cell_DR, bs_env%index_to_cell_3c, cell_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_R1) + IF (.NOT. cell_found) CYCLE + + ! R_1 - R + CALL add_R(cell_R1, -cell_R, bs_env%index_to_cell_3c, cell_R1_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_R1_minus_R) + IF (.NOT. cell_found) CYCLE + + ! R_2 - R + CALL add_R(cell_R2, -cell_R, bs_env%index_to_cell_3c, cell_R2_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_R2_minus_R) + IF (.NOT. cell_found) CYCLE + + ! reorder tensors for efficient contraction to χ_PQ^R + CALL dbt_copy(t_Gocc(i_cell_R1, i_cell_R2), t_Gocc_2, order=[1, 3, 2]) + CALL dbt_copy(t_Gvir(i_cell_R2_minus_R, i_cell_R1_minus_R), t_Gvir_2) + + ! χ_PQ^R(iτ) = sum_λR1,νR2 M^occ_λR1,νR2,P0 M^vir_νR2,λR1,QR + CALL dbt_contract(alpha=bs_env%spin_degeneracy, & + tensor_1=t_Gocc_2, tensor_2=t_Gvir_2, & + beta=1.0_dp, tensor_3=t_chi_R(i_cell_R), & + contract_1=[2, 3], notcontract_1=[1], map_1=[1], & + contract_2=[2, 3], notcontract_2=[1], map_2=[2], & + filter_eps=bs_env%eps_filter, move_data=.TRUE.) + END DO ! i_cell_R2 + + END DO ! i_cell_R + + ! remove all data from t_Gocc and t_Gvir to safe memory + DO i_cell_R1 = 1, bs_env%nimages_3c + DO i_cell_R2 = 1, bs_env%nimages_3c + CALL dbt_clear(t_Gocc(i_cell_R1, i_cell_R2)) + CALL dbt_clear(t_Gvir(i_cell_R1, i_cell_R2)) + END DO + END DO + + CALL dbt_destroy(t_Gocc_2) + CALL dbt_destroy(t_Gvir_2) + + CALL timestop(handle) + + END SUBROUTINE contract_M_occ_vir_to_chi + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE compute_W_real_space(bs_env, qs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_W_real_space' + + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: chi_k_w, eps_k_w, W_k_w, work + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: M_inv, M_inv_V_sqrt, V_sqrt + INTEGER :: handle, i_t, ikp, ikp_local, j_w, n_RI, & + nimages_scf_desymm + REAL(KIND=dp) :: freq_j, t1, time_i, weight_ij + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: chi_R, MWM_R, W_R + + CALL timeset(routineN, handle) + + n_RI = bs_env%n_RI + nimages_scf_desymm = bs_env%nimages_scf_desymm + + ALLOCATE (chi_k_w(n_RI, n_RI), work(n_RI, n_RI), eps_k_w(n_RI, n_RI), W_k_w(n_RI, n_RI)) + ALLOCATE (chi_R(n_RI, n_RI, nimages_scf_desymm), W_R(n_RI, n_RI, nimages_scf_desymm), & + MWM_R(n_RI, n_RI, nimages_scf_desymm)) + + t1 = m_walltime() + + CALL compute_Minv_and_Vsqrt(bs_env, qs_env, M_inv_V_sqrt, M_inv, V_sqrt) + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & + 'Computed V_PQ(k),', 'Execution time', m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + t1 = m_walltime() + + DO j_w = 1, bs_env%num_time_freq_points + + ! χ_PQ^R(iτ) -> χ_PQ^R(iω_j) (which is stored in chi_R, single ω_j from j_w loop) + chi_R(:, :, :) = 0.0_dp + DO i_t = 1, bs_env%num_time_freq_points + freq_j = bs_env%imag_freq_points(j_w) + time_i = bs_env%imag_time_points(i_t) + weight_ij = bs_env%weights_cos_t_to_w(j_w, i_t)*COS(time_i*freq_j) + + CALL fm_to_local_array(bs_env%fm_chi_R_t(:, i_t), chi_R, weight_ij, add=.TRUE.) + END DO + + ikp_local = 0 + W_R(:, :, :) = 0.0_dp + DO ikp = 1, bs_env%nkp_chi_eps_W_orig_plus_extra + + ! trivial parallelization over k-points + IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + + ikp_local = ikp_local + 1 + + ! 1. χ_PQ^R(iω_j) -> χ_PQ(iω_j,k) + CALL trafo_rs_to_ikp(chi_R, chi_k_w, bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_chi_eps_W%xkp(1:3, ikp)) + + ! 2. remove negative eigenvalues from χ_PQ(iω,k) + CALL power(chi_k_w, 1.0_dp, bs_env%eps_eigval_mat_RI) + + ! 3. ε(iω_j,k_i) = Id - V^0.5(k_i)*M^-1(k_i)*χ(iω_j,k_i)*M^-1(k_i)*V^0.5(k_i) + + ! 3. a) work = χ(iω_j,k_i)*M^-1(k_i)*V^0.5(k_i) + CALL ZGEMM('N', 'N', n_RI, n_RI, n_RI, z_one, chi_k_w, n_RI, & + M_inv_V_sqrt(:, :, ikp_local), n_RI, z_zero, work, n_RI) + + ! 3. b) eps_work = V^0.5(k_i)*M^-1(k_i)*work + CALL ZGEMM('C', 'N', n_RI, n_RI, n_RI, z_one, M_inv_V_sqrt(:, :, ikp_local), n_RI, & + work, n_RI, z_zero, eps_k_w, n_RI) + + ! 3. c) ε(iω_j,k_i) = eps_work - Id + CALL add_on_diag(eps_k_w, z_one) + + ! 4. W(iω_j,k_i) = M^-1(k_i)*V^0.5(k_i)*(ε^-1(iω_j,k_i)-Id)*V^0.5(k_i)*M^-1(k_i) + + ! 4. a) Inversion of ε(iω_j,k_i) using its Cholesky decomposition + CALL power(eps_k_w, -1.0_dp, 0.0_dp) + + ! 4. b) ε^-1(iω_j,k_i)-Id + CALL add_on_diag(eps_k_w, -z_one) + + ! 4. c) work = (ε^-1(iω_j,k_i)-Id)*V^0.5(k_i) + CALL ZGEMM('N', 'C', n_RI, n_RI, n_RI, z_one, eps_k_w, n_RI, & + V_sqrt(:, :, ikp_local), n_RI, z_zero, work, n_RI) + + ! 4. d) W(iω,k_i) = V^0.5(k_i)*work + CALL ZGEMM('N', 'N', n_RI, n_RI, n_RI, z_one, V_sqrt(:, :, ikp_local), n_RI, & + work, n_RI, z_zero, W_k_w, n_RI) + + ! 5. W(iω,k_i) -> W^R(iω) = sum_k w_k e^(-ikR) W(iω,k) (k-point extrapolation here) + CALL add_ikp_to_all_rs(W_k_w, W_R, bs_env%kpoints_chi_eps_W, ikp, & + index_to_cell_ext=bs_env%kpoints_scf_desymm%index_to_cell) + + END DO ! ikp + + CALL bs_env%para_env%sync() + CALL bs_env%para_env%sum(W_R) + + ! 6. W^R(iω) -> W(iω,k) [k-mesh is not extrapolated for stable mult. with M^-1(k) ] + ! -> M^-1(k)*W(iω,k)*M^-1(k) =: Ŵ(iω,k) -> Ŵ^R(iω) (stored in MWM_R) + CALL mult_W_with_Minv(W_R, MWM_R, bs_env, qs_env) + + ! 7. Ŵ^R(iω) -> Ŵ^R(iτ) and to fully distributed fm matrix bs_env%fm_MWM_R_t + DO i_t = 1, bs_env%num_time_freq_points + freq_j = bs_env%imag_freq_points(j_w) + time_i = bs_env%imag_time_points(i_t) + weight_ij = bs_env%weights_cos_w_to_t(i_t, j_w)*COS(time_i*freq_j) + CALL local_array_to_fm(MWM_R, bs_env%fm_MWM_R_t(:, i_t), weight_ij, add=.TRUE.) + END DO ! i_t + + END DO ! j_w + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T60,A,F7.1,A)') & + 'Computed W_PQ(k,iω) for all k and τ,', 'Execution time', m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + CALL timestop(handle) + + END SUBROUTINE compute_W_real_space + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param qs_env ... +!> \param M_inv_V_sqrt ... +!> \param M_inv ... +!> \param V_sqrt ... +! ************************************************************************************************** + SUBROUTINE compute_Minv_and_Vsqrt(bs_env, qs_env, M_inv_V_sqrt, M_inv, V_sqrt) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: M_inv_V_sqrt, M_inv, V_sqrt + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Minv_and_Vsqrt' + + INTEGER :: handle, ikp, ikp_local, n_RI, nkp, & + nkp_local, nkp_orig + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: M_R + + CALL timeset(routineN, handle) + + nkp = bs_env%nkp_chi_eps_W_orig_plus_extra + nkp_orig = bs_env%nkp_chi_eps_W_orig + n_RI = bs_env%n_RI + + nkp_local = 0 + DO ikp = 1, nkp + ! trivial parallelization over k-points + IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + nkp_local = nkp_local + 1 + END DO + + ALLOCATE (M_inv_V_sqrt(n_RI, n_RI, nkp_local), M_inv(n_RI, n_RI, nkp_local), & + V_sqrt(n_RI, n_RI, nkp_local)) + + M_inv_V_sqrt(:, :, :) = z_zero + M_inv(:, :, :) = z_zero + V_sqrt(:, :, :) = z_zero + + ! 1. 2c Coulomb integrals for the first "original" k-point grid + bs_env%kpoints_chi_eps_W%nkp_grid = bs_env%nkp_grid_chi_eps_W_orig + CALL build_2c_coulomb_matrix_kp_small_cell(V_sqrt, qs_env, bs_env%kpoints_chi_eps_W, & + bs_env%size_lattice_sum_V, basis_type="RI_AUX", & + ikp_start=1, ikp_end=nkp_orig) + + ! 2. 2c Coulomb integrals for the second "extrapolation" k-point grid + bs_env%kpoints_chi_eps_W%nkp_grid = bs_env%nkp_grid_chi_eps_W_extra + CALL build_2c_coulomb_matrix_kp_small_cell(V_sqrt, qs_env, bs_env%kpoints_chi_eps_W, & + bs_env%size_lattice_sum_V, basis_type="RI_AUX", & + ikp_start=nkp_orig + 1, ikp_end=nkp) + + ! now get M^-1(k) and M^-1(k)*V^0.5(k) + + ! compute M^R_PQ = for RI metric + CALL get_V_tr_R(M_R, bs_env%ri_metric, bs_env%regularization_RI, bs_env, qs_env) + + ikp_local = 0 + DO ikp = 1, nkp + + ! trivial parallelization + IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + + ikp_local = ikp_local + 1 + + ! M(k) = sum_R e^ikR M^R + CALL trafo_rs_to_ikp(M_R, M_inv(:, :, ikp_local), & + bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_chi_eps_W%xkp(1:3, ikp)) + + ! invert M_PQ(k) + CALL power(M_inv(:, :, ikp_local), -1.0_dp, 0.0_dp) + + ! V^0.5(k) + CALL power(V_sqrt(:, :, ikp_local), 0.5_dp, 0.0_dp) + + ! M^-1(k)*V^0.5(k) + CALL ZGEMM("N", "C", n_RI, n_RI, n_RI, z_one, M_inv(:, :, ikp_local), n_RI, & + V_sqrt(:, :, ikp_local), n_RI, z_zero, M_inv_V_sqrt(:, :, ikp_local), n_RI) + + END DO ! ikp + + CALL timestop(handle) + + END SUBROUTINE compute_Minv_and_Vsqrt + +! ************************************************************************************************** +!> \brief ... +!> \param matrix ... +!> \param exponent ... +!> \param eps ... +! ************************************************************************************************** + SUBROUTINE power(matrix, exponent, eps) + COMPLEX(KIND=dp), DIMENSION(:, :) :: matrix + REAL(KIND=dp) :: exponent, eps + + CHARACTER(len=*), PARAMETER :: routineN = 'power' + + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: eigenvectors + COMPLEX(KIND=dp), DIMENSION(:), POINTER :: work + COMPLEX(KIND=dp), DIMENSION(:, :), POINTER :: A + INTEGER :: handle, i, info, liwork, lrwork, lwork, n + INTEGER, DIMENSION(:), POINTER :: iwork + REAL(KIND=dp) :: pos_eval + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigenvalues + REAL(KIND=dp), DIMENSION(:), POINTER :: rwork + + CALL timeset(routineN, handle) + + ! code by Ole Schütt + IF (SIZE(matrix, 1) /= SIZE(matrix, 2)) CPABORT("expected square matrix") + + ! make matrix perfectly Hermitian + matrix(:, :) = 0.5_dp*(matrix(:, :) + CONJG(TRANSPOSE(matrix(:, :)))) + + n = SIZE(matrix, 1) + ALLOCATE (iwork(1), rwork(1), work(1), A(n, n), eigenvalues(n), eigenvectors(n, n)) + + A(:, :) = matrix ! ZHEEVD will overwrite A + ! work space query + lwork = -1 + lrwork = -1 + liwork = -1 + + CALL ZHEEVD('V', 'U', n, A(1, 1), n, eigenvalues(1), & + work(1), lwork, rwork(1), lrwork, iwork(1), liwork, info) + lwork = INT(REAL(work(1), dp)) + lrwork = INT(REAL(rwork(1), dp)) + liwork = iwork(1) + + DEALLOCATE (iwork, rwork, work) + ALLOCATE (iwork(liwork)) + iwork(:) = 0 + ALLOCATE (rwork(lrwork)) + rwork(:) = 0.0_dp + ALLOCATE (work(lwork)) + work(:) = CMPLX(0.0_dp, 0.0_dp, KIND=dp) + + CALL ZHEEVD('V', 'U', n, A(1, 1), n, eigenvalues(1), & + work(1), lwork, rwork(1), lrwork, iwork(1), liwork, info) + + eigenvectors(:, :) = A(:, :) + + IF (info /= 0) CPABORT("diagonalization failed") + + DO i = 1, n + IF (eigenvalues(i) > eps) THEN + pos_eval = (eigenvalues(i))**(0.5_dp*exponent) + ELSE + pos_eval = z_zero + END IF + eigenvectors(:, i) = eigenvectors(:, i)*pos_eval + END DO + + CALL ZGEMM("N", "C", n, n, n, z_one, eigenvectors, n, eigenvectors, n, z_zero, matrix, n) + + DEALLOCATE (iwork, rwork, work, A, eigenvalues, eigenvectors) + + CALL timestop(handle) + + END SUBROUTINE power + +! ************************************************************************************************** +!> \brief ... +!> \param matrix ... +!> \param alpha ... +! ************************************************************************************************** + SUBROUTINE add_on_diag(matrix, alpha) + COMPLEX(KIND=dp), DIMENSION(:, :) :: matrix + COMPLEX(KIND=dp) :: alpha + + CHARACTER(len=*), PARAMETER :: routineN = 'add_on_diag' + + INTEGER :: handle, i, n + + CALL timeset(routineN, handle) + + n = SIZE(matrix, 1) + CPASSERT(n == SIZE(matrix, 2)) + + DO i = 1, n + matrix(i, i) = matrix(i, i) + alpha + END DO + + CALL timestop(handle) + + END SUBROUTINE add_on_diag + +! ************************************************************************************************** +!> \brief ... +!> \param W_R ... +!> \param MWM_R ... +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE mult_W_with_Minv(W_R, MWM_R, bs_env, qs_env) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: W_R, MWM_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'mult_W_with_Minv' + + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: M_inv, W_k, work + INTEGER :: handle, ikp, n_RI + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: M_R + + CALL timeset(routineN, handle) + + ! compute M^R again + CALL get_V_tr_R(M_R, bs_env%ri_metric, bs_env%regularization_RI, bs_env, qs_env) + + n_RI = bs_env%n_RI + ALLOCATE (M_inv(n_RI, n_RI), W_k(n_RI, n_RI), work(n_RI, n_RI)) + MWM_R(:, :, :) = 0.0_dp + + DO ikp = 1, bs_env%nkp_scf_desymm + + ! trivial parallelization + IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + + ! M(k) = sum_R e^ikR M^R + CALL trafo_rs_to_ikp(M_R, M_inv, & + bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_scf_desymm%xkp(1:3, ikp)) + + ! invert M_PQ(k) + CALL power(M_inv, -1.0_dp, 0.0_dp) + + ! W(k) = sum_R e^ikR W^R [k-mesh is not extrapolated for stable mult. with M^-1(k) ] + CALL trafo_rs_to_ikp(W_R, W_k, & + bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_scf_desymm%xkp(1:3, ikp)) + + ! 2e. M^-1(k) W^trunc(k) + CALL ZGEMM("N", "N", n_RI, n_RI, n_RI, z_one, M_inv, n_RI, W_k, n_RI, z_zero, work, n_RI) + + ! 2f. Ŵ(k) = M^-1(k) W^trunc(k) M^-1(k) + CALL ZGEMM("N", "N", n_RI, n_RI, n_RI, z_one, work, n_RI, M_inv, n_RI, z_zero, W_k, n_RI) + + ! 2g. Ŵ^R = sum_k w_k e^(-ikR) Ŵ^(k) + CALL add_ikp_to_all_rs(W_k, MWM_R, bs_env%kpoints_scf_desymm, ikp) + + END DO ! ikp + + CALL bs_env%para_env%sync() + CALL bs_env%para_env%sum(MWM_R) + + CALL timestop(handle) + + END SUBROUTINE mult_W_with_Minv + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE compute_Sigma_x(bs_env, qs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_x' + + INTEGER :: handle, i_cell_Delta_R, & + i_task_Delta_R_local, ispin + REAL(KIND=dp) :: t1 + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: D_S, Mi_Vtr_Mi_R, Sigma_x_R + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_V + + CALL timeset(routineN, handle) + + CALL dbt_create_2c_R(Mi_Vtr_Mi_R, bs_env%t_W, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(D_S, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(Sigma_x_R, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_3c_R1_R2(t_V, bs_env%t_RI_AO__AO, bs_env%nimages_3c, bs_env%nimages_3c) + + t1 = m_walltime() + + ! V^tr_PQ^R = , V^tr(k) = sum_R e^ikR V^tr^R + ! M(k) = sum_R e^ikR M^R, M(k) -> M^-1(k) -> Ṽ^tr(k) = M^-1(k) * V^tr(k) * M^-1(k) + ! -> Ṽ^tr_PQ^R = sum_k w_k e^-ikR Ṽ^tr_PQ(k) + CALL get_Minv_Vtr_Minv_R(Mi_Vtr_Mi_R, bs_env, qs_env) + + ! Σ^x_λσ^R = sum_PR1νS1 [ sum_µS2 (λ0 µS1-S2 | PR1 ) D_µν^S2 ] + ! [ sum_QR2 (σR νS1 | QR1-R2) Ṽ^tr_PQ^R2 ] + DO ispin = 1, bs_env%n_spin + + ! compute D^S(iτ) for cell S from D_µν(k) = sum_n^occ C^*_µn(k) C_νn(k): + ! trafo k-point k -> cell S: D_µν^S = sum_k w_k D_µν(k) e^(ikS) + CALL G_occ_vir(bs_env, 0.0_dp, D_S, ispin, occ=.TRUE., vir=.FALSE.) + + ! loop over ΔR = S_1 - R_1 which are local in the tensor subgroup + DO i_task_Delta_R_local = 1, bs_env%n_tasks_Delta_R_local + + i_cell_Delta_R = bs_env%task_Delta_R(i_task_Delta_R_local) + + ! M^V_σ0,νS1,PR1 = sum_QR2 ( σ0 νS1 | QR1-R2 ) Ṽ^tr_QP^R2 for i_task_local + CALL contract_W(t_V, Mi_Vtr_Mi_R, bs_env, i_cell_Delta_R) + + ! M^D_λ0,νS1,PR1 = sum_µS2 (λ0 µS1-S2 | PR1) D_µν^S2 + ! Σ^x_λσ^R = sum_PR1νS1 M^D_λ0,νS1,PR1 * M^V_σR,νS1,PR1 for i_task_local, where + ! M^V_σR,νS1,PR1 = M^V_σ0,νS1-R,PR1-R + CALL contract_to_Sigma(Sigma_x_R, t_V, D_S, i_cell_Delta_R, bs_env, & + occ=.TRUE., vir=.FALSE., clear_t_W=.TRUE.) + + END DO ! i_cell_Delta_R_local + + CALL bs_env%para_env%sync() + + CALL local_dbt_to_global_fm(Sigma_x_R, bs_env%fm_Sigma_x_R, bs_env%mat_ao_ao, & + bs_env%mat_ao_ao_tensor, bs_env) + + END DO ! ispin + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,T58,A,F7.1,A)') & + 'Computed Σ^x,', ' Execution time', m_walltime() - t1, ' s' + WRITE (bs_env%unit_nr, '(A)') ' ' + END IF + + CALL destroy_t_1d(Mi_Vtr_Mi_R) + CALL destroy_t_1d(D_S) + CALL destroy_t_1d(Sigma_x_R) + CALL destroy_t_2d(t_V) + + CALL timestop(handle) + + END SUBROUTINE compute_Sigma_x + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE compute_Sigma_c(bs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Sigma_c' + + INTEGER :: handle, i_cell_Delta_R, i_t, & + i_task_Delta_R_local, ispin + REAL(KIND=dp) :: t1, tau + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: Gocc_S, Gvir_S, Sigma_c_R_neg_tau, & + Sigma_c_R_pos_tau, W_R + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_W + + CALL timeset(routineN, handle) + + CALL dbt_create_2c_R(Gocc_S, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(Gvir_S, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(W_R, bs_env%t_W, bs_env%nimages_scf_desymm) + CALL dbt_create_3c_R1_R2(t_W, bs_env%t_RI_AO__AO, bs_env%nimages_3c, bs_env%nimages_3c) + CALL dbt_create_2c_R(Sigma_c_R_neg_tau, bs_env%t_G, bs_env%nimages_scf_desymm) + CALL dbt_create_2c_R(Sigma_c_R_pos_tau, bs_env%t_G, bs_env%nimages_scf_desymm) + + ! Σ^c_λσ^R(iτ) = sum_PR1νS1 [ sum_µS2 (λ0 µS1-S2 | PR1 ) G^occ/vir_µν^S2(i|τ|) ] + ! [ sum_QR2 (σR νS1 | QR1-R2) Ŵ_PQ^R2(iτ) ] + DO i_t = 1, bs_env%num_time_freq_points + + DO ispin = 1, bs_env%n_spin + + t1 = m_walltime() + + tau = bs_env%imag_time_points(i_t) + + ! G^occ_µλ(i|τ|,k) = sum_n^occ C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k), τ < 0 + ! G^vir_µλ(i|τ|,k) = sum_n^vir C_µn(k)^* e^(-|(ϵ_nk-ϵ_F)τ|) C_λn(k), τ > 0 + ! k-point k -> cell S: G^occ/vir_µλ^S(i|τ|) = sum_k w_k G^occ/vir_µλ(i|τ|,k) e^(ikS) + CALL G_occ_vir(bs_env, tau, Gocc_S, ispin, occ=.TRUE., vir=.FALSE.) + CALL G_occ_vir(bs_env, tau, Gvir_S, ispin, occ=.FALSE., vir=.TRUE.) + + ! write data of W^R_PQ(iτ) to W_R 2-index tensor + CALL fm_MWM_R_t_to_local_tensor_W_R(bs_env%fm_MWM_R_t(:, i_t), W_R, bs_env) + + ! loop over ΔR = S_1 - R_1 which are local in the tensor subgroup + DO i_task_Delta_R_local = 1, bs_env%n_tasks_Delta_R_local + + i_cell_Delta_R = bs_env%task_Delta_R(i_task_Delta_R_local) + + ! for i_task_local (i.e. fixed ΔR = S_1 - R_1) and for all τ (W(iτ) = W(-iτ)): + ! M^W_σ0,νS1,PR1 = sum_QR2 ( σ0 νS1 | QR1-R2 ) W(iτ)_QP^R2 + CALL contract_W(t_W, W_R, bs_env, i_cell_Delta_R) + + ! for τ < 0 and for i_task_local (i.e. fixed ΔR = S_1 - R_1): + ! M^G_λ0,νS1,PR1 = sum_µS2 (λ0 µS1-S2 | PR1) G^occ(i|τ|)_µν^S2 + ! Σ^c_λσ^R(iτ) = sum_PR1νS1 M^G_λ0,νS1,PR1 * M^W_σR,νS1,PR1 + ! where M^W_σR,νS1,PR1 = M^W_σ0,νS1-R,PR1-R + CALL contract_to_Sigma(Sigma_c_R_neg_tau, t_W, Gocc_S, i_cell_Delta_R, bs_env, & + occ=.TRUE., vir=.FALSE., clear_t_W=.FALSE.) + + ! for τ > 0: same as for τ < 0, but G^occ -> G^vir + CALL contract_to_Sigma(Sigma_c_R_pos_tau, t_W, Gvir_S, i_cell_Delta_R, bs_env, & + occ=.FALSE., vir=.TRUE., clear_t_W=.TRUE.) + + END DO ! i_cell_Delta_R_local + + CALL bs_env%para_env%sync() + + CALL local_dbt_to_global_fm(Sigma_c_R_pos_tau, & + bs_env%fm_Sigma_c_R_pos_tau(:, i_t, ispin), & + bs_env%mat_ao_ao, bs_env%mat_ao_ao_tensor, bs_env) + + CALL local_dbt_to_global_fm(Sigma_c_R_neg_tau, & + bs_env%fm_Sigma_c_R_neg_tau(:, i_t, ispin), & + bs_env%mat_ao_ao, bs_env%mat_ao_ao_tensor, bs_env) + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, '(T2,A,I10,A,I3,A,F7.1,A)') & + 'Computed Σ^c(iτ) for time point ', i_t, ' /', bs_env%num_time_freq_points, & + ', Execution time', m_walltime() - t1, ' s' + END IF + + END DO ! ispin + + END DO ! i_t + + CALL destroy_t_1d(Gocc_S) + CALL destroy_t_1d(Gvir_S) + CALL destroy_t_1d(W_R) + CALL destroy_t_1d(Sigma_c_R_neg_tau) + CALL destroy_t_1d(Sigma_c_R_pos_tau) + CALL destroy_t_2d(t_W) + + CALL timestop(handle) + + END SUBROUTINE compute_Sigma_c + +! ************************************************************************************************** +!> \brief ... +!> \param Mi_Vtr_Mi_R ... +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE get_Minv_Vtr_Minv_R(Mi_Vtr_Mi_R, bs_env, qs_env) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: Mi_Vtr_Mi_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_Minv_Vtr_Minv_R' + + COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: M_inv_V_tr_kp, M_kp, Mi_Vtr_Mi_kp, & + V_tr_kp + INTEGER :: handle, i_cell_R, ikp, n_RI, & + nimages_scf, nkp_scf + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: M_R, Mi_Vtr_Mi_R_arr, V_tr_R + + CALL timeset(routineN, handle) + + nimages_scf = bs_env%nimages_scf_desymm + nkp_scf = bs_env%kpoints_scf_desymm%nkp + n_RI = bs_env%n_RI + + CALL get_V_tr_R(V_tr_R, bs_env%trunc_coulomb, 0.0_dp, bs_env, qs_env) + CALL get_V_tr_R(M_R, bs_env%ri_metric, bs_env%regularization_RI, bs_env, qs_env) + + ALLOCATE (V_tr_kp(n_RI, n_RI), M_kp(n_RI, n_RI), M_inv_V_tr_kp(n_RI, n_RI), & + Mi_Vtr_Mi_kp(n_RI, n_RI), Mi_Vtr_Mi_R_arr(n_RI, n_RI, nimages_scf)) + Mi_Vtr_Mi_R_arr(:, :, :) = 0.0_dp + + DO ikp = 1, nkp_scf + ! trivial parallelization + IF (MODULO(ikp, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + ! V_tr(k) = sum_R e^ikR V_tr^R + CALL trafo_rs_to_ikp(V_tr_R, V_tr_kp, bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_scf_desymm%xkp(1:3, ikp)) + ! M(k) = sum_R e^ikR M^R + CALL trafo_rs_to_ikp(M_R, M_kp, bs_env%kpoints_scf_desymm%index_to_cell, & + bs_env%kpoints_scf_desymm%xkp(1:3, ikp)) + ! M(k) -> M^-1(k) + CALL power(M_kp, -1.0_dp, 0.0_dp) + ! M^-1(k) * V_tr(k) + CALL ZGEMM('N', 'N', n_RI, n_RI, n_RI, z_one, M_kp, n_RI, & + V_tr_kp, n_RI, z_zero, M_inv_V_tr_kp, n_RI) + ! Ṽ(k) = M^-1(k) * V_tr(k) * M^-1(k) + CALL ZGEMM('N', 'N', n_RI, n_RI, n_RI, z_one, M_inv_V_tr_kp, n_RI, & + M_kp, n_RI, z_zero, Mi_Vtr_Mi_kp, n_RI) + ! Ṽ^R = sum_k w_k e^-ikR Ṽ(k) + CALL add_ikp_to_all_rs(Mi_Vtr_Mi_kp, Mi_Vtr_Mi_R_arr, bs_env%kpoints_scf_desymm, ikp) + END DO + CALL bs_env%para_env%sync() + CALL bs_env%para_env%sum(Mi_Vtr_Mi_R_arr) + + ! use bs_env%fm_chi_R_t for temporary storage + CALL local_array_to_fm(Mi_Vtr_Mi_R_arr, bs_env%fm_chi_R_t(:, 1)) + + ! communicate Mi_Vtr_Mi_R to tensor format; full replication in tensor group + DO i_cell_R = 1, nimages_scf + CALL fm_to_local_tensor(bs_env%fm_chi_R_t(i_cell_R, 1), bs_env%mat_RI_RI%matrix, & + bs_env%mat_RI_RI_tensor%matrix, Mi_Vtr_Mi_R(i_cell_R), bs_env) + END DO + + CALL timestop(handle) + + END SUBROUTINE get_Minv_Vtr_Minv_R + +! ************************************************************************************************** +!> \brief ... +!> \param V_tr_R ... +!> \param pot_type ... +!> \param regularization_RI ... +!> \param bs_env ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE get_V_tr_R(V_tr_R, pot_type, regularization_RI, bs_env, qs_env) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: V_tr_R + TYPE(libint_potential_type) :: pot_type + REAL(KIND=dp) :: regularization_RI + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_V_tr_R' + + INTEGER :: handle, img, nimages_scf_desymm + INTEGER, ALLOCATABLE, DIMENSION(:) :: sizes_RI + INTEGER, DIMENSION(:), POINTER :: col_bsize, row_bsize + TYPE(cp_blacs_env_type), POINTER :: blacs_env + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_V_tr_R + TYPE(dbcsr_distribution_type) :: dbcsr_dist + TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: mat_V_tr_R + TYPE(distribution_2d_type), POINTER :: dist_2d + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: sab_RI + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + + CALL timeset(routineN, handle) + + NULLIFY (sab_RI, dist_2d) + + CALL get_qs_env(qs_env=qs_env, & + blacs_env=blacs_env, & + distribution_2d=dist_2d, & + qs_kind_set=qs_kind_set, & + particle_set=particle_set) + + ALLOCATE (sizes_RI(bs_env%n_atom)) + CALL get_particle_set(particle_set, qs_kind_set, nsgf=sizes_RI, basis=bs_env%basis_set_RI) + CALL build_2c_neighbor_lists(sab_RI, bs_env%basis_set_RI, bs_env%basis_set_RI, & + pot_type, "2c_nl_RI", qs_env, sym_ij=.FALSE., & + dist_2d=dist_2d) + CALL cp_dbcsr_dist2d_to_dist(dist_2d, dbcsr_dist) + ALLOCATE (row_bsize(SIZE(sizes_RI))) + ALLOCATE (col_bsize(SIZE(sizes_RI))) + row_bsize(:) = sizes_RI + col_bsize(:) = sizes_RI + + nimages_scf_desymm = bs_env%nimages_scf_desymm + ALLOCATE (mat_V_tr_R(nimages_scf_desymm)) + CALL dbcsr_create(mat_V_tr_R(1), "(RI|RI)", dbcsr_dist, dbcsr_type_no_symmetry, & + row_bsize, col_bsize) + DEALLOCATE (row_bsize, col_bsize) + + DO img = 2, nimages_scf_desymm + CALL dbcsr_create(mat_V_tr_R(img), template=mat_V_tr_R(1)) + END DO + + CALL build_2c_integrals(mat_V_tr_R, 0.0_dp, qs_env, sab_RI, bs_env%basis_set_RI, & + bs_env%basis_set_RI, pot_type, do_kpoints=.TRUE., & + ext_kpoints=bs_env%kpoints_scf_desymm, & + regularization_RI=regularization_RI) + + ALLOCATE (fm_V_tr_R(nimages_scf_desymm)) + DO img = 1, nimages_scf_desymm + CALL cp_fm_create(fm_V_tr_R(img), bs_env%fm_RI_RI%matrix_struct) + CALL copy_dbcsr_to_fm(mat_V_tr_R(img), fm_V_tr_R(img)) + CALL dbcsr_release(mat_V_tr_R(img)) + END DO + + IF (.NOT. ALLOCATED(V_tr_R)) THEN + ALLOCATE (V_tr_R(bs_env%n_RI, bs_env%n_RI, nimages_scf_desymm)) + END IF + + CALL fm_to_local_array(fm_V_tr_R, V_tr_R) + + CALL cp_fm_release(fm_V_tr_R) + CALL dbcsr_distribution_release(dbcsr_dist) + CALL release_neighbor_list_sets(sab_RI) + + CALL timestop(handle) + + END SUBROUTINE get_V_tr_R + +! ************************************************************************************************** +!> \brief ... +!> \param t_1d ... +! ************************************************************************************************** + SUBROUTINE destroy_t_1d(t_1d) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_1d + + CHARACTER(LEN=*), PARAMETER :: routineN = 'destroy_t_1d' + + INTEGER :: handle, i + + CALL timeset(routineN, handle) + + DO i = 1, SIZE(t_1d) + CALL dbt_destroy(t_1d(i)) + END DO + DEALLOCATE (t_1d) + + CALL timestop(handle) + + END SUBROUTINE destroy_t_1d + +! ************************************************************************************************** +!> \brief ... +!> \param t_2d ... +! ************************************************************************************************** + SUBROUTINE destroy_t_2d(t_2d) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_2d + + CHARACTER(LEN=*), PARAMETER :: routineN = 'destroy_t_2d' + + INTEGER :: handle, i, j + + CALL timeset(routineN, handle) + + DO i = 1, SIZE(t_2d, 1) + DO j = 1, SIZE(t_2d, 2) + CALL dbt_destroy(t_2d(i, j)) + END DO + END DO + DEALLOCATE (t_2d) + + CALL timestop(handle) + + END SUBROUTINE destroy_t_2d + +! ************************************************************************************************** +!> \brief ... +!> \param t_W ... +!> \param W_R ... +!> \param bs_env ... +!> \param i_cell_Delta_R ... +! ************************************************************************************************** + SUBROUTINE contract_W(t_W, W_R, bs_env, i_cell_Delta_R) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_W + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: W_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: i_cell_Delta_R + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_W' + + INTEGER :: handle, i_cell_R1, i_cell_R2, & + i_cell_R2_m_R1, i_cell_S1, & + i_cell_S1_m_R1_p_R2 + INTEGER, DIMENSION(3) :: cell_DR, cell_R1, cell_R2, cell_R2_m_R1, & + cell_S1, cell_S1_m_R2_p_R1 + LOGICAL :: cell_found + TYPE(dbt_type) :: t_3c_int, t_W_tmp + + CALL timeset(routineN, handle) + + CALL dbt_create(bs_env%t_RI__AO_AO, t_W_tmp) + CALL dbt_create(bs_env%t_RI_AO__AO, t_3c_int) + + DO i_cell_R1 = 1, bs_env%nimages_3c + + cell_R1(1:3) = bs_env%index_to_cell_3c(i_cell_R1, 1:3) + cell_DR(1:3) = bs_env%index_to_cell_Delta_R(i_cell_Delta_R, 1:3) + + ! S_1 = R_1 + ΔR (from ΔR = S_1 - R_1) + CALL add_R(cell_R1, cell_DR, bs_env%index_to_cell_3c, cell_S1, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1) + IF (.NOT. cell_found) CYCLE + + DO i_cell_R2 = 1, bs_env%nimages_scf_desymm + + cell_R2(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_R2, 1:3) + + ! R_2 - R_1 + CALL add_R(cell_R2, -cell_R1, bs_env%index_to_cell_3c, cell_R2_m_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_R2_m_R1) + IF (.NOT. cell_found) CYCLE + + ! S_1 - R_1 + R_2 + CALL add_R(cell_S1, cell_R2_m_R1, bs_env%index_to_cell_3c, cell_S1_m_R2_p_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1_m_R1_p_R2) + IF (.NOT. cell_found) CYCLE + + CALL get_t_3c_int(t_3c_int, bs_env, i_cell_S1_m_R1_p_R2, i_cell_R2_m_R1) + + ! M^W_σ0,νS1,PR1 = sum_QR2 ( σ0 νS1 | QR1-R2 ) W_QP^R2 + ! = sum_QR2 ( σR2-R1 νS1-R1+R2 | Q0 ) W_QP^R2 + ! for ΔR = S_1 - R_1 + CALL dbt_contract(alpha=1.0_dp, & + tensor_1=W_R(i_cell_R2), & + tensor_2=t_3c_int, & + beta=0.0_dp, & + tensor_3=t_W_tmp, & + contract_1=[1], notcontract_1=[2], map_1=[1], & + contract_2=[1], notcontract_2=[2, 3], map_2=[2, 3], & + filter_eps=bs_env%eps_filter) + + ! reorder tensor + CALL dbt_copy(t_W_tmp, t_W(i_cell_S1, i_cell_R1), order=[1, 2, 3], & + move_data=.TRUE., summation=.TRUE.) + + END DO ! i_cell_R2 + + END DO ! i_cell_R1 + + CALL dbt_destroy(t_W_tmp) + CALL dbt_destroy(t_3c_int) + + CALL timestop(handle) + + END SUBROUTINE contract_W + +! ************************************************************************************************** +!> \brief ... +!> \param Sigma_R ... +!> \param t_W ... +!> \param G_S ... +!> \param i_cell_Delta_R ... +!> \param bs_env ... +!> \param occ ... +!> \param vir ... +!> \param clear_t_W ... +! ************************************************************************************************** + SUBROUTINE contract_to_Sigma(Sigma_R, t_W, G_S, i_cell_Delta_R, bs_env, occ, vir, clear_t_W) + TYPE(dbt_type), DIMENSION(:) :: Sigma_R + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_W + TYPE(dbt_type), DIMENSION(:) :: G_S + INTEGER :: i_cell_Delta_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + LOGICAL :: occ, vir, clear_t_W + + CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_to_Sigma' + + INTEGER :: handle, handle2, i_cell_m_R1, i_cell_R, i_cell_R1, i_cell_R1_minus_R, i_cell_S1, & + i_cell_S1_minus_R, i_cell_S1_p_S2_m_R1, i_cell_S2 + INTEGER, DIMENSION(3) :: cell_DR, cell_m_R1, cell_R, cell_R1, & + cell_R1_minus_R, cell_S1, & + cell_S1_minus_R, cell_S1_p_S2_m_R1, & + cell_S2 + LOGICAL :: cell_found + REAL(KIND=dp) :: sign_Sigma + TYPE(dbt_type) :: t_3c_int, t_G, t_G_2 + + CALL timeset(routineN, handle) + + CPASSERT(occ .EQV. (.NOT. vir)) + IF (occ) sign_Sigma = -1.0_dp + IF (vir) sign_Sigma = 1.0_dp + + CALL dbt_create(bs_env%t_RI_AO__AO, t_G) + CALL dbt_create(bs_env%t_RI_AO__AO, t_G_2) + CALL dbt_create(bs_env%t_RI_AO__AO, t_3c_int) + + DO i_cell_R1 = 1, bs_env%nimages_3c + + cell_R1(1:3) = bs_env%index_to_cell_3c(i_cell_R1, 1:3) + cell_DR(1:3) = bs_env%index_to_cell_Delta_R(i_cell_Delta_R, 1:3) + + ! S_1 = R_1 + ΔR (from ΔR = S_1 - R_1) + CALL add_R(cell_R1, cell_DR, bs_env%index_to_cell_3c, cell_S1, cell_found, & + bs_env%cell_to_index_3c, i_cell_S1) + IF (.NOT. cell_found) CYCLE + + DO i_cell_S2 = 1, bs_env%nimages_scf_desymm + + cell_S2(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_S2, 1:3) + cell_m_R1(1:3) = -cell_R1(1:3) + cell_S1_p_S2_m_R1(1:3) = cell_S1(1:3) + cell_S2(1:3) - cell_R1(1:3) + + CALL is_cell_in_index_to_cell(cell_m_R1, bs_env%index_to_cell_3c, cell_found) + IF (.NOT. cell_found) CYCLE + + CALL is_cell_in_index_to_cell(cell_S1_p_S2_m_R1, bs_env%index_to_cell_3c, cell_found) + IF (.NOT. cell_found) CYCLE + + i_cell_m_R1 = bs_env%cell_to_index_3c(cell_m_R1(1), cell_m_R1(2), cell_m_R1(3)) + i_cell_S1_p_S2_m_R1 = bs_env%cell_to_index_3c(cell_S1_p_S2_m_R1(1), & + cell_S1_p_S2_m_R1(2), & + cell_S1_p_S2_m_R1(3)) + + CALL timeset(routineN//"_3c_x_G", handle2) + + CALL get_t_3c_int(t_3c_int, bs_env, i_cell_m_R1, i_cell_S1_p_S2_m_R1) + + ! M_λ0,νS1,PR1 = sum_µS2 ( λ0 µS1-S2 | PR1 ) G^occ/vir_µν^S2(i|τ|) + ! = sum_µS2 ( λ-R1 µS1-S2-R1 | P0 ) G^occ/vir_µν^S2(i|τ|) + ! for ΔR = S_1 - R_1 + CALL dbt_contract(alpha=1.0_dp, & + tensor_1=G_S(i_cell_S2), & + tensor_2=t_3c_int, & + beta=1.0_dp, & + tensor_3=t_G, & + contract_1=[2], notcontract_1=[1], map_1=[3], & + contract_2=[3], notcontract_2=[1, 2], map_2=[1, 2], & + filter_eps=bs_env%eps_filter) + + CALL timestop(handle2) + + END DO ! i_cell_S2 + + CALL dbt_copy(t_G, t_G_2, order=[1, 3, 2], move_data=.TRUE.) + + CALL timeset(routineN//"_contract", handle2) + + DO i_cell_R = 1, bs_env%nimages_scf_desymm + + cell_R = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_R, 1:3) + + ! R_1 - R + CALL add_R(cell_R1, -cell_R, bs_env%index_to_cell_3c, cell_R1_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_R1_minus_R) + IF (.NOT. cell_found) CYCLE + + ! S_1 - R + CALL add_R(cell_S1, -cell_R, bs_env%index_to_cell_3c, cell_S1_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1_minus_R) + IF (.NOT. cell_found) CYCLE + + ! Σ_λσ^R = sum_PR1νS1 M^G_λ0,νS1,PR1 M^W_σR,νS1,PR1, where + ! M^G_λ0,νS1,PR1 = sum_µS2 (λ0 µS1-S2 | PR1) G_µν^S2 + ! M^W_σR,νS1,PR1 = sum_QR2 (σR νS1 | QR1-R2) W_PQ^R2 = M^W_σ0,νS1-R,PR1-R + CALL dbt_contract(alpha=sign_Sigma, & + tensor_1=t_G_2, & + tensor_2=t_W(i_cell_S1_minus_R, i_cell_R1_minus_R), & + beta=1.0_dp, & + tensor_3=Sigma_R(i_cell_R), & + contract_1=[1, 2], notcontract_1=[3], map_1=[1], & + contract_2=[1, 2], notcontract_2=[3], map_2=[2], & + filter_eps=bs_env%eps_filter) + + END DO ! i_cell_R + + CALL dbt_clear(t_G_2) + + CALL timestop(handle2) + + END DO ! i_cell_R1 + + ! release memory + IF (clear_t_W) THEN + DO i_cell_S1 = 1, bs_env%nimages_3c + DO i_cell_R1 = 1, bs_env%nimages_3c + CALL dbt_clear(t_W(i_cell_S1, i_cell_R1)) + END DO + END DO + END IF + + CALL dbt_destroy(t_G) + CALL dbt_destroy(t_G_2) + CALL dbt_destroy(t_3c_int) + + CALL timestop(handle) + + END SUBROUTINE contract_to_Sigma + +! ************************************************************************************************** +!> \brief ... +!> \param fm_W_R ... +!> \param W_R ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE fm_MWM_R_t_to_local_tensor_W_R(fm_W_R, W_R, bs_env) + TYPE(cp_fm_type), DIMENSION(:) :: fm_W_R + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: W_R + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'fm_MWM_R_t_to_local_tensor_W_R' + + INTEGER :: handle, i_cell_R + + CALL timeset(routineN, handle) + + ! communicate fm_W_R to tensor W_R; full replication in tensor group + DO i_cell_R = 1, bs_env%nimages_scf_desymm + CALL fm_to_local_tensor(fm_W_R(i_cell_R), bs_env%mat_RI_RI%matrix, & + bs_env%mat_RI_RI_tensor%matrix, W_R(i_cell_R), bs_env) + END DO + + CALL timestop(handle) + + END SUBROUTINE fm_MWM_R_t_to_local_tensor_W_R + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE compute_QP_energies(bs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_QP_energies' + + INTEGER :: handle, ikp, ispin, j_t + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Sigma_x_ikp_n + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: Sigma_c_ikp_n_freq, Sigma_c_ikp_n_time + TYPE(cp_cfm_type) :: cfm_mo_coeff + + CALL timeset(routineN, handle) + + CALL cp_cfm_create(cfm_mo_coeff, bs_env%fm_s_Gamma%matrix_struct) + ALLOCATE (Sigma_x_ikp_n(bs_env%n_ao)) + ALLOCATE (Sigma_c_ikp_n_time(bs_env%n_ao, bs_env%num_time_freq_points, 2)) + ALLOCATE (Sigma_c_ikp_n_freq(bs_env%n_ao, bs_env%num_time_freq_points, 2)) + + DO ispin = 1, bs_env%n_spin + + DO ikp = 1, bs_env%nkp_bs_and_DOS + + ! 1. get C_µn(k) + CALL cp_fm_to_cfm(bs_env%fm_mo_coeff_kp(ikp, ispin, 1), & + bs_env%fm_mo_coeff_kp(ikp, ispin, 2), cfm_mo_coeff) + + ! 2. Σ^x_µν(k) = sum_R Σ^x_µν^R e^ikR + ! Σ^x_nn(k) = sum_µν C^*_µn(k) Σ^x_µν(k) C_νn(k) + CALL trafo_to_k_and_nn(bs_env%fm_Sigma_x_R, Sigma_x_ikp_n, cfm_mo_coeff, bs_env, ikp) + + ! 3. Σ^c_µν(k,+/-i|τ_j|) = sum_R Σ^c_µν^R(+/-i|τ_j|) e^ikR + ! Σ^c_nn(k,+/-i|τ_j|) = sum_µν C^*_µn(k) Σ^c_µν(k,+/-i|τ_j|) C_νn(k) + DO j_t = 1, bs_env%num_time_freq_points + CALL trafo_to_k_and_nn(bs_env%fm_Sigma_c_R_pos_tau(:, j_t, ispin), & + Sigma_c_ikp_n_time(:, j_t, 1), cfm_mo_coeff, bs_env, ikp) + CALL trafo_to_k_and_nn(bs_env%fm_Sigma_c_R_neg_tau(:, j_t, ispin), & + Sigma_c_ikp_n_time(:, j_t, 2), cfm_mo_coeff, bs_env, ikp) + END DO + + ! 4. Σ^c_nn(k_i,iω) = ∫ from -∞ to ∞ dτ e^-iωτ Σ^c_nn(k_i,iτ) + CALL time_to_freq(bs_env, Sigma_c_ikp_n_time, Sigma_c_ikp_n_freq, ispin) + + ! 5. Analytic continuation Σ^c_nn(k_i,iω) -> Σ^c_nn(k_i,ϵ) and + ! ϵ_nk_i^GW = ϵ_nk_i^DFT + Σ^c_nn(k_i,ϵ) + Σ^x_nn(k_i) - v^xc_nn(k_i) + CALL analyt_conti_and_print(bs_env, Sigma_c_ikp_n_freq, Sigma_x_ikp_n, & + bs_env%v_xc_n(:, ikp, ispin), & + bs_env%eigenval_scf(:, ikp, ispin), ikp, ispin) + + END DO ! ikp + + END DO ! ispin + + CALL get_VBM_CBM_bandgaps(bs_env) + + CALL cp_cfm_release(cfm_mo_coeff) + + CALL timestop(handle) + + END SUBROUTINE compute_QP_energies + +! ************************************************************************************************** +!> \brief ... +!> \param fm_rs ... +!> \param array_ikp_n ... +!> \param cfm_mo_coeff ... +!> \param bs_env ... +!> \param ikp ... +! ************************************************************************************************** + SUBROUTINE trafo_to_k_and_nn(fm_rs, array_ikp_n, cfm_mo_coeff, bs_env, ikp) + TYPE(cp_fm_type), DIMENSION(:) :: fm_rs + REAL(KIND=dp), DIMENSION(:) :: array_ikp_n + TYPE(cp_cfm_type) :: cfm_mo_coeff + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER :: ikp + + CHARACTER(LEN=*), PARAMETER :: routineN = 'trafo_to_k_and_nn' + + INTEGER :: handle, n_ao + TYPE(cp_cfm_type) :: cfm_ikp, cfm_tmp + TYPE(cp_fm_type) :: fm_ikp_re + + CALL timeset(routineN, handle) + + CALL cp_cfm_create(cfm_ikp, cfm_mo_coeff%matrix_struct) + CALL cp_cfm_create(cfm_tmp, cfm_mo_coeff%matrix_struct) + CALL cp_fm_create(fm_ikp_re, cfm_mo_coeff%matrix_struct) + + ! Σ_µν(k_i) = sum_R e^ik_iR Σ_µν^R + CALL fm_trafo_rs_to_ikp(cfm_ikp, fm_rs, bs_env%kpoints_DOS, ikp) + + n_ao = bs_env%n_ao + + ! Σ_nm(k_i) = sum_µν C^*_µn(k_i) Σ_µν(k_i) C_νn(k_i) + CALL parallel_gemm('N', 'N', n_ao, n_ao, n_ao, z_one, cfm_ikp, cfm_mo_coeff, z_zero, cfm_tmp) + CALL parallel_gemm('C', 'N', n_ao, n_ao, n_ao, z_one, cfm_mo_coeff, cfm_tmp, z_zero, cfm_ikp) + + ! get Σ_nn(k_i) which is a real quantity as Σ^x and Σ^c(iτ) is Hermitian + CALL cp_cfm_to_fm(cfm_ikp, fm_ikp_re) + CALL cp_fm_get_diag(fm_ikp_re, array_ikp_n) + + CALL cp_cfm_release(cfm_ikp) + CALL cp_cfm_release(cfm_tmp) + CALL cp_fm_release(fm_ikp_re) + + CALL timestop(handle) + + END SUBROUTINE trafo_to_k_and_nn + +END MODULE gw_small_cell_full_kp diff --git a/src/gw_utils.F b/src/gw_utils.F index e033038a01..a976dd1745 100644 --- a/src/gw_utils.F +++ b/src/gw_utils.F @@ -13,7 +13,8 @@ MODULE gw_utils USE atomic_kind_types, ONLY: atomic_kind_type,& get_atomic_kind_set - USE basis_set_types, ONLY: gto_basis_set_type + USE basis_set_types, ONLY: get_gto_basis_set,& + gto_basis_set_type USE bibliography, ONLY: Graml2024,& cite_reference USE cell_types, ONLY: cell_type,& @@ -21,18 +22,32 @@ MODULE gw_utils USE cp_blacs_env, ONLY: cp_blacs_env_create,& cp_blacs_env_release,& cp_blacs_env_type + USE cp_cfm_diag, ONLY: cp_cfm_geeig_canon + USE cp_cfm_types, ONLY: cp_cfm_create,& + cp_cfm_release,& + cp_cfm_to_fm,& + cp_cfm_type,& + cp_fm_to_cfm USE cp_control_types, ONLY: dft_control_type - USE cp_dbcsr_api, ONLY: dbcsr_create,& - dbcsr_p_type + USE cp_dbcsr_api, ONLY: & + dbcsr_create, dbcsr_deallocate_matrix, dbcsr_desymmetrize, dbcsr_p_type, dbcsr_set, & + dbcsr_type, dbcsr_type_antisymmetric, dbcsr_type_no_symmetry, dbcsr_type_symmetric + USE cp_dbcsr_cp2k_link, ONLY: cp_dbcsr_alloc_block_from_nbl USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,& + copy_fm_to_dbcsr,& dbcsr_allocate_matrix_set,& dbcsr_deallocate_matrix_set + USE cp_files, ONLY: close_file,& + open_file USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add USE cp_fm_struct, ONLY: cp_fm_struct_create,& cp_fm_struct_release,& cp_fm_struct_type USE cp_fm_types, ONLY: cp_fm_create,& - cp_fm_set_all + cp_fm_get_diag,& + cp_fm_release,& + cp_fm_set_all,& + cp_fm_type USE cp_log_handling, ONLY: cp_get_default_logger,& cp_logger_type USE cp_output_handling, ONLY: cp_print_key_generate_filename @@ -40,7 +55,11 @@ MODULE gw_utils dbt_clear, dbt_create, dbt_destroy, dbt_filter, dbt_iterator_blocks_left, & dbt_iterator_next_block, dbt_iterator_start, dbt_iterator_stop, dbt_iterator_type, & dbt_mp_environ_pgrid, dbt_pgrid_create, dbt_pgrid_destroy, dbt_pgrid_type, dbt_type + USE gw_integrals, ONLY: build_3c_integral_block USE input_constants, ONLY: do_potential_truncated,& + large_cell_Gamma,& + ri_rpa_g0w0_crossing_newton,& + small_cell_full_kp,& xc_none USE input_section_types, ONLY: section_vals_get_subs_vals,& section_vals_type,& @@ -49,13 +68,18 @@ MODULE gw_utils USE kinds, ONLY: default_string_length,& dp,& int_8 - USE kpoint_methods, ONLY: kpoint_init_cell_index - USE kpoint_types, ONLY: kpoint_create,& + USE kpoint_methods, ONLY: kpoint_init_cell_index,& + rskp_transform + USE kpoint_types, ONLY: get_kpoint_info,& + kpoint_create,& kpoint_type USE libint_wrapper, ONLY: cp_libint_static_cleanup,& cp_libint_static_init USE machine, ONLY: m_memory,& m_walltime + USE mathconstants, ONLY: gaussi,& + z_one,& + z_zero USE mathlib, ONLY: gcd USE message_passing, ONLY: mp_cart_type,& mp_para_env_type @@ -67,12 +91,15 @@ MODULE gw_utils USE mp2_grids, ONLY: get_l_sq_wghts_cos_tf_t_to_w,& get_l_sq_wghts_cos_tf_w_to_t,& get_l_sq_wghts_sin_tf_t_to_w - USE mp2_ri_2c, ONLY: setup_trunc_coulomb_pot_for_exchange_self_energy + USE mp2_ri_2c, ONLY: trunc_coulomb_for_exchange + USE parallel_gemm_api, ONLY: parallel_gemm USE particle_methods, ONLY: get_particle_set USE particle_types, ONLY: particle_type USE physcon, ONLY: angstrom,& evolt - USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type + USE post_scf_bandstructure_types, ONLY: band_edges_type,& + post_scf_bandstructure_type + USE post_scf_bandstructure_utils, ONLY: get_fname USE qs_energy_types, ONLY: qs_energy_type USE qs_environment_types, ONLY: get_qs_env,& qs_env_part_release,& @@ -92,14 +119,16 @@ MODULE gw_utils distribution_3d_create,& distribution_3d_type,& neighbor_list_3c_type + USE rpa_gw, ONLY: continuation_pade #include "base/base_uses.f90" IMPLICIT NONE PRIVATE - PUBLIC :: create_and_init_bs_env_for_gw, de_init_bs_env, get_i_j_atoms, & - kpoint_init_cell_index_simple, compute_xkp + PUBLIC :: create_and_init_bs_env_for_gw, de_init_bs_env, get_i_j_atoms, get_VBM_CBM_bandgaps, & + kpoint_init_cell_index_simple, compute_xkp, time_to_freq, analyt_conti_and_print, & + add_R, is_cell_in_index_to_cell CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'gw_utils' @@ -132,23 +161,50 @@ SUBROUTINE create_and_init_bs_env_for_gw(qs_env, bs_env, bs_sec) CALL get_RI_basis_and_basis_function_indices(qs_env, bs_env) - CALL setup_kpoints_chi_eps_W(qs_env, bs_env, bs_env%kpoints_chi_eps_W) - CALL set_heuristic_parameters(bs_env, qs_env) + CALL cp_libint_static_init() + + CALL setup_kpoints_chi_eps_W(bs_env, bs_env%kpoints_chi_eps_W) + + IF (bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp) THEN + CALL setup_cells_3c(qs_env, bs_env) + END IF + CALL set_parallelization_parameters(qs_env, bs_env) - CALL allocate_and_fill_matrices_and_arrays(qs_env, bs_env) + CALL allocate_matrices(qs_env, bs_env) - CALL cp_libint_static_init() + CALL compute_V_xc(qs_env, bs_env) CALL create_tensors(qs_env, bs_env) - CALL set_sparsity_parallelization_parameters(bs_env) + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) + + CALL allocate_GW_eigenvalues(bs_env) + + CALL check_sparsity_3c(qs_env, bs_env) + + CALL set_sparsity_parallelization_parameters(bs_env) + + CALL check_for_restart_files(qs_env, bs_env) + + CASE (small_cell_full_kp) + + CALL compute_3c_integrals(qs_env, bs_env) + + CALL setup_cells_Delta_R(bs_env) + + CALL setup_parallelization_Delta_R(bs_env) + + CALL compute_cfm_mo_coeff_kp_and_eigenval_scf_kp(qs_env, bs_env) - CALL check_for_restart_files(qs_env, bs_env) + CALL allocate_matrices_small_cell_full_kp(qs_env, bs_env) - CALL compute_fm_V_xc_Gamma(qs_env, bs_env) + CALL trafo_V_xc_R_to_kp(qs_env, bs_env) + + END SELECT CALL setup_time_and_frequency_minimax_grid(bs_env) @@ -342,8 +398,8 @@ SUBROUTINE get_RI_basis_and_basis_function_indices(qs_env, bs_env) u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,A)") " " - WRITE (UNIT=u, FMT="(T2,2A,T75,I8)") "Number of auxiliary Gaussian basis functions ", & + WRITE (u, FMT="(T2,A)") " " + WRITE (u, FMT="(T2,2A,T75,I8)") "Number of auxiliary Gaussian basis functions ", & "for χ, ε, W", n_RI END IF @@ -353,20 +409,18 @@ END SUBROUTINE get_RI_basis_and_basis_function_indices ! ************************************************************************************************** !> \brief ... -!> \param qs_env ... !> \param bs_env ... !> \param kpoints ... ! ************************************************************************************************** - SUBROUTINE setup_kpoints_chi_eps_W(qs_env, bs_env, kpoints) + SUBROUTINE setup_kpoints_chi_eps_W(bs_env, kpoints) - TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(kpoint_type), POINTER :: kpoints CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_chi_eps_W' - INTEGER :: handle, i_dim, n_dim, nkp, nkp_extra, & - nkp_orig, u + INTEGER :: exp_two, handle, i_dim, n_dim, nkp, & + nkp_extra, nkp_orig, u INTEGER, DIMENSION(3) :: nkp_grid, nkp_grid_extra, periodic REAL(KIND=dp) :: exp_s_p, n_dim_inv @@ -384,20 +438,38 @@ SUBROUTINE setup_kpoints_chi_eps_W(qs_env, bs_env, kpoints) CPASSERT(periodic(i_dim) == 0 .OR. periodic(i_dim) == 1) - IF (periodic(i_dim) == 1) nkp_grid(i_dim) = 4 - IF (periodic(i_dim) == 0) nkp_grid(i_dim) = 1 + SELECT CASE (periodic(i_dim)) + CASE (0) - IF (periodic(i_dim) == 1) THEN - ! only even k-meshes in periodic direction implemented - CPASSERT(MODULO(nkp_grid(i_dim), 2) == 0) - END IF - IF (periodic(i_dim) == 0) THEN - ! single k-kpoint in non-periodic direction needed - CPASSERT(nkp_grid(i_dim) == 1) - END IF + nkp_grid(i_dim) = 1 + nkp_grid_extra(i_dim) = 1 + + CASE (1) + + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) + nkp_grid(i_dim) = 4 + nkp_grid_extra(i_dim) = 6 + CASE (small_cell_full_kp) + ! for small cell, use the smallest 2^n x 2^m x 2^k k-mesh which is larger than + ! the SCF k-point grid; extrapolate with 2^(n+1) x 2^(m+1) x 2^(k+1) k-mesh + exp_two = 4 + DO WHILE (.TRUE.) + IF (exp_two > bs_env%kpoints_scf_desymm%nkp_grid(i_dim)) THEN + nkp_grid(i_dim) = exp_two + nkp_grid_extra(i_dim) = exp_two*2 + EXIT + ELSE + exp_two = exp_two*2 + END IF + END DO + END SELECT + + CASE DEFAULT - IF (periodic(i_dim) == 1) nkp_grid_extra(i_dim) = nkp_grid(i_dim) + 2 - IF (periodic(i_dim) == 0) nkp_grid_extra(i_dim) = 1 + CPABORT("Error in periodicity.") + + END SELECT END DO @@ -455,8 +527,6 @@ SUBROUTINE setup_kpoints_chi_eps_W(qs_env, bs_env, kpoints) bs_env%wkp_orig = 1.0_dp/REAL(nkp_orig, KIND=dp) END IF - CALL kpoint_init_cell_index_simple(kpoints, qs_env) - ! heuristic parameter: how many k-points for χ, ε, and W are used simultaneously ! (less simultaneous k-points: less memory, but more computational effort because of ! recomputation of V(k)) @@ -468,11 +538,11 @@ SUBROUTINE setup_kpoints_chi_eps_W(qs_env, bs_env, kpoints) u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,A)") " " - WRITE (UNIT=u, FMT="(T2,1A,T71,3I4)") "K-point mesh 1 for χ, ε, W", nkp_grid(1:3) - WRITE (UNIT=u, FMT="(T2,2A,T71,3I4)") "K-point mesh 2 for χ, ε, W ", & + WRITE (u, FMT="(T2,A)") " " + WRITE (u, FMT="(T2,1A,T71,3I4)") "K-point mesh 1 for χ, ε, W", nkp_grid(1:3) + WRITE (u, FMT="(T2,2A,T71,3I4)") "K-point mesh 2 for χ, ε, W ", & "(for k-point extrapolation of W)", nkp_grid_extra(1:3) - WRITE (UNIT=u, FMT="(T2,A,T80,L)") "Approximate the k-point extrapolation", & + WRITE (u, FMT="(T2,A,T80,L)") "Approximate the k-point extrapolation", & bs_env%approx_kp_extrapol END IF @@ -572,34 +642,32 @@ SUBROUTINE compute_wkp(wkp, nkp_1, nkp_2, exponent) CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE compute_wkp ! ************************************************************************************************** !> \brief ... !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** - SUBROUTINE allocate_and_fill_matrices_and_arrays(qs_env, bs_env) + SUBROUTINE allocate_matrices(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env - CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_and_fill_matrices_and_arrays' + CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_matrices' - INTEGER :: handle, i_t, num_time_freq_points + INTEGER :: handle, i_t TYPE(cp_blacs_env_type), POINTER :: blacs_env, blacs_env_tensor TYPE(cp_fm_struct_type), POINTER :: fm_struct, fm_struct_RI_global - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s TYPE(mp_para_env_type), POINTER :: para_env CALL timeset(routineN, handle) - CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env, matrix_s=matrix_s) + CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) fm_struct => bs_env%fm_ks_Gamma(1)%matrix_struct CALL cp_fm_create(bs_env%fm_Gocc, fm_struct) CALL cp_fm_create(bs_env%fm_Gvir, fm_struct) - CALL cp_fm_create(bs_env%fm_h_G0W0_Gamma, fm_struct) NULLIFY (fm_struct_RI_global) CALL cp_fm_struct_create(fm_struct_RI_global, context=blacs_env, nrow_global=bs_env%n_RI, & @@ -615,16 +683,6 @@ SUBROUTINE allocate_and_fill_matrices_and_arrays(qs_env, bs_env) END IF CALL cp_fm_struct_release(fm_struct_RI_global) - ALLOCATE (bs_env%eigenval_G0W0(bs_env%n_ao, bs_env%nkp_DOS, bs_env%n_spin)) - - num_time_freq_points = bs_env%num_time_freq_points - - ALLOCATE (bs_env%imag_freq_points(num_time_freq_points)) - ALLOCATE (bs_env%imag_time_points(num_time_freq_points)) - ALLOCATE (bs_env%weights_cos_t_to_w(num_time_freq_points, num_time_freq_points)) - ALLOCATE (bs_env%weights_cos_w_to_t(num_time_freq_points, num_time_freq_points)) - ALLOCATE (bs_env%weights_sin_t_to_w(num_time_freq_points, num_time_freq_points)) - ! create blacs_env for subgroups of tensor operations NULLIFY (blacs_env_tensor) CALL cp_blacs_env_create(blacs_env=blacs_env_tensor, para_env=bs_env%para_env_tensor) @@ -654,7 +712,27 @@ SUBROUTINE allocate_and_fill_matrices_and_arrays(qs_env, bs_env) CALL timestop(handle) - END SUBROUTINE allocate_and_fill_matrices_and_arrays + END SUBROUTINE allocate_matrices + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE allocate_GW_eigenvalues(bs_env) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_GW_eigenvalues' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ALLOCATE (bs_env%eigenval_G0W0(bs_env%n_ao, bs_env%nkp_bs_and_DOS, bs_env%n_spin)) + ALLOCATE (bs_env%eigenval_HF(bs_env%n_ao, bs_env%nkp_bs_and_DOS, bs_env%n_spin)) + + CALL timestop(handle) + + END SUBROUTINE allocate_GW_eigenvalues ! ************************************************************************************************** !> \brief ... @@ -667,16 +745,10 @@ SUBROUTINE create_tensors(qs_env, bs_env) CHARACTER(LEN=*), PARAMETER :: routineN = 'create_tensors' - INTEGER :: handle, n_atom_step, RI_atom - INTEGER(int_8) :: mem, non_zero_elements_sum, nze - REAL(dp) :: max_dist_AO_atoms, occ, occupation_sum - TYPE(dbt_type) :: t_3c_global - TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_global_array - TYPE(neighbor_list_3c_type) :: nl_3c_global + INTEGER :: handle CALL timeset(routineN, handle) - ! be careful: routine needs bs_env%eps_3c_int which is set in set_heuristic_parameters CALL init_interaction_radii(bs_env) ! split blocks does not improve load balancing/efficienfy for tensor contraction, so we go @@ -689,6 +761,31 @@ SUBROUTINE create_tensors(qs_env, bs_env) CALL create_2c_t(bs_env, bs_env%sizes_RI, bs_env%sizes_AO) + CALL timestop(handle) + + END SUBROUTINE create_tensors + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE check_sparsity_3c(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'check_sparsity_3c' + + INTEGER :: handle, n_atom_step, RI_atom + INTEGER(int_8) :: mem, non_zero_elements_sum, nze + REAL(dp) :: max_dist_AO_atoms, occ, occupation_sum + REAL(KIND=dp) :: t1, t2 + TYPE(dbt_type) :: t_3c_global + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_global_array + TYPE(neighbor_list_3c_type) :: nl_3c_global + + CALL timeset(routineN, handle) + ! check the sparsity of 3c integral tensor (µν|P); calculate maximum distance between ! AO atoms µ, ν where at least a single integral (µν|P) is larger than the filter threshold CALL create_3c_t(t_3c_global, bs_env%para_env, "(RI AO | AO)", [1, 2], [3], & @@ -702,7 +799,7 @@ SUBROUTINE create_tensors(qs_env, bs_env) CALL dbt_create(t_3c_global, t_3c_global_array(1, 1)) CALL bs_env%para_env%sync() - bs_env%t1 = m_walltime() + t1 = m_walltime() occupation_sum = 0.0_dp non_zero_elements_sum = 0 @@ -715,7 +812,7 @@ SUBROUTINE create_tensors(qs_env, bs_env) bs_env%eps_filter, & qs_env, & nl_3c_global, & - int_eps=bs_env%eps_3c_int, & + int_eps=bs_env%eps_filter, & basis_i=bs_env%basis_set_RI, & basis_j=bs_env%basis_set_AO, & basis_k=bs_env%basis_set_AO, & @@ -737,7 +834,7 @@ SUBROUTINE create_tensors(qs_env, bs_env) END DO - bs_env%t2 = m_walltime() + t2 = m_walltime() bs_env%occupation_3c_int = occupation_sum bs_env%max_dist_AO_atoms = max_dist_AO_atoms @@ -751,7 +848,7 @@ SUBROUTINE create_tensors(qs_env, bs_env) IF (bs_env%unit_nr > 0) THEN WRITE (bs_env%unit_nr, '(T2,A)') '' WRITE (bs_env%unit_nr, '(T2,A,F27.1,A)') & - 'Computed 3-center integrals (µν|P), execution time', bs_env%t2 - bs_env%t1, ' s' + 'Computed 3-center integrals (µν|P), execution time', t2 - t1, ' s' WRITE (bs_env%unit_nr, '(T2,A,F48.3,A)') 'Percentage of non-zero (µν|P)', & occupation_sum*100, ' %' WRITE (bs_env%unit_nr, '(T2,A,F33.1,A)') 'Max. distance between µ,ν in non-zero (µν|P)', & @@ -762,7 +859,7 @@ SUBROUTINE create_tensors(qs_env, bs_env) CALL timestop(handle) - END SUBROUTINE create_tensors + END SUBROUTINE check_sparsity_3c ! ************************************************************************************************** !> \brief ... @@ -891,10 +988,10 @@ SUBROUTINE init_interaction_radii(bs_env) DO ibasis = 1, SIZE(bs_env%basis_set_AO) orb_basis => bs_env%basis_set_AO(ibasis)%gto_basis_set - CALL init_interaction_radii_orb_basis(orb_basis, bs_env%eps_3c_int) + CALL init_interaction_radii_orb_basis(orb_basis, bs_env%eps_filter) ri_basis => bs_env%basis_set_RI(ibasis)%gto_basis_set - CALL init_interaction_radii_orb_basis(ri_basis, bs_env%eps_3c_int) + CALL init_interaction_radii_orb_basis(ri_basis, bs_env%eps_filter) END DO @@ -920,7 +1017,6 @@ SUBROUTINE get_max_dist_AO_atoms(t_3c_int, max_dist_AO_atoms, qs_env) INTEGER, DIMENSION(:, :), POINTER :: index_to_cell REAL(KIND=dp) :: abs_rab REAL(KIND=dp), DIMENSION(3) :: rab - REAL(KIND=dp), DIMENSION(3, 3) :: hmat TYPE(cell_type), POINTER :: cell TYPE(dbt_iterator_type) :: iter TYPE(mp_para_env_type), POINTER :: para_env @@ -932,7 +1028,7 @@ SUBROUTINE get_max_dist_AO_atoms(t_3c_int, max_dist_AO_atoms, qs_env) CALL get_qs_env(qs_env, cell=cell, particle_set=particle_set, para_env=para_env) !$OMP PARALLEL DEFAULT(NONE) & -!$OMP SHARED(t_3c_int, max_dist_AO_atoms, num_cells, index_to_cell, hmat, particle_set, cell) & +!$OMP SHARED(t_3c_int, max_dist_AO_atoms, num_cells, index_to_cell, particle_set, cell) & !$OMP PRIVATE(iter,atom_ind,rab, abs_rab, atom_1, atom_2) CALL dbt_iterator_start(iter, t_3c_int) DO WHILE (dbt_iterator_blocks_left(iter)) @@ -968,17 +1064,20 @@ SUBROUTINE set_sparsity_parallelization_parameters(bs_env) INTEGER :: handle, i_ivl, IL_ivl, j_ivl, n_atom_per_IL_ivl, n_atom_per_ivl, n_intervals_i, & n_intervals_inner_loop_atoms, n_intervals_j, u + INTEGER(KIND=int_8) :: input_memory_per_proc CALL timeset(routineN, handle) ! heuristic parameter to prevent out of memory bs_env%safety_factor_memory = 0.10_dp + input_memory_per_proc = INT(bs_env%input_memory_per_proc_GB*1.0E9_dp, KIND=int_8) + ! choose atomic range for λ ("i_atom"), ν ("j_atom") in ! M_λνP(iτ) = sum_µ (µν|P) G^occ_µλ(i|τ|,k=0) ! N_νλQ(iτ) = sum_σ (σλ|Q) G^vir_σν(i|τ|,k=0) ! such that M and N fit into the memory - n_atom_per_ivl = INT(SQRT(bs_env%safety_factor_memory*bs_env%input_memory_per_proc & + n_atom_per_ivl = INT(SQRT(bs_env%safety_factor_memory*input_memory_per_proc & *bs_env%group_size_tensor/24/bs_env%n_RI & /SQRT(bs_env%occupation_3c_int)))/bs_env%max_AO_bf_per_atom @@ -1012,7 +1111,7 @@ SUBROUTINE set_sparsity_parallelization_parameters(bs_env) ! choose atomic range for µ and σ ("inner loop (IL) atom") in ! M_λνP(iτ) = sum_µ (µν|P) G^occ_µλ(i|τ|,k=0) ! N_νλQ(iτ) = sum_σ (σλ|Q) G^vir_σν(i|τ|,k=0) - n_atom_per_IL_ivl = MIN(INT(bs_env%safety_factor_memory*bs_env%input_memory_per_proc & + n_atom_per_IL_ivl = MIN(INT(bs_env%safety_factor_memory*input_memory_per_proc & *bs_env%group_size_tensor/n_atom_per_ivl & /bs_env%max_AO_bf_per_atom & /bs_env%n_RI/8/SQRT(bs_env%occupation_3c_int) & @@ -1167,9 +1266,10 @@ SUBROUTINE set_parallelization_parameters(qs_env, bs_env) CALL get_qs_env(qs_env, para_env=para_env) num_pe = para_env%num_pe - ! use all processors for the group (in principle, number could be changed, but performance + ! if not already set, use all processors for the group (for large-cell GW, performance ! seems to be best for a single group with all MPI processes per group) - bs_env%group_size_tensor = num_pe + IF (bs_env%group_size_tensor < 0 .OR. bs_env%group_size_tensor > num_pe) & + bs_env%group_size_tensor = num_pe ! group_size_tensor must divide num_pe without rest; otherwise everything will be complicated IF (MODULO(num_pe, bs_env%group_size_tensor) .NE. 0) THEN @@ -1200,17 +1300,9 @@ SUBROUTINE set_parallelization_parameters(qs_env, bs_env) CALL m_memory(mem) CALL bs_env%para_env%max(mem) - bs_env%input_memory_per_proc = INT(bs_env%input_memory_per_proc_GB*1.0E9_dp, KIND=int_8) - u = bs_env%unit_nr IF (u > 0) THEN - WRITE (u, '(T2,A)') '' WRITE (u, '(T2,A,I47)') 'Group size for tensor operations', bs_env%group_size_tensor - WRITE (u, '(T2,A)') '' - WRITE (u, '(T2,A,F37.1,A)') 'Input: Available memory per MPI process', & - bs_env%input_memory_per_proc_GB, ' GB' - WRITE (u, '(T2,A,F35.1,A)') 'Used memory per MPI process before GW run', & - REAL(mem, KIND=dp)/1.E9_dp, ' GB' END IF CALL timestop(handle) @@ -1361,14 +1453,11 @@ SUBROUTINE set_heuristic_parameters(bs_env, qs_env) CHARACTER(LEN=*), PARAMETER :: routineN = 'set_heuristic_parameters' - INTEGER :: handle + INTEGER :: handle, u + LOGICAL :: do_BvK_cell CALL timeset(routineN, handle) - ! use the same threshold for computing 3-center integrals (µν|P) as for filtering - ! tensor operations - bs_env%eps_3c_int = bs_env%eps_filter - ! Determines number of cells used for summing the cells R in the Coulomb matrix, ! V_PQ(k) = \sum_R . SIZE_LATTICE_SUM_V 3 gives ! good convergence @@ -1389,17 +1478,13 @@ SUBROUTINE set_heuristic_parameters(bs_env, qs_env) bs_env%stabilize_exp = 70.0_dp bs_env%eps_atom_grid_2d_mat = 1.0E-50_dp - ! only use interval ω in [0, 27.211 eV] (1 Hartree = 27.211 eV) for virt, and ω in - ! [-27.211 eV, 0] for occ for use in analytic continuation of - ! self-energy Σ^c_n(iω,k) -> Σ^c_n(ϵ,k) + ! only use interval ω in [0, 1 Ha] (1 Hartree = 27.211 eV) for virt, and ω in [-1 Ha, 0] + ! for occ for use in analytic continuation of self-energy Σ^c_n(iω,k) -> Σ^c_n(ϵ,k) bs_env%freq_max_fit = 1.0_dp ! use a 16-parameter Padé fit bs_env%nparam_pade = 16 - ! minimum block size for tensor operations, taken from MP2/RPA input - bs_env%min_block_size = 5 - ! resolution of the identity with the truncated Coulomb metric, cutoff radius 3 Angström bs_env%ri_metric%potential_type = do_potential_truncated bs_env%ri_metric%omega = 0.0_dp @@ -1418,8 +1503,21 @@ SUBROUTINE set_heuristic_parameters(bs_env, qs_env) ! truncated Coulomb operator for exchange self-energy ! (see details in Guidon, VandeVondele, Hutter, JCTC 5, 3010 (2009) and references therein) - CALL setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env, bs_env%trunc_coulomb, & - rel_cutoff_trunc_coulomb_ri_x=0.5_dp) + do_BvK_cell = bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp + CALL trunc_coulomb_for_exchange(qs_env, bs_env%trunc_coulomb, & + rel_cutoff_trunc_coulomb_ri_x=0.5_dp, & + cell_grid=bs_env%cell_grid_scf_desymm, & + do_BvK_cell=do_BvK_cell) + + ! for small-cell GW, we need more cells than normally used by the filter bs_env%eps_filter + ! (in particular for computing the self-energy because of higher number of cells needed) + bs_env%heuristic_filter_factor = 1.0E-4 + + u = bs_env%unit_nr + IF (u > 0) THEN + WRITE (u, FMT="(T2,2A,F21.1,A)") "Cutoff radius for the truncated Coulomb ", & + "operator in Σ^x:", bs_env%trunc_coulomb%cutoff_radius*angstrom, " Å" + END IF CALL timestop(handle) @@ -1468,15 +1566,16 @@ END SUBROUTINE print_header_and_input_parameters !> \param qs_env ... !> \param bs_env ... ! ************************************************************************************************** - SUBROUTINE compute_fm_V_xc_Gamma(qs_env, bs_env) + SUBROUTINE compute_V_xc(qs_env, bs_env) TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env - CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_fm_V_xc_Gamma' + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_V_xc' - INTEGER :: handle, ispin, myfun, nimages + INTEGER :: handle, img, ispin, myfun, nimages REAL(KIND=dp) :: energy_ex, energy_exc, energy_total TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: mat_ks_without_v_xc + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks_kp TYPE(dft_control_type), POINTER :: dft_control TYPE(qs_energy_type), POINTER :: energy TYPE(section_vals_type), POINTER :: input, xc_section @@ -1487,7 +1586,7 @@ SUBROUTINE compute_fm_V_xc_Gamma(qs_env, bs_env) ! previously, dft_control%nimages set to # neighbor cells, revert for Γ-only KS matrix nimages = dft_control%nimages - dft_control%nimages = 1 + dft_control%nimages = bs_env%nimages_scf ! we need to reset XC functional, therefore, get XC input xc_section => section_vals_get_subs_vals(input, "DFT%XC") @@ -1499,27 +1598,52 @@ SUBROUTINE compute_fm_V_xc_Gamma(qs_env, bs_env) energy_exc = energy%exc energy_ex = energy%ex - NULLIFY (mat_ks_without_v_xc) - CALL dbcsr_allocate_matrix_set(mat_ks_without_v_xc, bs_env%n_spin) + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) - DO ispin = 1, bs_env%n_spin - ALLOCATE (mat_ks_without_v_xc(ispin)%matrix) - CALL dbcsr_create(mat_ks_without_v_xc(ispin)%matrix, template=bs_env%mat_ao_ao%matrix) - END DO + NULLIFY (mat_ks_without_v_xc) + CALL dbcsr_allocate_matrix_set(mat_ks_without_v_xc, bs_env%n_spin) - ! calculate KS-matrix without XC - CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & - ext_ks_matrix=mat_ks_without_v_xc) + DO ispin = 1, bs_env%n_spin + ALLOCATE (mat_ks_without_v_xc(ispin)%matrix) + CALL dbcsr_create(mat_ks_without_v_xc(ispin)%matrix, template=bs_env%mat_ao_ao%matrix) + END DO - DO ispin = 1, bs_env%n_spin - ! transfer dbcsr matrix to fm - CALL cp_fm_create(bs_env%fm_V_xc_Gamma(ispin), bs_env%fm_s_Gamma%matrix_struct) - CALL copy_dbcsr_to_fm(mat_ks_without_v_xc(ispin)%matrix, bs_env%fm_V_xc_Gamma(ispin)) + ! calculate KS-matrix without XC + CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE., & + ext_ks_matrix=mat_ks_without_v_xc) - ! finally compute the xc potential in the AO basis - CALL cp_fm_scale_and_add(alpha=-1.0_dp, matrix_a=bs_env%fm_V_xc_Gamma(ispin), & - beta=1.0_dp, matrix_b=bs_env%fm_ks_Gamma(ispin)) - END DO + DO ispin = 1, bs_env%n_spin + ! transfer dbcsr matrix to fm + CALL cp_fm_create(bs_env%fm_V_xc_Gamma(ispin), bs_env%fm_s_Gamma%matrix_struct) + CALL copy_dbcsr_to_fm(mat_ks_without_v_xc(ispin)%matrix, bs_env%fm_V_xc_Gamma(ispin)) + + ! v_xc = h_ks - h_ks(v_xc = 0) + CALL cp_fm_scale_and_add(alpha=-1.0_dp, matrix_a=bs_env%fm_V_xc_Gamma(ispin), & + beta=1.0_dp, matrix_b=bs_env%fm_ks_Gamma(ispin)) + END DO + + CALL dbcsr_deallocate_matrix_set(mat_ks_without_v_xc) + + CASE (small_cell_full_kp) + + ! calculate KS-matrix without XC + CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.) + CALL get_qs_env(qs_env=qs_env, matrix_ks_kp=matrix_ks_kp) + + ALLOCATE (bs_env%fm_V_xc_R(dft_control%nimages, bs_env%n_spin)) + DO ispin = 1, bs_env%n_spin + DO img = 1, dft_control%nimages + ! safe fm_V_xc_R in fm_matrix because saving in dbcsr matrix caused trouble... + CALL copy_dbcsr_to_fm(matrix_ks_kp(ispin, img)%matrix, bs_env%fm_work_mo(1)) + CALL cp_fm_create(bs_env%fm_V_xc_R(img, ispin), bs_env%fm_work_mo(1)%matrix_struct) + ! store h_ks(v_xc = 0) in fm_V_xc_R + CALL cp_fm_scale_and_add(alpha=1.0_dp, matrix_a=bs_env%fm_V_xc_R(img, ispin), & + beta=1.0_dp, matrix_b=bs_env%fm_work_mo(1)) + END DO + END DO + + END SELECT ! set back the energy energy%total = energy_total @@ -1530,14 +1654,25 @@ SUBROUTINE compute_fm_V_xc_Gamma(qs_env, bs_env) dft_control%nimages = nimages ! set the DFT functional and HF fraction back - CALL section_vals_val_set(xc_section, "XC_FUNCTIONAL%_SECTION_PARAMETERS_", & - i_val=myfun) - - CALL dbcsr_deallocate_matrix_set(mat_ks_without_v_xc) + CALL section_vals_val_set(xc_section, "XC_FUNCTIONAL%_SECTION_PARAMETERS_", i_val=myfun) + + IF (bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp) THEN + ! calculate KS-matrix again with XC + CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.) + DO ispin = 1, bs_env%n_spin + DO img = 1, dft_control%nimages + ! store h_ks in fm_work_mo + CALL copy_dbcsr_to_fm(matrix_ks_kp(ispin, img)%matrix, bs_env%fm_work_mo(1)) + ! v_xc = h_ks - h_ks(v_xc = 0) + CALL cp_fm_scale_and_add(alpha=-1.0_dp, matrix_a=bs_env%fm_V_xc_R(img, ispin), & + beta=1.0_dp, matrix_b=bs_env%fm_work_mo(1)) + END DO + END DO + END IF CALL timestop(handle) - END SUBROUTINE compute_fm_V_xc_Gamma + END SUBROUTINE compute_V_xc ! ************************************************************************************************** !> \brief ... @@ -1548,22 +1683,43 @@ SUBROUTINE setup_time_and_frequency_minimax_grid(bs_env) CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_time_and_frequency_minimax_grid' - INTEGER :: handle, homo, i_w, ierr, j_w, n_mo, & - num_time_freq_points, u - REAL(KIND=dp) :: E_max, E_min, E_range, max_error_min + INTEGER :: handle, homo, i_w, ierr, ispin, j_w, & + n_mo, num_time_freq_points, u + REAL(KIND=dp) :: E_max, E_max_ispin, E_min, E_min_ispin, & + E_range, max_error_min REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: points_and_weights CALL timeset(routineN, handle) - homo = bs_env%n_occ(1) n_mo = bs_env%n_ao num_time_freq_points = bs_env%num_time_freq_points + ALLOCATE (bs_env%imag_freq_points(num_time_freq_points)) + ALLOCATE (bs_env%imag_time_points(num_time_freq_points)) + ALLOCATE (bs_env%weights_cos_t_to_w(num_time_freq_points, num_time_freq_points)) + ALLOCATE (bs_env%weights_cos_w_to_t(num_time_freq_points, num_time_freq_points)) + ALLOCATE (bs_env%weights_sin_t_to_w(num_time_freq_points, num_time_freq_points)) + ! minimum and maximum difference between eigenvalues of unoccupied and an occupied MOs - E_min = MINVAL(bs_env%eigenval_scf_Gamma(homo + 1, :)) - & - MAXVAL(bs_env%eigenval_scf_Gamma(homo, :)) - E_max = MAXVAL(bs_env%eigenval_scf_Gamma(n_mo, :)) - & - MINVAL(bs_env%eigenval_scf_Gamma(1, :)) + E_min = 1000.0_dp + E_max = -1000.0_dp + DO ispin = 1, bs_env%n_spin + homo = bs_env%n_occ(ispin) + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) + E_min_ispin = bs_env%eigenval_scf_Gamma(homo + 1, ispin) - & + bs_env%eigenval_scf_Gamma(homo, ispin) + E_max_ispin = bs_env%eigenval_scf_Gamma(n_mo, ispin) - & + bs_env%eigenval_scf_Gamma(1, ispin) + CASE (small_cell_full_kp) + E_min_ispin = MINVAL(bs_env%eigenval_scf(homo + 1, :, ispin)) - & + MAXVAL(bs_env%eigenval_scf(homo, :, ispin)) + E_max_ispin = MAXVAL(bs_env%eigenval_scf(n_mo, :, ispin)) - & + MINVAL(bs_env%eigenval_scf(1, :, ispin)) + END SELECT + E_min = MIN(E_min, E_min_ispin) + E_max = MAX(E_max, E_max_ispin) + END DO E_range = E_max/E_min @@ -1582,7 +1738,7 @@ SUBROUTINE setup_time_and_frequency_minimax_grid(bs_env) ! determine number of fit points in the interval [0,ω_max] for virt, or [-ω_max,0] for occ bs_env%num_freq_points_fit = 0 - DO i_w = 1, bs_env%num_time_freq_points + DO i_w = 1, num_time_freq_points IF (bs_env%imag_freq_points(i_w) < bs_env%freq_max_fit) THEN bs_env%num_freq_points_fit = bs_env%num_freq_points_fit + 1 END IF @@ -1591,7 +1747,7 @@ SUBROUTINE setup_time_and_frequency_minimax_grid(bs_env) ! iω values for the analytic continuation Σ^c_n(iω,k) -> Σ^c_n(ϵ,k) ALLOCATE (bs_env%imag_freq_points_fit(bs_env%num_freq_points_fit)) j_w = 0 - DO i_w = 1, bs_env%num_time_freq_points + DO i_w = 1, num_time_freq_points IF (bs_env%imag_freq_points(i_w) < bs_env%freq_max_fit) THEN j_w = j_w + 1 bs_env%imag_freq_points_fit(j_w) = bs_env%imag_freq_points(i_w) @@ -1615,6 +1771,17 @@ SUBROUTINE setup_time_and_frequency_minimax_grid(bs_env) DEALLOCATE (points_and_weights) + u = bs_env%unit_nr + IF (u > 0) THEN + WRITE (u, '(T2,A)') '' + WRITE (u, '(T2,A,F55.2)') 'SCF direct band gap (eV)', E_min*evolt + WRITE (u, '(T2,A,F53.2)') 'Max. SCF eigval diff. (eV)', E_max*evolt + WRITE (u, '(T2,A,F55.2)') 'E-Range for minimax grid', E_range + WRITE (u, '(T2,A,I27)') 'Number of Padé parameters for analytic continuation:', & + bs_env%nparam_pade + WRITE (u, '(T2,A)') '' + END IF + ! in minimax grids, Fourier transforms t -> w and w -> t are split using ! e^(iwt) = cos(wt) + i sin(wt); we thus calculate weights for trafos with a cos and ! sine prefactor; details in Azizi, Wilhelm, Golze, Giantomassi, Panades-Barrueta, @@ -1647,18 +1814,1402 @@ SUBROUTINE setup_time_and_frequency_minimax_grid(bs_env) bs_env%num_points_per_magnitude, & bs_env%regularization_minimax) + CALL timestop(handle) + + END SUBROUTINE setup_time_and_frequency_minimax_grid + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE setup_cells_3c(qs_env, bs_env) + + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_cells_3c' + + INTEGER :: atom_i, atom_j, atom_k, cell_pair_count, handle, i, i_cell_x, i_cell_x_max, & + i_cell_x_min, i_size, ikind, img, j, j_cell, j_cell_max, j_cell_y, j_cell_y_max, & + j_cell_y_min, j_size, k_cell, k_cell_max, k_cell_z, k_cell_z_max, k_cell_z_min, k_size, & + nimage_pairs_3c, nimages_3c, nimages_3c_max, nkind, u + INTEGER(KIND=int_8) :: mem_occ_per_proc + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_other_3c_images_max + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: index_to_cell_3c_max, nblocks_3c_max + INTEGER, DIMENSION(3) :: cell_index, n_max + REAL(KIND=dp) :: avail_mem_per_proc_GB, cell_dist, cell_radius_3c, eps, exp_min_ao, & + exp_min_RI, frobenius_norm, mem_3c_GB, mem_occ_per_proc_GB, radius_ao, radius_ao_product, & + radius_RI + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: int_3c + REAL(KIND=dp), DIMENSION(:, :), POINTER :: exp_ao, exp_RI + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env, nkind=nkind) + + exp_min_RI = 10.0_dp + exp_min_ao = 10.0_dp + + DO ikind = 1, nkind + + CALL get_gto_basis_set(bs_env%basis_set_RI(ikind)%gto_basis_set, zet=exp_RI) + CALL get_gto_basis_set(bs_env%basis_set_ao(ikind)%gto_basis_set, zet=exp_ao) + + ! we need to remove all exponents lower than a lower bound, e.g. 1E-3, because + ! for contracted basis sets, there might be exponents = 0 in zet + DO i = 1, SIZE(exp_RI, 1) + DO j = 1, SIZE(exp_RI, 2) + IF (exp_RI(i, j) < exp_min_RI .AND. exp_RI(i, j) > 1E-3_dp) exp_min_RI = exp_RI(i, j) + END DO + END DO + DO i = 1, SIZE(exp_ao, 1) + DO j = 1, SIZE(exp_ao, 2) + IF (exp_ao(i, j) < exp_min_ao .AND. exp_ao(i, j) > 1E-3_dp) exp_min_ao = exp_ao(i, j) + END DO + END DO + + END DO + + eps = bs_env%eps_filter*bs_env%heuristic_filter_factor + + radius_ao = SQRT(-LOG(eps)/exp_min_ao) + radius_ao_product = SQRT(-LOG(eps)/(2.0_dp*exp_min_ao)) + radius_RI = SQRT(-LOG(eps)/exp_min_RI) + + ! For a 3c integral (μR υS | P0) we have that cell R and cell S need to be within radius_3c + cell_radius_3c = radius_ao_product + radius_RI + bs_env%ri_metric%cutoff_radius + + n_max(1:3) = bs_env%periodic(1:3)*30 + + nimages_3c_max = 0 + + i_cell_x_min = 0 + i_cell_x_max = 0 + j_cell_y_min = 0 + j_cell_y_max = 0 + k_cell_z_min = 0 + k_cell_z_max = 0 + + DO i_cell_x = -n_max(1), n_max(1) + DO j_cell_y = -n_max(2), n_max(2) + DO k_cell_z = -n_max(3), n_max(3) + + cell_index(1:3) = (/i_cell_x, j_cell_y, k_cell_z/) + + CALL get_cell_dist(cell_index, bs_env%hmat, cell_dist) + + IF (cell_dist < cell_radius_3c) THEN + nimages_3c_max = nimages_3c_max + 1 + i_cell_x_min = MIN(i_cell_x_min, i_cell_x) + i_cell_x_max = MAX(i_cell_x_max, i_cell_x) + j_cell_y_min = MIN(j_cell_y_min, j_cell_y) + j_cell_y_max = MAX(j_cell_y_max, j_cell_y) + k_cell_z_min = MIN(k_cell_z_min, k_cell_z) + k_cell_z_max = MAX(k_cell_z_max, k_cell_z) + END IF + + END DO + END DO + END DO + + ! get index_to_cell_3c_max for the maximum possible cell range; + ! compute 3c integrals later in this routine and check really which cell is needed + ALLOCATE (index_to_cell_3c_max(nimages_3c_max, 3)) + + img = 0 + DO i_cell_x = -n_max(1), n_max(1) + DO j_cell_y = -n_max(2), n_max(2) + DO k_cell_z = -n_max(3), n_max(3) + + cell_index(1:3) = (/i_cell_x, j_cell_y, k_cell_z/) + + CALL get_cell_dist(cell_index, bs_env%hmat, cell_dist) + + IF (cell_dist < cell_radius_3c) THEN + img = img + 1 + index_to_cell_3c_max(img, 1:3) = cell_index(1:3) + END IF + + END DO + END DO + END DO + + ! get pairs of R and S which have non-zero 3c integral (μR υS | P0) + ALLOCATE (nblocks_3c_max(nimages_3c_max, nimages_3c_max)) + nblocks_3c_max(:, :) = 0 + + cell_pair_count = 0 + DO j_cell = 1, nimages_3c_max + DO k_cell = 1, nimages_3c_max + + cell_pair_count = cell_pair_count + 1 + + ! trivial parallelization over cell pairs + IF (MODULO(cell_pair_count, bs_env%para_env%num_pe) .NE. bs_env%para_env%mepos) CYCLE + + DO atom_j = 1, bs_env%n_atom + DO atom_k = 1, bs_env%n_atom + DO atom_i = 1, bs_env%n_atom + + j_size = bs_env%i_ao_end_from_atom(atom_j) - bs_env%i_ao_start_from_atom(atom_j) + 1 + k_size = bs_env%i_ao_end_from_atom(atom_k) - bs_env%i_ao_start_from_atom(atom_k) + 1 + i_size = bs_env%i_RI_end_from_atom(atom_i) - bs_env%i_RI_start_from_atom(atom_i) + 1 + + ALLOCATE (int_3c(j_size, k_size, i_size)) + + ! compute 3-c int. ( μ(atom j) R , ν (atom k) S | P (atom i) 0 ) + ! ("|": truncated Coulomb operator), inside build_3c_integrals: (j k | i) + CALL build_3c_integral_block(int_3c, qs_env, bs_env%ri_metric, & + basis_j=bs_env%basis_set_AO, & + basis_k=bs_env%basis_set_AO, & + basis_i=bs_env%basis_set_RI, & + cell_j=index_to_cell_3c_max(j_cell, 1:3), & + cell_k=index_to_cell_3c_max(k_cell, 1:3), & + atom_k=atom_k, atom_j=atom_j, atom_i=atom_i) + + frobenius_norm = SQRT(SUM(int_3c(:, :, :)**2)) + + DEALLOCATE (int_3c) + + ! we use a higher threshold here to safe memory when storing the 3c integrals + ! in every tensor group + IF (frobenius_norm > eps) THEN + nblocks_3c_max(j_cell, k_cell) = nblocks_3c_max(j_cell, k_cell) + 1 + END IF + + END DO + END DO + END DO + + END DO + END DO + + CALL bs_env%para_env%sum(nblocks_3c_max) + + ALLOCATE (n_other_3c_images_max(nimages_3c_max)) + n_other_3c_images_max(:) = 0 + + nimages_3c = 0 + nimage_pairs_3c = 0 + + DO j_cell = 1, nimages_3c_max + DO k_cell = 1, nimages_3c_max + IF (nblocks_3c_max(j_cell, k_cell) > 0) THEN + n_other_3c_images_max(j_cell) = n_other_3c_images_max(j_cell) + 1 + nimage_pairs_3c = nimage_pairs_3c + 1 + END IF + END DO + + IF (n_other_3c_images_max(j_cell) > 0) nimages_3c = nimages_3c + 1 + + END DO + + bs_env%nimages_3c = nimages_3c + ALLOCATE (bs_env%index_to_cell_3c(nimages_3c, 3)) + ALLOCATE (bs_env%cell_to_index_3c(i_cell_x_min:i_cell_x_max, & + j_cell_y_min:j_cell_y_max, & + k_cell_z_min:k_cell_z_max)) + bs_env%cell_to_index_3c(:, :, :) = -1 + + ALLOCATE (bs_env%nblocks_3c(nimages_3c, nimages_3c)) + bs_env%nblocks_3c(nimages_3c, nimages_3c) = 0 + + j_cell = 0 + DO j_cell_max = 1, nimages_3c_max + IF (n_other_3c_images_max(j_cell_max) == 0) CYCLE + j_cell = j_cell + 1 + cell_index(1:3) = index_to_cell_3c_max(j_cell_max, 1:3) + bs_env%index_to_cell_3c(j_cell, 1:3) = cell_index(1:3) + bs_env%cell_to_index_3c(cell_index(1), cell_index(2), cell_index(3)) = j_cell + + k_cell = 0 + DO k_cell_max = 1, nimages_3c_max + IF (n_other_3c_images_max(k_cell_max) == 0) CYCLE + k_cell = k_cell + 1 + + bs_env%nblocks_3c(j_cell, k_cell) = nblocks_3c_max(j_cell_max, k_cell_max) + END DO + + END DO + + ! we use: 8*10^-9 GB / double precision number + mem_3c_GB = REAL(bs_env%n_RI, KIND=dp)*REAL(bs_env%n_ao, KIND=dp)**2 & + *REAL(nimage_pairs_3c, KIND=dp)*8E-9_dp + + CALL m_memory(mem_occ_per_proc) + CALL bs_env%para_env%max(mem_occ_per_proc) + + mem_occ_per_proc_GB = REAL(mem_occ_per_proc, KIND=dp)/1.0E9_dp + + ! number of processors per group that entirely stores the 3c integrals and does tensor ops + avail_mem_per_proc_GB = bs_env%input_memory_per_proc_GB - mem_occ_per_proc_GB + + ! careful: downconvering real to integer, 1.9 -> 1; thus add 1.0 for upconversion, 1.9 -> 2 + bs_env%group_size_tensor = MAX(INT(mem_3c_GB/avail_mem_per_proc_GB + 1.0_dp), 1) + u = bs_env%unit_nr + IF (u > 0) THEN + WRITE (u, FMT="(T2,A,F52.1,A)") "Radius of atomic orbitals", radius_ao*angstrom, " Å" + WRITE (u, FMT="(T2,A,F55.1,A)") "Radius of RI functions", radius_RI*angstrom, " Å" + WRITE (u, FMT="(T2,A,I47)") "Number of cells for 3c integrals", nimages_3c + WRITE (u, FMT="(T2,A,I42)") "Number of cell pairs for 3c integrals", nimage_pairs_3c WRITE (u, '(T2,A)') '' - WRITE (u, '(T2,A,F44.2)') 'SCF direct band gap at Γ-point (eV)', E_min*evolt - WRITE (u, '(T2,A,F42.2)') 'Max. SCF eigval diff. at Γ-point (eV)', E_max*evolt - WRITE (u, '(T2,A,F55.2)') 'E-Range for minimax grid', E_range - WRITE (u, '(T2,A,I27)') 'Number of Padé parameters for analytic continuation:', & - bs_env%nparam_pade - WRITE (u, '(T2,A)') '' + WRITE (u, '(T2,A,F37.1,A)') 'Input: Available memory per MPI process', & + bs_env%input_memory_per_proc_GB, ' GB' + WRITE (u, '(T2,A,F35.1,A)') 'Used memory per MPI process before GW run', & + mem_occ_per_proc_GB, ' GB' + WRITE (u, '(T2,A,F44.1,A)') 'Memory of three-center integrals', mem_3c_GB, ' GB' END IF + CALL timestop(handle) - END SUBROUTINE setup_time_and_frequency_minimax_grid + END SUBROUTINE setup_cells_3c + +! ************************************************************************************************** +!> \brief ... +!> \param index_to_cell_1 ... +!> \param index_to_cell_2 ... +!> \param nimages_1 ... +!> \param nimages_2 ... +!> \param index_to_cell ... +!> \param cell_to_index ... +!> \param nimages ... +! ************************************************************************************************** + SUBROUTINE sum_two_R_grids(index_to_cell_1, index_to_cell_2, nimages_1, nimages_2, & + index_to_cell, cell_to_index, nimages) + + INTEGER, DIMENSION(:, :) :: index_to_cell_1, index_to_cell_2 + INTEGER :: nimages_1, nimages_2 + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: index_to_cell + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index + INTEGER :: nimages + + CHARACTER(LEN=*), PARAMETER :: routineN = 'sum_two_R_grids' + + INTEGER :: handle, i_dim, img_1, img_2, nimages_max + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: index_to_cell_tmp + INTEGER, DIMENSION(3) :: cell_1, cell_2, R, R_max, R_min + + CALL timeset(routineN, handle) + + DO i_dim = 1, 3 + R_min(i_dim) = MINVAL(index_to_cell_1(:, i_dim)) + MINVAL(index_to_cell_2(:, i_dim)) + R_max(i_dim) = MAXVAL(index_to_cell_1(:, i_dim)) + MAXVAL(index_to_cell_2(:, i_dim)) + END DO + + nimages_max = (R_max(1) - R_min(1) + 1)*(R_max(2) - R_min(2) + 1)*(R_max(3) - R_min(3) + 1) + + ALLOCATE (index_to_cell_tmp(nimages_max, 3)) + index_to_cell_tmp(:, :) = -1 + + ALLOCATE (cell_to_index(R_min(1):R_max(1), R_min(2):R_max(2), R_min(3):R_max(3))) + cell_to_index(:, :, :) = -1 + + nimages = 0 + + DO img_1 = 1, nimages_1 + + DO img_2 = 1, nimages_2 + + cell_1(1:3) = index_to_cell_1(img_1, 1:3) + cell_2(1:3) = index_to_cell_2(img_2, 1:3) + + R(1:3) = cell_1(1:3) + cell_2(1:3) + + ! check whether we have found a new cell + IF (cell_to_index(R(1), R(2), R(3)) == -1) THEN + + nimages = nimages + 1 + cell_to_index(R(1), R(2), R(3)) = nimages + index_to_cell_tmp(nimages, 1:3) = R(1:3) + + END IF + + END DO + + END DO + + ALLOCATE (index_to_cell(nimages, 3)) + index_to_cell(:, :) = index_to_cell_tmp(1:nimages, 1:3) + + CALL timestop(handle) + + END SUBROUTINE sum_two_R_grids + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE compute_3c_integrals(qs_env, bs_env) + + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_3c_integrals' + + INTEGER :: handle, j_cell, k_cell, nimages_3c + + CALL timeset(routineN, handle) + + nimages_3c = bs_env%nimages_3c + ALLOCATE (bs_env%t_3c_int(nimages_3c, nimages_3c)) + DO j_cell = 1, nimages_3c + DO k_cell = 1, nimages_3c + CALL dbt_create(bs_env%t_RI_AO__AO, bs_env%t_3c_int(j_cell, k_cell)) + END DO + END DO + + CALL build_3c_integrals(bs_env%t_3c_int, & + bs_env%eps_filter, & + qs_env, & + bs_env%nl_3c, & + int_eps=bs_env%eps_filter*0.05_dp, & + basis_i=bs_env%basis_set_RI, & + basis_j=bs_env%basis_set_AO, & + basis_k=bs_env%basis_set_AO, & + potential_parameter=bs_env%ri_metric, & + desymmetrize=.FALSE., do_kpoints=.TRUE., cell_sym=.TRUE., & + cell_to_index_ext=bs_env%cell_to_index_3c) + + CALL bs_env%para_env%sync() + + CALL timestop(handle) + + END SUBROUTINE compute_3c_integrals + +! ************************************************************************************************** +!> \brief ... +!> \param cell_index ... +!> \param hmat ... +!> \param cell_dist ... +! ************************************************************************************************** + SUBROUTINE get_cell_dist(cell_index, hmat, cell_dist) + + INTEGER, DIMENSION(3) :: cell_index + REAL(KIND=dp) :: hmat(3, 3), cell_dist + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_cell_dist' + + INTEGER :: handle, i_dim + INTEGER, DIMENSION(3) :: cell_index_adj + REAL(KIND=dp) :: cell_dist_3(3) + + CALL timeset(routineN, handle) + + ! the distance of cells needs to be taken to adjacent neighbors, not + ! between the center of the cells. We thus need to rescale the cell index + DO i_dim = 1, 3 + IF (cell_index(i_dim) > 0) cell_index_adj(i_dim) = cell_index(i_dim) - 1 + IF (cell_index(i_dim) < 0) cell_index_adj(i_dim) = cell_index(i_dim) + 1 + IF (cell_index(i_dim) == 0) cell_index_adj(i_dim) = cell_index(i_dim) + END DO + + cell_dist_3(1:3) = MATMUL(hmat, REAL(cell_index_adj, KIND=dp)) + + cell_dist = SQRT(ABS(SUM(cell_dist_3(1:3)**2))) + + CALL timestop(handle) + + END SUBROUTINE get_cell_dist + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +!> \param kpoints ... +!> \param do_print ... +! ************************************************************************************************** + SUBROUTINE setup_kpoints_scf_desymm(qs_env, bs_env, kpoints, do_print) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(kpoint_type), POINTER :: kpoints + + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_scf_desymm' + + INTEGER :: handle, i_cell_x, i_dim, img, j_cell_y, & + k_cell_z, nimages, nkp, u + INTEGER, DIMENSION(3) :: cell_grid, cixd, nkp_grid + TYPE(kpoint_type), POINTER :: kpoints_scf + + LOGICAL:: do_print + + CALL timeset(routineN, handle) + + NULLIFY (kpoints) + CALL kpoint_create(kpoints) + + CALL get_qs_env(qs_env=qs_env, kpoints=kpoints_scf) + + nkp_grid(1:3) = kpoints_scf%nkp_grid(1:3) + nkp = nkp_grid(1)*nkp_grid(2)*nkp_grid(3) + + ! we need in periodic directions at least 2 k-points in the SCF + DO i_dim = 1, 3 + IF (bs_env%periodic(i_dim) == 1) THEN + CPASSERT(nkp_grid(i_dim) > 1) + END IF + END DO + + kpoints%kp_scheme = "GENERAL" + kpoints%nkp_grid(1:3) = nkp_grid(1:3) + kpoints%nkp = nkp + bs_env%nkp_scf_desymm = nkp + + ALLOCATE (kpoints%xkp(1:3, nkp)) + CALL compute_xkp(kpoints%xkp, 1, nkp, nkp_grid) + + ALLOCATE (kpoints%wkp(nkp)) + kpoints%wkp(:) = 1.0_dp/REAL(nkp, KIND=dp) + + ! for example 4x3x6 kpoint grid -> 3x3x5 cell grid because we need the same number of + ! neighbor cells on both sides of the unit cell + cell_grid(1:3) = nkp_grid(1:3) - MODULO(nkp_grid(1:3) + 1, 2) + ! cell index: for example for x: from -n_x/2 to +n_x/2, n_x: number of cells in x direction + cixd(1:3) = cell_grid(1:3)/2 + + nimages = cell_grid(1)*cell_grid(2)*cell_grid(3) + + bs_env%nimages_scf_desymm = nimages + + ALLOCATE (kpoints%cell_to_index(-cixd(1):cixd(1), -cixd(2):cixd(2), -cixd(3):cixd(3))) + ALLOCATE (kpoints%index_to_cell(nimages, 3)) + + img = 0 + DO i_cell_x = -cixd(1), cixd(1) + DO j_cell_y = -cixd(2), cixd(2) + DO k_cell_z = -cixd(3), cixd(3) + img = img + 1 + kpoints%cell_to_index(i_cell_x, j_cell_y, k_cell_z) = img + kpoints%index_to_cell(img, 1:3) = (/i_cell_x, j_cell_y, k_cell_z/) + END DO + END DO + END DO + + u = bs_env%unit_nr + IF (u > 0 .AND. do_print) THEN + WRITE (u, FMT="(T2,A,I49)") "Number of cells for G, χ, W, Σ", nimages + END IF + + CALL timestop(handle) + + END SUBROUTINE setup_kpoints_scf_desymm + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE setup_cells_Delta_R(bs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_cells_Delta_R' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + ! cell sums batch wise for fixed ΔR = S_1 - R_1; for example: + ! Σ_λσ^R = sum_PR1νS1 M^G_λ0,νS1,PR1 M^W_σR,νS1,PR1 + + CALL sum_two_R_grids(bs_env%index_to_cell_3c, & + bs_env%index_to_cell_3c, & + bs_env%nimages_3c, bs_env%nimages_3c, & + bs_env%index_to_cell_Delta_R, & + bs_env%cell_to_index_Delta_R, & + bs_env%nimages_Delta_R) + + IF (bs_env%unit_nr > 0) THEN + WRITE (bs_env%unit_nr, FMT="(T2,A,I61)") "Number of cells ΔR", bs_env%nimages_Delta_R + END IF + + CALL timestop(handle) + + END SUBROUTINE setup_cells_Delta_R + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE setup_parallelization_Delta_R(bs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_parallelization_Delta_R' + + INTEGER :: handle, i_cell_Delta_R, i_task_local, & + n_tasks_local + INTEGER, ALLOCATABLE, DIMENSION(:) :: i_cell_Delta_R_group, & + n_tensor_ops_Delta_R + + CALL timeset(routineN, handle) + + CALL compute_n_tensor_ops_Delta_R(bs_env, n_tensor_ops_Delta_R) + + CALL compute_Delta_R_dist(bs_env, n_tensor_ops_Delta_R, i_cell_Delta_R_group, n_tasks_local) + + bs_env%n_tasks_Delta_R_local = n_tasks_local + + ALLOCATE (bs_env%task_Delta_R(n_tasks_local)) + + i_task_local = 0 + DO i_cell_Delta_R = 1, bs_env%nimages_Delta_R + + IF (i_cell_Delta_R_group(i_cell_Delta_R) /= bs_env%tensor_group_color) CYCLE + + i_task_local = i_task_local + 1 + + bs_env%task_Delta_R(i_task_local) = i_cell_Delta_R + + END DO + + CALL timestop(handle) + + END SUBROUTINE setup_parallelization_Delta_R + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param n_tensor_ops_Delta_R ... +!> \param i_cell_Delta_R_group ... +!> \param n_tasks_local ... +! ************************************************************************************************** + SUBROUTINE compute_Delta_R_dist(bs_env, n_tensor_ops_Delta_R, i_cell_Delta_R_group, n_tasks_local) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_tensor_ops_Delta_R, & + i_cell_Delta_R_group + INTEGER :: n_tasks_local + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Delta_R_dist' + + INTEGER :: handle, i_Delta_R_max_op, i_group_min, & + nimages_Delta_R, u + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_tensor_ops_Delta_R_in_group + + CALL timeset(routineN, handle) + + nimages_Delta_R = bs_env%nimages_Delta_R + + u = bs_env%unit_nr + + IF (u > 0 .AND. nimages_Delta_R < bs_env%num_tensor_groups) THEN + WRITE (u, FMT="(T2,A,I5,A,I5,A)") "There are only ", nimages_Delta_R, & + " tasks to work on but there are ", bs_env%num_tensor_groups, " groups." + WRITE (u, FMT="(T2,A)") "Please reduce the number of MPI processes." + WRITE (u, '(T2,A)') '' + END IF + + ALLOCATE (n_tensor_ops_Delta_R_in_group(bs_env%num_tensor_groups)) + n_tensor_ops_Delta_R_in_group(:) = 0 + ALLOCATE (i_cell_Delta_R_group(nimages_Delta_R)) + i_cell_Delta_R_group(:) = -1 + + n_tasks_local = 0 + + DO WHILE (ANY(n_tensor_ops_Delta_R(:) .NE. 0)) + + ! get largest element of n_tensor_ops_Delta_R + i_Delta_R_max_op = MAXLOC(n_tensor_ops_Delta_R, 1) + + ! distribute i_Delta_R_max_op to tensor group which has currently the smallest load + i_group_min = MINLOC(n_tensor_ops_Delta_R_in_group, 1) + + ! the tensor groups are 0-index based; but i_group_min is 1-index based + i_cell_Delta_R_group(i_Delta_R_max_op) = i_group_min - 1 + n_tensor_ops_Delta_R_in_group(i_group_min) = n_tensor_ops_Delta_R_in_group(i_group_min) + & + n_tensor_ops_Delta_R(i_Delta_R_max_op) + + ! remove i_Delta_R_max_op from n_tensor_ops_Delta_R + n_tensor_ops_Delta_R(i_Delta_R_max_op) = 0 + + IF (bs_env%tensor_group_color == i_group_min - 1) n_tasks_local = n_tasks_local + 1 + + END DO + + CALL timestop(handle) + + END SUBROUTINE compute_Delta_R_dist + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param n_tensor_ops_Delta_R ... +! ************************************************************************************************** + SUBROUTINE compute_n_tensor_ops_Delta_R(bs_env, n_tensor_ops_Delta_R) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + INTEGER, ALLOCATABLE, DIMENSION(:) :: n_tensor_ops_Delta_R + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_n_tensor_ops_Delta_R' + + INTEGER :: handle, i_cell_Delta_R, i_cell_R, i_cell_R1, i_cell_R1_minus_R, i_cell_R2, & + i_cell_R2_m_R1, i_cell_S1, i_cell_S1_m_R1_p_R2, i_cell_S1_minus_R, i_cell_S2, & + nimages_Delta_R + INTEGER, DIMENSION(3) :: cell_DR, cell_m_R1, cell_R, cell_R1, cell_R1_minus_R, cell_R2, & + cell_R2_m_R1, cell_S1, cell_S1_m_R2_p_R1, cell_S1_minus_R, cell_S1_p_S2_m_R1, cell_S2 + LOGICAL :: cell_found + + CALL timeset(routineN, handle) + + nimages_Delta_R = bs_env%nimages_Delta_R + + ALLOCATE (n_tensor_ops_Delta_R(nimages_Delta_R)) + n_tensor_ops_Delta_R(:) = 0 + + ! compute number of tensor operations for specific Delta_R + DO i_cell_Delta_R = 1, nimages_Delta_R + + IF (MODULO(i_cell_Delta_R, bs_env%num_tensor_groups) /= bs_env%tensor_group_color) CYCLE + + DO i_cell_R1 = 1, bs_env%nimages_3c + + cell_R1(1:3) = bs_env%index_to_cell_3c(i_cell_R1, 1:3) + cell_DR(1:3) = bs_env%index_to_cell_Delta_R(i_cell_Delta_R, 1:3) + + ! S_1 = R_1 + ΔR (from ΔR = S_1 - R_1) + CALL add_R(cell_R1, cell_DR, bs_env%index_to_cell_3c, cell_S1, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1) + IF (.NOT. cell_found) CYCLE + + DO i_cell_R2 = 1, bs_env%nimages_scf_desymm + + cell_R2(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_R2, 1:3) + + ! R_2 - R_1 + CALL add_R(cell_R2, -cell_R1, bs_env%index_to_cell_3c, cell_R2_m_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_R2_m_R1) + IF (.NOT. cell_found) CYCLE + + ! S_1 - R_1 + R_2 + CALL add_R(cell_S1, cell_R2_m_R1, bs_env%index_to_cell_3c, cell_S1_m_R2_p_R1, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1_m_R1_p_R2) + IF (.NOT. cell_found) CYCLE + + n_tensor_ops_Delta_R(i_cell_Delta_R) = n_tensor_ops_Delta_R(i_cell_Delta_R) + 1 + + END DO ! i_cell_R2 + + DO i_cell_S2 = 1, bs_env%nimages_scf_desymm + + cell_S2(1:3) = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_S2, 1:3) + cell_m_R1(1:3) = -cell_R1(1:3) + cell_S1_p_S2_m_R1(1:3) = cell_S1(1:3) + cell_S2(1:3) - cell_R1(1:3) + + CALL is_cell_in_index_to_cell(cell_m_R1, bs_env%index_to_cell_3c, cell_found) + IF (.NOT. cell_found) CYCLE + + CALL is_cell_in_index_to_cell(cell_S1_p_S2_m_R1, bs_env%index_to_cell_3c, cell_found) + IF (.NOT. cell_found) CYCLE + + END DO ! i_cell_S2 + + DO i_cell_R = 1, bs_env%nimages_scf_desymm + + cell_R = bs_env%kpoints_scf_desymm%index_to_cell(i_cell_R, 1:3) + + ! R_1 - R + CALL add_R(cell_R1, -cell_R, bs_env%index_to_cell_3c, cell_R1_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_R1_minus_R) + IF (.NOT. cell_found) CYCLE + + ! S_1 - R + CALL add_R(cell_S1, -cell_R, bs_env%index_to_cell_3c, cell_S1_minus_R, & + cell_found, bs_env%cell_to_index_3c, i_cell_S1_minus_R) + IF (.NOT. cell_found) CYCLE + + END DO ! i_cell_R + + END DO ! i_cell_R1 + + END DO ! i_cell_Delta_R + + CALL bs_env%para_env%sum(n_tensor_ops_Delta_R) + + CALL timestop(handle) + + END SUBROUTINE compute_n_tensor_ops_Delta_R + +! ************************************************************************************************** +!> \brief ... +!> \param cell_1 ... +!> \param cell_2 ... +!> \param index_to_cell ... +!> \param cell_1_plus_2 ... +!> \param cell_found ... +!> \param cell_to_index ... +!> \param i_cell_1_plus_2 ... +! ************************************************************************************************** + SUBROUTINE add_R(cell_1, cell_2, index_to_cell, cell_1_plus_2, cell_found, & + cell_to_index, i_cell_1_plus_2) + + INTEGER, DIMENSION(3) :: cell_1, cell_2 + INTEGER, DIMENSION(:, :) :: index_to_cell + INTEGER, DIMENSION(3) :: cell_1_plus_2 + LOGICAL :: cell_found + INTEGER, DIMENSION(:, :, :), INTENT(IN), & + OPTIONAL, POINTER :: cell_to_index + INTEGER, INTENT(OUT), OPTIONAL :: i_cell_1_plus_2 + + CHARACTER(LEN=*), PARAMETER :: routineN = 'add_R' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + cell_1_plus_2(1:3) = cell_1(1:3) + cell_2(1:3) + + CALL is_cell_in_index_to_cell(cell_1_plus_2, index_to_cell, cell_found) + + IF (PRESENT(i_cell_1_plus_2)) THEN + IF (cell_found) THEN + CPASSERT(PRESENT(cell_to_index)) + i_cell_1_plus_2 = cell_to_index(cell_1_plus_2(1), cell_1_plus_2(2), cell_1_plus_2(3)) + ELSE + i_cell_1_plus_2 = -1000 + END IF + END IF + + CALL timestop(handle) + + END SUBROUTINE add_R + +! ************************************************************************************************** +!> \brief ... +!> \param cell ... +!> \param index_to_cell ... +!> \param cell_found ... +! ************************************************************************************************** + SUBROUTINE is_cell_in_index_to_cell(cell, index_to_cell, cell_found) + INTEGER, DIMENSION(3) :: cell + INTEGER, DIMENSION(:, :) :: index_to_cell + LOGICAL :: cell_found + + CHARACTER(LEN=*), PARAMETER :: routineN = 'is_cell_in_index_to_cell' + + INTEGER :: handle, i_cell, nimg + INTEGER, DIMENSION(3) :: cell_i + + CALL timeset(routineN, handle) + + nimg = SIZE(index_to_cell, 1) + + cell_found = .FALSE. + + DO i_cell = 1, nimg + + cell_i(1:3) = index_to_cell(i_cell, 1:3) + + IF (cell_i(1) == cell(1) .AND. cell_i(2) == cell(2) .AND. cell_i(3) == cell(3)) THEN + cell_found = .TRUE. + END IF + + END DO + + CALL timestop(handle) + + END SUBROUTINE is_cell_in_index_to_cell + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE compute_cfm_mo_coeff_kp_and_eigenval_scf_kp(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_cfm_mo_coeff_kp_and_eigenval_scf_kp' + + INTEGER :: handle, ikp, ispin, nkp_bs_and_DOS, re_im + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index_scf + REAL(KIND=dp) :: CBM, VBM + REAL(KIND=dp), DIMENSION(3) :: xkp + TYPE(cp_cfm_type) :: cfm_ks, cfm_mos, cfm_s + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks, matrix_s + TYPE(kpoint_type), POINTER :: kpoints_scf + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: sab_nl + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env, & + matrix_ks_kp=matrix_ks, & + matrix_s_kp=matrix_s, & + kpoints=kpoints_scf) + + NULLIFY (sab_nl) + CALL get_kpoint_info(kpoints_scf, sab_nl=sab_nl, cell_to_index=cell_to_index_scf) + + CALL cp_cfm_create(cfm_ks, bs_env%cfm_work_mo%matrix_struct) + CALL cp_cfm_create(cfm_s, bs_env%cfm_work_mo%matrix_struct) + CALL cp_cfm_create(cfm_mos, bs_env%cfm_work_mo%matrix_struct) + + ! nkp_bs_and_DOS contains desymmetrized k-point mesh from SCF and k-points from GW bandstructure + nkp_bs_and_DOS = bs_env%nkp_bs_and_DOS + + ALLOCATE (bs_env%eigenval_G0W0(bs_env%n_ao, nkp_bs_and_DOS, bs_env%n_spin)) + ALLOCATE (bs_env%eigenval_HF(bs_env%n_ao, nkp_bs_and_DOS, bs_env%n_spin)) + ALLOCATE (bs_env%fm_mo_coeff_kp(nkp_bs_and_DOS, bs_env%n_spin, 2)) + ALLOCATE (bs_env%fm_ks_kp(nkp_bs_and_DOS, bs_env%n_spin, 2)) + ALLOCATE (bs_env%fm_s_kp(nkp_bs_and_DOS, bs_env%n_spin, 2)) + DO ikp = 1, nkp_bs_and_DOS + DO ispin = 1, bs_env%n_spin + DO re_im = 1, 2 + CALL cp_fm_create(bs_env%fm_mo_coeff_kp(ikp, ispin, re_im), & + bs_env%cfm_work_mo%matrix_struct) + CALL cp_fm_create(bs_env%fm_ks_kp(ikp, ispin, re_im), & + bs_env%cfm_work_mo%matrix_struct) + CALL cp_fm_create(bs_env%fm_s_kp(ikp, ispin, re_im), & + bs_env%cfm_work_mo%matrix_struct) + END DO + END DO + END DO + + DO ispin = 1, bs_env%n_spin + DO ikp = 1, nkp_bs_and_DOS + + xkp(1:3) = bs_env%kpoints_DOS%xkp(1:3, ikp) + + ! h^KS^R -> h^KS(k) + CALL rsmat_to_kp(matrix_ks, ispin, xkp, cell_to_index_scf, sab_nl, bs_env, cfm_ks) + + ! S^R -> S(k) + CALL rsmat_to_kp(matrix_s, 1, xkp, cell_to_index_scf, sab_nl, bs_env, cfm_s) + + ! JW comment: one might remove h^KS(k) again later + ! we store the complex KS matrix as fm matrix because the infrastructure for fm is + ! much nicer compared to cfm + CALL cp_cfm_to_fm(cfm_ks, & + bs_env%fm_ks_kp(ikp, ispin, 1), & + bs_env%fm_ks_kp(ikp, ispin, 2)) + CALL cp_cfm_to_fm(cfm_s, & + bs_env%fm_s_kp(ikp, ispin, 1), & + bs_env%fm_s_kp(ikp, ispin, 2)) + + ! Diagonalize KS-matrix via Rothaan-Hall equation: + ! H^KS(k) C(k) = S(k) C(k) ε(k) + CALL cp_cfm_geeig_canon(cfm_ks, cfm_s, cfm_mos, & + bs_env%eigenval_scf(:, ikp, ispin), & + bs_env%cfm_work_mo, bs_env%eps_eigval_mat_s) + + ! we store the complex MO coeff as fm matrix because the infrastructure for fm is + ! much nicer compared to cfm + CALL cp_cfm_to_fm(cfm_mos, & + bs_env%fm_mo_coeff_kp(ikp, ispin, 1), & + bs_env%fm_mo_coeff_kp(ikp, ispin, 2)) + + END DO + + VBM = MAXVAL(bs_env%eigenval_scf(bs_env%n_occ(ispin), :, ispin)) + CBM = MINVAL(bs_env%eigenval_scf(bs_env%n_occ(ispin) + 1, :, ispin)) + + bs_env%e_fermi(ispin) = 0.5_dp*(VBM + CBM) + + END DO + + CALL cp_cfm_release(cfm_ks) + CALL cp_cfm_release(cfm_s) + CALL cp_cfm_release(cfm_mos) + + CALL timestop(handle) + + END SUBROUTINE compute_cfm_mo_coeff_kp_and_eigenval_scf_kp + +! ************************************************************************************************** +!> \brief ... +!> \param matrix_ks ... +!> \param ispin ... +!> \param xkp ... +!> \param cell_to_index_scf ... +!> \param sab_nl ... +!> \param bs_env ... +!> \param cfm_ks ... +! ************************************************************************************************** + SUBROUTINE rsmat_to_kp(matrix_ks, ispin, xkp, cell_to_index_scf, sab_nl, bs_env, cfm_ks) + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks + INTEGER :: ispin + REAL(KIND=dp), DIMENSION(3) :: xkp + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index_scf + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: sab_nl + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(cp_cfm_type) :: cfm_ks + + CHARACTER(LEN=*), PARAMETER :: routineN = 'rsmat_to_kp' + + INTEGER :: handle + TYPE(dbcsr_type), POINTER :: cmat, nsmat, rmat + + CALL timeset(routineN, handle) + + ALLOCATE (rmat, cmat, nsmat) + CALL dbcsr_create(rmat, template=matrix_ks(1, 1)%matrix, matrix_type=dbcsr_type_symmetric) + CALL dbcsr_create(cmat, template=matrix_ks(1, 1)%matrix, matrix_type=dbcsr_type_antisymmetric) + CALL dbcsr_create(nsmat, template=matrix_ks(1, 1)%matrix, matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_alloc_block_from_nbl(rmat, sab_nl) + CALL cp_dbcsr_alloc_block_from_nbl(cmat, sab_nl) + + CALL dbcsr_set(rmat, 0.0_dp) + CALL dbcsr_set(cmat, 0.0_dp) + CALL rskp_transform(rmatrix=rmat, cmatrix=cmat, rsmat=matrix_ks, ispin=ispin, & + xkp=xkp, cell_to_index=cell_to_index_scf, sab_nl=sab_nl) + CALL dbcsr_desymmetrize(rmat, nsmat) + CALL copy_dbcsr_to_fm(nsmat, bs_env%fm_work_mo(1)) + CALL dbcsr_desymmetrize(cmat, nsmat) + CALL copy_dbcsr_to_fm(nsmat, bs_env%fm_work_mo(2)) + CALL cp_fm_to_cfm(bs_env%fm_work_mo(1), bs_env%fm_work_mo(2), cfm_ks) + + CALL dbcsr_deallocate_matrix(rmat) + CALL dbcsr_deallocate_matrix(cmat) + CALL dbcsr_deallocate_matrix(nsmat) + + CALL timestop(handle) + + END SUBROUTINE rsmat_to_kp + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE allocate_matrices_small_cell_full_kp(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_matrices_small_cell_full_kp' + + INTEGER :: handle, i_spin, i_t, img, n_spin, & + nimages_scf, num_time_freq_points + TYPE(cp_blacs_env_type), POINTER :: blacs_env + TYPE(mp_para_env_type), POINTER :: para_env + + CALL timeset(routineN, handle) + + nimages_scf = bs_env%nimages_scf_desymm + num_time_freq_points = bs_env%num_time_freq_points + n_spin = bs_env%n_spin + + CALL get_qs_env(qs_env, para_env=para_env, blacs_env=blacs_env) + + ALLOCATE (bs_env%fm_G_S(nimages_scf)) + ALLOCATE (bs_env%fm_Sigma_x_R(nimages_scf)) + ALLOCATE (bs_env%fm_chi_R_t(nimages_scf, num_time_freq_points)) + ALLOCATE (bs_env%fm_MWM_R_t(nimages_scf, num_time_freq_points)) + ALLOCATE (bs_env%fm_Sigma_c_R_neg_tau(nimages_scf, num_time_freq_points, n_spin)) + ALLOCATE (bs_env%fm_Sigma_c_R_pos_tau(nimages_scf, num_time_freq_points, n_spin)) + DO img = 1, nimages_scf + CALL cp_fm_create(bs_env%fm_G_S(img), bs_env%fm_work_mo(1)%matrix_struct) + CALL cp_fm_create(bs_env%fm_Sigma_x_R(img), bs_env%fm_work_mo(1)%matrix_struct) + DO i_t = 1, num_time_freq_points + CALL cp_fm_create(bs_env%fm_chi_R_t(img, i_t), bs_env%fm_RI_RI%matrix_struct) + CALL cp_fm_create(bs_env%fm_MWM_R_t(img, i_t), bs_env%fm_RI_RI%matrix_struct) + CALL cp_fm_set_all(bs_env%fm_MWM_R_t(img, i_t), 0.0_dp) + DO i_spin = 1, n_spin + CALL cp_fm_create(bs_env%fm_Sigma_c_R_neg_tau(img, i_t, i_spin), & + bs_env%fm_work_mo(1)%matrix_struct) + CALL cp_fm_create(bs_env%fm_Sigma_c_R_pos_tau(img, i_t, i_spin), & + bs_env%fm_work_mo(1)%matrix_struct) + CALL cp_fm_set_all(bs_env%fm_Sigma_c_R_neg_tau(img, i_t, i_spin), 0.0_dp) + CALL cp_fm_set_all(bs_env%fm_Sigma_c_R_pos_tau(img, i_t, i_spin), 0.0_dp) + END DO + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE allocate_matrices_small_cell_full_kp + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE trafo_V_xc_R_to_kp(qs_env, bs_env) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'trafo_V_xc_R_to_kp' + + INTEGER :: handle, ikp, img, ispin, n_ao + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index_scf + TYPE(cp_cfm_type) :: cfm_mo_coeff, cfm_tmp, cfm_V_xc + TYPE(cp_fm_type) :: fm_V_xc_re + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks + TYPE(kpoint_type), POINTER :: kpoints_scf + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: sab_nl + + CALL timeset(routineN, handle) + + n_ao = bs_env%n_ao + + CALL get_qs_env(qs_env, matrix_ks_kp=matrix_ks, kpoints=kpoints_scf) + + NULLIFY (sab_nl) + CALL get_kpoint_info(kpoints_scf, sab_nl=sab_nl, cell_to_index=cell_to_index_scf) + + CALL cp_cfm_create(cfm_V_xc, bs_env%cfm_work_mo%matrix_struct) + CALL cp_cfm_create(cfm_mo_coeff, bs_env%cfm_work_mo%matrix_struct) + CALL cp_cfm_create(cfm_tmp, bs_env%cfm_work_mo%matrix_struct) + CALL cp_fm_create(fm_V_xc_re, bs_env%cfm_work_mo%matrix_struct) + + DO img = 1, bs_env%nimages_scf + DO ispin = 1, bs_env%n_spin + ! JW kind of hack because the format of matrix_ks remains dubious... + CALL dbcsr_set(matrix_ks(ispin, img)%matrix, 0.0_dp) + CALL copy_fm_to_dbcsr(bs_env%fm_V_xc_R(img, ispin), matrix_ks(ispin, img)%matrix) + END DO + END DO + + ALLOCATE (bs_env%v_xc_n(n_ao, bs_env%nkp_bs_and_DOS, bs_env%n_spin)) + + DO ispin = 1, bs_env%n_spin + DO ikp = 1, bs_env%nkp_bs_and_DOS + + ! v^xc^R -> v^xc(k) (matrix_ks stores v^xc^R, see SUBROUTINE compute_V_xc) + CALL rsmat_to_kp(matrix_ks, ispin, bs_env%kpoints_DOS%xkp(1:3, ikp), & + cell_to_index_scf, sab_nl, bs_env, cfm_V_xc) + + ! get C_µn(k) + CALL cp_fm_to_cfm(bs_env%fm_mo_coeff_kp(ikp, ispin, 1), & + bs_env%fm_mo_coeff_kp(ikp, ispin, 2), cfm_mo_coeff) + + ! v^xc_nm(k_i) = sum_µν C^*_µn(k_i) v^xc_µν(k_i) C_νn(k_i) + CALL parallel_gemm('N', 'N', n_ao, n_ao, n_ao, z_one, cfm_V_xc, cfm_mo_coeff, & + z_zero, cfm_tmp) + CALL parallel_gemm('C', 'N', n_ao, n_ao, n_ao, z_one, cfm_mo_coeff, cfm_tmp, & + z_zero, cfm_V_xc) + + ! get v^xc_nn(k_i) which is a real quantity as v^xc is Hermitian + CALL cp_cfm_to_fm(cfm_V_xc, fm_V_xc_re) + CALL cp_fm_get_diag(fm_V_xc_re, bs_env%v_xc_n(:, ikp, ispin)) + + END DO + + END DO + + ! just rebuild the overwritten KS matrix again + CALL qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces=.FALSE., just_energy=.FALSE.) + + CALL cp_cfm_release(cfm_V_xc) + CALL cp_cfm_release(cfm_mo_coeff) + CALL cp_cfm_release(cfm_tmp) + CALL cp_fm_release(fm_V_xc_re) + + CALL timestop(handle) + + END SUBROUTINE trafo_V_xc_R_to_kp + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param Sigma_c_n_time ... +!> \param Sigma_c_n_freq ... +!> \param ispin ... +! ************************************************************************************************** + SUBROUTINE time_to_freq(bs_env, Sigma_c_n_time, Sigma_c_n_freq, ispin) + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp), DIMENSION(:, :, :) :: Sigma_c_n_time, Sigma_c_n_freq + INTEGER :: ispin + + CHARACTER(LEN=*), PARAMETER :: routineN = 'time_to_freq' + + INTEGER :: handle, i_t, j_w, n_occ + REAL(KIND=dp) :: freq_j, time_i, w_cos_ij, w_sin_ij + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Sigma_c_n_cos_time, Sigma_c_n_sin_time + + CALL timeset(routineN, handle) + + ALLOCATE (Sigma_c_n_cos_time(bs_env%n_ao, bs_env%num_time_freq_points)) + ALLOCATE (Sigma_c_n_sin_time(bs_env%n_ao, bs_env%num_time_freq_points)) + + Sigma_c_n_cos_time(:, :) = 0.5_dp*(Sigma_c_n_time(:, :, 1) + Sigma_c_n_time(:, :, 2)) + Sigma_c_n_sin_time(:, :) = 0.5_dp*(Sigma_c_n_time(:, :, 1) - Sigma_c_n_time(:, :, 2)) + + Sigma_c_n_freq(:, :, :) = 0.0_dp + + DO i_t = 1, bs_env%num_time_freq_points + + DO j_w = 1, bs_env%num_time_freq_points + + freq_j = bs_env%imag_freq_points(j_w) + time_i = bs_env%imag_time_points(i_t) + ! integration weights for cosine and sine transform + w_cos_ij = bs_env%weights_cos_t_to_w(j_w, i_t)*COS(freq_j*time_i) + w_sin_ij = bs_env%weights_sin_t_to_w(j_w, i_t)*SIN(freq_j*time_i) + + ! 1. Re(Σ^c_nn(k_i,iω)) from cosine transform + Sigma_c_n_freq(:, j_w, 1) = Sigma_c_n_freq(:, j_w, 1) + & + w_cos_ij*Sigma_c_n_cos_time(:, i_t) + + ! 2. Im(Σ^c_nn(k_i,iω)) from sine transform + Sigma_c_n_freq(:, j_w, 2) = Sigma_c_n_freq(:, j_w, 2) + & + w_sin_ij*Sigma_c_n_sin_time(:, i_t) + + END DO + + END DO + + ! for occupied levels, we need the correlation self-energy for negative omega. + ! Therefore, weight_sin should be computed with -omega, which results in an + ! additional minus for the imaginary part: + n_occ = bs_env%n_occ(ispin) + Sigma_c_n_freq(1:n_occ, :, 2) = -Sigma_c_n_freq(1:n_occ, :, 2) + + CALL timestop(handle) + + END SUBROUTINE time_to_freq + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param Sigma_c_ikp_n_freq ... +!> \param Sigma_x_ikp_n ... +!> \param V_xc_ikp_n ... +!> \param eigenval_scf ... +!> \param ikp ... +!> \param ispin ... +! ************************************************************************************************** + SUBROUTINE analyt_conti_and_print(bs_env, Sigma_c_ikp_n_freq, Sigma_x_ikp_n, V_xc_ikp_n, & + eigenval_scf, ikp, ispin) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + REAL(KIND=dp), DIMENSION(:, :, :) :: Sigma_c_ikp_n_freq + REAL(KIND=dp), DIMENSION(:) :: Sigma_x_ikp_n, V_xc_ikp_n, eigenval_scf + INTEGER :: ikp, ispin + + CHARACTER(LEN=*), PARAMETER :: routineN = 'analyt_conti_and_print' + + CHARACTER(len=3) :: occ_vir + CHARACTER(len=default_string_length) :: fname + INTEGER :: handle, i_mo, ikp_for_filename, iunit, & + n_mo, nkp + LOGICAL :: is_bandstruc_kpoint, print_DOS_kpoints, & + print_ikp + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dummy, Sigma_c_ikp_n_qp + + CALL timeset(routineN, handle) + + n_mo = bs_env%n_ao + ALLOCATE (dummy(n_mo), Sigma_c_ikp_n_qp(n_mo)) + Sigma_c_ikp_n_qp(:) = 0.0_dp + + DO i_mo = 1, n_mo + + ! parallelization + IF (MODULO(i_mo, bs_env%para_env%num_pe) /= bs_env%para_env%mepos) CYCLE + + CALL continuation_pade(Sigma_c_ikp_n_qp, & + bs_env%imag_freq_points_fit, dummy, dummy, & + Sigma_c_ikp_n_freq(:, 1:bs_env%num_freq_points_fit, 1)*z_one + & + Sigma_c_ikp_n_freq(:, 1:bs_env%num_freq_points_fit, 2)*gaussi, & + Sigma_x_ikp_n(:) - V_xc_ikp_n(:), & + eigenval_scf(:), & + eigenval_scf(:), & + i_mo, bs_env%n_occ(ispin), bs_env%nparam_pade, & + bs_env%num_freq_points_fit, & + ri_rpa_g0w0_crossing_newton, bs_env%n_occ(ispin), & + 0.0_dp, .TRUE., .FALSE., 1, e_fermi_ext=bs_env%e_fermi(ispin)) + END DO + + CALL bs_env%para_env%sum(Sigma_c_ikp_n_qp) + + CALL correct_obvious_fitting_fails(Sigma_c_ikp_n_qp, ispin, bs_env) + + bs_env%eigenval_G0W0(:, ikp, ispin) = eigenval_scf(:) + & + Sigma_c_ikp_n_qp(:) + & + Sigma_x_ikp_n(:) - & + V_xc_ikp_n(:) + + bs_env%eigenval_HF(:, ikp, ispin) = eigenval_scf(:) + Sigma_x_ikp_n(:) - V_xc_ikp_n(:) + + ! only print eigenvalues of DOS k-points in case no bandstructure path has been given + print_DOS_kpoints = (bs_env%nkp_only_bs .LE. 0) + ! in kpoints_DOS, the last nkp_only_bs are bandstructure k-points + is_bandstruc_kpoint = (ikp > bs_env%nkp_only_DOS) + print_ikp = print_DOS_kpoints .OR. is_bandstruc_kpoint + + IF (bs_env%para_env%is_source() .AND. print_ikp) THEN + + IF (print_DOS_kpoints) THEN + nkp = bs_env%nkp_only_DOS + ikp_for_filename = ikp + ELSE + nkp = bs_env%nkp_only_bs + ikp_for_filename = ikp - bs_env%nkp_only_DOS + END IF + + CALL get_fname(fname, bs_env, ikp_for_filename, nkp, "SCF_and_G0W0", ispin=ispin) + + CALL open_file(TRIM(fname), unit_number=iunit, file_status="REPLACE", file_action="WRITE") + + WRITE (iunit, "(A)") " " + + WRITE (iunit, "(A10,3F10.4)") "kpoint: ", bs_env%kpoints_DOS%xkp(:, ikp) + WRITE (iunit, "(A)") " " + WRITE (iunit, "(A5,A24,2A17,A16,A18)") "n", "ϵ_nk^DFT (eV)", "Σ^c_nk (eV)", & + "Σ^x_nk (eV)", "v_nk^xc (eV)", "ϵ_nk^G0W0 (eV)" + WRITE (iunit, "(A)") " " + + DO i_mo = 1, n_mo + IF (i_mo .LE. bs_env%n_occ(ispin)) occ_vir = 'occ' + IF (i_mo > bs_env%n_occ(ispin)) occ_vir = 'vir' + WRITE (iunit, "(I5,3A,4F16.3,F17.3)") i_mo, ' (', occ_vir, ') ', & + eigenval_scf(i_mo)*evolt, & + Sigma_c_ikp_n_qp(i_mo)*evolt, & + Sigma_x_ikp_n(i_mo)*evolt, & + V_xc_ikp_n(i_mo)*evolt, & + bs_env%eigenval_G0W0(i_mo, ikp, ispin)*evolt + END DO + + CALL close_file(iunit) + + END IF + + CALL timestop(handle) + + END SUBROUTINE analyt_conti_and_print + +! ************************************************************************************************** +!> \brief ... +!> \param Sigma_c_ikp_n_qp ... +!> \param ispin ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE correct_obvious_fitting_fails(Sigma_c_ikp_n_qp, ispin, bs_env) + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Sigma_c_ikp_n_qp + INTEGER :: ispin + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'correct_obvious_fitting_fails' + + INTEGER :: handle, homo, i_mo, j_mo, & + n_levels_scissor, n_mo + LOGICAL :: is_occ, is_vir + REAL(KIND=dp) :: sum_Sigma_c + + CALL timeset(routineN, handle) + + n_mo = bs_env%n_ao + homo = bs_env%n_occ(ispin) + + DO i_mo = 1, n_mo + + ! if |𝚺^c| > 13 eV, we use a scissors shift + IF (ABS(Sigma_c_ikp_n_qp(i_mo)) > 13.0_dp/evolt) THEN + + is_occ = (i_mo .LE. homo) + is_vir = (i_mo > homo) + + n_levels_scissor = 0 + sum_Sigma_c = 0.0_dp + + ! compute scissor + DO j_mo = 1, n_mo + + ! only compute scissor from other GW levels close in energy + IF (is_occ .AND. j_mo > homo) CYCLE + IF (is_vir .AND. j_mo .LE. homo) CYCLE + IF (ABS(i_mo - j_mo) > 10) CYCLE + IF (i_mo == j_mo) CYCLE + + n_levels_scissor = n_levels_scissor + 1 + sum_Sigma_c = sum_Sigma_c + Sigma_c_ikp_n_qp(j_mo) + + END DO + + ! overwrite the self-energy with scissor shift + Sigma_c_ikp_n_qp(i_mo) = sum_Sigma_c/REAL(n_levels_scissor, KIND=dp) + + END IF + + END DO ! i_mo + + CALL timestop(handle) + + END SUBROUTINE correct_obvious_fitting_fails + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE get_VBM_CBM_bandgaps(bs_env) + + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_VBM_CBM_bandgaps' + + INTEGER :: handle + + CALL timeset(routineN, handle) + + CALL get_VBM_CBM_bandgaps_single(bs_env%band_edges_scf, bs_env%eigenval_scf, bs_env) + CALL get_VBM_CBM_bandgaps_single(bs_env%band_edges_G0W0, bs_env%eigenval_G0W0, bs_env) + CALL get_VBM_CBM_bandgaps_single(bs_env%band_edges_HF, bs_env%eigenval_HF, bs_env) + + CALL timestop(handle) + + END SUBROUTINE get_VBM_CBM_bandgaps + +! ************************************************************************************************** +!> \brief ... +!> \param band_edges ... +!> \param ev ... +!> \param bs_env ... +! ************************************************************************************************** + SUBROUTINE get_VBM_CBM_bandgaps_single(band_edges, ev, bs_env) + TYPE(band_edges_type) :: band_edges + REAL(KIND=dp), DIMENSION(:, :, :) :: ev + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_VBM_CBM_bandgaps_single' + + INTEGER :: handle, homo, homo_1, homo_2, ikp, & + ispin, lumo, lumo_1, lumo_2, n_mo + REAL(KIND=dp) :: E_DBG_at_ikp + + CALL timeset(routineN, handle) + + n_mo = bs_env%n_ao + + band_edges%DBG = 1000.0_dp + + SELECT CASE (bs_env%n_spin) + CASE (1) + homo = bs_env%n_occ(1) + lumo = homo + 1 + band_edges%VBM = MAXVAL(ev(1:homo, :, 1)) + band_edges%CBM = MINVAL(ev(homo + 1:n_mo, :, 1)) + CASE (2) + homo_1 = bs_env%n_occ(1) + lumo_1 = homo_1 + 1 + homo_2 = bs_env%n_occ(2) + lumo_2 = homo_2 + 1 + band_edges%VBM = MAX(MAXVAL(ev(1:homo_1, :, 1)), MAXVAL(ev(1:homo_2, :, 2))) + band_edges%CBM = MIN(MINVAL(ev(homo_1 + 1:n_mo, :, 1)), MINVAL(ev(homo_2 + 1:n_mo, :, 2))) + CASE DEFAULT + CPABORT("Error with number of spins.") + END SELECT + + band_edges%IDBG = band_edges%CBM - band_edges%VBM + + DO ispin = 1, bs_env%n_spin + + homo = bs_env%n_occ(ispin) + + DO ikp = 1, bs_env%nkp_bs_and_DOS + + E_DBG_at_ikp = -MAXVAL(ev(1:homo, ikp, ispin)) + MINVAL(ev(homo + 1:n_mo, ikp, ispin)) + + IF (E_DBG_at_ikp < band_edges%DBG) band_edges%DBG = E_DBG_at_ikp + + END DO + + END DO + + CALL timestop(handle) + + END SUBROUTINE get_VBM_CBM_bandgaps_single END MODULE gw_utils diff --git a/src/input_constants.F b/src/input_constants.F index 9ad0b8458c..55af41ab69 100644 --- a/src/input_constants.F +++ b/src/input_constants.F @@ -1080,7 +1080,9 @@ MODULE input_constants int_ldos_x = 19, & int_ldos_y = 20, & int_ldos_z = 21, & - int_ldos_none = 22 + int_ldos_none = 22, & + small_cell_full_kp = 31, & + large_cell_Gamma = 32 ! periodic RESP parameters INTEGER, PARAMETER, PUBLIC :: do_resp_x_dir = 0, & diff --git a/src/kpoint_coulomb_2c.F b/src/kpoint_coulomb_2c.F index cb0351aa7e..287337d54b 100644 --- a/src/kpoint_coulomb_2c.F +++ b/src/kpoint_coulomb_2c.F @@ -19,6 +19,7 @@ MODULE kpoint_coulomb_2c USE cell_types, ONLY: cell_type,& get_cell,& pbc + USE constants_operator, ONLY: operator_coulomb USE cp_dbcsr_api, ONLY: & dbcsr_create, dbcsr_init_p, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, & dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_p_type, & @@ -28,8 +29,13 @@ MODULE kpoint_coulomb_2c USE kinds, ONLY: dp USE kpoint_types, ONLY: get_kpoint_info,& kpoint_type - USE mathconstants, ONLY: twopi + USE mathconstants, ONLY: gaussi,& + twopi,& + z_one + USE message_passing, ONLY: mp_para_env_type USE particle_types, ONLY: particle_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type USE qs_kind_types, ONLY: get_qs_kind,& qs_kind_type #include "./base/base_uses.f90" @@ -40,7 +46,7 @@ MODULE kpoint_coulomb_2c CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_coulomb_2c' - PUBLIC :: build_2c_coulomb_matrix_kp + PUBLIC :: build_2c_coulomb_matrix_kp, build_2c_coulomb_matrix_kp_small_cell ! ************************************************************************************************** @@ -79,13 +85,11 @@ SUBROUTINE build_2c_coulomb_matrix_kp(matrix_v_kp, kpoints, basis_type, cell, pa CHARACTER(LEN=*), PARAMETER :: routineN = 'build_2c_coulomb_matrix_kp' - INTEGER :: handle, total_periodicity + INTEGER :: handle TYPE(dbcsr_type), POINTER :: matrix_v_L_tmp CALL timeset(routineN, handle) - CALL check_periodicity(cell, kpoints, total_periodicity) - CALL allocate_tmp(matrix_v_L_tmp, matrix_v_kp, ikp_start) CALL lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & @@ -130,9 +134,9 @@ SUBROUTINE lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & CHARACTER(LEN=*), PARAMETER :: routineN = 'lattice_sum' - INTEGER :: factor, handle, i_block, i_x, i_x_inner, i_x_outer, ik, j_y, j_y_inner, & - j_y_outer, k_z, k_z_inner, k_z_outer, nkp, x_max, x_min, y_max, y_min, z_max, z_min - INTEGER, DIMENSION(3) :: nkp_grid, periodic + INTEGER :: factor, handle, handle2, i_block, i_x, i_x_inner, i_x_outer, ik, j_y, j_y_inner, & + j_y_outer, k_z, k_z_inner, k_z_outer, x_max, x_min, y_max, y_min, z_max, z_min + INTEGER, DIMENSION(3) :: nkp_grid REAL(KIND=dp) :: coskl, sinkl REAL(KIND=dp), DIMENSION(3) :: vec_L, vec_s REAL(KIND=dp), DIMENSION(3, 3) :: hmat @@ -142,50 +146,8 @@ SUBROUTINE lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & CALL timeset(routineN, handle) - CALL get_kpoint_info(kpoints, nkp_grid=nkp_grid, nkp=nkp) - CALL get_cell(cell=cell, h=hmat, periodic=periodic) - - IF (MODULO(nkp_grid(1), 2) == 1) THEN - factor = 3**(size_lattice_sum - 1) - ELSE IF (MODULO(nkp_grid(1), 2) == 0) THEN - factor = 2**(size_lattice_sum - 1) - END IF - - IF (MODULO(nkp_grid(1), 2) == 1) THEN - x_min = -(factor*nkp_grid(1) - 1)/2 - x_max = (factor*nkp_grid(1) - 1)/2 - ELSE IF (MODULO(nkp_grid(1), 2) == 0) THEN - x_min = -factor*nkp_grid(1)/2 - x_max = factor*nkp_grid(1)/2 - 1 - END IF - IF (periodic(1) == 0) THEN - x_min = 0 - x_max = 0 - END IF - - IF (MODULO(nkp_grid(2), 2) == 1) THEN - y_min = -(factor*nkp_grid(2) - 1)/2 - y_max = (factor*nkp_grid(2) - 1)/2 - ELSE IF (MODULO(nkp_grid(2), 2) == 0) THEN - y_min = -factor*nkp_grid(2)/2 - y_max = factor*nkp_grid(2)/2 - 1 - END IF - IF (periodic(2) == 0) THEN - y_min = 0 - y_max = 0 - END IF - - IF (MODULO(nkp_grid(3), 2) == 1) THEN - z_min = -(factor*nkp_grid(3) - 1)/2 - z_max = (factor*nkp_grid(3) - 1)/2 - ELSE IF (MODULO(nkp_grid(3), 2) == 0) THEN - z_min = -factor*nkp_grid(3)/2 - z_max = factor*nkp_grid(3)/2 - 1 - END IF - IF (periodic(3) == 0) THEN - z_min = 0 - z_max = 0 - END IF + CALL get_factor_and_xyz_min_max(cell, kpoints, size_lattice_sum, factor, hmat, & + x_min, x_max, y_min, y_max, z_min, z_max, nkp_grid) CALL allocate_blocks_v_kp(blocks_v_kp, matrix_v_kp, ikp_start, ikp_end) CALL allocate_blocks_v_L(blocks_v_L, matrix_v_L_tmp) @@ -225,6 +187,8 @@ SUBROUTINE lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & END DO END DO + CALL timeset(routineN//"_R_to_k", handle2) + ! add exp(iq*vec_L) * (P 0 | Q vec_L) to V_PQ(q) DO ik = ikp_start, ikp_end @@ -249,6 +213,8 @@ SUBROUTINE lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & END DO + CALL timestop(handle2) + END DO END DO END DO @@ -261,7 +227,7 @@ SUBROUTINE lattice_sum(matrix_v_kp, kpoints, basis_type, cell, particle_set, & CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE lattice_sum ! ************************************************************************************************** !> \brief ... @@ -311,7 +277,7 @@ SUBROUTINE set_blocks_to_matrix_v_kp(matrix_v_kp, blocks_v_kp, ikp_start, ikp_en CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE set_blocks_to_matrix_v_kp ! ************************************************************************************************** !> \brief ... @@ -396,7 +362,7 @@ SUBROUTINE compute_v_transl(matrix_v_L_tmp, blocks_v_L, vec_L, particle_set, & CALL timestop(handle) - END SUBROUTINE + END SUBROUTINE compute_v_transl ! ************************************************************************************************** !> \brief ... @@ -575,22 +541,36 @@ SUBROUTINE allocate_blocks_v_kp(blocks_v_kp, matrix_v_kp, ikp_start, ikp_end) !> \brief ... !> \param cell ... !> \param kpoints ... -!> \param total_periodicity ... +!> \param size_lattice_sum ... +!> \param factor ... +!> \param hmat ... +!> \param x_min ... +!> \param x_max ... +!> \param y_min ... +!> \param y_max ... +!> \param z_min ... +!> \param z_max ... +!> \param nkp_grid ... ! ************************************************************************************************** - SUBROUTINE check_periodicity(cell, kpoints, total_periodicity) + SUBROUTINE get_factor_and_xyz_min_max(cell, kpoints, size_lattice_sum, factor, hmat, & + x_min, x_max, y_min, y_max, z_min, z_max, nkp_grid) + TYPE(cell_type), POINTER :: cell TYPE(kpoint_type), POINTER :: kpoints - INTEGER :: total_periodicity + INTEGER :: size_lattice_sum, factor + REAL(KIND=dp), DIMENSION(3, 3) :: hmat + INTEGER :: x_min, x_max, y_min, y_max, z_min, z_max + INTEGER, DIMENSION(3) :: nkp_grid - CHARACTER(LEN=*), PARAMETER :: routineN = 'check_periodicity' + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_factor_and_xyz_min_max' - INTEGER :: handle - INTEGER, DIMENSION(3) :: nkp_grid, periodic + INTEGER :: handle, nkp + INTEGER, DIMENSION(3) :: periodic CALL timeset(routineN, handle) - CALL get_cell(cell=cell, periodic=periodic) - CALL get_kpoint_info(kpoints, nkp_grid=nkp_grid) + CALL get_kpoint_info(kpoints, nkp_grid=nkp_grid, nkp=nkp) + CALL get_cell(cell=cell, h=hmat, periodic=periodic) IF (periodic(1) == 0) THEN CPASSERT(nkp_grid(1) == 1) @@ -602,7 +582,47 @@ SUBROUTINE check_periodicity(cell, kpoints, total_periodicity) CPASSERT(nkp_grid(3) == 1) END IF - total_periodicity = SUM(periodic) + IF (MODULO(nkp_grid(1), 2) == 1) THEN + factor = 3**(size_lattice_sum - 1) + ELSE IF (MODULO(nkp_grid(1), 2) == 0) THEN + factor = 2**(size_lattice_sum - 1) + END IF + + IF (MODULO(nkp_grid(1), 2) == 1) THEN + x_min = -(factor*nkp_grid(1) - 1)/2 + x_max = (factor*nkp_grid(1) - 1)/2 + ELSE IF (MODULO(nkp_grid(1), 2) == 0) THEN + x_min = -factor*nkp_grid(1)/2 + x_max = factor*nkp_grid(1)/2 - 1 + END IF + IF (periodic(1) == 0) THEN + x_min = 0 + x_max = 0 + END IF + + IF (MODULO(nkp_grid(2), 2) == 1) THEN + y_min = -(factor*nkp_grid(2) - 1)/2 + y_max = (factor*nkp_grid(2) - 1)/2 + ELSE IF (MODULO(nkp_grid(2), 2) == 0) THEN + y_min = -factor*nkp_grid(2)/2 + y_max = factor*nkp_grid(2)/2 - 1 + END IF + IF (periodic(2) == 0) THEN + y_min = 0 + y_max = 0 + END IF + + IF (MODULO(nkp_grid(3), 2) == 1) THEN + z_min = -(factor*nkp_grid(3) - 1)/2 + z_max = (factor*nkp_grid(3) - 1)/2 + ELSE IF (MODULO(nkp_grid(3), 2) == 0) THEN + z_min = -factor*nkp_grid(3)/2 + z_max = factor*nkp_grid(3)/2 - 1 + END IF + IF (periodic(3) == 0) THEN + z_min = 0 + z_max = 0 + END IF CALL timestop(handle) @@ -658,4 +678,270 @@ SUBROUTINE deallocate_tmp(matrix_v_L_tmp) END SUBROUTINE +! ************************************************************************************************** +!> \brief ... +!> \param V_k ... +!> \param qs_env ... +!> \param kpoints ... +!> \param size_lattice_sum ... +!> \param basis_type ... +!> \param ikp_start ... +!> \param ikp_end ... +! ************************************************************************************************** + SUBROUTINE build_2c_coulomb_matrix_kp_small_cell(V_k, qs_env, kpoints, size_lattice_sum, & + basis_type, ikp_start, ikp_end) + COMPLEX(KIND=dp), DIMENSION(:, :, :) :: V_k + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(kpoint_type), POINTER :: kpoints + INTEGER :: size_lattice_sum + CHARACTER(LEN=*), INTENT(IN) :: basis_type + INTEGER :: ikp_start, ikp_end + + CHARACTER(LEN=*), PARAMETER :: routineN = 'build_2c_coulomb_matrix_kp_small_cell' + + INTEGER :: factor, handle, handle2, i_cell, i_x, i_x_inner, i_x_outer, ik, ikp_local, j_y, & + j_y_inner, j_y_outer, k_z, k_z_inner, k_z_outer, n_atom, n_bf, x_max, x_min, y_max, & + y_min, z_max, z_min + INTEGER, ALLOCATABLE, DIMENSION(:) :: bf_end_from_atom, bf_start_from_atom + INTEGER, DIMENSION(3) :: nkp_grid + REAL(KIND=dp) :: coskl, sinkl + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: V_L + REAL(KIND=dp), DIMENSION(3) :: vec_L, vec_s + REAL(KIND=dp), DIMENSION(3, 3) :: hmat + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(cell_type), POINTER :: cell + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env=qs_env, & + para_env=para_env, & + particle_set=particle_set, & + cell=cell, & + qs_kind_set=qs_kind_set, & + atomic_kind_set=atomic_kind_set) + + CALL get_factor_and_xyz_min_max(cell, kpoints, size_lattice_sum, factor, hmat, & + x_min, x_max, y_min, y_max, z_min, z_max, nkp_grid) + + CALL get_basis_sizes(qs_env, n_atom, basis_type, bf_start_from_atom, bf_end_from_atom, n_bf) + + ALLOCATE (V_L(n_bf, n_bf)) + + DO i_x_inner = 0, 2*nkp_grid(1) - 1 + DO j_y_inner = 0, 2*nkp_grid(2) - 1 + DO k_z_inner = 0, 2*nkp_grid(3) - 1 + + V_L(:, :) = 0.0_dp + i_cell = 0 + + DO i_x_outer = x_min, x_max + nkp_grid(1), 2*nkp_grid(1) + DO j_y_outer = y_min, y_max + nkp_grid(2), 2*nkp_grid(2) + DO k_z_outer = z_min, z_max + nkp_grid(3), 2*nkp_grid(3) + + i_x = i_x_inner + i_x_outer + j_y = j_y_inner + j_y_outer + k_z = k_z_inner + k_z_outer + + IF (i_x > x_max .OR. i_x < x_min .OR. & + j_y > y_max .OR. j_y < y_min .OR. & + k_z > z_max .OR. k_z < z_min) CYCLE + + i_cell = i_cell + 1 + + vec_s = [REAL(i_x, dp), REAL(j_y, dp), REAL(k_z, dp)] + + IF (MODULO(i_cell, para_env%num_pe) .NE. para_env%mepos) CYCLE + + vec_L = MATMUL(hmat, vec_s) + + ! Compute (P 0 | Q vec_L) and add it to V_R + CALL add_V_L(V_L, vec_L, n_atom, bf_start_from_atom, bf_end_from_atom, & + particle_set, qs_kind_set, atomic_kind_set, basis_type, cell) + + END DO + END DO + END DO + + CALL para_env%sync() + CALL para_env%sum(V_L) + + CALL timeset(routineN//"_R_to_k", handle2) + + ikp_local = 0 + + ! add exp(iq*vec_L) * (P 0 | Q vec_L) to V_PQ(q) + DO ik = 1, ikp_end + + IF (MODULO(ik, para_env%num_pe) .NE. para_env%mepos) CYCLE + + ikp_local = ikp_local + 1 + + IF (ik < ikp_start) CYCLE + + ! coskl and sinkl are identical for all i_x_outer, j_y_outer, k_z_outer + coskl = COS(twopi*DOT_PRODUCT(vec_s(1:3), kpoints%xkp(1:3, ik))) + sinkl = SIN(twopi*DOT_PRODUCT(vec_s(1:3), kpoints%xkp(1:3, ik))) + + V_k(:, :, ikp_local) = V_k(:, :, ikp_local) + z_one*coskl*V_L(:, :) + & + gaussi*sinkl*V_L(:, :) + + END DO + + CALL timestop(handle2) + + END DO + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE build_2c_coulomb_matrix_kp_small_cell + +! ************************************************************************************************** +!> \brief ... +!> \param qs_env ... +!> \param n_atom ... +!> \param basis_type ... +!> \param bf_start_from_atom ... +!> \param bf_end_from_atom ... +!> \param n_bf ... +! ************************************************************************************************** + SUBROUTINE get_basis_sizes(qs_env, n_atom, basis_type, bf_start_from_atom, bf_end_from_atom, n_bf) + + TYPE(qs_environment_type), POINTER :: qs_env + INTEGER :: n_atom + CHARACTER(LEN=*), INTENT(IN) :: basis_type + INTEGER, ALLOCATABLE, DIMENSION(:) :: bf_start_from_atom, bf_end_from_atom + INTEGER :: n_bf + + CHARACTER(LEN=*), PARAMETER :: routineN = 'get_basis_sizes' + + INTEGER :: handle, iatom, ikind, n_kind, nsgf + INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + TYPE(gto_basis_set_type), POINTER :: basis_set_a + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + + CALL timeset(routineN, handle) + + CALL get_qs_env(qs_env=qs_env, particle_set=particle_set, & + qs_kind_set=qs_kind_set, atomic_kind_set=atomic_kind_set) + CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) + + n_atom = SIZE(particle_set) + n_kind = SIZE(qs_kind_set) + + DO ikind = 1, n_kind + CALL get_qs_kind(qs_kind=qs_kind_set(ikind), basis_set=basis_set_a, & + basis_type=basis_type) + CPASSERT(ASSOCIATED(basis_set_a)) + END DO + + ALLOCATE (bf_start_from_atom(n_atom), bf_end_from_atom(n_atom)) + + n_bf = 0 + DO iatom = 1, n_atom + bf_start_from_atom(iatom) = n_bf + 1 + ikind = kind_of(iatom) + CALL get_qs_kind(qs_kind=qs_kind_set(ikind), nsgf=nsgf, basis_type=basis_type) + n_bf = n_bf + nsgf + bf_end_from_atom(iatom) = n_bf + END DO + + CALL timestop(handle) + + END SUBROUTINE get_basis_sizes + +! ************************************************************************************************** +!> \brief ... +!> \param V_L ... +!> \param vec_L ... +!> \param n_atom ... +!> \param bf_start_from_atom ... +!> \param bf_end_from_atom ... +!> \param particle_set ... +!> \param qs_kind_set ... +!> \param atomic_kind_set ... +!> \param basis_type ... +!> \param cell ... +! ************************************************************************************************** + SUBROUTINE add_V_L(V_L, vec_L, n_atom, bf_start_from_atom, bf_end_from_atom, & + particle_set, qs_kind_set, atomic_kind_set, basis_type, cell) + + REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: V_L + REAL(KIND=dp), DIMENSION(3) :: vec_L + INTEGER :: n_atom + INTEGER, ALLOCATABLE, DIMENSION(:) :: bf_start_from_atom, bf_end_from_atom + TYPE(particle_type), DIMENSION(:), POINTER :: particle_set + TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set + TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set + CHARACTER(LEN=*), INTENT(IN) :: basis_type + TYPE(cell_type), POINTER :: cell + + CHARACTER(LEN=*), PARAMETER :: routineN = 'add_V_L' + + INTEGER :: a_1, a_2, atom_a, atom_b, b_1, b_2, & + handle, kind_a, kind_b + INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of + REAL(dp), DIMENSION(3) :: ra, rab_L, rb + REAL(KIND=dp), DIMENSION(:, :), POINTER :: V_L_ab + REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: contr_a, contr_b + TYPE(gto_basis_set_type), POINTER :: basis_set_a, basis_set_b + + CALL timeset(routineN, handle) + + NULLIFY (basis_set_a, basis_set_b) + + CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) + + DO atom_a = 1, n_atom + + DO atom_b = 1, n_atom + + kind_a = kind_of(atom_a) + kind_b = kind_of(atom_b) + + CALL get_qs_kind(qs_kind=qs_kind_set(kind_a), basis_set=basis_set_a, & + basis_type=basis_type) + CALL get_qs_kind(qs_kind=qs_kind_set(kind_b), basis_set=basis_set_b, & + basis_type=basis_type) + + ra(1:3) = pbc(particle_set(atom_a)%r(1:3), cell) + rb(1:3) = pbc(particle_set(atom_b)%r(1:3), cell) + + rab_L(1:3) = rb(1:3) - ra(1:3) + vec_L(1:3) + + CALL contraction_matrix_shg(basis_set_a, contr_a) + CALL contraction_matrix_shg(basis_set_b, contr_b) + + a_1 = bf_start_from_atom(atom_a) + a_2 = bf_end_from_atom(atom_a) + b_1 = bf_start_from_atom(atom_b) + b_2 = bf_end_from_atom(atom_b) + + ALLOCATE (V_L_ab(a_2 - a_1 + 1, b_2 - b_1 + 1)) + + CALL int_operators_r12_ab_shg(operator_coulomb, V_L_ab, rab=rab_L, & + fba=basis_set_a, fbb=basis_set_b, & + scona_shg=contr_a, sconb_shg=contr_b, & + calculate_forces=.FALSE.) + + V_L(a_1:a_2, b_1:b_2) = V_L(a_1:a_2, b_1:b_2) + V_L_ab(:, :) + + DEALLOCATE (contr_a, contr_b, V_L_ab) + + END DO + + END DO + + DEALLOCATE (kind_of) + + CALL timestop(handle) + + END SUBROUTINE add_V_L + END MODULE kpoint_coulomb_2c diff --git a/src/manybody_allegro.F b/src/manybody_allegro.F index acbbaaaef4..c6d279f36d 100644 --- a/src/manybody_allegro.F +++ b/src/manybody_allegro.F @@ -24,6 +24,7 @@ MODULE manybody_allegro USE kinds, ONLY: dp,& int_8,& sp + USE message_passing, ONLY: mp_para_env_type USE pair_potential_types, ONLY: allegro_pot_type,& allegro_type,& pair_potential_pp_type,& @@ -214,6 +215,7 @@ END SUBROUTINE destroy_allegro_arrays !> \param pot_allegro ... !> \param fist_nonbond_env ... !> \param unique_list_a ... +!> \param para_env ... !> \param use_virial ... !> \par History !> Implementation of the allegro potential - [gtocci] 2023 @@ -222,7 +224,7 @@ END SUBROUTINE destroy_allegro_arrays ! ************************************************************************************************** SUBROUTINE allegro_energy_store_force_virial(nonbonded, particle_set, cell, atomic_kind_set, & potparm, allegro, glob_loc_list_a, r_last_update_pbc, & - pot_allegro, fist_nonbond_env, unique_list_a, use_virial) + pot_allegro, fist_nonbond_env, unique_list_a, para_env, use_virial) TYPE(fist_neighbor_type), POINTER :: nonbonded TYPE(particle_type), POINTER :: particle_set(:) @@ -235,6 +237,7 @@ SUBROUTINE allegro_energy_store_force_virial(nonbonded, particle_set, cell, atom REAL(kind=dp) :: pot_allegro TYPE(fist_nonbond_env_type), POINTER :: fist_nonbond_env INTEGER, DIMENSION(:), POINTER :: unique_list_a + TYPE(mp_para_env_type), POINTER :: para_env LOGICAL, INTENT(IN) :: use_virial CHARACTER(LEN=*), PARAMETER :: routineN = 'allegro_energy_store_force_virial' @@ -475,6 +478,7 @@ SUBROUTINE allegro_energy_store_force_virial(nonbonded, particle_set, cell, atom DEALLOCATE (t_edge_index, atom_types) + IF (use_virial) allegro_data%virial(:, :) = allegro_data%virial/REAL(para_env%num_pe, dp) CALL timestop(handle) END SUBROUTINE allegro_energy_store_force_virial diff --git a/src/manybody_potential.F b/src/manybody_potential.F index c09ca86158..6be4ce0e3d 100644 --- a/src/manybody_potential.F +++ b/src/manybody_potential.F @@ -218,7 +218,7 @@ SUBROUTINE energy_manybody(fist_nonbond_env, atomic_kind_set, local_particles, & unique_list_a, cell) CALL allegro_energy_store_force_virial(nonbonded, particle_set, cell, atomic_kind_set, potparm, & allegro, glob_loc_list_a, r_last_update_pbc, pot_allegro, & - fist_nonbond_env, unique_list_a, use_virial) + fist_nonbond_env, unique_list_a, para_env, use_virial) pot_manybody = pot_manybody + pot_allegro CALL destroy_allegro_arrays(glob_loc_list, glob_cell_v, glob_loc_list_a, unique_list_a) END IF diff --git a/src/mp2_integrals.F b/src/mp2_integrals.F index 88e26853b7..95edf0e314 100644 --- a/src/mp2_integrals.F +++ b/src/mp2_integrals.F @@ -43,7 +43,7 @@ MODULE mp2_integrals dbt_clear, dbt_contract, dbt_copy, dbt_create, dbt_destroy, dbt_distribution_destroy, & dbt_distribution_new, dbt_distribution_type, dbt_filter, dbt_get_block, dbt_get_info, & dbt_get_stored_coordinates, dbt_mp_environ_pgrid, dbt_pgrid_create, dbt_pgrid_destroy, & - dbt_pgrid_type, dbt_put_block, dbt_reserve_blocks, dbt_split_blocks, dbt_type + dbt_pgrid_type, dbt_put_block, dbt_reserve_blocks, dbt_scale, dbt_split_blocks, dbt_type USE group_dist_types, ONLY: create_group_dist,& get_group_dist,& group_dist_d1_type @@ -803,6 +803,10 @@ SUBROUTINE mp2_ri_gpw_compute_in(BIb_C, BIb_C_gw, BIb_C_bse_ij, BIb_C_bse_ab, gd summation=.TRUE., move_data=.TRUE.) CALL dbt_clear(t_3c_overl_int(i, j)) CALL dbt_filter(t_3c_O(i, j), qs_env%mp2_env%ri_rpa_im_time%eps_filter/2) + ! rescaling, probably because of neighbor list + IF (do_kpoints_cubic_RPA .AND. cm == cut_memory_int) THEN + CALL dbt_scale(t_3c_O(i, j), 0.5_dp) + END IF END DO END DO CALL timestop(handle4) diff --git a/src/mp2_ri_2c.F b/src/mp2_ri_2c.F index 7fa281e162..652eb720c8 100644 --- a/src/mp2_ri_2c.F +++ b/src/mp2_ri_2c.F @@ -71,7 +71,8 @@ MODULE mp2_ri_2c do_potential_truncated USE kinds, ONLY: dp USE kpoint_coulomb_2c, ONLY: build_2c_coulomb_matrix_kp - USE kpoint_methods, ONLY: rskp_transform + USE kpoint_methods, ONLY: kpoint_init_cell_index,& + rskp_transform USE kpoint_types, ONLY: get_kpoint_info,& kpoint_type USE libint_2c_3c, ONLY: compare_potential_types,& @@ -111,7 +112,7 @@ MODULE mp2_ri_2c CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'mp2_ri_2c' - PUBLIC :: get_2c_integrals, setup_trunc_coulomb_pot_for_exchange_self_energy, RI_2c_integral_mat, & + PUBLIC :: get_2c_integrals, trunc_coulomb_for_exchange, RI_2c_integral_mat, & inversion_of_M_and_mult_with_chol_dec_of_V CONTAINS @@ -263,7 +264,7 @@ SUBROUTINE get_2c_integrals(qs_env, eri_method, eri_param, para_env, para_env_su CALL inversion_of_M_and_mult_with_chol_dec_of_V(fm_matrix_Minv_L_kpoints, fm_matrix_L_kpoints, dimen_RI, & kpoints, qs_env%mp2_env%ri_rpa_im_time%eps_eigval_S) - CALL setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env, trunc_coulomb) + CALL trunc_coulomb_for_exchange(qs_env, trunc_coulomb) ! Gamma-only truncated Coulomb matrix V^tr with cutoff radius = half the unit cell size; for exchange self-energy CALL RI_2c_integral_mat(qs_env, fm_matrix_Minv_Vtrunc_Minv, fm_matrix_L_work, dimen_RI, trunc_coulomb, & @@ -548,9 +549,11 @@ END SUBROUTINE allocate_matrix_v_RI_kp !> \param put_mat_KS_env ... !> \param regularization_RI ... !> \param ikp_ext ... +!> \param do_build_cell_index ... ! ************************************************************************************************** SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dimen_RI, ri_metric, & - do_kpoints, kpoints, put_mat_KS_env, regularization_RI, ikp_ext) + do_kpoints, kpoints, put_mat_KS_env, regularization_RI, ikp_ext, & + do_build_cell_index) TYPE(qs_environment_type), POINTER :: qs_env TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_matrix_Minv_L_kpoints @@ -562,6 +565,7 @@ SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dim LOGICAL, OPTIONAL :: put_mat_KS_env REAL(KIND=dp), OPTIONAL :: regularization_RI INTEGER, OPTIONAL :: ikp_ext + LOGICAL, OPTIONAL :: do_build_cell_index CHARACTER(LEN=*), PARAMETER :: routineN = 'RI_2c_integral_mat' @@ -571,7 +575,7 @@ SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dim INTEGER, ALLOCATABLE, DIMENSION(:) :: sizes_RI INTEGER, DIMENSION(:), POINTER :: col_bsize, row_bsize INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - LOGICAL :: my_put_mat_KS_env + LOGICAL :: my_do_build_cell_index, my_put_mat_KS_env REAL(KIND=dp) :: my_regularization_RI REAL(KIND=dp), DIMENSION(:, :), POINTER :: xkp TYPE(cp_blacs_env_type), POINTER :: blacs_env @@ -607,6 +611,12 @@ SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dim my_put_mat_KS_env = .FALSE. END IF + IF (PRESENT(do_build_cell_index)) THEN + my_do_build_cell_index = do_build_cell_index + ELSE + my_do_build_cell_index = .FALSE. + END IF + CALL get_qs_env(qs_env=qs_env, & para_env=para_env, & blacs_env=blacs_env, & @@ -633,8 +643,17 @@ SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dim col_bsize(:) = sizes_RI IF (do_kpoints) THEN + CPASSERT(PRESENT(kpoints)) + IF (my_do_build_cell_index) THEN + CALL kpoint_init_cell_index(kpoints, sab_RI, para_env, dft_control) + END IF + CALL get_kpoint_info(kpoints, nkp=nkp, xkp=xkp, & + cell_to_index=cell_to_index) + n_real_imag = 2 nimg = dft_control%nimages ELSE + nkp = 1 + n_real_imag = 1 nimg = 1 END IF @@ -669,16 +688,6 @@ SUBROUTINE RI_2c_integral_mat(qs_env, fm_matrix_Minv_L_kpoints, fm_matrix_L, dim CALL set_ks_env(qs_env%ks_env, matrix_s_RI_aux_kp=matrix_s_RI_aux_transl) END IF - IF (do_kpoints) THEN - CPASSERT(PRESENT(kpoints)) - CALL get_kpoint_info(kpoints, nkp=nkp, xkp=xkp, & - cell_to_index=cell_to_index) - n_real_imag = 2 - ELSE - nkp = 1 - n_real_imag = 1 - END IF - IF (PRESENT(ikp_ext)) nkp = 1 ALLOCATE (fm_matrix_Minv_L_kpoints(nkp, n_real_imag)) @@ -1600,27 +1609,52 @@ END SUBROUTINE Gamma_only_inversion_of_M_and_mult_with_chol_dec_of_Vtrunc !> \param qs_env ... !> \param trunc_coulomb ... !> \param rel_cutoff_trunc_coulomb_ri_x ... +!> \param cell_grid ... +!> \param do_BvK_cell ... ! ************************************************************************************************** - SUBROUTINE setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env, trunc_coulomb, & - rel_cutoff_trunc_coulomb_ri_x) + SUBROUTINE trunc_coulomb_for_exchange(qs_env, trunc_coulomb, rel_cutoff_trunc_coulomb_ri_x, & + cell_grid, do_BvK_cell) TYPE(qs_environment_type), POINTER :: qs_env TYPE(libint_potential_type), OPTIONAL :: trunc_coulomb REAL(KIND=dp), OPTIONAL :: rel_cutoff_trunc_coulomb_ri_x + INTEGER, DIMENSION(3), OPTIONAL :: cell_grid + LOGICAL, OPTIONAL :: do_BvK_cell - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_trunc_coulomb_pot_for_exchange_self_energy' + CHARACTER(LEN=*), PARAMETER :: routineN = 'trunc_coulomb_for_exchange' - INTEGER :: handle + INTEGER :: handle, i_dim INTEGER, DIMENSION(3) :: periodic - REAL(KIND=dp) :: my_rel_cutoff_trunc_coulomb_ri_x, shortest_dist_cell_planes + LOGICAL :: my_do_BvK_cell + REAL(KIND=dp) :: kp_fac, kp_fac_idim, my_rel_cutoff_trunc_coulomb_ri_x, & + shortest_dist_cell_planes TYPE(cell_type), POINTER :: cell + TYPE(kpoint_type), POINTER :: kpoints_scf CALL timeset(routineN, handle) NULLIFY (cell) - CALL get_qs_env(qs_env, cell=cell) - + CALL get_qs_env(qs_env, cell=cell, kpoints=kpoints_scf) CALL get_cell(cell=cell, periodic=periodic) + my_do_BvK_cell = .FALSE. + IF (PRESENT(do_BvK_cell)) my_do_BvK_cell = do_BvK_cell + IF (my_do_BvK_cell) THEN + kp_fac = 1.0E10_dp + DO i_dim = 1, 3 + ! look for smallest k-point mesh in periodic direction + IF (periodic(i_dim) == 1) THEN + IF (PRESENT(cell_grid)) THEN + kp_fac_idim = REAL(cell_grid(i_dim), KIND=dp) + ELSE + kp_fac_idim = REAL(kpoints_scf%nkp_grid(i_dim), KIND=dp) + END IF + IF (kp_fac > kp_fac_idim) kp_fac = kp_fac_idim + END IF + END DO + ELSE + kp_fac = 1.0_dp + END IF + shortest_dist_cell_planes = 1.0E4_dp IF (periodic(1) == 1) THEN IF (shortest_dist_cell_planes > plane_distance(1, 0, 0, cell)) THEN @@ -1646,7 +1680,9 @@ SUBROUTINE setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env, trunc_coulom IF (PRESENT(trunc_coulomb)) THEN trunc_coulomb%potential_type = do_potential_truncated - trunc_coulomb%cutoff_radius = shortest_dist_cell_planes*my_rel_cutoff_trunc_coulomb_ri_x + trunc_coulomb%cutoff_radius = shortest_dist_cell_planes* & + my_rel_cutoff_trunc_coulomb_ri_x* & + kp_fac trunc_coulomb%filename = "t_c_g.dat" ! dummy trunc_coulomb%omega = 0.0_dp @@ -1654,7 +1690,7 @@ SUBROUTINE setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env, trunc_coulom CALL timestop(handle) - END SUBROUTINE setup_trunc_coulomb_pot_for_exchange_self_energy + END SUBROUTINE trunc_coulomb_for_exchange ! ************************************************************************************************** !> \brief ... diff --git a/src/nequip_unittest.F b/src/nequip_unittest.F index e07dab813d..26ad9e6b6e 100644 --- a/src/nequip_unittest.F +++ b/src/nequip_unittest.F @@ -186,8 +186,7 @@ PROGRAM nequip_unittest DO iatom = 1, natoms WRITE (*, *) forces(:, iatom)*angstrom/evolt END DO - - CPASSERT(ABS(-14985.6299_dp - REAL(total_energy(1, 1), kind=dp)) < 2e-3_dp) + CPASSERT(ABS(-14985.4443_dp - REAL(total_energy(1, 1), kind=dp)) < 2e-3_dp) CALL torch_dict_release(inputs) CALL torch_dict_release(outputs) diff --git a/src/post_scf_bandstructure_methods.F b/src/post_scf_bandstructure_methods.F index 33b60067f7..b30720151d 100644 --- a/src/post_scf_bandstructure_methods.F +++ b/src/post_scf_bandstructure_methods.F @@ -6,12 +6,10 @@ !--------------------------------------------------------------------------------------------------! MODULE post_scf_bandstructure_methods - USE gw_methods, ONLY: gw + USE gw_main, ONLY: gw USE input_section_types, ONLY: section_vals_type USE post_scf_bandstructure_types, ONLY: post_scf_bandstructure_type - USE post_scf_bandstructure_utils, ONLY: bandstructure_primitive_cell,& - bandstructure_primitive_cell_spinor,& - create_and_init_bs_env,& + USE post_scf_bandstructure_utils, ONLY: create_and_init_bs_env,& dos_pdos_ldos USE qs_environment_types, ONLY: qs_environment_type USE qs_scf, ONLY: scf @@ -54,21 +52,14 @@ SUBROUTINE post_scf_bandstructure(qs_env, post_scf_bandstructure_section) CALL soc(qs_env, qs_env%bs_env) END IF - ! GW calculation for eigenvalues/bandstructure + ! GW calculation for eigenvalues/bandstructure for molecules and periodic systems IF (qs_env%bs_env%do_gw) THEN CALL gw(qs_env, qs_env%bs_env, post_scf_bandstructure_section) END IF - ! density of states (DOS) and projected DOS for DFT, DFT+SOC, G0W0, G0W0+SOC, also - ! quantities from local DOS (LDOS) as local valence band maximum (VBM), local conduction - ! band minimum (CBM), and local gap are calculated (local: as function of space r) + ! density of states (DOS), projected DOS, local DOS for DFT, DFT+SOC, G0W0, G0W0+SOC CALL dos_pdos_ldos(qs_env, qs_env%bs_env) - ! band structure of primitive unit cell for DFT, DFT+SOC, G0W0, G0W0+SOC - IF (qs_env%bs_env%do_bs_primitive_cell) THEN - CALL bandstructure_primitive_cell_all_methods(qs_env, qs_env%bs_env) - END IF - CALL timestop(handle) END SUBROUTINE post_scf_bandstructure @@ -102,42 +93,4 @@ SUBROUTINE soc(qs_env, bs_env) END SUBROUTINE soc -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE bandstructure_primitive_cell_all_methods(qs_env, bs_env) - - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'bandstructure_primitive_cell_all_methods' - - INTEGER :: handle - - CALL timeset(routineN, handle) - - CALL bandstructure_primitive_cell(qs_env, bs_env, & - bs_env%eigenval_prim_cell_scf, & - "bandstructure_SCF.bs", & - bs_env%fm_ks_Gamma(1)) - IF (bs_env%do_gw) THEN - CALL bandstructure_primitive_cell(qs_env, bs_env, & - bs_env%eigenval_prim_cell_G0W0, & - "bandstructure_G0W0.bs", & - bs_env%fm_h_G0W0_Gamma) - END IF - - IF (bs_env%do_soc) THEN - CALL bandstructure_primitive_cell_spinor(qs_env, bs_env, & - bs_env%eigenval_prim_cell_scf_soc, & - "bandstructure_SCF_SOC.bs", & - bs_env%cfm_ks_spinor_ao_Gamma) - END IF - - CALL timestop(handle) - - END SUBROUTINE bandstructure_primitive_cell_all_methods - END MODULE post_scf_bandstructure_methods diff --git a/src/post_scf_bandstructure_types.F b/src/post_scf_bandstructure_types.F index b989b9bbe5..8e831d8471 100644 --- a/src/post_scf_bandstructure_types.F +++ b/src/post_scf_bandstructure_types.F @@ -21,9 +21,9 @@ MODULE post_scf_bandstructure_types cp_fm_type USE dbt_api, ONLY: dbt_destroy,& dbt_type + USE input_constants, ONLY: small_cell_full_kp USE kinds, ONLY: default_string_length,& - dp,& - int_8 + dp USE kpoint_types, ONLY: kpoint_release,& kpoint_type USE libint_2c_3c, ONLY: libint_potential_type @@ -38,7 +38,7 @@ MODULE post_scf_bandstructure_types CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'post_scf_bandstructure_types' - PUBLIC :: post_scf_bandstructure_type, band_edges_type, bs_env_release + PUBLIC :: post_scf_bandstructure_type, band_edges_type, data_3_type, bs_env_release ! valence band maximum (VBM), conduction band minimum (CBM), direct band gap (DBG), ! indirect band gap (IDBG) @@ -49,224 +49,239 @@ MODULE post_scf_bandstructure_types IDBG = -1.0_dp END TYPE band_edges_type + ! data type for storing 3-index quantities for small-cell, full-k-points GW code + TYPE data_3_type + REAL(KIND=dp), DIMENSION(:, :, :), ALLOCATABLE :: data_3 + END TYPE data_3_type + TYPE post_scf_bandstructure_type ! decide which calculations will be done LOGICAL :: do_gw = .FALSE., & do_soc = .FALSE., & - do_bs = .FALSE., & - do_bs_primitive_cell = .FALSE., & do_ldos = .FALSE. ! various eigenvalues computed in GW code, some depend on k-points ! and have therefore three dimensions (band index, k-point, spin) REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: eigenval_scf_Gamma REAL(KIND=dp), DIMENSION(:, :, :), ALLOCATABLE :: eigenval_scf, & - eigenval_G0W0 - REAL(KIND=dp), DIMENSION(:, :, :), ALLOCATABLE :: eigenval_scGW0 - REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: eigenval_prim_cell_scf, & - eigenval_prim_cell_scf_soc, & - eigenval_prim_cell_G0W0, & - eigenval_prim_cell_G0W0_soc + eigenval_G0W0, & + eigenval_HF, & + eigenval_scGW0 REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: eigenval_scf_soc, & eigenval_G0W0_soc TYPE(band_edges_type), DIMENSION(2) :: band_edges_scf_Gamma TYPE(band_edges_type) :: band_edges_scf, & - band_edges_G0W0 + band_edges_G0W0, & + band_edges_HF ! general parameters on molecular orbitals and basis sets - INTEGER :: n_ao = -1, & - n_RI = -1, & - n_spin = -1, & - n_atom = -1, & - max_AO_bf_per_atom = -1 - INTEGER, DIMENSION(:), ALLOCATABLE :: i_ao_start_from_atom, & - i_ao_end_from_atom, & - i_RI_start_from_atom, & - i_RI_end_from_atom - INTEGER, DIMENSION(2) :: n_occ = -1, & - n_vir = -1 - REAL(KIND=dp) :: spin_degeneracy = -1.0_dp - REAL(KIND=dp), DIMENSION(2) :: e_fermi = -1.0_dp + INTEGER :: n_ao = -1, & + n_RI = -1, & + n_spin = -1, & + n_atom = -1, & + max_AO_bf_per_atom = -1 + INTEGER, DIMENSION(:), ALLOCATABLE :: i_ao_start_from_atom, & + i_ao_end_from_atom, & + i_RI_start_from_atom, & + i_RI_end_from_atom + INTEGER, DIMENSION(2) :: n_occ = -1, & + n_vir = -1 + REAL(KIND=dp) :: spin_degeneracy = -1.0_dp + REAL(KIND=dp), DIMENSION(2) :: e_fermi = -1.0_dp ! kpoint mesh for chi, eps, W - INTEGER, DIMENSION(:), POINTER :: nkp_grid_DOS_input => NULL() - INTEGER, DIMENSION(3) :: nkp_grid_chi_eps_W_orig = -1, & - nkp_grid_chi_eps_W_extra = -1 - INTEGER :: nkp_chi_eps_W_orig = -1, & - nkp_chi_eps_W_extra = -1, & - nkp_chi_eps_W_orig_plus_extra = -1, & - nkp_chi_eps_W_batch = -1, & - num_chi_eps_W_batches = -1, & - size_lattice_sum_V = -1 - TYPE(kpoint_type), POINTER :: kpoints_chi_eps_W => NULL(), & - kpoints_DOS => NULL(), & - kpoints_bandstructure => NULL() - LOGICAL :: approx_kp_extrapol = .FALSE. - REAL(KIND=dp) :: wkp_orig = -1.0_dp - REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: wkp_s_p, & - wkp_no_extra - INTEGER, DIMENSION(:), ALLOCATABLE :: l_RI - INTEGER :: input_kp_bs_npoints = -1, & - input_kp_bs_n_sp_pts = -1, & - nkp_bs = -1, & - nkp_DOS = -1 - REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: xkp_special - CHARACTER(LEN=default_string_length), & - DIMENSION(:), ALLOCATABLE :: kp_special_name + INTEGER, DIMENSION(:), POINTER :: nkp_grid_DOS_input => NULL() + INTEGER, DIMENSION(3) :: nkp_grid_chi_eps_W_orig = -1, & + nkp_grid_chi_eps_W_extra = -1 + INTEGER :: nkp_chi_eps_W_orig = -1, & + nkp_chi_eps_W_extra = -1, & + nkp_chi_eps_W_orig_plus_extra = -1, & + nkp_chi_eps_W_batch = -1, & + num_chi_eps_W_batches = -1, & + size_lattice_sum_V = -1 + TYPE(kpoint_type), POINTER :: kpoints_chi_eps_W => NULL(), & + kpoints_DOS => NULL() + LOGICAL :: approx_kp_extrapol = .FALSE. + REAL(KIND=dp) :: wkp_orig = -1.0_dp + REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: wkp_s_p, & + wkp_no_extra + INTEGER, DIMENSION(:), ALLOCATABLE :: l_RI + INTEGER :: input_kp_bs_npoints = -1, & + input_kp_bs_n_sp_pts = -1, & + nkp_bs_and_DOS = -1, & + nkp_only_bs = -1, & + nkp_only_DOS + REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: xkp_special ! parameters for GW band structure calculation of small unit cell (with multiple unit cell) - INTEGER, DIMENSION(3) :: periodic = -1, & - multiple_unit_cell = -1 - LOGICAL :: calculate_bandstructure_of_primitive_cell & - = .FALSE. - INTEGER :: n_atom_in_primitive_cell = -1, & - n_primitive_cells = -1 - INTEGER, DIMENSION(:), ALLOCATABLE :: atoms_i_primitive_cell, & - ref_atom_primitive_cell - INTEGER, DIMENSION(:, :), ALLOCATABLE :: cell_of_i_atom - REAL(KIND=dp), DIMENSION(3, 3) :: hmat_primitive_cell = -1.0_dp, & - hinv_primitive_cell = -1.0_dp, & - hmat = -1.0_dp + INTEGER :: small_cell_full_kp_or_large_cell_Gamma = -1, & + nimages_scf = -1 + INTEGER, DIMENSION(3) :: periodic = -1 + REAL(KIND=dp), DIMENSION(3, 3) :: hmat = -1.0_dp ! imaginary time and imaginary frequency grids - INTEGER :: num_time_freq_points = -1, & - num_freq_points_fit = -1 - REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: imag_time_points, & - imag_freq_points, & - imag_freq_points_fit - REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: weights_cos_t_to_w, & - weights_cos_w_to_t, & - weights_sin_t_to_w - INTEGER :: nparam_pade = -1, & - num_points_per_magnitude = -1 - REAL(KIND=dp) :: freq_max_fit = -1.0_dp, & - regularization_minimax = -1.0_dp, & - stabilize_exp = -1.0_dp + INTEGER :: num_time_freq_points = -1, & + num_freq_points_fit = -1 + REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: imag_time_points, & + imag_freq_points, & + imag_freq_points_fit + REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: weights_cos_t_to_w, & + weights_cos_w_to_t, & + weights_sin_t_to_w + INTEGER :: nparam_pade = -1, & + num_points_per_magnitude = -1 + REAL(KIND=dp) :: freq_max_fit = -1.0_dp, & + regularization_minimax = -1.0_dp, & + stabilize_exp = -1.0_dp ! filter threshold for matrix-tensor operations - REAL(KIND=dp) :: eps_filter = -1.0_dp, & - eps_3c_int = -1.0_dp, & - eps_atom_grid_2d_mat = -1.0_dp - - ! threshold for inverting ao overlap matrix, RI matrices - REAL(KIND=dp) :: eps_eigval_mat_s = -1.0_dp, & - eps_eigval_mat_RI = -1.0_dp, & - regularization_RI = -1.0_dp - - ! global full matrices used in GW - TYPE(cp_fm_type) :: fm_s_Gamma, & - fm_Gocc, & - fm_Gvir - TYPE(cp_fm_type), DIMENSION(2) :: fm_ks_Gamma, & - fm_V_xc_Gamma, & - fm_mo_coeff_Gamma - TYPE(cp_fm_type), DIMENSION(4) :: fm_work_mo - TYPE(cp_fm_type) :: fm_RI_RI, & - fm_chi_Gamma_freq, & - fm_W_MIC_freq, & - fm_W_MIC_freq_1_extra, & - fm_W_MIC_freq_1_no_extra, & - fm_h_G0W0_Gamma - - ! global dbcsr matrices used in GW - TYPE(dbcsr_p_type) :: mat_ao_ao, & - mat_RI_RI - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: mat_chi_Gamma_tau => NULL() - - ! local dbcsr matrices used in GW (local in tensor group) - TYPE(dbcsr_p_type) :: mat_ao_ao_tensor, & - mat_RI_RI_tensor, & - mat_Sigma_from_Gocc_tensor, & - mat_Sigma_from_Gvir_tensor, & - mat_W_MIC_time_tensor + REAL(KIND=dp) :: eps_filter = -1.0_dp, & + eps_atom_grid_2d_mat = -1.0_dp + + ! threshold for inverting ao overlap matrix, RI cfm_1d + REAL(KIND=dp) :: eps_eigval_mat_s = -1.0_dp, & + eps_eigval_mat_RI = -1.0_dp, & + regularization_RI = -1.0_dp + + ! global full cfm_1d used in GW + TYPE(cp_fm_type) :: fm_s_Gamma, & + fm_Gocc, & + fm_Gvir + TYPE(cp_fm_type), DIMENSION(2) :: fm_ks_Gamma, & + fm_V_xc_Gamma, & + fm_mo_coeff_Gamma + TYPE(cp_fm_type), DIMENSION(4) :: fm_work_mo + TYPE(cp_fm_type) :: fm_RI_RI, & + fm_chi_Gamma_freq, & + fm_W_MIC_freq, & + fm_W_MIC_freq_1_extra, & + fm_W_MIC_freq_1_no_extra + TYPE(cp_cfm_type) :: cfm_work_mo, & + cfm_work_mo_2 + + ! global dbcsr cfm_1d used in GW + TYPE(dbcsr_p_type) :: mat_ao_ao, & + mat_RI_RI + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: mat_chi_Gamma_tau => NULL() + + ! local dbcsr cfm_1d used in GW (local in tensor group) + TYPE(dbcsr_p_type) :: mat_ao_ao_tensor, & + mat_RI_RI_tensor ! tensors for sparse matrix-tensor operations - TYPE(dbt_type) :: t_G, & - t_chi, & - t_W, & - t_RI_AO__AO, & - t_RI__AO_AO + TYPE(dbt_type) :: t_G, & + t_chi, & + t_W, & + t_RI_AO__AO, & + t_RI__AO_AO ! parameters and data for parallelization - INTEGER :: group_size_tensor = -1, & - tensor_group_color = -1, & - num_tensor_groups = -1, & - diag_group_color = -1, & - num_diag_groups = -1, & - min_block_size = -1 - REAL(KIND=dp) :: input_memory_per_proc_GB = -1.0_dp - INTEGER(KIND=int_8) :: input_memory_per_proc = -1 - TYPE(mp_para_env_type), POINTER :: para_env => NULL(), & - para_env_tensor => NULL() - REAL(KIND=dp) :: occupation_3c_int = -1.0_dp, & - max_dist_AO_atoms = -1.0_dp, & - safety_factor_memory = -1.0_dp + INTEGER :: group_size_tensor = -1, & + tensor_group_color = -1, & + num_tensor_groups = -1 + REAL(KIND=dp) :: input_memory_per_proc_GB = -1.0_dp + TYPE(mp_para_env_type), POINTER :: para_env => NULL(), & + para_env_tensor => NULL() + REAL(KIND=dp) :: occupation_3c_int = -1.0_dp, & + max_dist_AO_atoms = -1.0_dp, & + safety_factor_memory = -1.0_dp + ! parallelization: atom range i and atom range j for tensor group - INTEGER, DIMENSION(2) :: atoms_i = -1, & - atoms_j = -1 - INTEGER :: n_atom_i = -1, & - n_intervals_i = -1, & - n_atom_j = -1, & - n_intervals_j = -1, & - n_atom_per_interval_ij = -1, & - n_intervals_inner_loop_atoms = -1, & - n_atom_per_IL_interval = -1 - INTEGER, DIMENSION(:, :), ALLOCATABLE :: i_atom_intervals, & - j_atom_intervals, & - inner_loop_atom_intervals, & - atoms_i_t_group, & - atoms_j_t_group - LOGICAL, DIMENSION(:, :), ALLOCATABLE :: skip_Sigma_occ, & - skip_Sigma_vir + INTEGER, DIMENSION(2) :: atoms_i = -1, & + atoms_j = -1 + INTEGER :: n_atom_i = -1, & + n_intervals_i = -1, & + n_atom_j = -1, & + n_intervals_j = -1, & + n_atom_per_interval_ij = -1, & + n_intervals_inner_loop_atoms = -1, & + n_atom_per_IL_interval = -1 + INTEGER, DIMENSION(:, :), ALLOCATABLE :: i_atom_intervals, & + j_atom_intervals, & + inner_loop_atom_intervals, & + atoms_i_t_group, & + atoms_j_t_group + LOGICAL, DIMENSION(:, :), ALLOCATABLE :: skip_Sigma_occ, & + skip_Sigma_vir ! check-arrays and names for restarting - LOGICAL, DIMENSION(:), ALLOCATABLE :: read_chi, & - calc_chi - LOGICAL, DIMENSION(:, :), ALLOCATABLE :: Sigma_c_exists - LOGICAL :: all_W_exist = .FALSE., & - Sigma_x_exists = .FALSE. - CHARACTER(LEN=3) :: chi_name = "chi" - CHARACTER(LEN=6) :: W_time_name = "W_time" - CHARACTER(LEN=7) :: Sigma_x_name = "Sigma_x" - CHARACTER(LEN=13) :: Sigma_p_name = "Sigma_pos_tau", & - Sigma_n_name = "Sigma_neg_tau" - CHARACTER(LEN=default_string_length) :: prefix = "" - - REAL(KIND=dp) :: t1 = -1.0_dp, & - t2 = -1.0_dp - INTEGER :: unit_nr = -1 + LOGICAL, DIMENSION(:), ALLOCATABLE :: read_chi, & + calc_chi + LOGICAL, DIMENSION(:, :), ALLOCATABLE :: Sigma_c_exists + LOGICAL :: all_W_exist = .FALSE., & + Sigma_x_exists = .FALSE. + CHARACTER(LEN=3) :: chi_name = "chi" + CHARACTER(LEN=6) :: W_time_name = "W_time" + CHARACTER(LEN=7) :: Sigma_x_name = "Sigma_x" + CHARACTER(LEN=13) :: Sigma_p_name = "Sigma_pos_tau", & + Sigma_n_name = "Sigma_neg_tau" + CHARACTER(LEN=default_string_length) :: prefix = "" + INTEGER :: unit_nr = -1 ! parameters and data for basis sets - TYPE(gto_basis_set_p_type), DIMENSION(:), & - ALLOCATABLE :: basis_set_AO, & - basis_set_RI - INTEGER, DIMENSION(:), ALLOCATABLE :: sizes_AO, & - sizes_RI - TYPE(neighbor_list_3c_type) :: nl_3c - TYPE(libint_potential_type) :: ri_metric, & - trunc_coulomb + TYPE(gto_basis_set_p_type), & + DIMENSION(:), ALLOCATABLE :: basis_set_AO, & + basis_set_RI + INTEGER, DIMENSION(:), ALLOCATABLE :: sizes_AO, & + sizes_RI + TYPE(neighbor_list_3c_type) :: nl_3c + TYPE(libint_potential_type) :: ri_metric, & + trunc_coulomb ! parameters for SOC calculation - REAL(KIND=dp) :: energy_window_soc = -1.0_dp - TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_V_SOC_xyz => NULL() - TYPE(cp_fm_type), DIMENSION(3) :: fm_V_SOC_xyz_mo - TYPE(cp_cfm_type) :: cfm_ks_spinor_ao_Gamma, & - cfm_SOC_spinor_ao_Gamma, & - cfm_s_spinor_Gamma - TYPE(band_edges_type) :: band_edges_scf_SOC, & - band_edges_G0W0_SOC + REAL(KIND=dp) :: energy_window_soc = -1.0_dp + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_V_SOC_xyz => NULL() + TYPE(cp_fm_type), DIMENSION(3) :: fm_V_SOC_xyz_mo + TYPE(cp_cfm_type) :: cfm_ks_spinor_ao_Gamma, & + cfm_SOC_spinor_ao_Gamma, & + cfm_s_spinor_Gamma + TYPE(band_edges_type) :: band_edges_scf_SOC, & + band_edges_G0W0_SOC ! parameters for DOS and PDOS calculation - REAL(KIND=dp) :: energy_window_DOS = -1.0_dp, & - energy_step_DOS = -1.0_dp, & - broadening_DOS = -1.0_dp + REAL(KIND=dp) :: energy_window_DOS = -1.0_dp, & + energy_step_DOS = -1.0_dp, & + broadening_DOS = -1.0_dp ! parameters for LDOS calculation (LDOS: local density of states) - INTEGER :: int_ldos_xyz = -1 - INTEGER, DIMENSION(:), POINTER :: bin_mesh => NULL() - INTEGER :: n_bins_max_for_printing = -1 - REAL(KIND=dp) :: unit_ldos_int_z_inv_Ang2_eV = -1.0_dp + INTEGER :: int_ldos_xyz = -1 + INTEGER, DIMENSION(:), POINTER :: bin_mesh => NULL() + INTEGER :: n_bins_max_for_printing = -1 + REAL(KIND=dp) :: unit_ldos_int_z_inv_Ang2_eV = -1.0_dp + + ! quantities only needed for small cells and k-point sampling in DFT (small_cell_full_kp) + INTEGER :: nkp_scf_desymm = -1, & + nimages_3c = -1, & + nimages_scf_desymm = -1, & + nimages_Delta_R = -1 + TYPE(kpoint_type), POINTER :: kpoints_scf_desymm => NULL(), & + kpoints_scf_desymm_2 => NULL() + INTEGER, DIMENSION(3) :: cell_grid_scf_desymm = -1 + INTEGER, DIMENSION(:, :), ALLOCATABLE :: index_to_cell_3c, & + index_to_cell_Delta_R + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index_3c, & + cell_to_index_Delta_R + REAL(KIND=dp) :: heuristic_filter_factor = -1.0_dp + + ! small_cell_full_kp parallelization + INTEGER :: n_tasks_Delta_R_local = -1 + INTEGER, DIMENSION(:), ALLOCATABLE :: task_Delta_R + INTEGER, DIMENSION(:, :), ALLOCATABLE :: nblocks_3c + + ! full complex fm for k-dependent mo coefficients C_μn(k,spin,re/im) from SCF + TYPE(cp_fm_type), DIMENSION(:, :, :), ALLOCATABLE :: fm_mo_coeff_kp, & + fm_ks_kp, & + fm_s_kp + TYPE(cp_fm_type), DIMENSION(:), ALLOCATABLE :: fm_G_S, & + fm_Sigma_x_R + TYPE(cp_fm_type), DIMENSION(:, :), ALLOCATABLE :: fm_V_xc_R, & + fm_chi_R_t, & + fm_MWM_R_t + TYPE(cp_fm_type), DIMENSION(:, :, :), ALLOCATABLE :: fm_Sigma_c_R_neg_tau, & + fm_Sigma_c_R_pos_tau + REAL(KIND=dp), DIMENSION(:, :, :), ALLOCATABLE :: v_xc_n + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_int END TYPE post_scf_bandstructure_type @@ -289,26 +304,20 @@ SUBROUTINE bs_env_release(bs_env) CALL safe_kpoints_release(bs_env%kpoints_chi_eps_W) CALL safe_kpoints_release(bs_env%kpoints_DOS) - CALL safe_kpoints_release(bs_env%kpoints_bandstructure) + CALL safe_kpoints_release(bs_env%kpoints_scf_desymm) + CALL safe_kpoints_release(bs_env%kpoints_scf_desymm_2) IF (ALLOCATED(bs_env%wkp_s_p)) DEALLOCATE (bs_env%wkp_s_p) IF (ALLOCATED(bs_env%wkp_no_extra)) DEALLOCATE (bs_env%wkp_no_extra) IF (ALLOCATED(bs_env%l_RI)) DEALLOCATE (bs_env%l_RI) IF (ALLOCATED(bs_env%xkp_special)) DEALLOCATE (bs_env%xkp_special) - IF (ALLOCATED(bs_env%kp_special_name)) DEALLOCATE (bs_env%kp_special_name) - IF (ALLOCATED(bs_env%atoms_i_primitive_cell)) DEALLOCATE (bs_env%atoms_i_primitive_cell) - IF (ALLOCATED(bs_env%ref_atom_primitive_cell)) DEALLOCATE (bs_env%ref_atom_primitive_cell) - IF (ALLOCATED(bs_env%cell_of_i_atom)) DEALLOCATE (bs_env%cell_of_i_atom) IF (ALLOCATED(bs_env%imag_time_points)) DEALLOCATE (bs_env%imag_time_points) IF (ALLOCATED(bs_env%imag_freq_points)) DEALLOCATE (bs_env%imag_freq_points) IF (ALLOCATED(bs_env%eigenval_scf_Gamma)) DEALLOCATE (bs_env%eigenval_scf_Gamma) IF (ALLOCATED(bs_env%eigenval_scf)) DEALLOCATE (bs_env%eigenval_scf) IF (ALLOCATED(bs_env%eigenval_G0W0)) DEALLOCATE (bs_env%eigenval_G0W0) + IF (ALLOCATED(bs_env%eigenval_HF)) DEALLOCATE (bs_env%eigenval_HF) IF (ALLOCATED(bs_env%eigenval_scGW0)) DEALLOCATE (bs_env%eigenval_scGW0) - IF (ALLOCATED(bs_env%eigenval_prim_cell_scf)) DEALLOCATE (bs_env%eigenval_prim_cell_scf) - IF (ALLOCATED(bs_env%eigenval_prim_cell_scf_soc)) DEALLOCATE (bs_env%eigenval_prim_cell_scf_soc) - IF (ALLOCATED(bs_env%eigenval_prim_cell_G0W0)) DEALLOCATE (bs_env%eigenval_prim_cell_G0W0) - IF (ALLOCATED(bs_env%eigenval_prim_cell_G0W0_soc)) DEALLOCATE (bs_env%eigenval_prim_cell_G0W0_soc) IF (ALLOCATED(bs_env%eigenval_scf_soc)) DEALLOCATE (bs_env%eigenval_scf_soc) IF (ALLOCATED(bs_env%eigenval_G0W0_soc)) DEALLOCATE (bs_env%eigenval_G0W0_soc) IF (ALLOCATED(bs_env%i_ao_start_from_atom)) DEALLOCATE (bs_env%i_ao_start_from_atom) @@ -326,6 +335,12 @@ SUBROUTINE bs_env_release(bs_env) IF (ALLOCATED(bs_env%Sigma_c_exists)) DEALLOCATE (bs_env%Sigma_c_exists) IF (ALLOCATED(bs_env%sizes_AO)) DEALLOCATE (bs_env%sizes_AO) IF (ALLOCATED(bs_env%sizes_RI)) DEALLOCATE (bs_env%sizes_RI) + IF (ALLOCATED(bs_env%index_to_cell_3c)) DEALLOCATE (bs_env%index_to_cell_3c) + IF (ALLOCATED(bs_env%index_to_cell_Delta_R)) DEALLOCATE (bs_env%index_to_cell_Delta_R) + IF (ASSOCIATED(bs_env%cell_to_index_3c)) DEALLOCATE (bs_env%cell_to_index_3c) + IF (ASSOCIATED(bs_env%cell_to_index_Delta_R)) DEALLOCATE (bs_env%cell_to_index_Delta_R) + IF (ALLOCATED(bs_env%task_Delta_R)) DEALLOCATE (bs_env%task_Delta_R) + IF (ALLOCATED(bs_env%nblocks_3c)) DEALLOCATE (bs_env%nblocks_3c) CALL cp_fm_release(bs_env%fm_s_Gamma) CALL cp_fm_release(bs_env%fm_ks_Gamma(1)) @@ -345,7 +360,20 @@ SUBROUTINE bs_env_release(bs_env) CALL cp_fm_release(bs_env%fm_W_MIC_freq) CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_extra) CALL cp_fm_release(bs_env%fm_W_MIC_freq_1_no_extra) - CALL cp_fm_release(bs_env%fm_h_G0W0_Gamma) + CALL cp_cfm_release(bs_env%cfm_work_mo) + CALL cp_cfm_release(bs_env%cfm_work_mo_2) + + CALL safe_fm_destroy_1d(bs_env%fm_G_S) + CALL safe_fm_destroy_1d(bs_env%fm_Sigma_x_R) + CALL safe_fm_destroy_2d(bs_env%fm_V_xc_R) + CALL safe_fm_destroy_2d(bs_env%fm_chi_R_t) + CALL safe_fm_destroy_2d(bs_env%fm_MWM_R_t) + CALL safe_fm_destroy_3d(bs_env%fm_Sigma_c_R_neg_tau) + CALL safe_fm_destroy_3d(bs_env%fm_Sigma_c_R_pos_tau) + + IF (bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp) THEN + CALL t_destroy_2d(bs_env%t_3c_int) + END IF CALL release_dbcsr_p_type(bs_env%mat_ao_ao) CALL release_dbcsr_p_type(bs_env%mat_RI_RI) @@ -353,9 +381,10 @@ SUBROUTINE bs_env_release(bs_env) CALL release_dbcsr_p_type(bs_env%mat_ao_ao_tensor) CALL release_dbcsr_p_type(bs_env%mat_RI_RI_tensor) - CALL release_dbcsr_p_type(bs_env%mat_Sigma_from_Gocc_tensor) - CALL release_dbcsr_p_type(bs_env%mat_Sigma_from_Gvir_tensor) - CALL release_dbcsr_p_type(bs_env%mat_W_MIC_time_tensor) + + CALL safe_fm_destroy_3d(bs_env%fm_ks_kp) + CALL safe_fm_destroy_3d(bs_env%fm_s_kp) + CALL safe_fm_destroy_3d(bs_env%fm_mo_coeff_kp) CALL mp_para_env_release(bs_env%para_env) IF (ASSOCIATED(bs_env%para_env_tensor)) CALL mp_para_env_release(bs_env%para_env_tensor) @@ -369,7 +398,7 @@ SUBROUTINE bs_env_release(bs_env) IF (ALLOCATED(bs_env%basis_set_AO)) DEALLOCATE (bs_env%basis_set_AO) IF (ALLOCATED(bs_env%basis_set_RI)) DEALLOCATE (bs_env%basis_set_RI) - ! SOC matrices and arrays + ! SOC cfm_1d and arrays CALL safe_dbcsr_deallocate_matrix_set_2d(bs_env%mat_V_SOC_xyz) CALL cp_fm_release(bs_env%fm_V_SOC_xyz_mo(1)) CALL cp_fm_release(bs_env%fm_V_SOC_xyz_mo(2)) @@ -422,25 +451,104 @@ END SUBROUTINE safe_dbt_destroy ! ************************************************************************************************** !> \brief ... -!> \param dbcsr_p_type_matrix_array ... +!> \param dbcsr_array ... ! ************************************************************************************************** - SUBROUTINE safe_dbcsr_deallocate_matrix_set_1d(dbcsr_p_type_matrix_array) - - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: dbcsr_p_type_matrix_array + SUBROUTINE safe_dbcsr_deallocate_matrix_set_1d(dbcsr_array) + TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: dbcsr_array - IF (ASSOCIATED(dbcsr_p_type_matrix_array)) CALL dbcsr_deallocate_matrix_set(dbcsr_p_type_matrix_array) + IF (ASSOCIATED(dbcsr_array)) CALL dbcsr_deallocate_matrix_set(dbcsr_array) END SUBROUTINE safe_dbcsr_deallocate_matrix_set_1d + ! ************************************************************************************************** !> \brief ... -!> \param dbcsr_p_type_matrix_array ... +!> \param dbcsr_array ... ! ************************************************************************************************** - SUBROUTINE safe_dbcsr_deallocate_matrix_set_2d(dbcsr_p_type_matrix_array) - - TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: dbcsr_p_type_matrix_array + SUBROUTINE safe_dbcsr_deallocate_matrix_set_2d(dbcsr_array) + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: dbcsr_array - IF (ASSOCIATED(dbcsr_p_type_matrix_array)) CALL dbcsr_deallocate_matrix_set(dbcsr_p_type_matrix_array) + IF (ASSOCIATED(dbcsr_array)) CALL dbcsr_deallocate_matrix_set(dbcsr_array) END SUBROUTINE safe_dbcsr_deallocate_matrix_set_2d +! ************************************************************************************************** +!> \brief ... +!> \param fm_1d ... +! ************************************************************************************************** + SUBROUTINE safe_fm_destroy_1d(fm_1d) + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_1d + + INTEGER :: i + + IF (ALLOCATED(fm_1d)) THEN + DO i = 1, SIZE(fm_1d, 1) + CALL cp_fm_release(fm_1d(i)) + END DO + DEALLOCATE (fm_1d) + END IF + + END SUBROUTINE safe_fm_destroy_1d + +! ************************************************************************************************** +!> \brief ... +!> \param fm_2d ... +! ************************************************************************************************** + SUBROUTINE safe_fm_destroy_2d(fm_2d) + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :) :: fm_2d + + INTEGER :: i, j + + IF (ALLOCATED(fm_2d)) THEN + DO i = 1, SIZE(fm_2d, 1) + DO j = 1, SIZE(fm_2d, 2) + CALL cp_fm_release(fm_2d(i, j)) + END DO + END DO + DEALLOCATE (fm_2d) + END IF + + END SUBROUTINE safe_fm_destroy_2d + +! ************************************************************************************************** +!> \brief ... +!> \param fm_3d ... +! ************************************************************************************************** + SUBROUTINE safe_fm_destroy_3d(fm_3d) + TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:, :, :) :: fm_3d + + INTEGER :: i, j, k + + IF (ALLOCATED(fm_3d)) THEN + DO i = 1, SIZE(fm_3d, 1) + DO j = 1, SIZE(fm_3d, 2) + DO k = 1, SIZE(fm_3d, 3) + CALL cp_fm_release(fm_3d(i, j, k)) + END DO + END DO + END DO + DEALLOCATE (fm_3d) + END IF + + END SUBROUTINE safe_fm_destroy_3d + +! ************************************************************************************************** +!> \brief ... +!> \param t_2d ... +! ************************************************************************************************** + SUBROUTINE t_destroy_2d(t_2d) + TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_2d + + INTEGER :: i, j + + IF (ALLOCATED(t_2d)) THEN + DO i = 1, SIZE(t_2d, 1) + DO j = 1, SIZE(t_2d, 2) + CALL dbt_destroy(t_2d(i, j)) + END DO + END DO + END IF + DEALLOCATE (t_2d) + + END SUBROUTINE t_destroy_2d + END MODULE post_scf_bandstructure_types diff --git a/src/post_scf_bandstructure_utils.F b/src/post_scf_bandstructure_utils.F index 0d20ebf755..a8cfd95955 100644 --- a/src/post_scf_bandstructure_utils.F +++ b/src/post_scf_bandstructure_utils.F @@ -27,7 +27,8 @@ MODULE post_scf_bandstructure_utils cp_cfm_set_all,& cp_cfm_to_cfm,& cp_cfm_to_fm,& - cp_cfm_type + cp_cfm_type,& + cp_fm_to_cfm USE cp_control_types, ONLY: dft_control_type USE cp_dbcsr_api, ONLY: dbcsr_create,& dbcsr_p_type,& @@ -52,9 +53,9 @@ MODULE post_scf_bandstructure_utils cp_fm_type USE cp_log_handling, ONLY: cp_logger_get_default_io_unit USE cp_parser_methods, ONLY: read_float_object - USE gw_utils, ONLY: compute_xkp,& - kpoint_init_cell_index_simple - USE input_constants, ONLY: int_ldos_z + USE input_constants, ONLY: int_ldos_z,& + large_cell_Gamma,& + small_cell_full_kp USE input_section_types, ONLY: section_vals_get,& section_vals_get_subs_vals,& section_vals_type,& @@ -62,6 +63,7 @@ MODULE post_scf_bandstructure_utils USE kinds, ONLY: default_string_length,& dp,& max_line_length + USE kpoint_methods, ONLY: kpoint_init_cell_index USE kpoint_types, ONLY: get_kpoint_info,& kpoint_create,& kpoint_type @@ -70,8 +72,6 @@ MODULE post_scf_bandstructure_utils twopi,& z_one,& z_zero - USE mathlib, ONLY: complex_diag,& - inv_3x3 USE message_passing, ONLY: mp_para_env_type USE parallel_gemm_api, ONLY: parallel_gemm USE particle_types, ONLY: particle_type @@ -90,6 +90,7 @@ MODULE post_scf_bandstructure_utils USE qs_ks_types, ONLY: qs_ks_env_type USE qs_mo_types, ONLY: get_mo_set,& mo_set_type + USE qs_neighbor_list_types, ONLY: neighbor_list_set_p_type USE rpa_gw_im_time_util, ONLY: compute_weight_re_im,& get_atom_index_from_basis_function_index USE scf_control_types, ONLY: scf_control_type @@ -104,8 +105,8 @@ MODULE post_scf_bandstructure_utils PRIVATE PUBLIC :: create_and_init_bs_env, & - bandstructure_primitive_cell, bandstructure_primitive_cell_spinor, & - dos_pdos_ldos, cfm_ikp_from_fm_Gamma, get_fname, MIC_contribution_from_ikp + dos_pdos_ldos, cfm_ikp_from_fm_Gamma, get_fname, MIC_contribution_from_ikp, & + compute_xkp, kpoint_init_cell_index_simple CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'post_scf_bandstructure_utils' @@ -138,7 +139,19 @@ SUBROUTINE create_and_init_bs_env(qs_env, bs_env, post_scf_bandstructure_section CALL set_heuristic_parameters(bs_env) - CALL setup_kpoints_DOS(qs_env, bs_env, bs_env%kpoints_DOS) + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) + + CALL setup_kpoints_DOS_large_cell_Gamma(qs_env, bs_env, bs_env%kpoints_DOS) + + CASE (small_cell_full_kp) + + CALL setup_kpoints_scf_desymm(qs_env, bs_env, bs_env%kpoints_scf_desymm, .TRUE.) + CALL setup_kpoints_scf_desymm(qs_env, bs_env, bs_env%kpoints_scf_desymm_2, .FALSE.) + + CALL setup_kpoints_DOS_small_cell_full_kp(bs_env, bs_env%kpoints_DOS) + + END SELECT CALL allocate_and_fill_fm_ks_fm_s(qs_env, bs_env) @@ -146,11 +159,6 @@ SUBROUTINE create_and_init_bs_env(qs_env, bs_env, post_scf_bandstructure_section CALL check_positive_definite_overlap_mat(bs_env, qs_env) - IF (bs_env%do_bs) THEN - CALL setup_kpoints_bandstructure(bs_env, bs_env%kpoints_bandstructure) - CALL setup_primitive_cell_for_bandstructure(qs_env, bs_env) - END IF - CALL timestop(handle) END SUBROUTINE create_and_init_bs_env @@ -198,17 +206,14 @@ SUBROUTINE read_bandstructure_input_parameters(bs_env, bs_sec) NULLIFY (kp_bs_sec) kp_bs_sec => section_vals_get_subs_vals(bs_sec, "BANDSTRUCTURE_PATH") - CALL section_vals_get(kp_bs_sec, explicit=bs_env%do_bs) CALL section_vals_val_get(kp_bs_sec, "NPOINTS", i_val=bs_env%input_kp_bs_npoints) CALL section_vals_val_get(kp_bs_sec, "SPECIAL_POINT", n_rep_val=bs_env%input_kp_bs_n_sp_pts) ! read special points for band structure ALLOCATE (bs_env%xkp_special(3, bs_env%input_kp_bs_n_sp_pts)) - ALLOCATE (bs_env%kp_special_name(bs_env%input_kp_bs_n_sp_pts)) DO ikp = 1, bs_env%input_kp_bs_n_sp_pts CALL section_vals_val_get(kp_bs_sec, "SPECIAL_POINT", i_rep_val=ikp, c_vals=string_ptr) CPASSERT(SIZE(string_ptr(:), 1) == 4) - bs_env%kp_special_name(ikp) = string_ptr(1) DO i = 1, 3 CALL read_float_object(string_ptr(i + 1), bs_env%xkp_special(i, ikp), error_msg) IF (LEN_TRIM(error_msg) > 0) CPABORT(TRIM(error_msg)) @@ -262,15 +267,18 @@ END SUBROUTINE print_header !> \param bs_env ... !> \param kpoints ... ! ************************************************************************************************** - SUBROUTINE setup_kpoints_DOS(qs_env, bs_env, kpoints) + SUBROUTINE setup_kpoints_DOS_large_cell_Gamma(qs_env, bs_env, kpoints) TYPE(qs_environment_type), POINTER :: qs_env TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(kpoint_type), POINTER :: kpoints - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_DOS' + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_DOS_large_cell_Gamma' - INTEGER :: handle, i_dim, nkp, u + INTEGER :: handle, i_dim, i_kp_in_line, & + i_special_kp, ikk, n_kp_in_line, & + n_special_kp, nkp, nkp_only_bs, & + nkp_only_DOS, u INTEGER, DIMENSION(3) :: nkp_grid, periodic CALL timeset(routineN, handle) @@ -281,6 +289,9 @@ SUBROUTINE setup_kpoints_DOS(qs_env, bs_env, kpoints) kpoints%kp_scheme = "GENERAL" + n_special_kp = bs_env%input_kp_bs_n_sp_pts + n_kp_in_line = bs_env%input_kp_bs_npoints + periodic(1:3) = bs_env%periodic(1:3) DO i_dim = 1, 3 @@ -298,52 +309,175 @@ SUBROUTINE setup_kpoints_DOS(qs_env, bs_env, kpoints) ! use the k <-> -k symmetry to reduce the number of kpoints IF (nkp_grid(1) > 1) THEN - nkp = (nkp_grid(1) + 1)/2*nkp_grid(2)*nkp_grid(3) + nkp_only_DOS = (nkp_grid(1) + 1)/2*nkp_grid(2)*nkp_grid(3) ELSE IF (nkp_grid(2) > 1) THEN - nkp = nkp_grid(1)*(nkp_grid(2) + 1)/2*nkp_grid(3) + nkp_only_DOS = nkp_grid(1)*(nkp_grid(2) + 1)/2*nkp_grid(3) ELSE IF (nkp_grid(3) > 1) THEN - nkp = nkp_grid(1)*nkp_grid(2)*(nkp_grid(3) + 1)/2 + nkp_only_DOS = nkp_grid(1)*nkp_grid(2)*(nkp_grid(3) + 1)/2 + ELSE + nkp_only_DOS = 1 + END IF + + ! we will compute the GW QP levels for all k's in the bandstructure path but also + ! for all k-points from the SCF (e.g. for DOS or for self-consistent GW) + IF (n_special_kp > 0) THEN + nkp_only_bs = n_kp_in_line*(n_special_kp - 1) + 1 ELSE - nkp = 1 + nkp_only_bs = 0 END IF + nkp = nkp_only_DOS + nkp_only_bs + kpoints%nkp_grid(1:3) = nkp_grid(1:3) kpoints%nkp = nkp - bs_env%nkp_DOS = nkp + bs_env%nkp_bs_and_DOS = nkp + bs_env%nkp_only_bs = nkp_only_bs + bs_env%nkp_only_DOS = nkp_only_DOS ALLOCATE (kpoints%xkp(3, nkp), kpoints%wkp(nkp)) - kpoints%wkp(1:nkp) = 1.0_dp/REAL(nkp, KIND=dp) - - CALL compute_xkp(kpoints%xkp, 1, nkp, nkp_grid) + kpoints%wkp(1:nkp_only_DOS) = 1.0_dp/REAL(nkp_only_DOS, KIND=dp) + + CALL compute_xkp(kpoints%xkp, 1, nkp_only_DOS, nkp_grid) + + IF (n_special_kp > 0) THEN + kpoints%xkp(1:3, nkp_only_DOS + 1) = bs_env%xkp_special(1:3, 1) + ikk = nkp_only_DOS + 1 + DO i_special_kp = 2, n_special_kp + DO i_kp_in_line = 1, n_kp_in_line + ikk = ikk + 1 + kpoints%xkp(1:3, ikk) = bs_env%xkp_special(1:3, i_special_kp - 1) + & + REAL(i_kp_in_line, KIND=dp)/REAL(n_kp_in_line, KIND=dp)* & + (bs_env%xkp_special(1:3, i_special_kp) - & + bs_env%xkp_special(1:3, i_special_kp - 1)) + kpoints%wkp(ikk) = 0.0_dp + END DO + END DO + END IF CALL kpoint_init_cell_index_simple(kpoints, qs_env) u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,1A,T69,3I4)") "K-point mesh for the density of states (DOS)", & - nkp_grid(1:3) + IF (nkp_only_bs > 0) THEN + WRITE (u, FMT="(T2,1A,T77,I4)") & + "Number of special k-points for the bandstructure", n_special_kp + WRITE (u, FMT="(T2,1A,T77,I4)") "Number of k-points for the bandstructure", nkp + WRITE (u, FMT="(T2,1A,T69,3I4)") & + "K-point mesh for the density of states (DOS)", nkp_grid(1:3) + ELSE + WRITE (u, FMT="(T2,1A,T69,3I4)") & + "K-point mesh for the density of states (DOS) and the self-energy", nkp_grid(1:3) + END IF END IF CALL timestop(handle) - END SUBROUTINE setup_kpoints_DOS + END SUBROUTINE setup_kpoints_DOS_large_cell_Gamma ! ************************************************************************************************** !> \brief ... +!> \param qs_env ... !> \param bs_env ... !> \param kpoints ... +!> \param do_print ... ! ************************************************************************************************** - SUBROUTINE setup_kpoints_bandstructure(bs_env, kpoints) + SUBROUTINE setup_kpoints_scf_desymm(qs_env, bs_env, kpoints, do_print) + TYPE(qs_environment_type), POINTER :: qs_env + TYPE(post_scf_bandstructure_type), POINTER :: bs_env + TYPE(kpoint_type), POINTER :: kpoints + + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_scf_desymm' + + INTEGER :: handle, i_cell_x, i_dim, img, j_cell_y, & + k_cell_z, nimages, nkp, u + INTEGER, DIMENSION(3) :: cell_grid, cixd, nkp_grid + TYPE(kpoint_type), POINTER :: kpoints_scf + + LOGICAL:: do_print + + CALL timeset(routineN, handle) + + NULLIFY (kpoints) + CALL kpoint_create(kpoints) + + CALL get_qs_env(qs_env=qs_env, kpoints=kpoints_scf) + + nkp_grid(1:3) = kpoints_scf%nkp_grid(1:3) + nkp = nkp_grid(1)*nkp_grid(2)*nkp_grid(3) + + ! we need in periodic directions at least 4 k-points in the SCF + DO i_dim = 1, 3 + IF (bs_env%periodic(i_dim) == 1) THEN + CPASSERT(nkp_grid(i_dim) .GE. 4) + END IF + END DO + + kpoints%kp_scheme = "GENERAL" + kpoints%nkp_grid(1:3) = nkp_grid(1:3) + kpoints%nkp = nkp + bs_env%nkp_scf_desymm = nkp + + ALLOCATE (kpoints%xkp(1:3, nkp)) + CALL compute_xkp(kpoints%xkp, 1, nkp, nkp_grid) + + ALLOCATE (kpoints%wkp(nkp)) + kpoints%wkp(:) = 1.0_dp/REAL(nkp, KIND=dp) + + ! for example 4x3x6 kpoint grid -> 3x3x5 cell grid because we need the same number of + ! neighbor cells on both sides of the unit cell + cell_grid(1:3) = nkp_grid(1:3) - MODULO(nkp_grid(1:3) + 1, 2) + + ! cell index: for example for x: from -n_x/2 to +n_x/2, n_x: number of cells in x direction + cixd(1:3) = cell_grid(1:3)/2 + + nimages = cell_grid(1)*cell_grid(2)*cell_grid(3) + + bs_env%nimages_scf_desymm = nimages + bs_env%cell_grid_scf_desymm(1:3) = cell_grid(1:3) + + IF (ASSOCIATED(kpoints%index_to_cell)) DEALLOCATE (kpoints%index_to_cell) + IF (ASSOCIATED(kpoints%cell_to_index)) DEALLOCATE (kpoints%cell_to_index) + + ALLOCATE (kpoints%cell_to_index(-cixd(1):cixd(1), -cixd(2):cixd(2), -cixd(3):cixd(3))) + ALLOCATE (kpoints%index_to_cell(nimages, 3)) + + img = 0 + DO i_cell_x = -cixd(1), cixd(1) + DO j_cell_y = -cixd(2), cixd(2) + DO k_cell_z = -cixd(3), cixd(3) + img = img + 1 + kpoints%cell_to_index(i_cell_x, j_cell_y, k_cell_z) = img + kpoints%index_to_cell(img, 1:3) = (/i_cell_x, j_cell_y, k_cell_z/) + END DO + END DO + END DO + + u = bs_env%unit_nr + IF (u > 0 .AND. do_print) THEN + WRITE (u, FMT="(T2,A,I49)") "Number of cells for G, χ, W, Σ", nimages + END IF + + CALL timestop(handle) + + END SUBROUTINE setup_kpoints_scf_desymm + +! ************************************************************************************************** +!> \brief ... +!> \param bs_env ... +!> \param kpoints ... +! ************************************************************************************************** + SUBROUTINE setup_kpoints_DOS_small_cell_full_kp(bs_env, kpoints) TYPE(post_scf_bandstructure_type), POINTER :: bs_env TYPE(kpoint_type), POINTER :: kpoints - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_bandstructure' + CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_kpoints_DOS_small_cell_full_kp' INTEGER :: handle, i_kp_in_line, i_special_kp, ikk, & - n_kp_in_line, n_special_kp, nkp, u + n_kp_in_line, n_special_kp, nkp, & + nkp_only_bs, nkp_scf_desymm, u CALL timeset(routineN, handle) @@ -353,44 +487,60 @@ SUBROUTINE setup_kpoints_bandstructure(bs_env, kpoints) n_special_kp = bs_env%input_kp_bs_n_sp_pts n_kp_in_line = bs_env%input_kp_bs_npoints + nkp_scf_desymm = bs_env%nkp_scf_desymm - nkp = n_kp_in_line*(n_special_kp - 1) + 1 - - IF (n_special_kp < 1) & - CPABORT("Please specify special k-points in the Brillouin zone via SPECIAL_POINT.") - IF (n_kp_in_line < 1) & - CPABORT("Please specify the number of k-points between special k-points.") + ! we will compute the GW QP levels for all k's in the bandstructure path but also + ! for all k-points from the SCF (e.g. for DOS or for self-consistent GW) + IF (n_special_kp > 0) THEN + nkp_only_bs = n_kp_in_line*(n_special_kp - 1) + 1 + ELSE + nkp_only_bs = 0 + END IF + nkp = nkp_only_bs + nkp_scf_desymm ALLOCATE (kpoints%xkp(3, nkp)) + ALLOCATE (kpoints%wkp(nkp)) kpoints%nkp = nkp - kpoints%xkp(1:3, 1) = bs_env%xkp_special(1:3, 1) - bs_env%nkp_bs = nkp + bs_env%nkp_bs_and_DOS = nkp + bs_env%nkp_only_bs = nkp_only_bs + bs_env%nkp_only_DOS = nkp_scf_desymm + + kpoints%xkp(1:3, 1:nkp_scf_desymm) = bs_env%kpoints_scf_desymm%xkp(1:3, 1:nkp_scf_desymm) + kpoints%wkp(1:nkp_scf_desymm) = 1.0_dp/REAL(nkp_scf_desymm, KIND=dp) + + IF (n_special_kp > 0) THEN + kpoints%xkp(1:3, nkp_scf_desymm + 1) = bs_env%xkp_special(1:3, 1) + ikk = nkp_scf_desymm + 1 + DO i_special_kp = 2, n_special_kp + DO i_kp_in_line = 1, n_kp_in_line + ikk = ikk + 1 + kpoints%xkp(1:3, ikk) = bs_env%xkp_special(1:3, i_special_kp - 1) + & + REAL(i_kp_in_line, KIND=dp)/REAL(n_kp_in_line, KIND=dp)* & + (bs_env%xkp_special(1:3, i_special_kp) - & + bs_env%xkp_special(1:3, i_special_kp - 1)) + kpoints%wkp(ikk) = 0.0_dp + END DO + END DO + END IF - ikk = 1 + IF (ASSOCIATED(kpoints%index_to_cell)) DEALLOCATE (kpoints%index_to_cell) - DO i_special_kp = 2, n_special_kp - DO i_kp_in_line = 1, n_kp_in_line - ikk = ikk + 1 - kpoints%xkp(1:3, ikk) = bs_env%xkp_special(1:3, i_special_kp - 1) + & - REAL(i_kp_in_line, KIND=dp)/REAL(n_kp_in_line, KIND=dp)* & - (bs_env%xkp_special(1:3, i_special_kp) - & - bs_env%xkp_special(1:3, i_special_kp - 1)) - END DO - END DO + ALLOCATE (kpoints%index_to_cell(bs_env%nimages_scf_desymm, 3)) + kpoints%index_to_cell(:, :) = bs_env%kpoints_scf_desymm%index_to_cell(:, :) u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,1A,T77,I4)") "Number of special k-points for the bandstructure", & + WRITE (u, FMT="(T2,1A,T77,I4)") "Number of special k-points for the bandstructure", & n_special_kp - WRITE (UNIT=u, FMT="(T2,1A,T77,I4)") "Number of k-points for the bandstructure", nkp + WRITE (u, FMT="(T2,1A,T77,I4)") "Number of k-points for the bandstructure", nkp END IF CALL timestop(handle) - END SUBROUTINE setup_kpoints_bandstructure + END SUBROUTINE setup_kpoints_DOS_small_cell_full_kp ! ************************************************************************************************** !> \brief ... @@ -467,14 +617,14 @@ SUBROUTINE check_positive_definite_overlap_mat(bs_env, qs_env) u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,A)") "" - WRITE (UNIT=u, FMT="(T2,A)") "ERROR: The Cholesky decomposition "// & + WRITE (u, FMT="(T2,A)") "" + WRITE (u, FMT="(T2,A)") "ERROR: The Cholesky decomposition "// & "of the k-point overlap matrix failed. This is" - WRITE (UNIT=u, FMT="(T2,A)") "because the algorithm is "// & + WRITE (u, FMT="(T2,A)") "because the algorithm is "// & "only correct in the limit of large cells. The cell of " - WRITE (UNIT=u, FMT="(T2,A)") "the calculation is too small. "// & + WRITE (u, FMT="(T2,A)") "the calculation is too small. "// & "Use MULTIPLE_UNIT_CELL to create a larger cell " - WRITE (UNIT=u, FMT="(T2,A)") "and to prevent this error." + WRITE (u, FMT="(T2,A)") "and to prevent this error." END IF CALL bs_env%para_env%sync() @@ -550,15 +700,27 @@ SUBROUTINE get_parameters_from_qs_env(qs_env, bs_env) CALL get_cell(cell=cell, periodic=periodic, h=hmat) bs_env%periodic(1:3) = periodic(1:3) bs_env%hmat(1:3, 1:3) = hmat + bs_env%nimages_scf = dft_control%nimages + IF (dft_control%nimages == 1) THEN + bs_env%small_cell_full_kp_or_large_cell_Gamma = large_cell_Gamma + ELSE IF (dft_control%nimages > 1) THEN + bs_env%small_cell_full_kp_or_large_cell_Gamma = small_cell_full_kp + ELSE + CPABORT("Wrong number of cells from DFT calculation.") + END IF u = bs_env%unit_nr IF (u > 0) THEN - WRITE (UNIT=u, FMT="(T2,2A,T73,I8)") "Number of occupied molecular orbitals (MOs) ", & + WRITE (u, FMT="(T2,2A,T73,I8)") "Number of occupied molecular orbitals (MOs) ", & "= Number of occupied bands", homo - WRITE (UNIT=u, FMT="(T2,2A,T73,I8)") "Number of unoccupied (= virtual) MOs ", & + WRITE (u, FMT="(T2,2A,T73,I8)") "Number of unoccupied (= virtual) MOs ", & "= Number of unoccupied bands", n_ao - homo - WRITE (UNIT=u, FMT="(T2,A,T73,I8)") "Number of Gaussian basis functions for MOs", n_ao + WRITE (u, FMT="(T2,A,T73,I8)") "Number of Gaussian basis functions for MOs", n_ao + IF (bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp) THEN + WRITE (u, FMT="(T2,2A,T73,I8)") "Number of cells considered in the DFT ", & + "calculation", bs_env%nimages_scf + END IF END IF CALL timestop(handle) @@ -598,7 +760,7 @@ SUBROUTINE allocate_and_fill_fm_ks_fm_s(qs_env, bs_env) INTEGER :: handle, i_work, ispin TYPE(cp_blacs_env_type), POINTER :: blacs_env TYPE(cp_fm_struct_type), POINTER :: fm_struct - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_ks, matrix_s + TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks, matrix_s TYPE(mp_para_env_type), POINTER :: para_env CALL timeset(routineN, handle) @@ -606,8 +768,8 @@ SUBROUTINE allocate_and_fill_fm_ks_fm_s(qs_env, bs_env) CALL get_qs_env(qs_env, & para_env=para_env, & blacs_env=blacs_env, & - matrix_ks=matrix_ks, & - matrix_s=matrix_s) + matrix_ks_kp=matrix_ks, & + matrix_s_kp=matrix_s) NULLIFY (fm_struct) CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=bs_env%n_ao, & @@ -617,12 +779,15 @@ SUBROUTINE allocate_and_fill_fm_ks_fm_s(qs_env, bs_env) CALL cp_fm_create(bs_env%fm_work_mo(i_work), fm_struct) END DO + CALL cp_cfm_create(bs_env%cfm_work_mo, fm_struct) + CALL cp_cfm_create(bs_env%cfm_work_mo_2, fm_struct) + CALL cp_fm_create(bs_env%fm_s_Gamma, fm_struct) - CALL copy_dbcsr_to_fm(matrix_s(1)%matrix, bs_env%fm_s_Gamma) + CALL copy_dbcsr_to_fm(matrix_s(1, 1)%matrix, bs_env%fm_s_Gamma) DO ispin = 1, bs_env%n_spin CALL cp_fm_create(bs_env%fm_ks_Gamma(ispin), fm_struct) - CALL copy_dbcsr_to_fm(matrix_ks(ispin)%matrix, bs_env%fm_ks_Gamma(ispin)) + CALL copy_dbcsr_to_fm(matrix_ks(ispin, 1)%matrix, bs_env%fm_ks_Gamma(ispin)) CALL cp_fm_create(bs_env%fm_mo_coeff_Gamma(ispin), fm_struct) END DO @@ -630,706 +795,15 @@ SUBROUTINE allocate_and_fill_fm_ks_fm_s(qs_env, bs_env) NULLIFY (bs_env%mat_ao_ao%matrix) ALLOCATE (bs_env%mat_ao_ao%matrix) - CALL dbcsr_create(bs_env%mat_ao_ao%matrix, template=matrix_s(1)%matrix, & + CALL dbcsr_create(bs_env%mat_ao_ao%matrix, template=matrix_s(1, 1)%matrix, & matrix_type=dbcsr_type_no_symmetry) - ALLOCATE (bs_env%eigenval_scf(bs_env%n_ao, bs_env%nkp_DOS, bs_env%n_spin)) + ALLOCATE (bs_env%eigenval_scf(bs_env%n_ao, bs_env%nkp_bs_and_DOS, bs_env%n_spin)) CALL timestop(handle) END SUBROUTINE allocate_and_fill_fm_ks_fm_s -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param bs_env ... -! ************************************************************************************************** - SUBROUTINE setup_primitive_cell_for_bandstructure(qs_env, bs_env) - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'setup_primitive_cell_for_bandstructure' - - INTEGER :: handle, i_atom, i_x_cell, index_j, j_atom, j_atom_prim_cell, j_y_cell, k_z_cell, & - n_atom, n_atom_in_primitive_cell, n_max_check, n_max_x, n_max_y, n_max_z, & - n_mult_unit_cell_x, n_mult_unit_cell_y, n_mult_unit_cell_z, n_primitive_cells, n_x, n_y, & - n_z - INTEGER, ALLOCATABLE, DIMENSION(:) :: kind_of - LOGICAL :: i_atom_has_image_in_every_subcell, i_atom_has_image_in_subcell_ijk - LOGICAL, ALLOCATABLE, DIMENSION(:, :, :) :: valid_multiple_unit_cell - REAL(dp), DIMENSION(3) :: center_primitive_cell, coord_ijk, coord_sub_cell_ijk, & - index_atom_i, index_ijk, index_sub_cell_ijk, offset, ra, ra_ijk, rab, rb - REAL(KIND=dp) :: dab - REAL(KIND=dp), DIMENSION(3, 3) :: hmat - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(cell_type), POINTER :: cell - TYPE(particle_type), DIMENSION(:), POINTER :: particle_set - - CALL timeset(routineN, handle) - - CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, particle_set=particle_set, cell=cell) - CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of) - CALL get_cell(cell=cell, h=hmat) - - ! automatically check structure for smallest possible unit cell - n_max_check = 20 - n_max_x = n_max_check*bs_env%periodic(1) + 1 - n_max_y = n_max_check*bs_env%periodic(2) + 1 - n_max_z = n_max_check*bs_env%periodic(3) + 1 - - ALLOCATE (valid_multiple_unit_cell(n_max_x, n_max_y, n_max_z)) - valid_multiple_unit_cell(:, :, :) = .TRUE. - - n_atom = bs_env%n_atom - - DO i_atom = 1, n_atom - - IF (.NOT. MODULO(i_atom, bs_env%para_env%num_pe) == bs_env%para_env%mepos) CYCLE - - ra(1:3) = particle_set(i_atom)%r(1:3) - - DO n_x = 1, n_max_x - DO n_y = 1, n_max_y - DO n_z = 1, n_max_z - - i_atom_has_image_in_every_subcell = .TRUE. - - DO i_x_cell = 0, n_x - 1 - DO j_y_cell = 0, n_y - 1 - DO k_z_cell = 0, n_z - 1 - - i_atom_has_image_in_subcell_ijk = .FALSE. - - DO j_atom = 1, n_atom - - IF (kind_of(i_atom) .NE. kind_of(j_atom)) CYCLE - - IF (i_atom_has_image_in_subcell_ijk) CYCLE - - IF (.NOT. i_atom_has_image_in_every_subcell) CYCLE - - index_sub_cell_ijk(1:3) = (/REAL(i_x_cell, dp)/REAL(n_x, dp), & - REAL(j_y_cell, dp)/REAL(n_y, dp), & - REAL(k_z_cell, dp)/REAL(n_z, dp)/) - - coord_sub_cell_ijk(1:3) = MATMUL(hmat, index_sub_cell_ijk) - - ra_ijk(1:3) = ra(1:3) + coord_sub_cell_ijk(1:3) - - rb(1:3) = pbc(particle_set(j_atom)%r(1:3), cell) - - rab(1:3) = rb(1:3) - pbc(ra_ijk(1:3), cell) - - dab = SQRT((rab(1))**2 + (rab(2))**2 + (rab(3))**2) - - IF (dab < 1.0E-5) i_atom_has_image_in_subcell_ijk = .TRUE. - - END DO - - IF (.NOT. i_atom_has_image_in_subcell_ijk) THEN - i_atom_has_image_in_every_subcell = .FALSE. - END IF - - END DO - END DO - END DO - - ! a valid multiple unit cell must be valid for all atoms - valid_multiple_unit_cell(n_x, n_y, n_z) = i_atom_has_image_in_every_subcell .AND. & - valid_multiple_unit_cell(n_x, n_y, n_z) - - END DO - END DO - END DO - - END DO - - CALL mpi_AND(valid_multiple_unit_cell, bs_env%para_env) - - n_mult_unit_cell_x = 1 - n_mult_unit_cell_y = 1 - n_mult_unit_cell_z = 1 - - DO n_x = 1, n_max_x - DO n_y = 1, n_max_y - DO n_z = 1, n_max_z - IF (valid_multiple_unit_cell(n_x, n_y, n_z)) THEN - n_mult_unit_cell_x = MAX(n_mult_unit_cell_x, n_x) - n_mult_unit_cell_y = MAX(n_mult_unit_cell_y, n_y) - n_mult_unit_cell_z = MAX(n_mult_unit_cell_z, n_z) - END IF - END DO - END DO - END DO - - bs_env%multiple_unit_cell(1) = n_mult_unit_cell_x - bs_env%multiple_unit_cell(2) = n_mult_unit_cell_y - bs_env%multiple_unit_cell(3) = n_mult_unit_cell_z - - IF (n_mult_unit_cell_x .NE. 1 .OR. & - n_mult_unit_cell_y .NE. 1 .OR. & - n_mult_unit_cell_z .NE. 1) THEN - bs_env%calculate_bandstructure_of_primitive_cell = .TRUE. - ELSE - bs_env%calculate_bandstructure_of_primitive_cell = .FALSE. - END IF - - n_atom_in_primitive_cell = n_atom/n_mult_unit_cell_x/n_mult_unit_cell_y/n_mult_unit_cell_z - bs_env%n_atom_in_primitive_cell = n_atom_in_primitive_cell - - n_primitive_cells = n_atom/n_atom_in_primitive_cell - bs_env%n_primitive_cells = n_primitive_cells - - bs_env%hmat_primitive_cell(1, 1:3) = hmat(1, 1:3)/REAL(n_mult_unit_cell_x) - bs_env%hmat_primitive_cell(2, 1:3) = hmat(2, 1:3)/REAL(n_mult_unit_cell_y) - bs_env%hmat_primitive_cell(3, 1:3) = hmat(3, 1:3)/REAL(n_mult_unit_cell_z) - - bs_env%hinv_primitive_cell = inv_3x3(bs_env%hmat_primitive_cell) - - bs_env%do_bs_primitive_cell = bs_env%do_bs .AND. n_atom_in_primitive_cell < 20 & - .AND. n_primitive_cells > 1 - - ALLOCATE (bs_env%atoms_i_primitive_cell(n_atom_in_primitive_cell)) - bs_env%atoms_i_primitive_cell(:) = 0 - - ! just a small offset to avoid that atoms are precisely on egdes or faces - offset(1:3) = MATMUL(bs_env%hmat_primitive_cell, (/0.001_dp, 0.001_dp, 0.001_dp/)) - center_primitive_cell(1:3) = pbc(particle_set(1)%r(1:3), cell) - offset(1:3) - - index_j = 0 - DO i_atom = 1, n_atom - - rb(1:3) = pbc(particle_set(i_atom)%r(1:3), cell) - center_primitive_cell(1:3) - - index_atom_i(1:3) = MATMUL(bs_env%hinv_primitive_cell, rb) - - IF (index_atom_i(1) > -0.5_dp .AND. index_atom_i(1) < 0.5_dp .AND. & - index_atom_i(2) > -0.5_dp .AND. index_atom_i(2) < 0.5_dp .AND. & - index_atom_i(3) > -0.5_dp .AND. index_atom_i(3) < 0.5_dp) THEN - - index_j = index_j + 1 - CPASSERT(index_j .LE. n_atom_in_primitive_cell) - bs_env%atoms_i_primitive_cell(index_j) = i_atom - - END IF - - END DO - - ALLOCATE (bs_env%ref_atom_primitive_cell(n_atom)) - ALLOCATE (bs_env%cell_of_i_atom(n_atom, 3)) - - DO i_atom = 1, n_atom - - ra(1:3) = pbc(particle_set(i_atom)%r(1:3), cell) - - DO j_atom_prim_cell = 1, n_atom_in_primitive_cell - - j_atom = bs_env%atoms_i_primitive_cell(j_atom_prim_cell) - - rb(1:3) = pbc(particle_set(j_atom)%r(1:3), cell) - - DO i_x_cell = -n_mult_unit_cell_x/2, n_mult_unit_cell_x/2 - DO j_y_cell = -n_mult_unit_cell_y/2, n_mult_unit_cell_y/2 - DO k_z_cell = -n_mult_unit_cell_z/2, n_mult_unit_cell_z/2 - - index_ijk(1:3) = (/REAL(i_x_cell, dp), REAL(j_y_cell, dp), REAL(k_z_cell, dp)/) - coord_ijk(1:3) = MATMUL(bs_env%hmat_primitive_cell, index_ijk) - - ra_ijk(1:3) = ra(1:3) + coord_ijk(1:3) - - rab(1:3) = rb(1:3) - pbc(ra_ijk(1:3), cell) - - dab = SQRT((rab(1))**2 + (rab(2))**2 + (rab(3))**2) - - IF (dab < 1.0E-5) THEN - bs_env%ref_atom_primitive_cell(i_atom) = j_atom - bs_env%cell_of_i_atom(i_atom, 1) = i_x_cell - bs_env%cell_of_i_atom(i_atom, 2) = j_y_cell - bs_env%cell_of_i_atom(i_atom, 3) = k_z_cell - END IF - - END DO - END DO - END DO - END DO - END DO - IF (bs_env%unit_nr > 0 .AND. bs_env%calculate_bandstructure_of_primitive_cell) THEN - WRITE (bs_env%unit_nr, '(T2,A,3I4)') & - 'Detected a multiple unit cell (will be used for band structure) ', & - bs_env%multiple_unit_cell - WRITE (bs_env%unit_nr, '(T2,A,I28)') & - 'Number of occupied bands in the primitive unit cell', & - bs_env%n_occ(1)/bs_env%n_primitive_cells - WRITE (bs_env%unit_nr, '(T2,A,I26)') & - 'Number of unoccupied bands in the primitive unit cell', & - bs_env%n_vir(1)/bs_env%n_primitive_cells - END IF - - CALL timestop(handle) - - END SUBROUTINE setup_primitive_cell_for_bandstructure - -! ************************************************************************************************** -!> \brief ... -!> \param logical_array_3d ... -!> \param para_env ... -! ************************************************************************************************** - SUBROUTINE mpi_AND(logical_array_3d, para_env) - LOGICAL, ALLOCATABLE, DIMENSION(:, :, :) :: logical_array_3d - TYPE(mp_para_env_type), POINTER :: para_env - - CHARACTER(LEN=*), PARAMETER :: routineN = 'mpi_AND' - - INTEGER :: handle, i, j, k, n_1, n_2, n_3 - INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: integer_array_3d - - CALL timeset(routineN, handle) - - n_1 = SIZE(logical_array_3d, 1) - n_2 = SIZE(logical_array_3d, 2) - n_3 = SIZE(logical_array_3d, 3) - - ALLOCATE (integer_array_3d(n_1, n_2, n_3)) - integer_array_3d(:, :, :) = 0 - - DO i = 1, n_1 - DO j = 1, n_2 - DO k = 1, n_3 - IF (logical_array_3d(i, j, k)) integer_array_3d(i, j, k) = 1 - END DO - END DO - END DO - - CALL para_env%sync() - CALL para_env%sum(integer_array_3d) - CALL para_env%sync() - - logical_array_3d(:, :, :) = .FALSE. - - DO i = 1, n_1 - DO j = 1, n_2 - DO k = 1, n_3 - IF (integer_array_3d(i, j, k) == para_env%num_pe) logical_array_3d(i, j, k) = .TRUE. - END DO - END DO - END DO - - CALL timestop(handle) - - END SUBROUTINE mpi_AND - -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param bs_env ... -!> \param eigenvalues ... -!> \param filename ... -!> \param fm_h_Gamma ... -! ************************************************************************************************** - SUBROUTINE bandstructure_primitive_cell(qs_env, bs_env, eigenvalues, filename, fm_h_Gamma) - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: eigenvalues - CHARACTER(LEN=*) :: filename - TYPE(cp_fm_type) :: fm_h_Gamma - - CHARACTER(LEN=*), PARAMETER :: routineN = 'bandstructure_primitive_cell' - - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: h_munu_k, mo_coeff_k, s_munu_k - INTEGER :: col_global, handle, i, i_atom, i_dim, i_row, ikp, imo, ip, iunit, j, j_atom, & - j_col, n_ao, n_ao_primitive_cell, n_atom, ncol_local, nrow_local, ref_atom_j, row_global - INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_from_bf, first_bf_from_atom, & - first_bf_of_primit_atom - INTEGER, DIMENSION(3) :: cell_atom_i, cell_atom_j, min_max_cell - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - REAL(KIND=dp) :: arg - - CALL timeset(routineN, handle) - - n_ao = bs_env%n_ao - n_ao_primitive_cell = n_ao/bs_env%n_primitive_cells - n_atom = bs_env%n_atom - - ALLOCATE (h_munu_k(n_ao_primitive_cell, n_ao_primitive_cell)) - ALLOCATE (s_munu_k(n_ao_primitive_cell, n_ao_primitive_cell)) - ALLOCATE (mo_coeff_k(n_ao_primitive_cell, n_ao_primitive_cell)) - ALLOCATE (eigenvalues(n_ao_primitive_cell, bs_env%nkp_bs)) - - ALLOCATE (atom_from_bf(n_ao)) - ALLOCATE (first_bf_from_atom(n_atom)) - CALL get_atom_index_from_basis_function_index(qs_env, atom_from_bf, n_ao, "ORB", & - first_bf_from_atom) - - ALLOCATE (first_bf_of_primit_atom(n_atom)) - CALL get_basis_function_index_of_primitive_atoms(bs_env, first_bf_of_primit_atom, & - first_bf_from_atom) - - IF (bs_env%para_env%is_source()) THEN - CALL open_file(filename, unit_number=iunit, file_status="REPLACE", & - file_action="WRITE", file_position="APPEND") - ELSE - iunit = -1 - END IF - - IF (iunit > 0) THEN - - WRITE (UNIT=iunit, FMT="(2(A,I0),A)") "# ", & - bs_env%input_kp_bs_n_sp_pts, " special points, ", bs_env%nkp_bs, " k-points" - DO ip = 1, bs_env%input_kp_bs_n_sp_pts - WRITE (UNIT=iunit, FMT="(A,I0,T20,T24,3(1X,F14.8),2X,A)") & - "# Special point ", ip, bs_env%xkp_special(1:3, ip), & - ADJUSTL(TRIM(bs_env%kp_special_name(ip))) - END DO - - END IF - - CALL cp_fm_get_info(matrix=fm_h_Gamma, & - nrow_local=nrow_local, & - ncol_local=ncol_local, & - row_indices=row_indices, & - col_indices=col_indices) - - DO i_dim = 1, 3 - min_max_cell(i_dim) = MIN(MAXVAL(bs_env%cell_of_i_atom(:, i_dim)), & - MAXVAL(-bs_env%cell_of_i_atom(:, i_dim))) - END DO - - DO ikp = 1, bs_env%nkp_bs - - h_munu_k = z_zero - s_munu_k = z_zero - - DO i_row = 1, nrow_local - DO j_col = 1, ncol_local - - row_global = row_indices(i_row) - col_global = col_indices(j_col) - - i_atom = atom_from_bf(row_global) - j_atom = atom_from_bf(col_global) - - cell_atom_i = bs_env%cell_of_i_atom(i_atom, 1:3) - - ! atom_i must be in the primitive cell (0,0,0) - ! (because we calculate h_mu,nu(k) = \sum_R - IF (ANY(cell_atom_i(1:3) .NE. 0)) CYCLE - - cell_atom_j = bs_env%cell_of_i_atom(j_atom, 1:3) - - ! only consider symmetric cell summation, i.e. cell (4,-2,0) needs to have - ! counterpart (-4,2,0). In case we have 7x7 cell, (-4,2,0) will be absent - IF (ANY(ABS(cell_atom_j(1:3)) > min_max_cell(1:3))) CYCLE - - arg = (REAL(cell_atom_j(1), dp)*bs_env%kpoints_bandstructure%xkp(1, ikp) + & - REAL(cell_atom_j(2), dp)*bs_env%kpoints_bandstructure%xkp(2, ikp) + & - REAL(cell_atom_j(3), dp)*bs_env%kpoints_bandstructure%xkp(3, ikp))*twopi - - ref_atom_j = bs_env%ref_atom_primitive_cell(j_atom) - - i = row_global - first_bf_from_atom(i_atom) + first_bf_of_primit_atom(i_atom) - j = col_global - first_bf_from_atom(j_atom) + first_bf_of_primit_atom(ref_atom_j) - - h_munu_k(i, j) = h_munu_k(i, j) + & - COS(arg)*fm_h_Gamma%local_data(i_row, j_col)*z_one + & - SIN(arg)*fm_h_Gamma%local_data(i_row, j_col)*gaussi - - s_munu_k(i, j) = s_munu_k(i, j) + & - COS(arg)*bs_env%fm_s_Gamma%local_data(i_row, j_col)*z_one + & - SIN(arg)*bs_env%fm_s_Gamma%local_data(i_row, j_col)*gaussi - END DO ! j_col - END DO ! i_row - - CALL bs_env%para_env%sync() - CALL bs_env%para_env%sum(h_munu_k) - CALL bs_env%para_env%sum(s_munu_k) - CALL bs_env%para_env%sync() - - CALL complex_geeig(h_munu_k, s_munu_k, mo_coeff_k, eigenvalues(:, ikp)) - - IF (iunit > 0) THEN - - WRITE (UNIT=iunit, FMT="(A,I0,T15,A,T24,3(1X,F14.8))") & - "# Point ", ikp, ":", bs_env%kpoints_bandstructure%xkp(1:3, ikp) - WRITE (UNIT=iunit, FMT="(A)") "# Band Energy [eV]" - DO imo = 1, n_ao_primitive_cell - WRITE (UNIT=iunit, FMT="(T2,I7,1X,F14.8)") imo, eigenvalues(imo, ikp)*evolt - END DO - - END IF - - END DO ! ikp - - IF (bs_env%para_env%is_source()) CALL close_file(unit_number=iunit) - - CALL timestop(handle) - - END SUBROUTINE bandstructure_primitive_cell - -! ************************************************************************************************** -!> \brief ... -!> \param qs_env ... -!> \param bs_env ... -!> \param eigenvalues ... -!> \param filename ... -!> \param cfm_h_Gamma_spinor ... -! ************************************************************************************************** - SUBROUTINE bandstructure_primitive_cell_spinor(qs_env, bs_env, eigenvalues, filename, & - cfm_h_Gamma_spinor) - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: eigenvalues - CHARACTER(LEN=*) :: filename - TYPE(cp_cfm_type) :: cfm_h_Gamma_spinor - - CHARACTER(LEN=*), PARAMETER :: routineN = 'bandstructure_primitive_cell_spinor' - - COMPLEX(KIND=dp) :: arg, s_z - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: s_dot_mo_coeff_down, s_dot_mo_coeff_up - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: h_munu_k, mo_coeff_k, s_munu_k, & - s_munu_k_single - INTEGER :: col_global, handle, i, i_atom, i_atom_non_spinor, i_dim, i_row, ikp, imo, ip, & - iunit, j, j_atom, j_atom_non_spinor, j_col, n_ao, n_ao_primitive_cell, n_atom, & - n_atom_primitive_cell, ncol_local, nrow_local, ref_atom_j, row_global - INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_from_bf, first_bf_from_atom, & - first_bf_of_primit_atom - INTEGER, DIMENSION(3) :: cell_atom_i, cell_atom_j, min_max_cell - INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices - - CALL timeset(routineN, handle) - - n_ao = bs_env%n_ao - n_ao_primitive_cell = n_ao/bs_env%n_primitive_cells - n_atom = bs_env%n_atom - n_atom_primitive_cell = n_atom/bs_env%n_primitive_cells - - ALLOCATE (h_munu_k(2*n_ao_primitive_cell, 2*n_ao_primitive_cell)) - ALLOCATE (s_munu_k(2*n_ao_primitive_cell, 2*n_ao_primitive_cell)) - ALLOCATE (s_munu_k_single(n_ao_primitive_cell, n_ao_primitive_cell)) - ALLOCATE (mo_coeff_k(2*n_ao_primitive_cell, 2*n_ao_primitive_cell)) - ALLOCATE (eigenvalues(2*n_ao_primitive_cell, bs_env%nkp_bs)) - ALLOCATE (s_dot_mo_coeff_up(n_ao_primitive_cell)) - ALLOCATE (s_dot_mo_coeff_down(n_ao_primitive_cell)) - - ALLOCATE (atom_from_bf(2*n_ao)) - ALLOCATE (first_bf_from_atom(2*n_atom)) - CALL get_atom_index_from_basis_function_index(qs_env, atom_from_bf, n_ao, "ORB", & - first_bf_from_atom) - atom_from_bf(n_ao + 1:2*n_ao) = atom_from_bf(1:n_ao) + n_atom - first_bf_from_atom(n_atom + 1:2*n_atom) = first_bf_from_atom(1:n_atom) + n_ao - - ALLOCATE (first_bf_of_primit_atom(2*n_atom)) - CALL get_basis_function_index_of_primitive_atoms(bs_env, first_bf_of_primit_atom, & - first_bf_from_atom) - first_bf_of_primit_atom(n_atom + 1:2*n_atom) = first_bf_of_primit_atom(1:n_atom) & - + n_ao_primitive_cell - - IF (bs_env%para_env%is_source()) THEN - CALL open_file(filename, unit_number=iunit, file_status="REPLACE", & - file_action="WRITE", file_position="APPEND") - ELSE - iunit = -1 - END IF - - IF (iunit > 0) THEN - - WRITE (UNIT=iunit, FMT="(2(A,I0),A)") "# ", & - bs_env%input_kp_bs_n_sp_pts, " special points, ", bs_env%nkp_bs, " k-points" - DO ip = 1, bs_env%input_kp_bs_n_sp_pts - WRITE (UNIT=iunit, FMT="(A,I0,T20,T24,3(1X,F14.8),2X,A)") & - "# Special point ", ip, bs_env%xkp_special(1:3, ip), & - ADJUSTL(TRIM(bs_env%kp_special_name(ip))) - END DO - - END IF - - CALL cp_cfm_get_info(matrix=cfm_h_Gamma_spinor, & - nrow_local=nrow_local, & - ncol_local=ncol_local, & - row_indices=row_indices, & - col_indices=col_indices) - - DO i_dim = 1, 3 - min_max_cell(i_dim) = MIN(MAXVAL(bs_env%cell_of_i_atom(:, i_dim)), & - MAXVAL(-bs_env%cell_of_i_atom(:, i_dim))) - END DO - - DO ikp = 1, bs_env%nkp_bs - - h_munu_k = z_zero - s_munu_k = z_zero - - DO i_row = 1, nrow_local - DO j_col = 1, ncol_local - - row_global = row_indices(i_row) - col_global = col_indices(j_col) - - i_atom = atom_from_bf(row_global) - j_atom = atom_from_bf(col_global) - - IF (i_atom > n_atom) THEN - i_atom_non_spinor = i_atom - n_atom - ELSE - i_atom_non_spinor = i_atom - END IF - - IF (j_atom > n_atom) THEN - j_atom_non_spinor = j_atom - n_atom - ELSE - j_atom_non_spinor = j_atom - END IF - - cell_atom_i = bs_env%cell_of_i_atom(i_atom_non_spinor, 1:3) - - ! atom_i must be in the primitive cell (0,0,0) - ! (because we calculate h_mu,nu(k) = \sum_R - IF (ANY(cell_atom_i(1:3) .NE. 0)) CYCLE - - cell_atom_j = bs_env%cell_of_i_atom(j_atom_non_spinor, 1:3) - - ! only consider symmetric cell summation, i.e. cell (4,-2,0) needs to have - ! counterpart (-4,2,0). In case we have 7x7 cell, (-4,2,0) will be absent - IF (ANY(ABS(cell_atom_j(1:3)) > min_max_cell(1:3))) CYCLE - - arg = (REAL(cell_atom_j(1), dp)*bs_env%kpoints_bandstructure%xkp(1, ikp) + & - REAL(cell_atom_j(2), dp)*bs_env%kpoints_bandstructure%xkp(2, ikp) + & - REAL(cell_atom_j(3), dp)*bs_env%kpoints_bandstructure%xkp(3, ikp))*twopi - - IF (j_atom > n_atom) THEN - ref_atom_j = bs_env%ref_atom_primitive_cell(j_atom_non_spinor) + n_atom - ELSE - ref_atom_j = bs_env%ref_atom_primitive_cell(j_atom) - END IF - - i = row_global - first_bf_from_atom(i_atom) + first_bf_of_primit_atom(i_atom) - j = col_global - first_bf_from_atom(j_atom) + first_bf_of_primit_atom(ref_atom_j) - - h_munu_k(i, j) = h_munu_k(i, j) + & - COS(arg)*cfm_h_Gamma_spinor%local_data(i_row, j_col) + & - SIN(arg)*cfm_h_Gamma_spinor%local_data(i_row, j_col)*gaussi - - s_munu_k(i, j) = s_munu_k(i, j) + & - COS(arg)*bs_env%cfm_s_spinor_Gamma%local_data(i_row, j_col) + & - SIN(arg)*bs_env%cfm_s_spinor_Gamma%local_data(i_row, j_col)*gaussi - - END DO ! j_col - END DO ! i_row - - CALL bs_env%para_env%sync() - CALL bs_env%para_env%sum(h_munu_k) - CALL bs_env%para_env%sum(s_munu_k) - CALL bs_env%para_env%sync() - - CALL complex_geeig(h_munu_k, s_munu_k, mo_coeff_k, eigenvalues(:, ikp)) - - IF (iunit > 0) THEN - - s_munu_k_single(:, :) = s_munu_k(1:n_ao_primitive_cell, 1:n_ao_primitive_cell) - - WRITE (UNIT=iunit, FMT="(A,I0,T15,A,T24,3(1X,F14.8))") & - "# Point ", ikp, ":", bs_env%kpoints_bandstructure%xkp(1:3, ikp) - WRITE (UNIT=iunit, FMT="(A)") "# Band Energy [eV] / (ħ/2) " - DO imo = 1, 2*n_ao_primitive_cell - s_dot_mo_coeff_up(:) = MATMUL(s_munu_k_single, & - mo_coeff_k(1:n_ao_primitive_cell, imo)) - s_dot_mo_coeff_down(:) = MATMUL(s_munu_k_single, & - mo_coeff_k(n_ao_primitive_cell + 1:, imo)) - s_z = SUM(CONJG(mo_coeff_k(1:n_ao_primitive_cell, imo))*s_dot_mo_coeff_up) - & - SUM(CONJG(mo_coeff_k(n_ao_primitive_cell + 1:, imo))*s_dot_mo_coeff_down) - WRITE (UNIT=iunit, FMT="(T2,I7,1X,2F14.8)") imo, eigenvalues(imo, ikp)*evolt, & - REAL(s_z, KIND=dp) - END DO - - END IF - - END DO ! ikp - - IF (bs_env%para_env%is_source()) CALL close_file(unit_number=iunit) - - CALL timestop(handle) - - END SUBROUTINE bandstructure_primitive_cell_spinor - -! ************************************************************************************************** -!> \brief Solves generalized, complex eigenvalue problem, HC = SCε by diagonalizing S^-0.5*H*S^-0.5 -!> \param matrix ... -!> \param overlap ... -!> \param eigenvectors ... -!> \param eigenvalues ... -! ************************************************************************************************** - SUBROUTINE complex_geeig(matrix, overlap, eigenvectors, eigenvalues) - - COMPLEX(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: matrix, overlap, eigenvectors - REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: eigenvalues - - COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: overlap_sqrt_inv, work_1, work_2 - INTEGER :: i, n - LOGICAL :: check_size - - n = SIZE(matrix, 1) - - check_size = SIZE(matrix, 2) == n .AND. SIZE(overlap, 1) == n .AND. & - SIZE(eigenvalues) == n .AND. & - SIZE(eigenvectors, 1) == n .AND. SIZE(eigenvectors, 2) == n - CPASSERT(check_size) - - ALLOCATE (work_1(n, n), work_2(n, n), overlap_sqrt_inv(n, n)) - - CALL complex_diag(overlap, eigenvectors, eigenvalues) - - work_1(:, :) = z_zero - DO i = 1, n - IF (eigenvalues(i) > 1.0E-5_dp) THEN - work_1(i, i) = eigenvalues(i)**(-0.5_dp) - END IF - END DO - work_2(:, :) = MATMUL(work_1, TRANSPOSE(CONJG(eigenvectors))) - overlap_sqrt_inv(:, :) = MATMUL(eigenvectors, work_2) - - work_1(:, :) = MATMUL(matrix, overlap_sqrt_inv) - work_2(:, :) = MATMUL(overlap_sqrt_inv, work_1) - - CALL complex_diag(work_2, eigenvectors, eigenvalues) - - work_2(:, :) = MATMUL(overlap_sqrt_inv, eigenvectors) - eigenvectors(:, :) = work_2(:, :) - - END SUBROUTINE complex_geeig - -! ************************************************************************************************** -!> \brief ... -!> \param bs_env ... -!> \param first_bf_of_primit_atom ... -!> \param first_bf_from_atom ... -! ************************************************************************************************** - SUBROUTINE get_basis_function_index_of_primitive_atoms(bs_env, first_bf_of_primit_atom, & - first_bf_from_atom) - TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER, ALLOCATABLE, DIMENSION(:) :: first_bf_of_primit_atom, & - first_bf_from_atom - - CHARACTER(LEN=*), PARAMETER :: routineN = 'get_basis_function_index_of_primitive_atoms' - - INTEGER :: handle, i_atom, n_atom, n_bf_of_atom_i - - CALL timeset(routineN, handle) - - first_bf_of_primit_atom(:) = 1 - - n_atom = bs_env%n_atom - - DO i_atom = 2, n_atom - IF (ANY(bs_env%atoms_i_primitive_cell(:) == i_atom)) THEN - n_bf_of_atom_i = first_bf_from_atom(i_atom) - first_bf_from_atom(i_atom - 1) - first_bf_of_primit_atom(i_atom:n_atom) = first_bf_of_primit_atom(i_atom:n_atom) & - + n_bf_of_atom_i - END IF - END DO - - CALL timestop(handle) - - END SUBROUTINE get_basis_function_index_of_primitive_atoms - ! ************************************************************************************************** !> \brief ... !> \param qs_env ... @@ -1342,11 +816,13 @@ SUBROUTINE dos_pdos_ldos(qs_env, bs_env) CHARACTER(LEN=*), PARAMETER :: routineN = 'dos_pdos_ldos' INTEGER :: handle, homo, homo_1, homo_2, & - homo_spinor, ikp, ispin, n_ao, n_E, & - nkind + homo_spinor, ikp, ikp_for_filename, & + ispin, n_ao, n_E, nkind, nkp + LOGICAL :: is_bandstruc_kpoint, print_DOS_kpoints, & + print_ikp REAL(KIND=dp) :: broadening, E_max, E_max_G0W0, E_min, & E_min_G0W0, E_total_window, & - energy_step_DOS, energy_window_DOS + energy_step_DOS, energy_window_DOS, t1 REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: DOS_G0W0, DOS_G0W0_SOC, DOS_scf, DOS_scf_SOC, & eigenval, eigenval_spinor, eigenval_spinor_G0W0, eigenval_spinor_no_SOC REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: PDOS_G0W0, PDOS_G0W0_SOC, PDOS_scf, & @@ -1480,24 +956,47 @@ SUBROUTINE dos_pdos_ldos(qs_env, bs_env) WRITE (bs_env%unit_nr, '(A)') '' END IF - DO ikp = 1, bs_env%kpoints_DOS%nkp + IF (bs_env%small_cell_full_kp_or_large_cell_Gamma == small_cell_full_kp) THEN + CALL cp_cfm_create(cfm_ks_ikp, bs_env%fm_ks_kp(1, 1, 1)%matrix_struct) + CALL cp_cfm_create(cfm_s_ikp, bs_env%fm_ks_kp(1, 1, 1)%matrix_struct) + END IF + + DO ikp = 1, bs_env%nkp_bs_and_DOS - bs_env%t1 = m_walltime() + t1 = m_walltime() DO ispin = 1, bs_env%n_spin - ! 1. get H^KS_µν(k_i) from H^KS_µν(k=0) - CALL cfm_ikp_from_fm_Gamma(cfm_ks_ikp, bs_env%fm_ks_Gamma(ispin), & - ikp, qs_env, bs_env%kpoints_DOS, "ORB") + SELECT CASE (bs_env%small_cell_full_kp_or_large_cell_Gamma) + CASE (large_cell_Gamma) + + ! 1. get H^KS_µν(k_i) from H^KS_µν(k=0) + CALL cfm_ikp_from_fm_Gamma(cfm_ks_ikp, bs_env%fm_ks_Gamma(ispin), & + ikp, qs_env, bs_env%kpoints_DOS, "ORB") - ! 2. get S_µν(k_i) from S_µν(k=0) - CALL cfm_ikp_from_fm_Gamma(cfm_s_ikp, bs_env%fm_s_Gamma, & - ikp, qs_env, bs_env%kpoints_DOS, "ORB") - CALL cp_cfm_to_cfm(cfm_s_ikp, cfm_s_ikp_copy) + ! 2. get S_µν(k_i) from S_µν(k=0) + CALL cfm_ikp_from_fm_Gamma(cfm_s_ikp, bs_env%fm_s_Gamma, & + ikp, qs_env, bs_env%kpoints_DOS, "ORB") + CALL cp_cfm_to_cfm(cfm_s_ikp, cfm_s_ikp_copy) - ! 3. Diagonalize (Roothaan-Hall): H_KS(k_i)*C(k_i) = S(k_i)*C(k_i)*ϵ(k_i) - CALL cp_cfm_geeig(cfm_ks_ikp, cfm_s_ikp_copy, cfm_mos_ikp(ispin), & - eigenval, cfm_work_ikp) + ! 3. Diagonalize (Roothaan-Hall): H_KS(k_i)*C(k_i) = S(k_i)*C(k_i)*ϵ(k_i) + CALL cp_cfm_geeig(cfm_ks_ikp, cfm_s_ikp_copy, cfm_mos_ikp(ispin), & + eigenval, cfm_work_ikp) + + CASE (small_cell_full_kp) + + ! 1. get H^KS_µν(k_i) + CALL cp_fm_to_cfm(bs_env%fm_ks_kp(ikp, ispin, 1), & + bs_env%fm_ks_kp(ikp, ispin, 2), cfm_ks_ikp) + ! 2. get S_µν(k_i) + CALL cp_fm_to_cfm(bs_env%fm_s_kp(ikp, ispin, 1), & + bs_env%fm_s_kp(ikp, ispin, 2), cfm_s_ikp) + ! 3. get C_µn(k_i) and ϵ_n(k_i) + CALL cp_fm_to_cfm(bs_env%fm_mo_coeff_kp(ikp, ispin, 1), & + bs_env%fm_mo_coeff_kp(ikp, ispin, 2), cfm_mos_ikp(ispin)) + eigenval(:) = bs_env%eigenval_scf(:, ikp, ispin) + + END SELECT ! 4. Projection p_nk^A of MO ψ_nk(r) on atom type A (inspired by Mulliken charge) ! p_nk^A = sum_µ^A,ν C*_µ^A,n(k) S_µ^A,ν(k) C_ν,n(k) @@ -1533,12 +1032,28 @@ SUBROUTINE dos_pdos_ldos(qs_env, bs_env) ! now the same with spin-orbit coupling IF (bs_env%do_soc) THEN + ! only print eigenvalues of DOS k-points in case no bandstructure path has been given + print_DOS_kpoints = (bs_env%nkp_only_bs .LE. 0) + ! in kpoints_DOS, the last nkp_only_bs are bandstructure k-points + is_bandstruc_kpoint = (ikp > bs_env%nkp_only_DOS) + print_ikp = print_DOS_kpoints .OR. is_bandstruc_kpoint + + IF (print_DOS_kpoints) THEN + nkp = bs_env%nkp_only_DOS + ikp_for_filename = ikp + ELSE + nkp = bs_env%nkp_only_bs + ikp_for_filename = ikp - bs_env%nkp_only_DOS + END IF + ! compute DFT+SOC eigenvalues; based on these, compute band edges, DOS and LDOS CALL SOC(bs_env, qs_env, ikp, bs_env%eigenval_scf, band_edges_scf, E_min, cfm_mos_ikp, & DOS_scf_SOC, PDOS_scf_SOC, band_edges_scf_SOC, eigenval_spinor, & cfm_spinor_wf_ikp) - IF (.NOT. bs_env%do_gw) CALL write_SOC_eigenvalues(eigenval_spinor, "SCF", ikp, bs_env) + IF (.NOT. bs_env%do_gw .AND. print_ikp) THEN + CALL write_SOC_eigenvalues(eigenval_spinor, "SCF", ikp_for_filename, nkp, bs_env) + END IF IF (bs_env%do_ldos) THEN CALL add_to_LDOS_2d(LDOS_scf_2d_SOC, qs_env, ikp, bs_env, cfm_spinor_wf_ikp, & @@ -1552,19 +1067,21 @@ SUBROUTINE dos_pdos_ldos(qs_env, bs_env) E_min, cfm_mos_ikp, DOS_G0W0_SOC, PDOS_G0W0_SOC, & band_edges_G0W0_SOC, eigenval_spinor_G0W0, cfm_spinor_wf_ikp) - ! write SCF+SOC and G0W0+SOC eigenvalues to file - ! SCF_and_G0W0_band_structure_for_kpoint__+_SOC - CALL write_SOC_eigenvalues(eigenval_spinor, "SCF_and_G0W0", ikp, bs_env, & - eigenval_spinor_G0W0) + IF (print_ikp) THEN + ! write SCF+SOC and G0W0+SOC eigenvalues to file + ! SCF_and_G0W0_band_structure_for_kpoint__+_SOC + CALL write_SOC_eigenvalues(eigenval_spinor, "SCF_and_G0W0", ikp_for_filename, & + nkp, bs_env, eigenval_spinor_G0W0) + END IF END IF ! do_gw END IF ! do_soc - IF (bs_env%unit_nr > 0) THEN + IF (bs_env%unit_nr > 0 .AND. m_walltime() - t1 > 20.0_dp) THEN WRITE (bs_env%unit_nr, '(T2,A,T43,I5,A,I3,A,F7.1,A)') & - 'Compute DOS, LDOS for k-point ', ikp, ' /', bs_env%kpoints_DOS%nkp, & - ', Execution time', m_walltime() - bs_env%t1, ' s' + 'Compute DOS, LDOS for k-point ', ikp, ' /', bs_env%nkp_bs_and_DOS, & + ', Execution time', m_walltime() - t1, ' s' END IF END DO ! ikp_DOS @@ -1597,6 +1114,7 @@ SUBROUTINE dos_pdos_ldos(qs_env, bs_env) IF (bs_env%do_gw) THEN CALL write_band_edges(band_edges_G0W0, "G0W0", bs_env) + CALL write_band_edges(bs_env%band_edges_HF, "Hartree-Fock with SCF orbitals", bs_env) CALL write_dos_pdos(DOS_G0W0, PDOS_G0W0, bs_env, qs_env, "G0W0", E_min, & band_edges_G0W0%VBM) IF (bs_env%do_ldos) THEN @@ -2005,8 +1523,7 @@ SUBROUTINE add_to_DOS_PDOS(DOS, PDOS, eigenval, ikp, bs_env, n_E, E_min, proj_mo CHARACTER(LEN=*), PARAMETER :: routineN = 'add_to_DOS_PDOS' - INTEGER :: handle, i_E, i_kind, i_mo, n_mo, & - n_primitive_cells, nkind + INTEGER :: handle, i_E, i_kind, i_mo, n_mo, nkind REAL(KIND=dp) :: broadening, energy, energy_step_DOS, wkp CALL timeset(routineN, handle) @@ -2014,14 +1531,11 @@ SUBROUTINE add_to_DOS_PDOS(DOS, PDOS, eigenval, ikp, bs_env, n_E, E_min, proj_mo energy_step_DOS = bs_env%energy_step_DOS broadening = bs_env%broadening_DOS - n_primitive_cells = 1 - IF (bs_env%do_bs) n_primitive_cells = bs_env%n_primitive_cells - n_mo = SIZE(eigenval) nkind = SIZE(proj_mo_on_kind, 2) - ! normalize to the primitive cell and to closed-shell / open-shell - wkp = bs_env%kpoints_DOS%wkp(ikp)/n_primitive_cells*bs_env%spin_degeneracy + ! normalize to closed-shell / open-shell + wkp = bs_env%kpoints_DOS%wkp(ikp)*bs_env%spin_degeneracy DO i_E = 1, n_E energy = E_min + i_E*energy_step_DOS DO i_mo = 1, n_mo @@ -2095,7 +1609,7 @@ SUBROUTINE add_to_LDOS_2d(LDOS_2d, qs_env, ikp, bs_env, cfm_mos_ikp, eigenval, & ! previously, dft_control%nimages set to # neighbor cells, revert for Γ-only KS matrix nimages = dft_control%nimages - dft_control%nimages = 1 + dft_control%nimages = bs_env%nimages_scf energy_window = bs_env%energy_window_DOS energy_step = bs_env%energy_step_DOS @@ -2254,14 +1768,15 @@ END SUBROUTINE add_to_LDOS_2d !> \param eigenval_spinor ... !> \param scf_gw ... !> \param ikp ... +!> \param nkp ... !> \param bs_env ... !> \param eigenval_spinor_G0W0 ... ! ************************************************************************************************** - SUBROUTINE write_SOC_eigenvalues(eigenval_spinor, scf_gw, ikp, bs_env, eigenval_spinor_G0W0) + SUBROUTINE write_SOC_eigenvalues(eigenval_spinor, scf_gw, ikp, nkp, bs_env, eigenval_spinor_G0W0) REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigenval_spinor CHARACTER(LEN=*) :: scf_gw - INTEGER :: ikp + INTEGER :: ikp, nkp TYPE(post_scf_bandstructure_type), POINTER :: bs_env REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), OPTIONAL :: eigenval_spinor_G0W0 @@ -2273,7 +1788,7 @@ SUBROUTINE write_SOC_eigenvalues(eigenval_spinor, scf_gw, ikp, bs_env, eigenval_ CALL timeset(routineN, handle) - CALL get_fname(fname, bs_env, ikp, scf_gw, SOC=.TRUE.) + CALL get_fname(fname, bs_env, ikp, nkp, scf_gw, SOC=.TRUE.) IF (bs_env%para_env%is_source()) THEN @@ -2312,14 +1827,15 @@ END SUBROUTINE write_SOC_eigenvalues !> \param fname ... !> \param bs_env ... !> \param ikp ... +!> \param nkp ... !> \param scf_gw ... !> \param ispin ... !> \param SOC ... ! ************************************************************************************************** - SUBROUTINE get_fname(fname, bs_env, ikp, scf_gw, ispin, SOC) + SUBROUTINE get_fname(fname, bs_env, ikp, nkp, scf_gw, ispin, SOC) CHARACTER(len=default_string_length) :: fname TYPE(post_scf_bandstructure_type), POINTER :: bs_env - INTEGER :: ikp + INTEGER :: ikp, nkp CHARACTER(len=*) :: scf_gw INTEGER, OPTIONAL :: ispin LOGICAL, OPTIONAL :: SOC @@ -2336,7 +1852,7 @@ SUBROUTINE get_fname(fname, bs_env, ikp, scf_gw, ispin, SOC) my_SOC = .FALSE. IF (PRESENT(SOC)) my_SOC = SOC - n_zeros = count_digits(bs_env%kpoints_DOS%nkp) - count_digits(ikp) + n_zeros = count_digits(nkp) - count_digits(ikp) WRITE (digits_ikp, '(I1)') count_digits(ikp) @@ -2935,4 +2451,75 @@ SUBROUTINE MIC_contribution_from_ikp(bs_env, qs_env, fm_W_MIC_freq_j, & END SUBROUTINE MIC_contribution_from_ikp +! ************************************************************************************************** +!> \brief ... +!> \param xkp ... +!> \param ikp_start ... +!> \param ikp_end ... +!> \param grid ... +! ************************************************************************************************** + SUBROUTINE compute_xkp(xkp, ikp_start, ikp_end, grid) + + REAL(KIND=dp), DIMENSION(:, :), POINTER :: xkp + INTEGER :: ikp_start, ikp_end + INTEGER, DIMENSION(3) :: grid + + CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_xkp' + + INTEGER :: handle, i, ix, iy, iz + + CALL timeset(routineN, handle) + + i = ikp_start + DO ix = 1, grid(1) + DO iy = 1, grid(2) + DO iz = 1, grid(3) + + IF (i > ikp_end) CYCLE + + xkp(1, i) = REAL(2*ix - grid(1) - 1, KIND=dp)/(2._dp*REAL(grid(1), KIND=dp)) + xkp(2, i) = REAL(2*iy - grid(2) - 1, KIND=dp)/(2._dp*REAL(grid(2), KIND=dp)) + xkp(3, i) = REAL(2*iz - grid(3) - 1, KIND=dp)/(2._dp*REAL(grid(3), KIND=dp)) + i = i + 1 + + END DO + END DO + END DO + + CALL timestop(handle) + + END SUBROUTINE compute_xkp + +! ************************************************************************************************** +!> \brief ... +!> \param kpoints ... +!> \param qs_env ... +! ************************************************************************************************** + SUBROUTINE kpoint_init_cell_index_simple(kpoints, qs_env) + + TYPE(kpoint_type), POINTER :: kpoints + TYPE(qs_environment_type), POINTER :: qs_env + + CHARACTER(LEN=*), PARAMETER :: routineN = 'kpoint_init_cell_index_simple' + + INTEGER :: handle, nimages + TYPE(dft_control_type), POINTER :: dft_control + TYPE(mp_para_env_type), POINTER :: para_env + TYPE(neighbor_list_set_p_type), DIMENSION(:), & + POINTER :: sab_orb + + CALL timeset(routineN, handle) + + NULLIFY (dft_control, para_env, sab_orb) + CALL get_qs_env(qs_env=qs_env, para_env=para_env, dft_control=dft_control, sab_orb=sab_orb) + nimages = dft_control%nimages + CALL kpoint_init_cell_index(kpoints, sab_orb, para_env, dft_control) + + ! set back dft_control%nimages + dft_control%nimages = nimages + + CALL timestop(handle) + + END SUBROUTINE kpoint_init_cell_index_simple + END MODULE post_scf_bandstructure_utils diff --git a/src/qs_ks_methods.F b/src/qs_ks_methods.F index c4dc41fb93..9a23526fe9 100644 --- a/src/qs_ks_methods.F +++ b/src/qs_ks_methods.F @@ -179,7 +179,7 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces, just_energy, & CHARACTER(LEN=*), PARAMETER :: routineN = 'qs_ks_build_kohn_sham_matrix' CHARACTER(len=default_string_length) :: name - INTEGER :: handle, iatom, img, ispin, nimages, ns, & + INTEGER :: handle, iatom, img, ispin, nimages, & nspins LOGICAL :: do_adiabatic_rescaling, do_ddapc, do_hfx, do_ppl, dokp, gapw, gapw_xc, & hfx_treat_lsd_in_core, just_energy_xc, lrigpw, my_print, rigpw, use_virial @@ -258,12 +258,11 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces, just_energy, & CALL qs_rho_get(rho, rho_r=rho_r, rho_ao_kp=rho_ao) - IF (PRESENT(ext_ks_matrix)) THEN - ! remap pointer to allow for non-kpoint external ks matrix - ! ext_ks_matrix is used in linear response code - ns = SIZE(ext_ks_matrix) - ks_matrix(1:ns, 1:1) => ext_ks_matrix(1:ns) - END IF + nimages = dft_control%nimages + nspins = dft_control%nspins + + ! remap pointer to allow for non-kpoint external ks matrix + IF (PRESENT(ext_ks_matrix)) ks_matrix(1:nspins, 1:1) => ext_ks_matrix(1:nspins) use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer) @@ -282,8 +281,6 @@ SUBROUTINE qs_ks_build_kohn_sham_matrix(qs_env, calculate_forces, just_energy, & just_energy_xc = .TRUE. END IF - nimages = dft_control%nimages - nspins = dft_control%nspins CPASSERT(ASSOCIATED(matrix_h)) CPASSERT(ASSOCIATED(matrix_s)) CPASSERT(ASSOCIATED(rho)) diff --git a/src/qs_tensors.F b/src/qs_tensors.F index b43f692987..a5d66157c8 100644 --- a/src/qs_tensors.F +++ b/src/qs_tensors.F @@ -36,9 +36,9 @@ MODULE qs_tensors open_file USE dbt_api, ONLY: & dbt_blk_sizes, dbt_clear, dbt_copy, dbt_create, dbt_destroy, dbt_filter, dbt_get_block, & - dbt_get_info, dbt_get_num_blocks, dbt_get_nze_total, dbt_get_stored_coordinates, & - dbt_iterator_next_block, dbt_iterator_num_blocks, dbt_iterator_start, dbt_iterator_stop, & - dbt_iterator_type, dbt_ndims, dbt_put_block, dbt_reserve_blocks, dbt_type + dbt_get_info, dbt_get_num_blocks, dbt_get_nze_total, dbt_iterator_next_block, & + dbt_iterator_num_blocks, dbt_iterator_start, dbt_iterator_stop, dbt_iterator_type, & + dbt_ndims, dbt_put_block, dbt_reserve_blocks, dbt_type USE distribution_1d_types, ONLY: distribution_1d_type USE distribution_2d_types, ONLY: distribution_2d_type USE gamma, ONLY: init_md_ftable @@ -619,10 +619,12 @@ SUBROUTINE get_3c_iterator_info(iterator, ikind, jkind, kkind, nkind, iatom, jat !> \param bounds_k ... !> \param RI_range ... !> \param img_to_RI_cell ... +!> \param cell_to_index ... +!> \param cell_sym ... ! ************************************************************************************************** SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potential_parameter, op_pos, & do_kpoints, do_hfx_kpoints, bounds_i, bounds_j, bounds_k, RI_range, & - img_to_RI_cell) + img_to_RI_cell, cell_to_index, cell_sym) TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t3c TYPE(neighbor_list_3c_type), INTENT(INOUT) :: nl_3c TYPE(gto_basis_set_p_type), DIMENSION(:) :: basis_i, basis_j, basis_k @@ -633,6 +635,8 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: bounds_i, bounds_j, bounds_k REAL(dp), INTENT(IN), OPTIONAL :: RI_range INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: img_to_RI_cell + INTEGER, DIMENSION(:, :, :), OPTIONAL, POINTER :: cell_to_index + LOGICAL, INTENT(IN), OPTIONAL :: cell_sym CHARACTER(LEN=*), PARAMETER :: routineN = 'alloc_block_3c' @@ -645,8 +649,8 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti INTEGER, ALLOCATABLE, DIMENSION(:) :: img_to_RI_cell_prv INTEGER, DIMENSION(3) :: blk_idx, cell_j, cell_k, & kp_index_lbounds, kp_index_ubounds - INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - LOGICAL :: do_hfx_kpoints_prv, do_kpoints_prv + LOGICAL :: cell_sym_prv, do_hfx_kpoints_prv, & + do_kpoints_prv REAL(KIND=dp) :: dij, dik, djk, dr_ij, dr_ik, dr_jk, & kind_radius_i, kind_radius_j, & kind_radius_k @@ -654,7 +658,6 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set TYPE(cell_type), POINTER :: cell TYPE(dft_control_type), POINTER :: dft_control - TYPE(kpoint_type), POINTER :: kpoints TYPE(mp_para_env_type), POINTER :: para_env TYPE(neighbor_list_3c_iterator_type) :: nl_3c_iter TYPE(one_dim_int_array), ALLOCATABLE, & @@ -685,6 +688,12 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti img_to_RI_cell_prv(:) = img_to_RI_cell END IF + IF (PRESENT(cell_sym)) THEN + cell_sym_prv = cell_sym + ELSE + cell_sym_prv = .FALSE. + END IF + dr_ij = 0.0_dp; dr_jk = 0.0_dp; dr_ik = 0.0_dp op_ij = do_potential_id; op_jk = do_potential_id @@ -719,16 +728,18 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti END IF CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, natom=natom, & - dft_control=dft_control, kpoints=kpoints, para_env=para_env, cell=cell) + dft_control=dft_control, para_env=para_env, cell=cell) IF (do_kpoints_prv) THEN - nimg = dft_control%nimages + CPASSERT(PRESENT(cell_to_index)) + CPASSERT(ASSOCIATED(cell_to_index)) +! nimg = dft_control%nimages + nimg = MAXVAL(cell_to_index) ncell_RI = nimg IF (do_hfx_kpoints_prv) THEN nimg = SIZE(t3c, 1) ncell_RI = SIZE(t3c, 2) END IF - CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index) ELSE nimg = 1 ncell_RI = 1 @@ -860,10 +871,11 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti CALL neighbor_list_3c_iterator_destroy(nl_3c_iter) !TODO: Parallelize creation of block list. -!$OMP PARALLEL DEFAULT(NONE) SHARED(t3c,nimg,nblk,alloc_i,alloc_j,alloc_k,ncell_RI) & +!$OMP PARALLEL DEFAULT(NONE) SHARED(t3c,nimg,nblk,alloc_i,alloc_j,alloc_k,ncell_RI,cell_sym_prv) & !$OMP PRIVATE(k_img,j_img,nblk_per_thread,A,b) DO k_img = 1, ncell_RI DO j_img = 1, nimg + IF (cell_sym_prv .AND. j_img < k_img) CYCLE IF (ALLOCATED(alloc_i(j_img, k_img)%array)) THEN nblk_per_thread = nblk(j_img, k_img)/omp_get_num_threads() + 1 a = omp_get_thread_num()*nblk_per_thread + 1 @@ -881,239 +893,6 @@ SUBROUTINE alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potenti END SUBROUTINE -! ************************************************************************************************** -!> \brief ... -!> \param t3c ... -!> \param nl_3c ... -!> \param basis_i ... -!> \param basis_j ... -!> \param basis_k ... -!> \param qs_env ... -!> \param potential_parameter ... -!> \param op_pos ... -!> \param do_kpoints ... -!> \param bounds_i ... -!> \param bounds_j ... -!> \param bounds_k ... -! ************************************************************************************************** - SUBROUTINE alloc_block_3c_old(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potential_parameter, op_pos, & - do_kpoints, bounds_i, bounds_j, bounds_k) - TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t3c - TYPE(neighbor_list_3c_type), INTENT(INOUT) :: nl_3c - TYPE(gto_basis_set_p_type), DIMENSION(:) :: basis_i, basis_j, basis_k - TYPE(qs_environment_type), POINTER :: qs_env - TYPE(libint_potential_type), INTENT(IN) :: potential_parameter - INTEGER, INTENT(IN), OPTIONAL :: op_pos - LOGICAL, INTENT(IN), OPTIONAL :: do_kpoints - INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: bounds_i, bounds_j, bounds_k - - CHARACTER(LEN=*), PARAMETER :: routineN = 'alloc_block_3c_old' - - INTEGER :: blk_cnt, handle, i, i_img, iatom, iblk, ikind, iproc, j_img, jatom, jcell, jkind, & - katom, kcell, kkind, natom, nimg, op_ij, op_jk, op_pos_prv - INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp - INTEGER, DIMENSION(3) :: cell_j, cell_k, kp_index_lbounds, & - kp_index_ubounds - INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - LOGICAL :: do_kpoints_prv, new_block - REAL(KIND=dp) :: dij, dik, djk, dr_ij, dr_ik, dr_jk, & - kind_radius_i, kind_radius_j, & - kind_radius_k - REAL(KIND=dp), DIMENSION(3) :: rij, rik, rjk - TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dft_control_type), POINTER :: dft_control - TYPE(kpoint_type), POINTER :: kpoints - TYPE(mp_para_env_type), POINTER :: para_env - TYPE(neighbor_list_3c_iterator_type) :: nl_3c_iter - TYPE(one_dim_int_array), ALLOCATABLE, & - DIMENSION(:, :) :: alloc_i, alloc_j, alloc_k - TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set - - CALL timeset(routineN, handle) - NULLIFY (qs_kind_set, atomic_kind_set) - - IF (PRESENT(do_kpoints)) THEN - do_kpoints_prv = do_kpoints - ELSE - do_kpoints_prv = .FALSE. - END IF - - dr_ij = 0.0_dp; dr_jk = 0.0_dp; dr_ik = 0.0_dp - - op_ij = do_potential_id; op_jk = do_potential_id - - IF (PRESENT(op_pos)) THEN - op_pos_prv = op_pos - ELSE - op_pos_prv = 1 - END IF - - SELECT CASE (op_pos_prv) - CASE (1) - op_ij = potential_parameter%potential_type - CASE (2) - op_jk = potential_parameter%potential_type - END SELECT - - IF (op_ij == do_potential_truncated .OR. op_ij == do_potential_short) THEN - dr_ij = potential_parameter%cutoff_radius*cutoff_screen_factor - dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_ij == do_potential_coulomb) THEN - dr_ij = 1000000.0_dp - dr_ik = 1000000.0_dp - END IF - - IF (op_jk == do_potential_truncated .OR. op_jk == do_potential_short) THEN - dr_jk = potential_parameter%cutoff_radius*cutoff_screen_factor - dr_ik = potential_parameter%cutoff_radius*cutoff_screen_factor - ELSEIF (op_jk == do_potential_coulomb) THEN - dr_jk = 1000000.0_dp - dr_ik = 1000000.0_dp - END IF - - CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, natom=natom, & - dft_control=dft_control, kpoints=kpoints, para_env=para_env) - - IF (do_kpoints_prv) THEN - nimg = dft_control%nimages - CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index) - ELSE - nimg = 1 - END IF - - ALLOCATE (alloc_i(nimg, nimg)) - ALLOCATE (alloc_j(nimg, nimg)) - ALLOCATE (alloc_k(nimg, nimg)) - - IF (do_kpoints_prv) THEN - kp_index_lbounds = LBOUND(cell_to_index) - kp_index_ubounds = UBOUND(cell_to_index) - END IF - - CALL neighbor_list_3c_iterator_create(nl_3c_iter, nl_3c) - CALL nl_3c_iter_set_bounds(nl_3c_iter, bounds_i, bounds_j, bounds_k) - DO WHILE (neighbor_list_3c_iterate(nl_3c_iter) == 0) - CALL get_3c_iterator_info(nl_3c_iter, ikind=ikind, jkind=jkind, kkind=kkind, & - iatom=iatom, jatom=jatom, katom=katom, & - rij=rij, rjk=rjk, rik=rik, cell_j=cell_j, cell_k=cell_k) - - IF (do_kpoints_prv) THEN - - IF (ANY([cell_j(1), cell_j(2), cell_j(3)] < kp_index_lbounds) .OR. & - ANY([cell_j(1), cell_j(2), cell_j(3)] > kp_index_ubounds)) CYCLE - - jcell = cell_to_index(cell_j(1), cell_j(2), cell_j(3)) - IF (jcell > nimg .OR. jcell < 1) CYCLE - - IF (ANY([cell_k(1), cell_k(2), cell_k(3)] < kp_index_lbounds) .OR. & - ANY([cell_k(1), cell_k(2), cell_k(3)] > kp_index_ubounds)) CYCLE - - kcell = cell_to_index(cell_k(1), cell_k(2), cell_k(3)) - IF (kcell > nimg .OR. kcell < 1) CYCLE - ELSE - jcell = 1; kcell = 1 - END IF - - djk = NORM2(rjk) - dij = NORM2(rij) - dik = NORM2(rik) - - CALL get_gto_basis_set(basis_i(ikind)%gto_basis_set, kind_radius=kind_radius_i) - CALL get_gto_basis_set(basis_j(jkind)%gto_basis_set, kind_radius=kind_radius_j) - CALL get_gto_basis_set(basis_k(kkind)%gto_basis_set, kind_radius=kind_radius_k) - - IF (kind_radius_j + kind_radius_i + dr_ij < dij) CYCLE - IF (kind_radius_j + kind_radius_k + dr_jk < djk) CYCLE - IF (kind_radius_k + kind_radius_i + dr_ik < dik) CYCLE - - ! tensor is not symmetric therefore need to allocate rows and columns in - ! correspondence with neighborlist. Note that this only allocates half - ! of the blocks (since neighborlist is symmetric). After filling the blocks, - ! tensor will be added to its transposed - - ASSOCIATE (ai => alloc_i(jcell, kcell)) - ASSOCIATE (aj => alloc_j(jcell, kcell)) - ASSOCIATE (ak => alloc_k(jcell, kcell)) - - new_block = .TRUE. - IF (ALLOCATED(aj%array)) THEN - DO iblk = 1, SIZE(aj%array) - IF (ai%array(iblk) == iatom .AND. & - aj%array(iblk) == jatom .AND. & - ak%array(iblk) == katom) THEN - new_block = .FALSE. - EXIT - END IF - END DO - END IF - IF (.NOT. new_block) CYCLE - - IF (ALLOCATED(ai%array)) THEN - blk_cnt = SIZE(ai%array) - ALLOCATE (tmp(blk_cnt)) - tmp(:) = ai%array(:) - DEALLOCATE (ai%array) - ALLOCATE (ai%array(blk_cnt + 1)) - ai%array(1:blk_cnt) = tmp(:) - ai%array(blk_cnt + 1) = iatom - ELSE - ALLOCATE (ai%array(1)) - ai%array(1) = iatom - END IF - - IF (ALLOCATED(aj%array)) THEN - tmp(:) = aj%array(:) - DEALLOCATE (aj%array) - ALLOCATE (aj%array(blk_cnt + 1)) - aj%array(1:blk_cnt) = tmp(:) - aj%array(blk_cnt + 1) = jatom - ELSE - ALLOCATE (aj%array(1)) - aj%array(1) = jatom - END IF - - IF (ALLOCATED(ak%array)) THEN - tmp(:) = ak%array(:) - DEALLOCATE (ak%array) - ALLOCATE (ak%array(blk_cnt + 1)) - ak%array(1:blk_cnt) = tmp(:) - ak%array(blk_cnt + 1) = katom - ELSE - ALLOCATE (ak%array(1)) - ak%array(1) = katom - END IF - - IF (ALLOCATED(tmp)) DEALLOCATE (tmp) - END ASSOCIATE - END ASSOCIATE - END ASSOCIATE - END DO - - CALL neighbor_list_3c_iterator_destroy(nl_3c_iter) - - DO i_img = 1, nimg - DO j_img = 1, nimg - IF (ALLOCATED(alloc_i(i_img, j_img)%array)) THEN - DO i = 1, SIZE(alloc_i(i_img, j_img)%array) - CALL dbt_get_stored_coordinates(t3c(i_img, j_img), & - [alloc_i(i_img, j_img)%array(i), alloc_j(i_img, j_img)%array(i), & - alloc_k(i_img, j_img)%array(i)], & - iproc) - CPASSERT(iproc .EQ. para_env%mepos) - END DO - - CALL dbt_reserve_blocks(t3c(i_img, j_img), & - alloc_i(i_img, j_img)%array, & - alloc_j(i_img, j_img)%array, & - alloc_k(i_img, j_img)%array) - END IF - END DO - END DO - - CALL timestop(handle) - - END SUBROUTINE - ! ************************************************************************************************** !> \brief Build 3-center derivative tensors !> \param t3c_der_i empty DBCSR tensor which will contain the 1st center derivatives @@ -1298,7 +1077,7 @@ SUBROUTINE build_3c_derivatives(t3c_der_i, t3c_der_k, filter_eps, qs_env, & CALL alloc_block_3c(t3c_template, nl_3c, basis_i, basis_j, basis_k, qs_env, potential_parameter, & op_pos=op_pos_prv, do_kpoints=do_kpoints, do_hfx_kpoints=do_hfx_kpoints, & bounds_i=bounds_i, bounds_j=bounds_j, bounds_k=bounds_k, & - RI_range=RI_range, img_to_RI_cell=img_to_RI_cell) + RI_range=RI_range, img_to_RI_cell=img_to_RI_cell, cell_to_index=cell_to_index) DO i_xyz = 1, 3 DO j_img = 1, ncell_RI DO i_img = 1, nimg @@ -2327,18 +2106,20 @@ END SUBROUTINE calc_3c_virial !> this routine requires that libint has been static initialised somewhere else !> \param do_hfx_kpoints ... !> \param desymmetrize ... +!> \param cell_sym ... !> \param bounds_i ... !> \param bounds_j ... !> \param bounds_k ... !> \param RI_range ... !> \param img_to_RI_cell ... +!> \param cell_to_index_ext ... ! ************************************************************************************************** SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & nl_3c, basis_i, basis_j, basis_k, & potential_parameter, int_eps, & - op_pos, do_kpoints, do_hfx_kpoints, desymmetrize, & + op_pos, do_kpoints, do_hfx_kpoints, desymmetrize, cell_sym, & bounds_i, bounds_j, bounds_k, & - RI_range, img_to_RI_cell) + RI_range, img_to_RI_cell, cell_to_index_ext) TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t3c REAL(KIND=dp), INTENT(IN) :: filter_eps @@ -2348,10 +2129,12 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & TYPE(libint_potential_type), INTENT(IN) :: potential_parameter REAL(KIND=dp), INTENT(IN), OPTIONAL :: int_eps INTEGER, INTENT(IN), OPTIONAL :: op_pos - LOGICAL, INTENT(IN), OPTIONAL :: do_kpoints, do_hfx_kpoints, desymmetrize + LOGICAL, INTENT(IN), OPTIONAL :: do_kpoints, do_hfx_kpoints, & + desymmetrize, cell_sym INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: bounds_i, bounds_j, bounds_k REAL(dp), INTENT(IN), OPTIONAL :: RI_range INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: img_to_RI_cell + INTEGER, DIMENSION(:, :, :), OPTIONAL, POINTER :: cell_to_index_ext CHARACTER(LEN=*), PARAMETER :: routineN = 'build_3c_integrals' @@ -2369,9 +2152,9 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & nsgfj, nsgfk INTEGER, DIMENSION(:, :), POINTER :: first_sgf_i, first_sgf_j, first_sgf_k INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index - LOGICAL :: block_not_zero, debug, desymmetrize_prv, & - do_hfx_kpoints_prv, do_kpoints_prv, & - found, skip + LOGICAL :: block_not_zero, cell_sym_prv, debug, & + desymmetrize_prv, do_hfx_kpoints_prv, & + do_kpoints_prv, found, skip REAL(KIND=dp) :: dij, dik, djk, dr_ij, dr_ik, dr_jk, & kind_radius_i, kind_radius_j, & kind_radius_k, max_contraction_i, & @@ -2429,6 +2212,12 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & desymmetrize_prv = .TRUE. END IF + IF (PRESENT(cell_sym)) THEN + cell_sym_prv = cell_sym + ELSE + cell_sym_prv = .FALSE. + END IF + op_ij = do_potential_id; op_jk = do_potential_id IF (PRESENT(op_pos)) THEN @@ -2466,26 +2255,33 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & ! get stuff CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, qs_kind_set=qs_kind_set, cell=cell, & - natom=natom, kpoints=kpoints, dft_control=dft_control, para_env=para_env) - - CALL alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potential_parameter, & - op_pos=op_pos_prv, do_kpoints=do_kpoints, do_hfx_kpoints=do_hfx_kpoints, & - bounds_i=bounds_i, bounds_j=bounds_j, bounds_k=bounds_k, & - RI_range=RI_range, img_to_RI_cell=img_to_RI_cell) + natom=natom, dft_control=dft_control, para_env=para_env) IF (do_kpoints_prv) THEN - nimg = dft_control%nimages + IF (PRESENT(cell_to_index_ext)) THEN + cell_to_index => cell_to_index_ext + nimg = MAXVAL(cell_to_index) + ELSE + CALL get_qs_env(qs_env, kpoints=kpoints) + CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index) + nimg = dft_control%nimages + END IF ncell_RI = nimg IF (do_hfx_kpoints_prv) THEN nimg = SIZE(t3c, 1) ncell_RI = SIZE(t3c, 2) END IF - CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index) ELSE nimg = 1 ncell_RI = 1 END IF + CALL alloc_block_3c(t3c, nl_3c, basis_i, basis_j, basis_k, qs_env, potential_parameter, & + op_pos=op_pos_prv, do_kpoints=do_kpoints, do_hfx_kpoints=do_hfx_kpoints, & + bounds_i=bounds_i, bounds_j=bounds_j, bounds_k=bounds_k, & + RI_range=RI_range, img_to_RI_cell=img_to_RI_cell, cell_sym=cell_sym_prv, & + cell_to_index=cell_to_index) + IF (do_hfx_kpoints_prv) THEN CPASSERT(op_pos_prv == 2) CPASSERT(.NOT. desymmetrize_prv) @@ -2595,9 +2391,10 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED (nthread,do_kpoints_prv,kp_index_lbounds,kp_index_ubounds,maxli,maxlk,maxlj,bounds_i,& -!$OMP bounds_j,bounds_k,nimg,basis_i,basis_j,basis_k,dr_ij,dr_jk,dr_ik,ncoset,int_eps,t3c,& -!$OMP tspj,spi,spk,debug,cell_to_index,natom,nl_3c,cell,op_pos_prv,do_hfx_kpoints_prv,& -!$OMP RI_range,ncell_RI,img_to_RI_cell_prv,potential_parameter) & +!$OMP bounds_j,bounds_k,nimg,basis_i,basis_j,basis_k,dr_ij,dr_jk,dr_ik,ncoset,& +!$OMP potential_parameter,int_eps,t3c,tspj,spi,spk,debug,cell_to_index,& +!$OMP natom,nl_3c,cell,op_pos_prv,do_hfx_kpoints_prv,RI_range,ncell_RI, & +!$OMP img_to_RI_cell_prv, cell_sym_prv) & !$OMP PRIVATE (lib,nl_3c_iter,ikind,jkind,kkind,iatom,jatom,katom,rij,rjk,rik,cell_j,cell_k,& !$OMP prefac,jcell,kcell,first_sgf_i,lmax_i,lmin_i,npgfi,nseti,nsgfi,rpgf_i,set_radius_i,& !$OMP sphi_i,zeti,kind_radius_i,first_sgf_j,lmax_j,lmin_j,npgfj,nsetj,nsgfj,rpgf_j,& @@ -2647,9 +2444,7 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & dij = NORM2(rij) dik = NORM2(rik) - IF (do_kpoints_prv) THEN - prefac = 0.5_dp - ELSEIF (nl_3c%sym == symmetric_jk) THEN + IF (nl_3c%sym == symmetric_jk) THEN IF (jatom == katom) THEN ! factor 0.5 due to double-counting of diagonal blocks ! (we desymmetrize by adding transpose) @@ -2668,7 +2463,7 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & ELSE prefac = 1.0_dp END IF - IF (do_hfx_kpoints_prv) prefac = 1.0_dp + IF (do_kpoints_prv) prefac = 1.0_dp IF (do_kpoints_prv) THEN @@ -2692,6 +2487,8 @@ SUBROUTINE build_3c_integrals(t3c, filter_eps, qs_env, & jcell = 1; kcell = 1 END IF + IF (cell_sym_prv .AND. jcell < kcell) CYCLE + blk_idx = [iatom, jatom, katom] IF (do_hfx_kpoints_prv) THEN blk_idx(3) = (kcell - 1)*natom + katom @@ -3381,7 +3178,7 @@ SUBROUTINE build_2c_integrals(t2c, filter_eps, qs_env, & INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index LOGICAL :: do_hfx_kpoints_prv, do_kpoints_prv, & do_symmetric, found, trans - REAL(KIND=dp) :: dab, my_regularization_RI + REAL(KIND=dp) :: dab, min_zet REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: sij, sij_contr, sij_rs REAL(KIND=dp), DIMENSION(3) :: ri, rij, rj REAL(KIND=dp), DIMENSION(:), POINTER :: set_radius_i, set_radius_j @@ -3415,9 +3212,6 @@ SUBROUTINE build_2c_integrals(t2c, filter_eps, qs_env, & CPASSERT(do_kpoints_prv) END IF - my_regularization_RI = 0.0_dp - IF (PRESENT(regularization_RI)) my_regularization_RI = regularization_RI - op_prv = potential_parameter%potential_type NULLIFY (qs_kind_set, atomic_kind_set, block_t%block, cell_to_index) @@ -3569,14 +3363,15 @@ SUBROUTINE build_2c_integrals(t2c, filter_eps, qs_env, & DEALLOCATE (sij_contr) ! RI regularization - IF (.NOT. do_hfx_kpoints_prv) THEN - IF (do_kpoints_prv .AND. cell_j(1) == 0 .AND. cell_j(2) == 0 .AND. cell_j(3) == 0 .AND. & - iatom == jatom .AND. iset == jset) THEN - DO i_diag = 1, nsgfi(iset) - sij_rs(i_diag, i_diag) = sij_rs(i_diag, i_diag) + & - regularization_RI*MAX(1.0_dp, 1.0_dp/MINVAL(zeti(:, iset))) - END DO - END IF + IF (.NOT. do_hfx_kpoints_prv .AND. PRESENT(regularization_RI) .AND. & + iatom == jatom .AND. iset == jset .AND. & + cell_j(1) == 0 .AND. cell_j(2) == 0 .AND. cell_j(3) == 0) THEN + DO i_diag = 1, nsgfi(iset) + min_zet = MINVAL(zeti(:, iset)) + CPASSERT(min_zet > 1.0E-10_dp) + sij_rs(i_diag, i_diag) = sij_rs(i_diag, i_diag) + & + regularization_RI*MAX(1.0_dp, 1.0_dp/min_zet) + END DO END IF CALL block_add("IN", sij_rs, & diff --git a/src/rpa_gw.F b/src/rpa_gw.F index e54a753947..b6df1323d5 100644 --- a/src/rpa_gw.F +++ b/src/rpa_gw.F @@ -4288,6 +4288,7 @@ END SUBROUTINE fit_and_continuation_2pole !> \param dos_eta ... !> \param dos_min ... !> \param dos_max ... +!> \param e_fermi_ext ... ! ************************************************************************************************** SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & z_value, m_value, vec_Sigma_c_gw, vec_Sigma_x_minus_vxc_gw, & @@ -4295,7 +4296,8 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & num_fit_points, crossing_search, homo, & fermi_level_offset, do_gw_im_time, print_self_energy, count_ev_sc_GW, & vec_gw_dos, dos_lower_bound, dos_precision, ndos, & - min_level_self_energy, max_level_self_energy, dos_eta, dos_min, dos_max) + min_level_self_energy, max_level_self_energy, & + dos_eta, dos_min, dos_max, e_fermi_ext) ! Optional arguments for spectral function REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_gw_energ @@ -4316,6 +4318,7 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & max_level_self_energy REAL(KIND=dp), OPTIONAL :: dos_eta INTEGER, INTENT(IN), OPTIONAL :: dos_min, dos_max + REAL(KIND=dp), OPTIONAL :: e_fermi_ext CHARACTER(LEN=*), PARAMETER :: routineN = 'continuation_pade' @@ -4348,8 +4351,8 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & END DO IF (do_gw_im_time) THEN - ! for cubic-scaling GW, we have one Green's function for occ and virt states with the Fermi level - ! in the middle of homo and lumo + ! for cubic-scaling GW, we have one Green's function for occ and virt states + ! with the Fermi level in the middle of homo and lumo e_fermi = 0.5_dp*(Eigenval(homo) + Eigenval(homo + 1)) ELSE ! in case of O(N^4) GW, we have the Fermi level differently for occ and virt states, see @@ -4361,6 +4364,8 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & END IF END IF + IF (PRESENT(e_fermi_ext)) e_fermi = e_fermi_ext + n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ !*** reorder, such that omega=i*0 is first entry @@ -4491,7 +4496,7 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & CALL get_sigma_c_bisection_pade(vec_gw_energ(n_level_gw), Eigenval_scf(n_level_gw_ref), & vec_Sigma_x_minus_vxc_gw(n_level_gw_ref), e_fermi, & nparam_pade, omega_points_pade, coeff_pade, & - n_level_gw_ref, start_val=level_energ_GW) + start_val=level_energ_GW) z_value(n_level_gw) = 1.0_dp m_value(n_level_gw) = 0.0_dp @@ -4499,7 +4504,7 @@ SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, & CALL get_sigma_c_newton_pade(vec_gw_energ(n_level_gw), Eigenval_scf(n_level_gw_ref), & vec_Sigma_x_minus_vxc_gw(n_level_gw_ref), e_fermi, & nparam_pade, omega_points_pade, coeff_pade, & - n_level_gw_ref, start_val=level_energ_GW) + start_val=level_energ_GW) z_value(n_level_gw) = 1.0_dp m_value(n_level_gw) = 0.0_dp @@ -4730,24 +4735,20 @@ END SUBROUTINE get_z_and_m_value_pade !> \param nparam_pade number of pade parameters !> \param omega_points_pade selection of frequency points of Sigma_c(iomega) !> \param coeff_pade pade coefficients -!> \param n_level_gw_ref ... !> \param start_val start value for the quasiparticle iteration ! ************************************************************************************************** SUBROUTINE get_sigma_c_bisection_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_gw, e_fermi, & - nparam_pade, omega_points_pade, coeff_pade, n_level_gw_ref, start_val) + nparam_pade, omega_points_pade, coeff_pade, start_val) REAL(KIND=dp), INTENT(OUT) :: gw_energ REAL(KIND=dp), INTENT(IN) :: Eigenval_scf, Sigma_x_minus_vxc_gw, & e_fermi INTEGER, INTENT(IN) :: nparam_pade COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: omega_points_pade, coeff_pade - INTEGER, INTENT(IN) :: n_level_gw_ref REAL(KIND=dp), INTENT(IN), OPTIONAL :: start_val CHARACTER(LEN=*), PARAMETER :: routineN = 'get_sigma_c_bisection_pade' - CHARACTER(LEN=512) :: error_msg - CHARACTER(LEN=64) :: n_level_gw_ref_char COMPLEX(KIND=dp) :: sigma_c INTEGER :: handle, icount REAL(KIND=dp) :: delta, energy_val, my_start_val, & @@ -4777,13 +4778,8 @@ SUBROUTINE get_sigma_c_bisection_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_ coeff_pade, sigma_c) qp_energy = Eigenval_scf + REAL(sigma_c) + Sigma_x_minus_vxc_gw delta = qp_energy - qp_energy_old - IF (icount > 500) THEN - WRITE (n_level_gw_ref_char, '(I10)') n_level_gw_ref - WRITE (error_msg, '(A,A,A)') " Self-consistent quasi-particle solution of "// & - "MO ", TRIM(n_level_gw_ref_char), " has not been found." - CPWARN(error_msg) - EXIT - END IF + ! Self-consistent quasi-particle solution has not been found + IF (icount > 500) EXIT END DO gw_energ = REAL(sigma_c) @@ -4801,24 +4797,20 @@ END SUBROUTINE get_sigma_c_bisection_pade !> \param nparam_pade number of pade parameters !> \param omega_points_pade selection of frequency points of Sigma_c(iomega) !> \param coeff_pade pade coefficients -!> \param n_level_gw_ref ... !> \param start_val start value for the quasiparticle iteration ! ************************************************************************************************** SUBROUTINE get_sigma_c_newton_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_gw, e_fermi, & - nparam_pade, omega_points_pade, coeff_pade, n_level_gw_ref, start_val) + nparam_pade, omega_points_pade, coeff_pade, start_val) REAL(KIND=dp), INTENT(OUT) :: gw_energ REAL(KIND=dp), INTENT(IN) :: Eigenval_scf, Sigma_x_minus_vxc_gw, & e_fermi INTEGER, INTENT(IN) :: nparam_pade COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: omega_points_pade, coeff_pade - INTEGER, INTENT(IN) :: n_level_gw_ref REAL(KIND=dp), INTENT(IN), OPTIONAL :: start_val CHARACTER(LEN=*), PARAMETER :: routineN = 'get_sigma_c_newton_pade' - CHARACTER(LEN=512) :: error_msg - CHARACTER(LEN=64) :: n_level_gw_ref_char COMPLEX(KIND=dp) :: sigma_c INTEGER :: handle, icount REAL(KIND=dp) :: delta, energy_val, m_value, & @@ -4852,13 +4844,8 @@ SUBROUTINE get_sigma_c_newton_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_gw, qp_energy = qp_energy - (Eigenval_scf + Sigma_x_minus_vxc_gw + REAL(sigma_c) - qp_energy)/ & (m_value - 1.0_dp) delta = qp_energy - qp_energy_old - IF (icount > 500) THEN - WRITE (n_level_gw_ref_char, '(I10)') n_level_gw_ref - WRITE (error_msg, '(A,A,A)') " Self-consistent quasi-particle solution of "// & - "MO ", TRIM(n_level_gw_ref_char), " has not been found." - CPWARN(error_msg) - EXIT - END IF + ! Self-consistent quasi-particle solution has not been found + IF (icount > 500) EXIT END DO gw_energ = REAL(sigma_c) diff --git a/src/rpa_gw_sigma_x.F b/src/rpa_gw_sigma_x.F index dc40640984..0ba6bbbbd8 100644 --- a/src/rpa_gw_sigma_x.F +++ b/src/rpa_gw_sigma_x.F @@ -63,7 +63,7 @@ MODULE rpa_gw_sigma_x z_zero USE message_passing, ONLY: mp_para_env_type USE mp2_integrals, ONLY: compute_kpoints - USE mp2_ri_2c, ONLY: setup_trunc_coulomb_pot_for_exchange_self_energy + USE mp2_ri_2c, ONLY: trunc_coulomb_for_exchange USE mp2_types, ONLY: mp2_type USE parallel_gemm_api, ONLY: parallel_gemm USE physcon, ONLY: evolt @@ -616,7 +616,7 @@ SUBROUTINE compute_vec_Sigma_x_minus_vxc_gw(qs_env, mp2_env, mos_mp2, energy_ex, CALL get_qs_env(qs_env=qs_env, & kpoints=kpoints) - CALL setup_trunc_coulomb_pot_for_exchange_self_energy(qs_env) + CALL trunc_coulomb_for_exchange(qs_env) CALL compute_kpoints(qs_env, kpoints, unit_nr) diff --git a/src/soc_pseudopotential_methods.F b/src/soc_pseudopotential_methods.F index 2d6d2f7f45..009ad5aac9 100644 --- a/src/soc_pseudopotential_methods.F +++ b/src/soc_pseudopotential_methods.F @@ -32,6 +32,8 @@ MODULE soc_pseudopotential_methods cp_fm_release,& cp_fm_type USE kinds, ONLY: dp + USE kpoint_types, ONLY: get_kpoint_info,& + kpoint_type USE mathconstants, ONLY: gaussi,& z_one,& z_zero @@ -41,7 +43,8 @@ MODULE soc_pseudopotential_methods qs_environment_type USE qs_force_types, ONLY: qs_force_type USE qs_kind_types, ONLY: qs_kind_type - USE qs_neighbor_list_types, ONLY: neighbor_list_set_p_type + USE qs_neighbor_list_types, ONLY: get_neighbor_list_set_p,& + neighbor_list_set_p_type USE soc_pseudopotential_utils, ONLY: add_dbcsr_submat,& add_fm_submat,& create_cfm_double @@ -76,14 +79,16 @@ SUBROUTINE V_SOC_xyz_from_pseudopotential(qs_env, mat_V_SOC_xyz) CHARACTER(LEN=*), PARAMETER :: routineN = 'V_SOC_xyz_from_pseudopotential' - INTEGER :: handle, nder, xyz - LOGICAL :: calculate_forces, use_virial + INTEGER :: handle, img, nder, nimages, xyz + INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index + LOGICAL :: calculate_forces, do_symmetric, & + use_virial REAL(KIND=dp) :: eps_ppnl TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set - TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_l, mat_l_nosym, mat_pot_dummy, & - matrix_dummy + matrix_dummy, matrix_s TYPE(dft_control_type), POINTER :: dft_control + TYPE(kpoint_type), POINTER :: kpoints TYPE(neighbor_list_set_p_type), DIMENSION(:), & POINTER :: sab_orb, sap_ppnl TYPE(particle_type), DIMENSION(:), POINTER :: particle_set @@ -93,60 +98,76 @@ SUBROUTINE V_SOC_xyz_from_pseudopotential(qs_env, mat_V_SOC_xyz) CALL timeset(routineN, handle) - NULLIFY (qs_kind_set, dft_control, sab_orb, sap_ppnl, particle_set, atomic_kind_set) + NULLIFY (qs_kind_set, dft_control, sab_orb, sap_ppnl, particle_set, atomic_kind_set, & + cell_to_index) CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set, dft_control=dft_control, & - matrix_s=matrix_s, atomic_kind_set=atomic_kind_set, & + matrix_s_kp=matrix_s, kpoints=kpoints, atomic_kind_set=atomic_kind_set, & particle_set=particle_set, sab_orb=sab_orb, sap_ppnl=sap_ppnl) eps_ppnl = dft_control%qs_control%eps_ppnl + nimages = dft_control%nimages + CALL get_neighbor_list_set_p(neighbor_list_sets=sab_orb, symmetric=do_symmetric) + CALL get_kpoint_info(kpoint=kpoints, cell_to_index=cell_to_index) - NULLIFY (mat_l) - CALL dbcsr_allocate_matrix_set(mat_l, 3, 1) + NULLIFY (mat_l, mat_pot_dummy) + CALL dbcsr_allocate_matrix_set(mat_l, 3, nimages) DO xyz = 1, 3 - ALLOCATE (mat_l(xyz, 1)%matrix) - CALL dbcsr_create(mat_l(xyz, 1)%matrix, template=matrix_s(1)%matrix, & - matrix_type=dbcsr_type_antisymmetric) - CALL cp_dbcsr_alloc_block_from_nbl(mat_l(xyz, 1)%matrix, sab_orb) - CALL dbcsr_set(mat_l(xyz, 1)%matrix, 0.0_dp) + DO img = 1, nimages + ALLOCATE (mat_l(xyz, img)%matrix) + CALL dbcsr_create(mat_l(xyz, img)%matrix, template=matrix_s(1, 1)%matrix, & + matrix_type=dbcsr_type_antisymmetric) + CALL cp_dbcsr_alloc_block_from_nbl(mat_l(xyz, img)%matrix, sab_orb) + CALL dbcsr_set(mat_l(xyz, img)%matrix, 0.0_dp) + END DO END DO - ! get mat_l + ! get mat_l; the next CPASSERT fails if the atoms do not have any SOC parameters, i.e. + ! SOC is zero and one should not activate the SOC section CPASSERT(ASSOCIATED(sap_ppnl)) nder = 0 use_virial = .FALSE. calculate_forces = .FALSE. NULLIFY (mat_pot_dummy) - CALL dbcsr_allocate_matrix_set(mat_pot_dummy, 1, 1) - ALLOCATE (mat_pot_dummy(1, 1)%matrix) - CALL dbcsr_create(mat_pot_dummy(1, 1)%matrix, template=matrix_s(1)%matrix) - CALL cp_dbcsr_alloc_block_from_nbl(mat_pot_dummy(1, 1)%matrix, sab_orb) - CALL dbcsr_set(mat_pot_dummy(1, 1)%matrix, 0.0_dp) + CALL dbcsr_allocate_matrix_set(mat_pot_dummy, 1, nimages) + DO img = 1, nimages + ALLOCATE (mat_pot_dummy(1, img)%matrix) + CALL dbcsr_create(mat_pot_dummy(1, img)%matrix, template=matrix_s(1, 1)%matrix) + CALL cp_dbcsr_alloc_block_from_nbl(mat_pot_dummy(1, img)%matrix, sab_orb) + CALL dbcsr_set(mat_pot_dummy(1, img)%matrix, 0.0_dp) + END DO CALL build_core_ppnl(mat_pot_dummy, matrix_dummy, force, virial, & calculate_forces, use_virial, nder, & qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, & - eps_ppnl, nimages=1, basis_type="ORB", matrix_l=mat_l) + eps_ppnl, nimages=nimages, cell_to_index=cell_to_index, & + basis_type="ORB", matrix_l=mat_l) + +! JW TODO: 1 -> nimages and TEST THIS!!! NULLIFY (mat_l_nosym) - CALL dbcsr_allocate_matrix_set(mat_l_nosym, 3, 1) + CALL dbcsr_allocate_matrix_set(mat_l_nosym, 3, nimages) DO xyz = 1, 3 - ALLOCATE (mat_l_nosym(xyz, 1)%matrix) - CALL dbcsr_create(mat_l_nosym(xyz, 1)%matrix, template=matrix_s(1)%matrix, & - matrix_type=dbcsr_type_no_symmetry) - CALL dbcsr_desymmetrize(mat_l(xyz, 1)%matrix, mat_l_nosym(xyz, 1)%matrix) - + DO img = 1, nimages + ALLOCATE (mat_l_nosym(xyz, img)%matrix) + CALL dbcsr_create(mat_l_nosym(xyz, img)%matrix, template=matrix_s(1, 1)%matrix, & + matrix_type=dbcsr_type_no_symmetry) + CALL dbcsr_desymmetrize(mat_l(xyz, img)%matrix, mat_l_nosym(xyz, img)%matrix) + END DO END DO NULLIFY (mat_V_SOC_xyz) - CALL dbcsr_allocate_matrix_set(mat_V_SOC_xyz, 3, 1) + CALL dbcsr_allocate_matrix_set(mat_V_SOC_xyz, 3, nimages) DO xyz = 1, 3 - ALLOCATE (mat_V_SOC_xyz(xyz, 1)%matrix) - CALL dbcsr_create(mat_V_SOC_xyz(xyz, 1)%matrix, template=matrix_s(1)%matrix, & - matrix_type=dbcsr_type_no_symmetry) - CALL cp_dbcsr_alloc_block_from_nbl(mat_V_SOC_xyz(xyz, 1)%matrix, sab_orb) - ! factor 0.5 from ħ/2 prefactor - CALL dbcsr_add(mat_V_SOC_xyz(xyz, 1)%matrix, mat_l_nosym(xyz, 1)%matrix, 0.0_dp, 0.5_dp) + DO img = 1, nimages + ALLOCATE (mat_V_SOC_xyz(xyz, img)%matrix) + CALL dbcsr_create(mat_V_SOC_xyz(xyz, img)%matrix, template=matrix_s(1, 1)%matrix, & + matrix_type=dbcsr_type_no_symmetry) + CALL cp_dbcsr_alloc_block_from_nbl(mat_V_SOC_xyz(xyz, img)%matrix, sab_orb) + ! factor 0.5 from ħ/2 prefactor + CALL dbcsr_add(mat_V_SOC_xyz(xyz, img)%matrix, mat_l_nosym(xyz, img)%matrix, & + 0.0_dp, 0.5_dp) + END DO END DO CALL dbcsr_deallocate_matrix_set(mat_pot_dummy) diff --git a/tests/Fist/regtest-allegro/Si-dp.inp b/tests/Fist/regtest-allegro/Si-dp.inp index 151d653c49..5c84ca177a 100644 --- a/tests/Fist/regtest-allegro/Si-dp.inp +++ b/tests/Fist/regtest-allegro/Si-dp.inp @@ -47,10 +47,6 @@ &END EWALD &END POISSON &END MM - &PRINT - &FORCES - &END FORCES - &END PRINT &SUBSYS &CELL ABC 10.861999859992501 10.861999859992501 10.861999859992501 @@ -58,7 +54,6 @@ &END CELL &TOPOLOGY COORD_FILE_FORMAT XYZ - # coordinates must be ordered by atomic number COORD_FILE_NAME Si.xyz # MULTIPLE_UNIT_CELL 4 4 4 &END TOPOLOGY diff --git a/tests/Fist/regtest-allegro/TEST_FILES b/tests/Fist/regtest-allegro/TEST_FILES index bbce57606f..30be4ff417 100644 --- a/tests/Fist/regtest-allegro/TEST_FILES +++ b/tests/Fist/regtest-allegro/TEST_FILES @@ -1,5 +1,4 @@ # Test of Allegro using libtorch https://pytorch.org/cppdocs/installing.html -Si-dp.inp 11 1.0E-12 -305.901401121683080 -water-gra-film-sp.inp 11 1.0E-6 -2073.192819118499756 -water-bulk-sp.inp 11 1.0E-6 -558.065488338470459 +Si-dp.inp 11 1.0E-12 -305.905681109061788 +water-bulk-sp.inp 11 1.0E-6 -556.070399189654040 #EOF diff --git a/tests/Fist/regtest-allegro/water-bulk-sp.inp b/tests/Fist/regtest-allegro/water-bulk-sp.inp index 24f274506b..ab9d8b363d 100644 --- a/tests/Fist/regtest-allegro/water-bulk-sp.inp +++ b/tests/Fist/regtest-allegro/water-bulk-sp.inp @@ -27,7 +27,7 @@ ATOMS H O PARM_FILE_NAME Allegro/gra-water-deployed-neq060sp.pth UNIT_COORDS angstrom - UNIT_ENERGY Hartree + UNIT_ENERGY eV UNIT_FORCES eV*angstrom^-1 &END ALLEGRO &END NONBONDED @@ -38,6 +38,10 @@ &END EWALD &END POISSON &END MM + &PRINT + &FORCES + &END FORCES + &END PRINT &SUBSYS &CELL A 9.8528 0.0 0.0 diff --git a/tests/Fist/regtest-allegro/water-gra-film-sp.inp b/tests/Fist/regtest-allegro/water-gra-film-sp.inp deleted file mode 100644 index 6d69d3d776..0000000000 --- a/tests/Fist/regtest-allegro/water-gra-film-sp.inp +++ /dev/null @@ -1,52 +0,0 @@ -&GLOBAL - PRINT_LEVEL LOW - PROJECT water_gra - RUN_TYPE MD -&END GLOBAL - -&MOTION - &MD - ENSEMBLE NVT - STEPS 0 - TEMPERATURE 300 - TIMESTEP 0.5 - &THERMOSTAT - &CSVR - TIMECON 10 - &END CSVR - &END THERMOSTAT - &END MD -&END MOTION - -&FORCE_EVAL - METHOD FIST - &MM - &FORCEFIELD - &NONBONDED - &ALLEGRO - ATOMS H C O - PARM_FILE_NAME Allegro/gra-water-deployed-neq060sp.pth - UNIT_COORDS angstrom - UNIT_ENERGY Hartree - UNIT_FORCES eV*angstrom^-1 - &END ALLEGRO - &END NONBONDED - &END FORCEFIELD - &POISSON - &EWALD - EWALD_TYPE none - &END EWALD - &END POISSON - &END MM - &SUBSYS - &CELL - A 12.8160 0.0 0.0 - B 0.0 12.3322 0.0 - C 0.0 0.0 55.0 - &END CELL - &TOPOLOGY - COORD_FILE_FORMAT XYZ - COORD_FILE_NAME ./water-gra-film.xyz - &END TOPOLOGY - &END SUBSYS -&END FORCE_EVAL diff --git a/tests/Fist/regtest-allegro/water-gra-film.xyz b/tests/Fist/regtest-allegro/water-gra-film.xyz deleted file mode 100644 index 6d28ed36b9..0000000000 --- a/tests/Fist/regtest-allegro/water-gra-film.xyz +++ /dev/null @@ -1,362 +0,0 @@ -360 -Properties=species:S:1:pos:R:3 i=115839 time=115839.0 E=-2073.6492066345 pbc="F F F" -H 30.50739371 1.94749496 11.01943875 -H 31.22099325 3.09801680 11.91463487 -H 46.09305139 -17.36894634 16.53478394 -H 46.99324579 -17.85427472 15.28476484 -H 47.41479383 2.03010080 17.45932109 -H 46.29600392 2.61389739 16.60418026 -H 34.19508989 3.77092340 6.21713489 -H 34.45070881 2.68877708 5.25463099 -H 45.35813420 -19.92103773 15.92931273 -H 46.34458000 -20.02769052 14.72304366 -H 26.07318639 7.25260954 3.18336272 -H 26.01785225 6.08997124 4.15793492 -H 39.02081145 -15.79467292 11.80839246 -H 37.67841367 -15.01828617 12.22090968 -H 30.71125463 -3.70760952 10.06056168 -H 30.33509171 -2.13475843 10.20873814 -H 49.19367799 -3.30427390 13.57075677 -H 48.10584571 -2.25418716 13.50875242 -H 33.59394501 0.41541301 9.75897555 -H 33.80044642 0.27512135 11.39280971 -H 41.27896535 9.78010261 16.45176399 -H 42.73026956 9.75560320 16.01581118 -H 49.47265572 2.78582559 18.59594847 -H 49.71478321 2.66405692 17.04069775 -H 48.87480984 9.02680978 9.63436753 -H 48.44194065 10.26341256 10.41549772 -H 27.34086509 10.10924167 7.33957700 -H 28.14452173 9.58366390 8.61272386 -H 20.99314648 8.86913407 8.43606130 -H 20.89406038 8.37328951 6.99263429 -H 54.78201380 9.20738892 14.05607965 -H 54.12161780 9.68586514 12.79293687 -H 36.61241181 6.28193382 14.69756697 -H 36.42889452 4.97895606 15.38587583 -H 41.49311819 6.89996002 15.76768393 -H 40.41775951 5.81673259 15.70931797 -H 47.72628828 -3.37483477 15.97355346 -H 48.77299467 -2.55688798 16.79413337 -H 22.23609751 0.10567114 3.76293910 -H 23.56210229 -0.76043957 3.95668866 -H 20.01249221 5.21752507 3.04821890 -H 20.93961334 5.01825912 4.32573379 -H 34.22288217 -6.87785759 9.47298753 -H 34.45152553 -5.61330173 8.70805305 -H 49.90402414 -17.82169611 3.91566392 -H 48.77750772 -18.27962503 2.81214757 -H 24.68305643 -8.37961843 4.01495774 -H 24.70682624 -7.51638045 5.41793674 -H 34.09302733 11.11871939 6.06935249 -H 32.63150082 11.03661392 6.59068531 -H 33.81177689 -3.88894284 17.91919677 -H 32.36370729 -3.63385557 17.51091027 -H 44.18194300 -18.77403460 11.21881564 -H 45.17137886 -19.15981127 12.48792572 -H 53.49009447 3.53974762 14.52502130 -H 53.48535436 3.35051743 16.10544986 -H 17.86812347 11.46026663 13.91503061 -H 17.73826129 10.16728145 13.14540250 -H 34.31443636 -10.80850181 7.49860353 -H 33.47063063 -12.04169236 7.10472877 -H 30.74381991 7.38191949 6.08681673 -H 29.25303917 7.87634169 6.23271636 -H 28.13510817 15.48562084 18.50940090 -H 27.61564023 14.09885636 17.74793219 -H 25.19428067 7.75984665 13.44959322 -H 24.23180257 7.44876312 12.26984012 -H 46.60083456 5.13871665 7.39916756 -H 45.13573445 5.10789071 6.71606425 -H 22.04990116 -4.51408142 4.63453233 -H 20.82943682 -5.17452533 5.26073685 -H 36.47919705 -11.02760927 10.56346414 -H 37.51889914 -12.17916216 10.55378777 -H 32.77239884 -0.47694398 4.29372366 -H 31.71629908 -0.28013105 3.12493058 -H 31.58851088 6.82235441 14.84712432 -H 30.44498526 6.33786487 13.78460272 -H 26.36918538 -9.72173763 5.88391344 -H 25.80162733 -9.51991808 7.37715906 -H 37.28295417 13.29564463 7.31538426 -H 38.14823720 12.13872200 6.43897442 -H 33.30914609 -9.09005628 3.71186903 -H 33.55157855 -10.43060604 3.01452790 -H 45.34387807 -4.76520929 10.47840331 -H 45.04709206 -4.80126778 8.93994259 -H 24.97246191 -15.99609854 7.32662310 -H 24.48352102 -17.04837342 6.16908612 -H 41.90499734 17.46405307 18.57250246 -H 40.46977546 17.72224071 18.26287698 -H 36.09035708 -1.02214532 6.97240661 -H 36.17017538 -2.42089110 6.53265339 -H 34.35352484 -6.11291392 13.01166229 -H 34.76266171 -7.62875599 12.94958832 -H 28.09061323 -6.60343130 6.12712457 -H 27.85482537 -8.10507517 6.46554852 -H 34.04891709 -13.35238909 16.66274721 -H 33.48252658 -11.92736197 16.32758562 -H 43.45630248 12.06505726 19.03704471 -H 43.78691049 10.73215802 19.77989511 -H 20.67152448 25.90542373 13.52417177 -H 21.50399816 24.84763303 14.22627746 -H 40.36868725 -4.53695150 7.05782134 -H 39.54235948 -4.59968826 5.62981041 -H 30.60179135 -18.25509872 2.86951884 -H 30.65938205 -19.71779653 3.36528763 -H 37.27507123 13.53120369 12.70160758 -H 36.03581366 13.54582905 13.66601385 -H 41.74117424 0.47285823 14.85647654 -H 43.05349858 0.69279538 15.64360156 -H 27.22440089 3.04612753 10.87256566 -H 27.63499662 2.29284482 9.55968602 -H 20.52294326 -3.25765593 14.67298049 -H 19.92452937 -2.24446456 13.47496503 -H 34.54896280 -6.56756149 18.38171382 -H 35.32728629 -7.12940550 17.15049462 -H 32.50009101 -2.53020425 3.05209243 -H 32.81627122 -3.94446845 3.62458914 -H 54.45925523 2.84879241 12.24917383 -H 53.40355500 2.04976675 13.25404368 -H 36.27652843 -9.60282621 7.09593791 -H 36.55683985 -9.41727907 8.70719144 -H 31.78979199 1.74663396 17.96189373 -H 30.14928983 1.93786562 17.65572692 -H 33.57513735 -3.96148254 12.20860836 -H 34.65544652 -3.97707434 11.06188827 -H 16.54214311 0.15766412 3.89492944 -H 16.39116622 -0.18474883 2.46668072 -H 32.16185806 10.60995243 16.17410578 -H 31.17196443 10.42143564 17.50029968 -H 44.78964525 14.05809071 8.13678687 -H 43.61646151 15.05221470 8.29987549 -H 25.95835410 -17.88117011 17.24071845 -H 24.76005481 -17.10410011 17.67920584 -H 30.75141102 -0.54218117 11.79954198 -H 31.64876488 0.07530088 10.73864012 -H 44.21244102 5.70496372 17.52745275 -H 43.27794064 5.66193536 16.29968156 -H 47.69717877 3.06640493 10.20335423 -H 48.97846803 3.25373392 11.15096459 -H 30.23473325 13.63313214 6.32122963 -H 30.28988190 12.24081281 6.77072714 -H 27.86193896 -4.44270203 12.55115931 -H 27.70112659 -4.92302757 11.04977929 -H 51.12200584 9.70790877 9.46959152 -H 50.63786637 8.17302037 9.76114077 -H 44.73826699 2.18743518 5.13063309 -H 43.49947637 3.09523240 4.86501813 -H 52.24597193 -7.38726616 9.20399304 -H 52.14881788 -5.80963715 8.91902675 -H 26.16339871 9.61729249 3.86966135 -H 27.67892095 9.53923212 3.45995118 -H 36.11707422 -6.49484928 7.21636583 -H 37.64725913 -6.56004418 7.41038220 -H 39.23447625 4.11286466 12.89819602 -H 39.24081709 5.77729101 12.80020778 -H 36.06778609 -6.00809385 10.15805359 -H 37.61696869 -6.25911505 10.21098388 -H 24.52735532 4.52536070 12.93111588 -H 24.00184960 3.05266355 13.10388030 -H 27.83100826 -0.26136297 6.32247484 -H 27.20111016 -1.28607751 5.15006791 -H 17.45243579 -7.40037770 6.86379151 -H 17.62212782 -7.01887972 8.36784957 -H 24.32632297 -1.88451050 15.15691138 -H 25.15624450 -2.59994008 16.16459336 -H 52.19022270 -0.17249622 9.11151299 -H 50.82857258 -0.62099999 8.37263514 -H 30.70711474 -2.50455850 6.78785956 -H 30.95841306 -2.19543295 8.20281914 -H 16.47113633 12.73111205 9.63457585 -H 16.09173761 12.91662504 8.14382018 -H 42.56852371 8.13220609 4.29600051 -H 42.84298866 8.88944226 2.94197892 -H 28.89506836 16.45272344 4.58158010 -H 28.38005304 15.27420008 3.64398323 -H 49.47591475 13.60079453 3.85290402 -H 49.59733348 14.38273059 2.53812624 -H 19.91262144 -9.13515439 9.33790206 -H 19.81779033 -8.02477668 10.43404612 -H 39.84548416 -4.01893661 15.36794533 -H 39.55152610 -2.68348842 14.67645134 -H 41.70314654 -4.51579193 9.34652435 -H 41.91250153 -5.94282580 9.81357932 -H 38.13606706 1.08697546 17.73471090 -H 38.38630837 -0.20112312 16.87199904 -H 57.87725897 -21.74287674 14.51117449 -H 56.77205931 -22.81071387 14.02904782 -H 24.20630098 9.66299014 4.81956935 -H 23.92118774 9.24814911 3.30295511 -H 51.18120285 15.80029592 15.32440342 -H 49.96959725 14.94081488 14.90173696 -H 26.78563198 0.50984550 4.00726040 -H 26.16396154 1.76482431 3.45574338 -H 53.81858469 -13.20147761 11.35539140 -H 52.44966375 -13.80303122 12.09207727 -H 42.93633924 4.32333680 10.57807704 -H 41.63738246 4.25720525 9.69856939 -H 40.58186642 -2.28921122 18.72113184 -H 39.98913250 -3.63979985 18.18913505 -H 26.31081143 13.05636112 15.07815375 -H 27.07107126 12.55658093 13.71679654 -C -53.99965576 34.81613042 0.18653161 -C -52.58212089 34.82336321 0.25276268 -C -51.89841228 36.07594564 0.19331495 -C -50.41068624 36.00945928 0.14059305 -C -54.01943015 37.29105069 0.33855290 -C -52.56756781 37.28894145 0.11342293 -C -51.82087700 38.47106932 0.13948807 -C -50.42787390 38.50981477 0.19257710 -C -54.00442862 39.73086869 0.40142001 -C -52.55938909 39.67800656 0.34277983 -C -51.87980219 41.00992730 0.46946189 -C -50.45828681 40.98928201 0.41179718 -C -54.03177364 42.17010085 0.38706483 -C -52.60652774 42.18972193 0.43042302 -C -51.88427840 43.43156387 0.47039863 -C -50.42441917 43.47126734 0.44069944 -C -54.01699919 44.67797096 0.25754172 -C -52.56646199 44.63316858 0.29387842 -C -51.88518989 45.85751607 0.29620930 -C -50.47890407 45.89941306 0.36357825 -C -49.72692308 34.82780755 0.19752541 -C -48.31055491 34.82878507 0.05695848 -C -47.60625594 36.05989613 -0.06964532 -C -46.19476004 35.97170658 0.04020664 -C -49.72760684 37.25617208 0.13387347 -C -48.30633421 37.29837674 0.04572615 -C -47.61834996 38.53952523 0.11682353 -C -46.17975375 38.45999350 0.10702390 -C -49.73063571 39.75055808 0.14601662 -C -48.33738975 39.80977172 0.12790348 -C -47.64893840 41.00963663 0.30224269 -C -46.19609078 40.96800462 0.18475035 -C -49.74372454 42.20409422 0.46909665 -C -48.33217274 42.19320312 0.32180443 -C -47.61116574 43.45996752 0.10398479 -C -46.21285696 43.39332157 0.05751580 -C -49.72501147 44.69346991 0.35654221 -C -48.31633301 44.69701015 0.20414518 -C -47.62830581 45.89462789 0.12871559 -C -46.19986886 45.85969657 0.01567749 -C -45.48697729 34.76014895 0.04754153 -C -44.04047139 34.81064524 -0.01155315 -C -43.31120224 36.03882510 0.14058154 -C -41.89467679 36.05134604 0.22359811 -C -45.47369485 37.23882482 0.03839722 -C -44.05657735 37.24749597 0.11576817 -C -43.32517393 38.43046215 0.18779629 -C -41.95880491 38.50469413 0.36632095 -C -45.47796634 39.71096379 0.04509862 -C -44.05000537 39.66591916 0.02188417 -C -43.34264805 40.88545071 0.09283394 -C -41.91271955 40.94213449 0.25597931 -C -45.51059464 42.20477885 0.10844694 -C -44.10137415 42.15383031 0.09745949 -C -43.41914606 43.39712048 0.19113563 -C -41.95116300 43.42861250 0.27082932 -C -45.50627037 44.65337740 0.00530157 -C -44.11548998 44.67479009 0.18282230 -C -43.33591697 45.90395212 0.07544342 -C -41.89594387 45.88847401 0.20520804 -O 30.40592905 2.78007352 11.49905776 -O 46.17491788 -17.33781903 15.44527879 -O 46.46929127 1.89683534 17.26390084 -O 34.77321942 2.97081398 6.12608289 -O 45.87189339 -20.58801791 15.42313638 -O 26.00985130 7.00181150 4.07859548 -O 38.61197971 -14.87531879 11.85608031 -O 30.08932208 -2.99894958 9.80763118 -O 49.10904350 -2.28982983 13.54417899 -O 33.21945991 0.61258863 10.64364556 -O 41.82206079 9.79049343 15.68446402 -O 49.30158450 2.19805035 17.83587462 -O 48.10135712 9.42341470 10.01389684 -O 27.49763404 9.32813601 7.92714529 -O 20.61903041 8.15284371 7.91082787 -O 54.77016412 8.97124752 13.08673568 -O 36.05861113 5.90417187 15.38688491 -O 40.55459320 6.79477712 16.04067733 -O 47.82146560 -2.92115626 16.88310392 -O 23.02763231 -0.00603316 4.34237026 -O 20.98130251 5.14491339 3.34094215 -O 34.90890096 -6.45514439 8.89616572 -O 49.03252037 -17.62581580 3.51142144 -O 25.20323426 -7.82768765 4.58373700 -O 33.24424456 11.56170014 5.92105345 -O 32.96902069 -4.35675818 17.97744622 -O 44.21047922 -19.26894941 12.05685068 -O 53.28523062 3.95591600 15.37015980 -O 18.36852391 10.91274517 13.27670402 -O 33.64810140 -11.40770056 7.89486542 -O 30.15856447 8.19955225 5.99190308 -O 28.32132940 14.81122075 17.83859580 -O 24.28802757 7.50234730 13.29001702 -O 46.18585749 5.26623843 6.49524746 -O 21.21904954 -4.30577800 5.06128495 -O 36.73209879 -11.87002409 11.06094984 -O 32.70822716 -0.20870457 3.35652938 -O 30.63425715 6.84121809 14.64454344 -O 26.63053357 -9.49445080 6.78666303 -O 37.39522307 12.32333285 6.97055832 -O 33.14483573 -10.05656626 3.81189759 -O 44.62803102 -5.06434792 9.85717368 -O 24.58800643 -16.06272337 6.40030171 -O 41.01079444 17.26485870 18.97199962 -O 35.49022415 -1.83968467 6.92387806 -O 33.99007229 -6.97048587 13.00585080 -O 28.56657638 -7.45784132 6.21869469 -O 33.49796192 -12.85043367 15.98168104 -O 43.27250113 11.08311313 19.02941711 -O 21.50364759 25.32714326 13.36717703 -O 40.28537127 -5.06801762 6.22895843 -O 31.19529032 -18.84882158 3.35790160 -O 37.00038263 13.79904279 13.65204714 -O 42.67992373 0.66434879 14.75357456 -O 27.31656115 3.19826094 9.89311436 -O 20.61904045 -2.90538796 13.73428897 -O 34.66451970 -7.35606148 17.84207392 -O 32.16986857 -3.46673250 3.01852050 -O 53.55871034 2.86417657 12.68534455 -O 36.95908823 -9.77851333 7.83340372 -O 30.86984976 1.29289081 17.85033178 -O 34.01881022 -4.54101240 11.51195783 -O 16.98488443 -0.32106508 3.19217409 -O 31.54949792 9.91654703 16.71047213 -O 44.32669295 14.58925514 8.79266609 -O 25.50053743 -17.58823338 18.08293410 -O 30.77646861 -0.34446852 10.81749476 -O 43.51111506 5.13086670 17.13487934 -O 48.60204990 2.88946097 10.24762205 -O 29.68830971 12.93590136 6.73868389 -O 27.16254026 -4.94180318 11.94490700 -O 50.51663884 8.98220602 9.18188128 -O 44.07896726 2.77121192 5.62049537 -O 51.64174392 -6.64003949 9.04014044 -O 26.98961876 10.16525626 3.74771689 -O 36.97447879 -6.47815297 6.69034028 -O 38.95521969 4.93112709 13.36117458 -O 36.88730487 -5.82072080 10.70827129 -O 23.78181783 3.92937082 12.58003294 -O 27.11726703 -0.88258186 6.09840978 -O 18.02668796 -6.81600595 7.47645292 -O 24.50352049 -1.91002101 16.13448336 -O 51.35700582 -0.63799658 9.26019468 -O 31.20006752 -1.83332383 7.30265962 -O 15.72348909 13.00092803 9.09611841 -O 42.12386863 8.32435092 3.40595497 -O 29.11197668 15.97263784 3.75261675 -O 50.06343502 14.27634205 3.39380523 -O 20.48383591 -8.51291356 9.94673973 -O 39.18130814 -3.51016460 14.80406597 -O 41.14104510 -5.30746112 9.53381549 -O 38.74724745 0.71124959 17.03758358 -O 57.64044602 -22.40427601 13.75632440 -O 24.34519102 9.91023791 3.89212226 -O 50.25201947 15.62276292 15.55606103 -O 27.01062228 1.43445354 3.75407869 -O 53.27073371 -13.23488893 12.18542402 -O 42.52331694 4.80519464 9.85129525 -O 40.04636965 -2.69488510 17.99040121 -O 27.08786667 13.19917295 14.48240915 diff --git a/tests/Fist/regtest-nequip/TEST_FILES b/tests/Fist/regtest-nequip/TEST_FILES index f3e50d9d7e..33fbf32faa 100644 --- a/tests/Fist/regtest-nequip/TEST_FILES +++ b/tests/Fist/regtest-nequip/TEST_FILES @@ -1,5 +1,4 @@ # Test of NequIP using libtorch https://pytorch.org/cppdocs/installing.html -water-sp.inp 11 1.0E-6 -17.192060707007283 -water-bulk-dp.inp 11 1.0E-12 -550.631245735074231 -water-bulk-dp.inp 31 1.0E-9 3.66494470310E+00 +water-sp.inp 11 1.0E-6 -17.195440909240052 +water-bulk-dp.inp 31 1.0E-9 3.78036960937E+00 #EOF diff --git a/tests/QS/regtest-scalable-gw/03_G0W0_bandstructure_IH_chain.inp b/tests/QS/regtest-scalable-gw/03_G0W0_bandstructure_IH_chain.inp index 59aa0a8fa7..48a3a9d307 100644 --- a/tests/QS/regtest-scalable-gw/03_G0W0_bandstructure_IH_chain.inp +++ b/tests/QS/regtest-scalable-gw/03_G0W0_bandstructure_IH_chain.inp @@ -15,6 +15,10 @@ BASIS_SET_FILE_NAME ./REGTEST_BASIS POTENTIAL_FILE_NAME GTH_SOC_POTENTIALS SORT_BASIS EXP + &KPOINTS + PARALLEL_GROUP_SIZE -1 + SCHEME MONKHORST-PACK 4 4 1 + &END KPOINTS &MGRID CUTOFF 100 REL_CUTOFF 20 @@ -44,11 +48,8 @@ SPECIAL_POINT Y 0.0 0.5 0.0 SPECIAL_POINT Gamma 0.0 0.0 0.0 &END BANDSTRUCTURE_PATH - &DOS - KPOINTS 2 2 1 - &END DOS &GW - EPS_FILTER 1.0E-6 + EPS_FILTER 1.0E-5 NUM_TIME_FREQ_POINTS 10 &END GW &SOC @@ -58,8 +59,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 3.000 10.000 3.000 - MULTIPLE_UNIT_CELL 3 1 1 + ABC [angstrom] 7.000 10.000 7.000 PERIODIC XY &END CELL &COORD @@ -76,8 +76,5 @@ BASIS_SET RI_AUX RI-dummy-regtest POTENTIAL GTH-PBE-q7 &END KIND - &TOPOLOGY - MULTIPLE_UNIT_CELL 3 1 1 - &END TOPOLOGY &END SUBSYS &END FORCE_EVAL diff --git a/tests/QS/regtest-scalable-gw/04_G0W0_bandstructure_IH_chain_approx_kp_extrapol.inp b/tests/QS/regtest-scalable-gw/04_G0W0_SOC_TeH_chain_open_shell_kp_extrapol.inp similarity index 70% rename from tests/QS/regtest-scalable-gw/04_G0W0_bandstructure_IH_chain_approx_kp_extrapol.inp rename to tests/QS/regtest-scalable-gw/04_G0W0_SOC_TeH_chain_open_shell_kp_extrapol.inp index fc2056199e..0b77da314a 100644 --- a/tests/QS/regtest-scalable-gw/04_G0W0_bandstructure_IH_chain_approx_kp_extrapol.inp +++ b/tests/QS/regtest-scalable-gw/04_G0W0_SOC_TeH_chain_open_shell_kp_extrapol.inp @@ -1,5 +1,5 @@ &GLOBAL - PRINT_LEVEL SILENT + PRINT_LEVEL MEDIUM PROJECT IH RUN_TYPE ENERGY &TIMINGS @@ -13,8 +13,10 @@ BASIS_SET_FILE_NAME BASIS_MOLOPT BASIS_SET_FILE_NAME HFX_BASIS BASIS_SET_FILE_NAME ./REGTEST_BASIS + MULTIPLICITY 2 POTENTIAL_FILE_NAME GTH_SOC_POTENTIALS SORT_BASIS EXP + UKS &MGRID CUTOFF 100 REL_CUTOFF 20 @@ -25,7 +27,6 @@ METHOD GPW &END QS &SCF - ADDED_MOS -1 EPS_SCF 1.0E-5 MAX_SCF 100 SCF_GUESS ATOMIC @@ -37,16 +38,6 @@ &END DFT &PROPERTIES &BANDSTRUCTURE - &BANDSTRUCTURE_PATH - NPOINTS 10 - SPECIAL_POINT Gamma 0.0 0.0 0.0 - SPECIAL_POINT X 0.5 0.0 0.0 - SPECIAL_POINT Y 0.0 0.5 0.0 - SPECIAL_POINT Gamma 0.0 0.0 0.0 - &END BANDSTRUCTURE_PATH - &DOS - KPOINTS 2 2 1 - &END DOS &GW APPROX_KP_EXTRAPOL EPS_FILTER 1.0E-6 @@ -59,26 +50,22 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 3.000 10.000 3.000 - MULTIPLE_UNIT_CELL 3 1 1 + ABC [angstrom] 7.000 10.000 7.000 PERIODIC XY &END CELL &COORD H 0.2 0.0 0.0 - I 1.2 0.0 0.0 + Te 1.4 0.0 0.0 &END COORD &KIND H BASIS_SET ORB DZVP-GTH BASIS_SET RI_AUX RI-dummy-regtest POTENTIAL GTH-PBE-q1 &END KIND - &KIND I + &KIND Te BASIS_SET ORB SZV-MOLOPT-SR-GTH BASIS_SET RI_AUX RI-dummy-regtest - POTENTIAL GTH-PBE-q7 + POTENTIAL GTH-PBE-q6 &END KIND - &TOPOLOGY - MULTIPLE_UNIT_CELL 3 1 1 - &END TOPOLOGY &END SUBSYS &END FORCE_EVAL diff --git a/tests/QS/regtest-scalable-gw/05_G0W0_SOC_TeH_chain_open_shell.inp b/tests/QS/regtest-scalable-gw/05_G0W0_SOC_TeH_chain_open_shell.inp index e124bbabbe..ba94657b85 100644 --- a/tests/QS/regtest-scalable-gw/05_G0W0_SOC_TeH_chain_open_shell.inp +++ b/tests/QS/regtest-scalable-gw/05_G0W0_SOC_TeH_chain_open_shell.inp @@ -13,7 +13,7 @@ BASIS_SET_FILE_NAME BASIS_MOLOPT BASIS_SET_FILE_NAME HFX_BASIS BASIS_SET_FILE_NAME ./REGTEST_BASIS - MULTIPLICITY 3 + MULTIPLICITY 2 POTENTIAL_FILE_NAME GTH_SOC_POTENTIALS SORT_BASIS EXP UKS @@ -38,9 +38,6 @@ &END DFT &PROPERTIES &BANDSTRUCTURE - &DOS - KPOINTS 2 2 1 - &END DOS &GW EPS_FILTER 1.0E-6 NUM_TIME_FREQ_POINTS 10 @@ -52,8 +49,7 @@ &END PROPERTIES &SUBSYS &CELL - ABC [angstrom] 5.000 10.000 3.000 - MULTIPLE_UNIT_CELL 2 1 1 + ABC [angstrom] 7.000 10.000 7.000 PERIODIC XY &END CELL &COORD @@ -70,8 +66,5 @@ BASIS_SET RI_AUX RI-dummy-regtest POTENTIAL GTH-PBE-q6 &END KIND - &TOPOLOGY - MULTIPLE_UNIT_CELL 2 1 1 - &END TOPOLOGY &END SUBSYS &END FORCE_EVAL diff --git a/tests/QS/regtest-scalable-gw/TEST_FILES b/tests/QS/regtest-scalable-gw/TEST_FILES index cfd2c89b49..a605c1fbdf 100644 --- a/tests/QS/regtest-scalable-gw/TEST_FILES +++ b/tests/QS/regtest-scalable-gw/TEST_FILES @@ -1,10 +1,9 @@ 01_G0W0_periodic_H2O.inp 106 1e-03 9.861 02_G0W0_IH_SOC_LDOS.inp 106 1e-03 17.826 02_G0W0_IH_SOC_LDOS.inp 107 1e-03 11.344 -03_G0W0_bandstructure_IH_chain.inp 106 1e-03 18.330 -03_G0W0_bandstructure_IH_chain.inp 107 1e-03 13.553 -04_G0W0_bandstructure_IH_chain_approx_kp_extrapol.inp 106 1e-03 18.311 -05_G0W0_SOC_TeH_chain_open_shell.inp 106 1e-03 5.437 -05_G0W0_SOC_TeH_chain_open_shell.inp 107 1e-03 1.039 -05_G0W0_SOC_TeH_chain_open_shell.inp 108 1e-03 5.361 +03_G0W0_bandstructure_IH_chain.inp 106 1e-03 21.977 +04_G0W0_SOC_TeH_chain_open_shell_kp_extrapol.inp 106 1e-03 5.174 +05_G0W0_SOC_TeH_chain_open_shell.inp 106 1e-03 5.178 +05_G0W0_SOC_TeH_chain_open_shell.inp 107 1e-03 0.306 +05_G0W0_SOC_TeH_chain_open_shell.inp 108 1e-03 5.134 #EOF