Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Routines for GW, continuous development [Jan Wilhelm]
10 : !> \par History
11 : !> 03.2019 created [Frederick Stein]
12 : !> 12.2022 added periodic GW routines [Jan Wilhelm]
13 : ! **************************************************************************************************
14 : MODULE rpa_gw
15 : USE ai_overlap, ONLY: overlap
16 : USE atomic_kind_types, ONLY: atomic_kind_type
17 : USE basis_set_types, ONLY: gto_basis_set_p_type,&
18 : gto_basis_set_type
19 : USE cell_types, ONLY: cell_type,&
20 : get_cell
21 : USE core_ppnl, ONLY: build_core_ppnl
22 : USE cp_cfm_basic_linalg, ONLY: cp_cfm_scale,&
23 : cp_cfm_scale_and_add,&
24 : cp_cfm_scale_and_add_fm,&
25 : cp_cfm_transpose
26 : USE cp_cfm_diag, ONLY: cp_cfm_geeig_canon
27 : USE cp_cfm_types, ONLY: cp_cfm_create,&
28 : cp_cfm_get_info,&
29 : cp_cfm_release,&
30 : cp_cfm_set_all,&
31 : cp_cfm_to_fm,&
32 : cp_cfm_type,&
33 : cp_fm_to_cfm
34 : USE cp_control_types, ONLY: dft_control_type
35 : USE cp_dbcsr_api, ONLY: &
36 : dbcsr_add_on_diag, dbcsr_copy, dbcsr_create, dbcsr_desymmetrize, dbcsr_filter, &
37 : dbcsr_get_info, dbcsr_init_p, dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, &
38 : dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, &
39 : dbcsr_p_type, dbcsr_release, dbcsr_release_p, dbcsr_scale, dbcsr_set, dbcsr_type, &
40 : dbcsr_type_antisymmetric, dbcsr_type_no_symmetry
41 : USE cp_dbcsr_cp2k_link, ONLY: cp_dbcsr_alloc_block_from_nbl
42 : USE cp_dbcsr_operations, ONLY: copy_dbcsr_to_fm,&
43 : copy_fm_to_dbcsr,&
44 : dbcsr_allocate_matrix_set,&
45 : dbcsr_deallocate_matrix_set
46 : USE cp_files, ONLY: close_file,&
47 : open_file
48 : USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add,&
49 : cp_fm_uplo_to_full
50 : USE cp_fm_cholesky, ONLY: cp_fm_cholesky_decompose,&
51 : cp_fm_cholesky_invert
52 : USE cp_fm_diag, ONLY: cp_fm_syevd
53 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
54 : cp_fm_struct_release,&
55 : cp_fm_struct_type
56 : USE cp_fm_types, ONLY: &
57 : cp_fm_copy_general, cp_fm_create, cp_fm_get_diag, cp_fm_get_info, cp_fm_release, &
58 : cp_fm_set_all, cp_fm_to_fm, cp_fm_to_fm_submat, cp_fm_type
59 : USE cp_log_handling, ONLY: cp_get_default_logger,&
60 : cp_logger_get_default_unit_nr,&
61 : cp_logger_type
62 : USE cp_output_handling, ONLY: cp_print_key_finished_output,&
63 : cp_print_key_unit_nr
64 : USE cp_realspace_grid_cube, ONLY: cp_pw_to_cube
65 : USE dbt_api, ONLY: &
66 : dbt_batched_contract_finalize, dbt_batched_contract_init, dbt_clear, dbt_contract, &
67 : dbt_copy, dbt_copy_matrix_to_tensor, dbt_copy_tensor_to_matrix, dbt_create, dbt_destroy, &
68 : dbt_get_block, dbt_get_info, dbt_iterator_blocks_left, dbt_iterator_next_block, &
69 : dbt_iterator_start, dbt_iterator_stop, dbt_iterator_type, dbt_nblks_total, &
70 : dbt_pgrid_create, dbt_pgrid_destroy, dbt_pgrid_type, dbt_type
71 : USE hfx_types, ONLY: block_ind_type,&
72 : dealloc_containers,&
73 : hfx_compression_type
74 : USE input_constants, ONLY: gw_pade_approx,&
75 : gw_two_pole_model,&
76 : ri_rpa_g0w0_crossing_bisection,&
77 : ri_rpa_g0w0_crossing_newton,&
78 : ri_rpa_g0w0_crossing_z_shot,&
79 : soc_none
80 : USE input_section_types, ONLY: section_vals_get_subs_vals,&
81 : section_vals_type
82 : USE kinds, ONLY: default_path_length,&
83 : dp
84 : USE kpoint_methods, ONLY: kpoint_density_matrices,&
85 : kpoint_density_transform,&
86 : kpoint_init_cell_index
87 : USE kpoint_types, ONLY: get_kpoint_info,&
88 : kpoint_create,&
89 : kpoint_release,&
90 : kpoint_sym_create,&
91 : kpoint_type
92 : USE machine, ONLY: m_walltime
93 : USE mathconstants, ONLY: fourpi,&
94 : gaussi,&
95 : pi,&
96 : twopi,&
97 : z_one,&
98 : z_zero
99 : USE message_passing, ONLY: mp_para_env_type
100 : USE mp2_types, ONLY: mp2_type,&
101 : one_dim_real_array,&
102 : two_dim_int_array
103 : USE parallel_gemm_api, ONLY: parallel_gemm
104 : USE particle_list_types, ONLY: particle_list_type
105 : USE particle_types, ONLY: particle_type
106 : USE physcon, ONLY: evolt
107 : USE pw_env_types, ONLY: pw_env_get,&
108 : pw_env_type
109 : USE pw_methods, ONLY: pw_axpy,&
110 : pw_copy,&
111 : pw_scale,&
112 : pw_zero
113 : USE pw_pool_types, ONLY: pw_pool_type
114 : USE pw_types, ONLY: pw_c1d_gs_type,&
115 : pw_r3d_rs_type
116 : USE qs_band_structure, ONLY: calculate_kp_orbitals
117 : USE qs_collocate_density, ONLY: calculate_rho_elec
118 : USE qs_environment_types, ONLY: get_qs_env,&
119 : qs_env_release,&
120 : qs_environment_type
121 : USE qs_force_types, ONLY: qs_force_type
122 : USE qs_gamma2kp, ONLY: create_kp_from_gamma
123 : USE qs_integral_utils, ONLY: basis_set_list_setup
124 : USE qs_kind_types, ONLY: get_qs_kind,&
125 : qs_kind_type
126 : USE qs_ks_types, ONLY: qs_ks_env_type
127 : USE qs_mo_types, ONLY: get_mo_set
128 : USE qs_moments, ONLY: build_berry_moment_matrix
129 : USE qs_neighbor_list_types, ONLY: neighbor_list_set_p_type,&
130 : release_neighbor_list_sets
131 : USE qs_neighbor_lists, ONLY: setup_neighbor_list
132 : USE qs_overlap, ONLY: build_overlap_matrix_simple
133 : USE qs_scf_types, ONLY: qs_scf_env_type
134 : USE qs_subsys_types, ONLY: qs_subsys_get,&
135 : qs_subsys_type
136 : USE qs_tensors, ONLY: decompress_tensor
137 : USE qs_tensors_types, ONLY: create_2c_tensor
138 : USE rpa_gw_ic, ONLY: apply_ic_corr
139 : USE rpa_gw_im_time_util, ONLY: get_tensor_3c_overl_int_gw
140 : USE rpa_gw_kpoints_util, ONLY: get_mat_cell_T_from_mat_gamma,&
141 : mat_kp_from_mat_gamma,&
142 : real_space_to_kpoint_transform_rpa
143 : USE rpa_im_time, ONLY: compute_periodic_dm
144 : USE scf_control_types, ONLY: scf_control_type
145 : USE util, ONLY: sort
146 : USE virial_types, ONLY: virial_type
147 : #include "./base/base_uses.f90"
148 :
149 : IMPLICIT NONE
150 :
151 : PRIVATE
152 :
153 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rpa_gw'
154 :
155 : PUBLIC :: allocate_matrices_gw_im_time, allocate_matrices_gw, compute_GW_self_energy, compute_QP_energies, &
156 : deallocate_matrices_gw_im_time, deallocate_matrices_gw, compute_minus_vxc_kpoints, trafo_to_mo_and_kpoints, &
157 : get_fermi_level_offset, compute_W_cubic_GW, continuation_pade
158 :
159 : CONTAINS
160 :
161 : ! **************************************************************************************************
162 : !> \brief ...
163 : !> \param gw_corr_lev_occ ...
164 : !> \param gw_corr_lev_virt ...
165 : !> \param homo ...
166 : !> \param nmo ...
167 : !> \param num_integ_points ...
168 : !> \param unit_nr ...
169 : !> \param RI_blk_sizes ...
170 : !> \param do_ic_model ...
171 : !> \param para_env ...
172 : !> \param fm_mat_W ...
173 : !> \param fm_mat_Q ...
174 : !> \param mo_coeff ...
175 : !> \param t_3c_overl_int_ao_mo ...
176 : !> \param t_3c_O_mo_compressed ...
177 : !> \param t_3c_O_mo_ind ...
178 : !> \param t_3c_overl_int_gw_RI ...
179 : !> \param t_3c_overl_int_gw_AO ...
180 : !> \param starts_array_mc ...
181 : !> \param ends_array_mc ...
182 : !> \param t_3c_overl_nnP_ic ...
183 : !> \param t_3c_overl_nnP_ic_reflected ...
184 : !> \param matrix_s ...
185 : !> \param mat_W ...
186 : !> \param t_3c_overl_int ...
187 : !> \param t_3c_O_compressed ...
188 : !> \param t_3c_O_ind ...
189 : !> \param qs_env ...
190 : ! **************************************************************************************************
191 96 : SUBROUTINE allocate_matrices_gw_im_time(gw_corr_lev_occ, gw_corr_lev_virt, homo, nmo, &
192 : num_integ_points, unit_nr, &
193 : RI_blk_sizes, do_ic_model, &
194 : para_env, fm_mat_W, fm_mat_Q, &
195 48 : mo_coeff, &
196 : t_3c_overl_int_ao_mo, t_3c_O_mo_compressed, t_3c_O_mo_ind, &
197 : t_3c_overl_int_gw_RI, t_3c_overl_int_gw_AO, &
198 48 : starts_array_mc, ends_array_mc, &
199 : t_3c_overl_nnP_ic, t_3c_overl_nnP_ic_reflected, &
200 48 : matrix_s, mat_W, t_3c_overl_int, &
201 48 : t_3c_O_compressed, t_3c_O_ind, &
202 : qs_env)
203 :
204 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo
205 : INTEGER, INTENT(IN) :: nmo, num_integ_points, unit_nr
206 : INTEGER, DIMENSION(:), POINTER :: RI_blk_sizes
207 : LOGICAL, INTENT(IN) :: do_ic_model
208 : TYPE(mp_para_env_type), POINTER :: para_env
209 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), &
210 : INTENT(OUT) :: fm_mat_W
211 : TYPE(cp_fm_type), INTENT(IN) :: fm_mat_Q
212 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: mo_coeff
213 : TYPE(dbt_type) :: t_3c_overl_int_ao_mo
214 : TYPE(hfx_compression_type), ALLOCATABLE, &
215 : DIMENSION(:) :: t_3c_O_mo_compressed
216 : TYPE(two_dim_int_array), ALLOCATABLE, &
217 : DIMENSION(:), INTENT(OUT) :: t_3c_O_mo_ind
218 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:), &
219 : INTENT(INOUT) :: t_3c_overl_int_gw_RI, &
220 : t_3c_overl_int_gw_AO
221 : INTEGER, DIMENSION(:), INTENT(IN) :: starts_array_mc, ends_array_mc
222 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:), &
223 : INTENT(INOUT) :: t_3c_overl_nnP_ic, &
224 : t_3c_overl_nnP_ic_reflected
225 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s
226 : TYPE(dbcsr_type), POINTER :: mat_W
227 : TYPE(dbt_type), DIMENSION(:, :) :: t_3c_overl_int
228 : TYPE(hfx_compression_type), DIMENSION(:, :, :) :: t_3c_O_compressed
229 : TYPE(block_ind_type), DIMENSION(:, :, :) :: t_3c_O_ind
230 : TYPE(qs_environment_type), POINTER :: qs_env
231 :
232 : CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_matrices_gw_im_time'
233 :
234 : INTEGER :: handle, jquad, nspins
235 : LOGICAL :: my_open_shell
236 432 : TYPE(dbt_type) :: t_3c_overl_int_ao_mo_beta
237 :
238 48 : CALL timeset(routineN, handle)
239 :
240 48 : nspins = SIZE(homo)
241 48 : my_open_shell = (nspins == 2)
242 :
243 0 : ALLOCATE (t_3c_O_mo_ind(nspins), t_3c_overl_int_gw_AO(nspins), t_3c_overl_int_gw_RI(nspins), &
244 103932 : t_3c_overl_nnP_ic(nspins), t_3c_overl_nnP_ic_reflected(nspins), t_3c_O_mo_compressed(nspins))
245 : CALL get_tensor_3c_overl_int_gw(t_3c_overl_int, &
246 : t_3c_O_compressed, t_3c_O_ind, &
247 : t_3c_overl_int_ao_mo, t_3c_O_mo_compressed(1), t_3c_O_mo_ind(1)%array, &
248 : t_3c_overl_int_gw_RI(1), t_3c_overl_int_gw_AO(1), &
249 : starts_array_mc, ends_array_mc, &
250 : mo_coeff(1), matrix_s, &
251 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), homo(1), nmo, &
252 : para_env, &
253 : do_ic_model, &
254 : t_3c_overl_nnP_ic(1), t_3c_overl_nnP_ic_reflected(1), &
255 48 : qs_env, unit_nr, do_alpha=.TRUE.)
256 :
257 48 : IF (my_open_shell) THEN
258 :
259 : CALL get_tensor_3c_overl_int_gw(t_3c_overl_int, &
260 : t_3c_O_compressed, t_3c_O_ind, &
261 : t_3c_overl_int_ao_mo_beta, t_3c_O_mo_compressed(2), t_3c_O_mo_ind(2)%array, &
262 : t_3c_overl_int_gw_RI(2), t_3c_overl_int_gw_AO(2), &
263 : starts_array_mc, ends_array_mc, &
264 : mo_coeff(2), matrix_s, &
265 : gw_corr_lev_occ(2), gw_corr_lev_virt(2), homo(2), nmo, &
266 : para_env, &
267 : do_ic_model, &
268 : t_3c_overl_nnP_ic(2), t_3c_overl_nnP_ic_reflected(2), &
269 10 : qs_env, unit_nr, do_alpha=.FALSE.)
270 :
271 10 : IF (.NOT. qs_env%mp2_env%ri_g0w0%do_kpoints_Sigma) THEN
272 6 : CALL dbt_destroy(t_3c_overl_int_ao_mo_beta)
273 : END IF
274 :
275 : END IF
276 :
277 642 : ALLOCATE (fm_mat_W(num_integ_points))
278 :
279 546 : DO jquad = 1, num_integ_points
280 :
281 498 : CALL cp_fm_create(fm_mat_W(jquad), fm_mat_Q%matrix_struct)
282 498 : CALL cp_fm_to_fm(fm_mat_Q, fm_mat_W(jquad))
283 546 : CALL cp_fm_set_all(fm_mat_W(jquad), 0.0_dp)
284 :
285 : END DO
286 :
287 48 : NULLIFY (mat_W)
288 48 : CALL dbcsr_init_p(mat_W)
289 : CALL dbcsr_create(matrix=mat_W, &
290 : template=matrix_s(1)%matrix, &
291 : matrix_type=dbcsr_type_no_symmetry, &
292 : row_blk_size=RI_blk_sizes, &
293 48 : col_blk_size=RI_blk_sizes)
294 :
295 48 : CALL timestop(handle)
296 :
297 96 : END SUBROUTINE allocate_matrices_gw_im_time
298 :
299 : ! **************************************************************************************************
300 : !> \brief ...
301 : !> \param vec_Sigma_c_gw ...
302 : !> \param color_rpa_group ...
303 : !> \param dimen_nm_gw ...
304 : !> \param gw_corr_lev_occ ...
305 : !> \param gw_corr_lev_virt ...
306 : !> \param homo ...
307 : !> \param nmo ...
308 : !> \param num_integ_group ...
309 : !> \param num_integ_points ...
310 : !> \param unit_nr ...
311 : !> \param gw_corr_lev_tot ...
312 : !> \param num_fit_points ...
313 : !> \param omega_max_fit ...
314 : !> \param do_minimax_quad ...
315 : !> \param do_periodic ...
316 : !> \param do_ri_Sigma_x ...
317 : !> \param my_do_gw ...
318 : !> \param first_cycle_periodic_correction ...
319 : !> \param a_scaling ...
320 : !> \param Eigenval ...
321 : !> \param tj ...
322 : !> \param vec_omega_fit_gw ...
323 : !> \param vec_Sigma_x_gw ...
324 : !> \param delta_corr ...
325 : !> \param Eigenval_last ...
326 : !> \param Eigenval_scf ...
327 : !> \param vec_W_gw ...
328 : !> \param fm_mat_S_gw ...
329 : !> \param fm_mat_S_gw_work ...
330 : !> \param para_env ...
331 : !> \param mp2_env ...
332 : !> \param kpoints ...
333 : !> \param nkp ...
334 : !> \param nkp_self_energy ...
335 : !> \param do_kpoints_cubic_RPA ...
336 : !> \param do_kpoints_from_Gamma ...
337 : ! **************************************************************************************************
338 118 : SUBROUTINE allocate_matrices_gw(vec_Sigma_c_gw, color_rpa_group, dimen_nm_gw, &
339 118 : gw_corr_lev_occ, gw_corr_lev_virt, homo, &
340 : nmo, num_integ_group, num_integ_points, unit_nr, &
341 : gw_corr_lev_tot, num_fit_points, omega_max_fit, &
342 : do_minimax_quad, do_periodic, do_ri_Sigma_x, my_do_gw, &
343 : first_cycle_periodic_correction, &
344 : a_scaling, Eigenval, tj, vec_omega_fit_gw, vec_Sigma_x_gw, &
345 : delta_corr, Eigenval_last, Eigenval_scf, vec_W_gw, &
346 118 : fm_mat_S_gw, fm_mat_S_gw_work, &
347 : para_env, mp2_env, kpoints, nkp, nkp_self_energy, &
348 : do_kpoints_cubic_RPA, do_kpoints_from_Gamma)
349 :
350 : COMPLEX(KIND=dp), ALLOCATABLE, &
351 : DIMENSION(:, :, :, :), INTENT(OUT) :: vec_Sigma_c_gw
352 : INTEGER, INTENT(IN) :: color_rpa_group, dimen_nm_gw
353 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo
354 : INTEGER, INTENT(IN) :: nmo, num_integ_group, num_integ_points, &
355 : unit_nr
356 : INTEGER, INTENT(INOUT) :: gw_corr_lev_tot, num_fit_points
357 : REAL(KIND=dp) :: omega_max_fit
358 : LOGICAL, INTENT(IN) :: do_minimax_quad, do_periodic, &
359 : do_ri_Sigma_x, my_do_gw
360 : LOGICAL, INTENT(OUT) :: first_cycle_periodic_correction
361 : REAL(KIND=dp), INTENT(IN) :: a_scaling
362 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
363 : INTENT(INOUT) :: Eigenval
364 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
365 : INTENT(IN) :: tj
366 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
367 : INTENT(OUT) :: vec_omega_fit_gw
368 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
369 : INTENT(OUT) :: vec_Sigma_x_gw
370 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
371 : INTENT(INOUT) :: delta_corr
372 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
373 : INTENT(OUT) :: Eigenval_last, Eigenval_scf
374 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
375 : INTENT(OUT) :: vec_W_gw
376 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_gw
377 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), &
378 : INTENT(INOUT) :: fm_mat_S_gw_work
379 : TYPE(mp_para_env_type), POINTER :: para_env
380 : TYPE(mp2_type) :: mp2_env
381 : TYPE(kpoint_type), POINTER :: kpoints
382 : INTEGER, INTENT(OUT) :: nkp, nkp_self_energy
383 : LOGICAL, INTENT(IN) :: do_kpoints_cubic_RPA, &
384 : do_kpoints_from_Gamma
385 :
386 : CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_matrices_gw'
387 :
388 : INTEGER :: handle, iquad, ispin, jquad, nspins
389 : LOGICAL :: my_open_shell
390 : REAL(KIND=dp) :: omega
391 118 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_omega_gw
392 :
393 118 : CALL timeset(routineN, handle)
394 :
395 118 : nspins = SIZE(Eigenval, 3)
396 118 : my_open_shell = (nspins == 2)
397 :
398 118 : gw_corr_lev_tot = gw_corr_lev_occ(1) + gw_corr_lev_virt(1)
399 :
400 : ! fill the omega_frequency vector
401 354 : ALLOCATE (vec_omega_gw(num_integ_points))
402 5156 : vec_omega_gw = 0.0_dp
403 :
404 5156 : DO jquad = 1, num_integ_points
405 5038 : IF (do_minimax_quad) THEN
406 498 : omega = tj(jquad)
407 : ELSE
408 4540 : omega = a_scaling/TAN(tj(jquad))
409 : END IF
410 5156 : vec_omega_gw(jquad) = omega
411 : END DO
412 :
413 : ! determine number of fit points in the interval [0,w_max] for virt, or [-w_max,0] for occ
414 118 : num_fit_points = 0
415 :
416 5156 : DO jquad = 1, num_integ_points
417 5156 : IF (vec_omega_gw(jquad) < omega_max_fit) THEN
418 4084 : num_fit_points = num_fit_points + 1
419 : END IF
420 : END DO
421 :
422 118 : IF (mp2_env%ri_g0w0%analytic_continuation == gw_pade_approx) THEN
423 82 : IF (mp2_env%ri_g0w0%nparam_pade > num_fit_points) THEN
424 36 : IF (unit_nr > 0) WRITE (UNIT=unit_nr, FMT="(T3,A)") &
425 18 : "Pade approximation: more parameters than data points. Reset # of parameters."
426 36 : mp2_env%ri_g0w0%nparam_pade = num_fit_points
427 36 : IF (unit_nr > 0) WRITE (UNIT=unit_nr, FMT="(T3,A,T74,I7)") &
428 18 : "Number of pade parameters:", mp2_env%ri_g0w0%nparam_pade
429 : END IF
430 : END IF
431 :
432 : ! create new arrays containing omega values at which we calculate vec_Sigma_c_gw
433 354 : ALLOCATE (vec_omega_fit_gw(num_fit_points))
434 :
435 : ! fill the omega vector with frequencies, where we calculate the self-energy
436 118 : iquad = 0
437 5156 : DO jquad = 1, num_integ_points
438 5156 : IF (vec_omega_gw(jquad) < omega_max_fit) THEN
439 4084 : iquad = iquad + 1
440 4084 : vec_omega_fit_gw(iquad) = vec_omega_gw(jquad)
441 : END IF
442 : END DO
443 :
444 118 : DEALLOCATE (vec_omega_gw)
445 :
446 118 : IF (do_kpoints_cubic_RPA) THEN
447 0 : CALL get_kpoint_info(kpoints, nkp=nkp)
448 0 : IF (mp2_env%ri_g0w0%do_gamma_only_sigma) THEN
449 0 : nkp_self_energy = 1
450 : ELSE
451 0 : nkp_self_energy = nkp
452 : END IF
453 118 : ELSE IF (do_kpoints_from_Gamma) THEN
454 18 : CALL get_kpoint_info(kpoints, nkp=nkp)
455 18 : IF (mp2_env%ri_g0w0%do_kpoints_Sigma) THEN
456 18 : nkp_self_energy = mp2_env%ri_g0w0%nkp_self_energy
457 : ELSE
458 0 : nkp_self_energy = 1
459 : END IF
460 : ELSE
461 100 : nkp = 1
462 100 : nkp_self_energy = 1
463 : END IF
464 708 : ALLOCATE (vec_Sigma_c_gw(gw_corr_lev_tot, num_fit_points, nkp_self_energy, nspins))
465 70844 : vec_Sigma_c_gw = z_zero
466 :
467 590 : ALLOCATE (Eigenval_scf(nmo, nkp_self_energy, nspins))
468 6454 : Eigenval_scf(:, :, :) = Eigenval(:, :, :)
469 :
470 472 : ALLOCATE (Eigenval_last(nmo, nkp_self_energy, nspins))
471 6454 : Eigenval_last(:, :, :) = Eigenval(:, :, :)
472 :
473 118 : IF (do_periodic) THEN
474 :
475 18 : ALLOCATE (delta_corr(1 + homo(1) - gw_corr_lev_occ(1):homo(1) + gw_corr_lev_virt(1)))
476 70 : delta_corr(:) = 0.0_dp
477 :
478 6 : first_cycle_periodic_correction = .TRUE.
479 :
480 : END IF
481 :
482 472 : ALLOCATE (vec_Sigma_x_gw(nmo, nkp_self_energy, nspins))
483 6454 : vec_Sigma_x_gw = 0.0_dp
484 :
485 118 : IF (my_do_gw) THEN
486 :
487 : ! minimax grids not implemented for O(N^4) GW
488 70 : CPASSERT(.NOT. do_minimax_quad)
489 :
490 : ! create temporary matrix to store B*([1+Q(iw')]^-1-1), has the same size as B
491 284 : ALLOCATE (fm_mat_S_gw_work(nspins))
492 144 : DO ispin = 1, nspins
493 74 : CALL cp_fm_create(fm_mat_S_gw_work(ispin), fm_mat_S_gw(ispin)%matrix_struct)
494 144 : CALL cp_fm_set_all(matrix=fm_mat_S_gw_work(ispin), alpha=0.0_dp)
495 : END DO
496 :
497 280 : ALLOCATE (vec_W_gw(dimen_nm_gw, nspins))
498 25848 : vec_W_gw = 0.0_dp
499 :
500 : ! in case we do RI for Sigma_x, we calculate Sigma_x right here
501 70 : IF (do_ri_Sigma_x) THEN
502 :
503 : CALL get_vec_sigma_x(vec_Sigma_x_gw(:, :, 1), nmo, fm_mat_S_gw(1), para_env, num_integ_group, color_rpa_group, &
504 52 : homo(1), gw_corr_lev_occ(1), mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 1, 1))
505 :
506 52 : IF (my_open_shell) THEN
507 : CALL get_vec_sigma_x(vec_Sigma_x_gw(:, :, 2), nmo, fm_mat_S_gw(2), para_env, num_integ_group, &
508 : color_rpa_group, homo(2), gw_corr_lev_occ(2), &
509 0 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 2, 1))
510 : END IF
511 :
512 : END IF
513 :
514 : END IF
515 :
516 118 : CALL timestop(handle)
517 :
518 118 : END SUBROUTINE allocate_matrices_gw
519 :
520 : ! **************************************************************************************************
521 : !> \brief ...
522 : !> \param vec_Sigma_x_gw ...
523 : !> \param nmo ...
524 : !> \param fm_mat_S_gw ...
525 : !> \param para_env ...
526 : !> \param num_integ_group ...
527 : !> \param color_rpa_group ...
528 : !> \param homo ...
529 : !> \param gw_corr_lev_occ ...
530 : !> \param vec_Sigma_x_minus_vxc_gw11 ...
531 : ! **************************************************************************************************
532 52 : SUBROUTINE get_vec_sigma_x(vec_Sigma_x_gw, nmo, fm_mat_S_gw, para_env, num_integ_group, color_rpa_group, homo, &
533 52 : gw_corr_lev_occ, vec_Sigma_x_minus_vxc_gw11)
534 :
535 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: vec_Sigma_x_gw
536 : INTEGER, INTENT(IN) :: nmo
537 : TYPE(cp_fm_type), INTENT(IN) :: fm_mat_S_gw
538 : TYPE(mp_para_env_type), POINTER :: para_env
539 : INTEGER, INTENT(IN) :: num_integ_group, color_rpa_group, homo, &
540 : gw_corr_lev_occ
541 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_Sigma_x_minus_vxc_gw11
542 :
543 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_vec_sigma_x'
544 :
545 : INTEGER :: handle, iiB, m_global, n_global, &
546 : ncol_local, nm_global, nrow_local
547 52 : INTEGER, DIMENSION(:), POINTER :: col_indices
548 :
549 52 : CALL timeset(routineN, handle)
550 :
551 : CALL cp_fm_get_info(matrix=fm_mat_S_gw, &
552 : nrow_local=nrow_local, &
553 : ncol_local=ncol_local, &
554 52 : col_indices=col_indices)
555 :
556 52 : CALL para_env%sync()
557 :
558 : ! loop over (nm) index
559 18728 : DO iiB = 1, ncol_local
560 :
561 : ! this is needed for correct values within parallelization
562 18676 : IF (MODULO(1, num_integ_group) /= color_rpa_group) CYCLE
563 :
564 17066 : nm_global = col_indices(iiB)
565 :
566 : ! transform the index nm to n and m, formulae copied from Mauro's code
567 17066 : n_global = MAX(1, nm_global - 1)/nmo + 1
568 17066 : m_global = nm_global - (n_global - 1)*nmo
569 17066 : n_global = n_global + homo - gw_corr_lev_occ
570 :
571 17118 : IF (m_global <= homo) THEN
572 :
573 : ! Sigma_x_n = -sum_m^occ sum_P (B_(nm)^P)^2
574 : vec_Sigma_x_gw(n_global, 1) = &
575 : vec_Sigma_x_gw(n_global, 1) - &
576 137760 : DOT_PRODUCT(fm_mat_S_gw%local_data(:, iiB), fm_mat_S_gw%local_data(:, iiB))
577 :
578 : END IF
579 :
580 : END DO
581 :
582 52 : CALL para_env%sync()
583 :
584 2548 : CALL para_env%sum(vec_Sigma_x_gw)
585 :
586 : vec_Sigma_x_minus_vxc_gw11(:) = &
587 : vec_Sigma_x_minus_vxc_gw11(:) + &
588 1248 : vec_Sigma_x_gw(:, 1)
589 :
590 52 : CALL timestop(handle)
591 :
592 52 : END SUBROUTINE get_vec_sigma_x
593 :
594 : ! **************************************************************************************************
595 : !> \brief ...
596 : !> \param fm_mat_S_gw_work ...
597 : !> \param vec_W_gw ...
598 : !> \param vec_Sigma_c_gw ...
599 : !> \param vec_omega_fit_gw ...
600 : !> \param vec_Sigma_x_minus_vxc_gw ...
601 : !> \param Eigenval_last ...
602 : !> \param Eigenval_scf ...
603 : !> \param do_periodic ...
604 : !> \param matrix_berry_re_mo_mo ...
605 : !> \param matrix_berry_im_mo_mo ...
606 : !> \param kpoints ...
607 : !> \param vec_Sigma_x_gw ...
608 : !> \param my_do_gw ...
609 : ! **************************************************************************************************
610 118 : SUBROUTINE deallocate_matrices_gw(fm_mat_S_gw_work, vec_W_gw, vec_Sigma_c_gw, vec_omega_fit_gw, &
611 : vec_Sigma_x_minus_vxc_gw, Eigenval_last, &
612 : Eigenval_scf, do_periodic, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, kpoints, &
613 : vec_Sigma_x_gw, my_do_gw)
614 :
615 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), &
616 : INTENT(INOUT) :: fm_mat_S_gw_work
617 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
618 : INTENT(INOUT) :: vec_W_gw
619 : COMPLEX(KIND=dp), ALLOCATABLE, &
620 : DIMENSION(:, :, :, :), INTENT(INOUT) :: vec_Sigma_c_gw
621 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
622 : INTENT(INOUT) :: vec_omega_fit_gw
623 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
624 : INTENT(INOUT) :: vec_Sigma_x_minus_vxc_gw, Eigenval_last, &
625 : Eigenval_scf
626 : LOGICAL, INTENT(IN) :: do_periodic
627 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_re_mo_mo, &
628 : matrix_berry_im_mo_mo
629 : TYPE(kpoint_type), POINTER :: kpoints
630 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
631 : INTENT(INOUT) :: vec_Sigma_x_gw
632 : LOGICAL, INTENT(IN) :: my_do_gw
633 :
634 : CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_matrices_gw'
635 :
636 : INTEGER :: handle, nspins
637 : LOGICAL :: my_open_shell
638 :
639 118 : CALL timeset(routineN, handle)
640 :
641 118 : nspins = SIZE(Eigenval_last, 3)
642 118 : my_open_shell = (nspins == 2)
643 :
644 118 : IF (my_do_gw) THEN
645 70 : CALL cp_fm_release(fm_mat_S_gw_work)
646 70 : DEALLOCATE (vec_Sigma_x_minus_vxc_gw)
647 70 : DEALLOCATE (vec_W_gw)
648 : END IF
649 :
650 118 : DEALLOCATE (vec_Sigma_c_gw)
651 118 : DEALLOCATE (vec_Sigma_x_gw)
652 118 : DEALLOCATE (vec_omega_fit_gw)
653 118 : DEALLOCATE (Eigenval_last)
654 118 : DEALLOCATE (Eigenval_scf)
655 :
656 118 : IF (do_periodic) THEN
657 6 : CALL dbcsr_deallocate_matrix_set(matrix_berry_re_mo_mo)
658 6 : CALL dbcsr_deallocate_matrix_set(matrix_berry_im_mo_mo)
659 6 : CALL kpoint_release(kpoints)
660 : END IF
661 :
662 118 : CALL timestop(handle)
663 :
664 118 : END SUBROUTINE deallocate_matrices_gw
665 :
666 : ! **************************************************************************************************
667 : !> \brief ...
668 : !> \param weights_cos_tf_w_to_t ...
669 : !> \param weights_sin_tf_t_to_w ...
670 : !> \param do_ic_model ...
671 : !> \param do_kpoints_cubic_RPA ...
672 : !> \param fm_mat_W ...
673 : !> \param t_3c_overl_int_ao_mo ...
674 : !> \param t_3c_O_mo_compressed ...
675 : !> \param t_3c_O_mo_ind ...
676 : !> \param t_3c_overl_int_gw_RI ...
677 : !> \param t_3c_overl_int_gw_AO ...
678 : !> \param t_3c_overl_nnP_ic ...
679 : !> \param t_3c_overl_nnP_ic_reflected ...
680 : !> \param mat_W ...
681 : !> \param qs_env ...
682 : ! **************************************************************************************************
683 48 : SUBROUTINE deallocate_matrices_gw_im_time(weights_cos_tf_w_to_t, weights_sin_tf_t_to_w, do_ic_model, do_kpoints_cubic_RPA, &
684 : fm_mat_W, &
685 : t_3c_overl_int_ao_mo, t_3c_O_mo_compressed, t_3c_O_mo_ind, &
686 : t_3c_overl_int_gw_RI, t_3c_overl_int_gw_AO, &
687 : t_3c_overl_nnP_ic, t_3c_overl_nnP_ic_reflected, mat_W, &
688 : qs_env)
689 :
690 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
691 : INTENT(INOUT) :: weights_cos_tf_w_to_t, &
692 : weights_sin_tf_t_to_w
693 : LOGICAL, INTENT(IN) :: do_ic_model, do_kpoints_cubic_RPA
694 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), &
695 : INTENT(INOUT) :: fm_mat_W
696 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_overl_int_ao_mo
697 : TYPE(hfx_compression_type), ALLOCATABLE, &
698 : DIMENSION(:) :: t_3c_O_mo_compressed
699 : TYPE(two_dim_int_array), ALLOCATABLE, DIMENSION(:) :: t_3c_O_mo_ind
700 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:), &
701 : INTENT(INOUT) :: t_3c_overl_int_gw_RI, &
702 : t_3c_overl_int_gw_AO, &
703 : t_3c_overl_nnP_ic, &
704 : t_3c_overl_nnP_ic_reflected
705 : TYPE(dbcsr_type), POINTER :: mat_W
706 : TYPE(qs_environment_type), POINTER :: qs_env
707 :
708 : CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_matrices_gw_im_time'
709 :
710 : INTEGER :: handle, ispin, nspins, unused
711 : LOGICAL :: my_open_shell
712 :
713 48 : CALL timeset(routineN, handle)
714 :
715 48 : nspins = SIZE(t_3c_overl_int_gw_RI)
716 48 : my_open_shell = (nspins == 2)
717 :
718 48 : IF (ALLOCATED(weights_cos_tf_w_to_t)) DEALLOCATE (weights_cos_tf_w_to_t)
719 48 : IF (ALLOCATED(weights_sin_tf_t_to_w)) DEALLOCATE (weights_sin_tf_t_to_w)
720 :
721 48 : IF (.NOT. do_kpoints_cubic_RPA) THEN
722 48 : CALL cp_fm_release(fm_mat_W)
723 48 : CALL dbcsr_release_P(mat_W)
724 : END IF
725 :
726 106 : DO ispin = 1, nspins
727 58 : CALL dbt_destroy(t_3c_overl_int_gw_RI(ispin))
728 106 : CALL dbt_destroy(t_3c_overl_int_gw_AO(ispin))
729 : END DO
730 164 : DEALLOCATE (t_3c_overl_int_gw_AO, t_3c_overl_int_gw_RI)
731 48 : IF (do_ic_model) THEN
732 4 : DO ispin = 1, nspins
733 2 : CALL dbt_destroy(t_3c_overl_nnP_ic(ispin))
734 4 : CALL dbt_destroy(t_3c_overl_nnP_ic_reflected(ispin))
735 : END DO
736 6 : DEALLOCATE (t_3c_overl_nnP_ic, t_3c_overl_nnP_ic_reflected)
737 : END IF
738 :
739 48 : IF (.NOT. qs_env%mp2_env%ri_g0w0%do_kpoints_Sigma) THEN
740 66 : DO ispin = 1, nspins
741 36 : DEALLOCATE (t_3c_O_mo_ind(ispin)%array)
742 66 : CALL dealloc_containers(t_3c_O_mo_compressed(ispin), unused)
743 : END DO
744 66 : DEALLOCATE (t_3c_O_mo_ind, t_3c_O_mo_compressed)
745 :
746 30 : CALL dbt_destroy(t_3c_overl_int_ao_mo)
747 : END IF
748 :
749 48 : IF (qs_env%mp2_env%ri_g0w0%do_kpoints_Sigma) THEN
750 40 : DO ispin = 1, nspins
751 22 : CALL dbcsr_release(qs_env%mp2_env%ri_g0w0%matrix_sigma_x_minus_vxc(ispin)%matrix)
752 22 : DEALLOCATE (qs_env%mp2_env%ri_g0w0%matrix_sigma_x_minus_vxc(ispin)%matrix)
753 :
754 22 : CALL dbcsr_release(qs_env%mp2_env%ri_g0w0%matrix_ks(ispin)%matrix)
755 40 : DEALLOCATE (qs_env%mp2_env%ri_g0w0%matrix_ks(ispin)%matrix)
756 : END DO
757 18 : DEALLOCATE (qs_env%mp2_env%ri_g0w0%matrix_sigma_x_minus_vxc)
758 18 : DEALLOCATE (qs_env%mp2_env%ri_g0w0%matrix_ks)
759 : END IF
760 :
761 48 : CALL timestop(handle)
762 :
763 48 : END SUBROUTINE deallocate_matrices_gw_im_time
764 :
765 : ! **************************************************************************************************
766 : !> \brief ...
767 : !> \param vec_Sigma_c_gw ...
768 : !> \param dimen_nm_gw ...
769 : !> \param dimen_RI ...
770 : !> \param gw_corr_lev_occ ...
771 : !> \param gw_corr_lev_virt ...
772 : !> \param homo ...
773 : !> \param jquad ...
774 : !> \param nmo ...
775 : !> \param num_fit_points ...
776 : !> \param do_im_time ...
777 : !> \param do_periodic ...
778 : !> \param first_cycle_periodic_correction ...
779 : !> \param fermi_level_offset ...
780 : !> \param omega ...
781 : !> \param Eigenval ...
782 : !> \param delta_corr ...
783 : !> \param vec_omega_fit_gw ...
784 : !> \param vec_W_gw ...
785 : !> \param wj ...
786 : !> \param fm_mat_Q ...
787 : !> \param fm_mat_R_gw ...
788 : !> \param fm_mat_S_gw ...
789 : !> \param fm_mat_S_gw_work ...
790 : !> \param mo_coeff ...
791 : !> \param para_env ...
792 : !> \param para_env_RPA ...
793 : !> \param matrix_berry_im_mo_mo ...
794 : !> \param matrix_berry_re_mo_mo ...
795 : !> \param kpoints ...
796 : !> \param qs_env ...
797 : !> \param mp2_env ...
798 : ! **************************************************************************************************
799 76050 : SUBROUTINE compute_GW_self_energy(vec_Sigma_c_gw, dimen_nm_gw, dimen_RI, gw_corr_lev_occ, &
800 15210 : gw_corr_lev_virt, homo, jquad, nmo, num_fit_points, &
801 : do_im_time, do_periodic, &
802 : first_cycle_periodic_correction, fermi_level_offset, &
803 15210 : omega, Eigenval, delta_corr, vec_omega_fit_gw, vec_W_gw, wj, &
804 15210 : fm_mat_Q, fm_mat_R_gw, fm_mat_S_gw, &
805 15210 : fm_mat_S_gw_work, mo_coeff, para_env, &
806 : para_env_RPA, matrix_berry_im_mo_mo, matrix_berry_re_mo_mo, &
807 : kpoints, qs_env, mp2_env)
808 :
809 : COMPLEX(KIND=dp), ALLOCATABLE, &
810 : DIMENSION(:, :, :, :), INTENT(INOUT) :: vec_Sigma_c_gw
811 : INTEGER, INTENT(IN) :: dimen_nm_gw, dimen_RI
812 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo
813 : INTEGER, INTENT(IN) :: jquad, nmo, num_fit_points
814 : LOGICAL, INTENT(IN) :: do_im_time, do_periodic
815 : LOGICAL, INTENT(INOUT) :: first_cycle_periodic_correction
816 : REAL(KIND=dp), INTENT(INOUT) :: fermi_level_offset, omega
817 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: Eigenval
818 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
819 : INTENT(INOUT) :: delta_corr
820 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
821 : INTENT(IN) :: vec_omega_fit_gw
822 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
823 : INTENT(INOUT) :: vec_W_gw
824 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
825 : INTENT(IN) :: wj
826 : TYPE(cp_fm_type), INTENT(IN) :: fm_mat_Q, fm_mat_R_gw
827 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_S_gw, fm_mat_S_gw_work
828 : TYPE(cp_fm_type), INTENT(IN) :: mo_coeff
829 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_RPA
830 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_im_mo_mo, &
831 : matrix_berry_re_mo_mo
832 : TYPE(kpoint_type), POINTER :: kpoints
833 : TYPE(qs_environment_type), POINTER :: qs_env
834 : TYPE(mp2_type) :: mp2_env
835 :
836 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_GW_self_energy'
837 :
838 : INTEGER :: handle, i_global, iiB, ispin, j_global, &
839 : jjB, ncol_local, nrow_local, nspins
840 15210 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
841 :
842 15210 : CALL timeset(routineN, handle)
843 :
844 15210 : nspins = SIZE(fm_mat_S_gw)
845 :
846 : CALL cp_fm_get_info(matrix=fm_mat_Q, &
847 : nrow_local=nrow_local, &
848 : ncol_local=ncol_local, &
849 : row_indices=row_indices, &
850 15210 : col_indices=col_indices)
851 :
852 15210 : IF (.NOT. do_im_time) THEN
853 : ! calculate [1+Q(iw')]^-1
854 15210 : CALL cp_fm_cholesky_invert(fm_mat_Q)
855 : ! symmetrize the result, fm_mat_R_gw is only temporary work matrix
856 15210 : CALL cp_fm_uplo_to_full(fm_mat_Q, fm_mat_R_gw)
857 :
858 : ! periodic correction for GW (paper Phys. Rev. B 95, 235123 (2017))
859 15210 : IF (do_periodic) THEN
860 : CALL calc_periodic_correction(delta_corr, qs_env, para_env, para_env_RPA, &
861 : mp2_env%ri_g0w0%kp_grid, homo(1), nmo, gw_corr_lev_occ(1), &
862 : gw_corr_lev_virt(1), omega, mo_coeff, Eigenval(:, 1), &
863 : matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
864 : first_cycle_periodic_correction, kpoints, &
865 : mp2_env%ri_g0w0%do_mo_coeff_gamma, &
866 : mp2_env%ri_g0w0%num_kp_grids, mp2_env%ri_g0w0%eps_kpoint, &
867 : mp2_env%ri_g0w0%do_extra_kpoints, &
868 240 : mp2_env%ri_g0w0%do_aux_bas_gw, mp2_env%ri_g0w0%frac_aux_mos)
869 : END IF
870 :
871 15210 : CALL para_env%sync()
872 :
873 : ! subtract 1 from the diagonal to get rid of exchange self-energy
874 : !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(jjB,iiB,i_global,j_global) &
875 15210 : !$OMP SHARED(ncol_local,nrow_local,col_indices,row_indices,fm_mat_Q,dimen_RI)
876 : DO jjB = 1, ncol_local
877 : j_global = col_indices(jjB)
878 : DO iiB = 1, nrow_local
879 : i_global = row_indices(iiB)
880 : IF (j_global == i_global .AND. i_global <= dimen_RI) THEN
881 : fm_mat_Q%local_data(iiB, jjB) = fm_mat_Q%local_data(iiB, jjB) - 1.0_dp
882 : END IF
883 : END DO
884 : END DO
885 :
886 15210 : CALL para_env%sync()
887 :
888 30480 : DO ispin = 1, nspins
889 : CALL compute_GW_self_energy_deep(vec_Sigma_c_gw(:, :, :, ispin), dimen_nm_gw, dimen_RI, &
890 : gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), &
891 : homo(ispin), jquad, nmo, &
892 : num_fit_points, do_periodic, fermi_level_offset, omega, &
893 : Eigenval(:, ispin), delta_corr, &
894 : vec_omega_fit_gw, vec_W_gw(:, ispin), wj, fm_mat_Q, &
895 30480 : fm_mat_S_gw(ispin), fm_mat_S_gw_work(ispin))
896 : END DO
897 :
898 : END IF ! GW
899 :
900 15210 : CALL timestop(handle)
901 :
902 15210 : END SUBROUTINE compute_GW_self_energy
903 :
904 : ! **************************************************************************************************
905 : !> \brief ...
906 : !> \param fermi_level_offset ...
907 : !> \param fermi_level_offset_input ...
908 : !> \param Eigenval ...
909 : !> \param homo ...
910 : ! **************************************************************************************************
911 15808 : SUBROUTINE get_fermi_level_offset(fermi_level_offset, fermi_level_offset_input, Eigenval, homo)
912 :
913 : REAL(KIND=dp), INTENT(INOUT) :: fermi_level_offset
914 : REAL(KIND=dp), INTENT(IN) :: fermi_level_offset_input
915 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: Eigenval
916 : INTEGER, DIMENSION(:), INTENT(IN) :: homo
917 :
918 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_fermi_level_offset'
919 :
920 : INTEGER :: handle, ispin, nspins
921 :
922 15808 : CALL timeset(routineN, handle)
923 :
924 15808 : nspins = SIZE(Eigenval, 2)
925 :
926 : ! Fermi level offset should have a maximum such that the Fermi level of occupied orbitals
927 : ! is always closer to occupied orbitals than to virtual orbitals and vice versa
928 : ! that means, the Fermi level offset is at most as big as half the bandgap
929 15808 : fermi_level_offset = fermi_level_offset_input
930 31820 : DO ispin = 1, nspins
931 31820 : fermi_level_offset = MIN(fermi_level_offset, (Eigenval(homo(ispin) + 1, ispin) - Eigenval(homo(ispin), ispin))*0.5_dp)
932 : END DO
933 :
934 15808 : CALL timestop(handle)
935 :
936 15808 : END SUBROUTINE get_fermi_level_offset
937 :
938 : ! **************************************************************************************************
939 : !> \brief ...
940 : !> \param fm_mat_W ...
941 : !> \param fm_mat_Q ...
942 : !> \param fm_mat_work ...
943 : !> \param dimen_RI ...
944 : !> \param fm_mat_L ...
945 : !> \param num_integ_points ...
946 : !> \param tj ...
947 : !> \param tau_tj ...
948 : !> \param weights_cos_tf_w_to_t ...
949 : !> \param jquad ...
950 : !> \param omega ...
951 : ! **************************************************************************************************
952 490 : SUBROUTINE compute_W_cubic_GW(fm_mat_W, fm_mat_Q, fm_mat_work, dimen_RI, fm_mat_L, num_integ_points, &
953 : tj, tau_tj, weights_cos_tf_w_to_t, jquad, omega)
954 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_W
955 : TYPE(cp_fm_type), INTENT(IN) :: fm_mat_Q, fm_mat_work
956 : INTEGER, INTENT(IN) :: dimen_RI
957 : TYPE(cp_fm_type), DIMENSION(:, :), INTENT(IN) :: fm_mat_L
958 : INTEGER, INTENT(IN) :: num_integ_points
959 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
960 : INTENT(IN) :: tj, tau_tj
961 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
962 : INTENT(IN) :: weights_cos_tf_w_to_t
963 : INTEGER, INTENT(IN) :: jquad
964 : REAL(KIND=dp), INTENT(INOUT) :: omega
965 :
966 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_W_cubic_GW'
967 :
968 : INTEGER :: handle, i_global, iiB, iquad, j_global, &
969 : jjB, ncol_local, nrow_local
970 490 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
971 : REAL(KIND=dp) :: tau, weight
972 :
973 490 : CALL timeset(routineN, handle)
974 :
975 : CALL cp_fm_get_info(matrix=fm_mat_Q, &
976 : nrow_local=nrow_local, &
977 : ncol_local=ncol_local, &
978 : row_indices=row_indices, &
979 490 : col_indices=col_indices)
980 : ! calculate [1+Q(iw')]^-1
981 490 : CALL cp_fm_cholesky_invert(fm_mat_Q)
982 :
983 : ! symmetrize the result
984 490 : CALL cp_fm_uplo_to_full(fm_mat_Q, fm_mat_work)
985 :
986 : ! subtract 1 from the diagonal to get rid of exchange self-energy
987 : !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(jjB,iiB,i_global,j_global) &
988 490 : !$OMP SHARED(ncol_local,nrow_local,col_indices,row_indices,fm_mat_Q,dimen_RI)
989 : DO jjB = 1, ncol_local
990 : j_global = col_indices(jjB)
991 : DO iiB = 1, nrow_local
992 : i_global = row_indices(iiB)
993 : IF (j_global == i_global .AND. i_global <= dimen_RI) THEN
994 : fm_mat_Q%local_data(iiB, jjB) = fm_mat_Q%local_data(iiB, jjB) - 1.0_dp
995 : END IF
996 : END DO
997 : END DO
998 :
999 : ! multiply with L from the left and the right to get the screened Coulomb interaction
1000 : CALL parallel_gemm('T', 'N', dimen_RI, dimen_RI, dimen_RI, 1.0_dp, fm_mat_L(1, 1), fm_mat_Q, &
1001 490 : 0.0_dp, fm_mat_work)
1002 :
1003 : CALL parallel_gemm('N', 'N', dimen_RI, dimen_RI, dimen_RI, 1.0_dp, fm_mat_work, fm_mat_L(1, 1), &
1004 490 : 0.0_dp, fm_mat_Q)
1005 :
1006 : ! Fourier transform from w to t
1007 8640 : DO iquad = 1, num_integ_points
1008 :
1009 8150 : omega = tj(jquad)
1010 8150 : tau = tau_tj(iquad)
1011 8150 : weight = weights_cos_tf_w_to_t(iquad, jquad)*COS(tau*omega)
1012 :
1013 8150 : IF (jquad == 1) THEN
1014 :
1015 490 : CALL cp_fm_set_all(matrix=fm_mat_W(iquad), alpha=0.0_dp)
1016 :
1017 : END IF
1018 :
1019 8640 : CALL cp_fm_scale_and_add(alpha=1.0_dp, matrix_a=fm_mat_W(iquad), beta=weight, matrix_b=fm_mat_Q)
1020 :
1021 : END DO
1022 :
1023 490 : CALL timestop(handle)
1024 490 : END SUBROUTINE compute_W_cubic_GW
1025 :
1026 : ! **************************************************************************************************
1027 : !> \brief ...
1028 : !> \param vec_Sigma_c_gw ...
1029 : !> \param dimen_nm_gw ...
1030 : !> \param dimen_RI ...
1031 : !> \param gw_corr_lev_occ ...
1032 : !> \param gw_corr_lev_virt ...
1033 : !> \param homo ...
1034 : !> \param jquad ...
1035 : !> \param nmo ...
1036 : !> \param num_fit_points ...
1037 : !> \param do_periodic ...
1038 : !> \param fermi_level_offset ...
1039 : !> \param omega ...
1040 : !> \param Eigenval ...
1041 : !> \param delta_corr ...
1042 : !> \param vec_omega_fit_gw ...
1043 : !> \param vec_W_gw ...
1044 : !> \param wj ...
1045 : !> \param fm_mat_Q ...
1046 : !> \param fm_mat_S_gw ...
1047 : !> \param fm_mat_S_gw_work ...
1048 : ! **************************************************************************************************
1049 76350 : SUBROUTINE compute_GW_self_energy_deep(vec_Sigma_c_gw, dimen_nm_gw, dimen_RI, &
1050 : gw_corr_lev_occ, gw_corr_lev_virt, &
1051 : homo, jquad, nmo, num_fit_points, &
1052 30540 : do_periodic, fermi_level_offset, omega, Eigenval, &
1053 22785 : delta_corr, vec_omega_fit_gw, vec_W_gw, &
1054 15270 : wj, fm_mat_Q, fm_mat_S_gw, fm_mat_S_gw_work)
1055 :
1056 : COMPLEX(KIND=dp), DIMENSION(:, :, :), &
1057 : INTENT(INOUT) :: vec_Sigma_c_gw
1058 : INTEGER, INTENT(IN) :: dimen_nm_gw, dimen_RI, gw_corr_lev_occ, &
1059 : gw_corr_lev_virt, homo, jquad, nmo, &
1060 : num_fit_points
1061 : LOGICAL, INTENT(IN) :: do_periodic
1062 : REAL(KIND=dp), INTENT(IN) :: fermi_level_offset
1063 : REAL(KIND=dp), INTENT(INOUT) :: omega
1064 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: Eigenval
1065 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: delta_corr, vec_omega_fit_gw
1066 : REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: vec_W_gw
1067 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: wj
1068 : TYPE(cp_fm_type), INTENT(IN) :: fm_mat_Q, fm_mat_S_gw, fm_mat_S_gw_work
1069 :
1070 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_GW_self_energy_deep'
1071 :
1072 : INTEGER :: handle, iiB, iquad, m_global, n_global, &
1073 : ncol_local, nm_global
1074 15270 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
1075 : REAL(KIND=dp) :: delta_corr_nn, e_fermi, omega_i, &
1076 : sign_occ_virt
1077 :
1078 15270 : CALL timeset(routineN, handle)
1079 :
1080 : ! S_work_(nm)Q = B_(nm)P * ([1+Q]^-1-1)_PQ
1081 : CALL parallel_gemm(transa="N", transb="N", m=dimen_RI, n=dimen_nm_gw, k=dimen_RI, alpha=1.0_dp, &
1082 : matrix_a=fm_mat_Q, matrix_b=fm_mat_S_gw, beta=0.0_dp, &
1083 15270 : matrix_c=fm_mat_S_gw_work)
1084 :
1085 : CALL cp_fm_get_info(matrix=fm_mat_S_gw, &
1086 : ncol_local=ncol_local, &
1087 : row_indices=row_indices, &
1088 15270 : col_indices=col_indices)
1089 :
1090 : ! vector W_(nm) = S_work_(nm)Q * [B_(nm)Q]^T
1091 :
1092 5655890 : vec_W_gw = 0.0_dp
1093 :
1094 5655890 : DO iiB = 1, ncol_local
1095 5640620 : nm_global = col_indices(iiB)
1096 : vec_W_gw(nm_global) = vec_W_gw(nm_global) + &
1097 244700480 : DOT_PRODUCT(fm_mat_S_gw_work%local_data(:, iiB), fm_mat_S_gw%local_data(:, iiB))
1098 :
1099 : ! transform the index nm of vec_W_gw back to n and m, formulae copied from Mauro's code
1100 5640620 : n_global = MAX(1, nm_global - 1)/nmo + 1
1101 5640620 : m_global = nm_global - (n_global - 1)*nmo
1102 5640620 : n_global = n_global + homo - gw_corr_lev_occ
1103 :
1104 : ! compute self-energy for imaginary frequencies
1105 462825470 : DO iquad = 1, num_fit_points
1106 :
1107 : ! for occ orbitals, we compute the self-energy for negative frequencies
1108 457169580 : IF (n_global <= homo) THEN
1109 : sign_occ_virt = -1.0_dp
1110 : ELSE
1111 342677820 : sign_occ_virt = 1.0_dp
1112 : END IF
1113 :
1114 457169580 : omega_i = vec_omega_fit_gw(iquad)*sign_occ_virt
1115 :
1116 : ! set the Fermi energy for occ orbitals slightly above the HOMO and
1117 : ! for virt orbitals slightly below the LUMO
1118 457169580 : IF (n_global <= homo) THEN
1119 686921400 : e_fermi = MAXVAL(Eigenval(homo - gw_corr_lev_occ + 1:homo)) + fermi_level_offset
1120 : ELSE
1121 4789213560 : e_fermi = MINVAL(Eigenval(homo + 1:homo + gw_corr_lev_virt)) - fermi_level_offset
1122 : END IF
1123 :
1124 : ! add here the periodic correction
1125 457169580 : IF (do_periodic .AND. row_indices(1) == 1 .AND. n_global == m_global) THEN
1126 57120 : delta_corr_nn = delta_corr(n_global)
1127 : ELSE
1128 : delta_corr_nn = 0.0_dp
1129 : END IF
1130 :
1131 : ! update the self-energy (use that vec_W_gw(iw) is symmetric), divide the integration
1132 : ! weight by 2, because the integration is from -infty to +infty and not just 0 to +infty
1133 : ! as for RPA, also we need for virtual orbitals a complex conjugate
1134 : vec_Sigma_c_gw(n_global - homo + gw_corr_lev_occ, iquad, 1) = &
1135 : vec_Sigma_c_gw(n_global - homo + gw_corr_lev_occ, iquad, 1) - &
1136 : 0.5_dp/pi*wj(jquad)/2.0_dp*(vec_W_gw(nm_global) + delta_corr_nn)* &
1137 : (1.0_dp/(gaussi*(omega + omega_i) + e_fermi - Eigenval(m_global)) + &
1138 462810200 : 1.0_dp/(gaussi*(-omega + omega_i) + e_fermi - Eigenval(m_global)))
1139 : END DO
1140 :
1141 : END DO
1142 :
1143 15270 : CALL timestop(handle)
1144 :
1145 15270 : END SUBROUTINE compute_GW_self_energy_deep
1146 :
1147 : ! **************************************************************************************************
1148 : !> \brief ...
1149 : !> \param vec_Sigma_c_gw ...
1150 : !> \param count_ev_sc_GW ...
1151 : !> \param gw_corr_lev_occ ...
1152 : !> \param gw_corr_lev_tot ...
1153 : !> \param gw_corr_lev_virt ...
1154 : !> \param homo ...
1155 : !> \param nmo ...
1156 : !> \param num_fit_points ...
1157 : !> \param num_integ_points ...
1158 : !> \param unit_nr ...
1159 : !> \param do_apply_ic_corr_to_gw ...
1160 : !> \param do_im_time ...
1161 : !> \param do_periodic ...
1162 : !> \param do_ri_Sigma_x ...
1163 : !> \param first_cycle_periodic_correction ...
1164 : !> \param e_fermi ...
1165 : !> \param eps_filter ...
1166 : !> \param fermi_level_offset ...
1167 : !> \param delta_corr ...
1168 : !> \param Eigenval ...
1169 : !> \param Eigenval_last ...
1170 : !> \param Eigenval_scf ...
1171 : !> \param iter_sc_GW0 ...
1172 : !> \param exit_ev_gw ...
1173 : !> \param tau_tj ...
1174 : !> \param tj ...
1175 : !> \param vec_omega_fit_gw ...
1176 : !> \param vec_Sigma_x_gw ...
1177 : !> \param ic_corr_list ...
1178 : !> \param weights_cos_tf_t_to_w ...
1179 : !> \param weights_sin_tf_t_to_w ...
1180 : !> \param fm_mo_coeff_occ_scaled ...
1181 : !> \param fm_mo_coeff_virt_scaled ...
1182 : !> \param fm_mo_coeff_occ ...
1183 : !> \param fm_mo_coeff_virt ...
1184 : !> \param fm_scaled_dm_occ_tau ...
1185 : !> \param fm_scaled_dm_virt_tau ...
1186 : !> \param mo_coeff ...
1187 : !> \param fm_mat_W ...
1188 : !> \param para_env ...
1189 : !> \param para_env_RPA ...
1190 : !> \param mat_dm ...
1191 : !> \param mat_MinvVMinv ...
1192 : !> \param t_3c_O ...
1193 : !> \param t_3c_M ...
1194 : !> \param t_3c_overl_int_ao_mo ...
1195 : !> \param t_3c_O_compressed ...
1196 : !> \param t_3c_O_mo_compressed ...
1197 : !> \param t_3c_O_ind ...
1198 : !> \param t_3c_O_mo_ind ...
1199 : !> \param t_3c_overl_int_gw_RI ...
1200 : !> \param t_3c_overl_int_gw_AO ...
1201 : !> \param matrix_berry_im_mo_mo ...
1202 : !> \param matrix_berry_re_mo_mo ...
1203 : !> \param mat_W ...
1204 : !> \param matrix_s ...
1205 : !> \param kpoints ...
1206 : !> \param mp2_env ...
1207 : !> \param qs_env ...
1208 : !> \param nkp_self_energy ...
1209 : !> \param do_kpoints_cubic_RPA ...
1210 : !> \param starts_array_mc ...
1211 : !> \param ends_array_mc ...
1212 : ! **************************************************************************************************
1213 1430 : SUBROUTINE compute_QP_energies(vec_Sigma_c_gw, count_ev_sc_GW, gw_corr_lev_occ, &
1214 572 : gw_corr_lev_tot, gw_corr_lev_virt, homo, &
1215 : nmo, num_fit_points, num_integ_points, &
1216 : unit_nr, do_apply_ic_corr_to_gw, do_im_time, &
1217 : do_periodic, do_ri_Sigma_x, &
1218 286 : first_cycle_periodic_correction, e_fermi, eps_filter, &
1219 286 : fermi_level_offset, delta_corr, Eigenval, &
1220 : Eigenval_last, Eigenval_scf, iter_sc_GW0, exit_ev_gw, tau_tj, tj, &
1221 : vec_omega_fit_gw, vec_Sigma_x_gw, ic_corr_list, &
1222 : weights_cos_tf_t_to_w, weights_sin_tf_t_to_w, &
1223 286 : fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, fm_mo_coeff_occ, &
1224 424 : fm_mo_coeff_virt, fm_scaled_dm_occ_tau, fm_scaled_dm_virt_tau, &
1225 : mo_coeff, fm_mat_W, para_env, para_env_RPA, mat_dm, mat_MinvVMinv, &
1226 : t_3c_O, t_3c_M, t_3c_overl_int_ao_mo, &
1227 286 : t_3c_O_compressed, t_3c_O_mo_compressed, &
1228 286 : t_3c_O_ind, t_3c_O_mo_ind, &
1229 738 : t_3c_overl_int_gw_RI, t_3c_overl_int_gw_AO, matrix_berry_im_mo_mo, &
1230 : matrix_berry_re_mo_mo, mat_W, matrix_s, &
1231 : kpoints, mp2_env, qs_env, nkp_self_energy, do_kpoints_cubic_RPA, &
1232 288 : starts_array_mc, ends_array_mc)
1233 :
1234 : COMPLEX(KIND=dp), DIMENSION(:, :, :, :), &
1235 : INTENT(OUT) :: vec_Sigma_c_gw
1236 : INTEGER, INTENT(IN) :: count_ev_sc_GW
1237 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ
1238 : INTEGER, INTENT(IN) :: gw_corr_lev_tot
1239 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_virt, homo
1240 : INTEGER, INTENT(IN) :: nmo, num_fit_points, num_integ_points, &
1241 : unit_nr
1242 : LOGICAL, INTENT(IN) :: do_apply_ic_corr_to_gw, do_im_time, &
1243 : do_periodic, do_ri_Sigma_x
1244 : LOGICAL, INTENT(INOUT) :: first_cycle_periodic_correction
1245 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_fermi
1246 : REAL(KIND=dp), INTENT(IN) :: eps_filter, fermi_level_offset
1247 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
1248 : INTENT(INOUT) :: delta_corr
1249 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: Eigenval
1250 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
1251 : INTENT(INOUT) :: Eigenval_last, Eigenval_scf
1252 : INTEGER, INTENT(IN) :: iter_sc_GW0
1253 : LOGICAL, INTENT(INOUT) :: exit_ev_gw
1254 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
1255 : INTENT(INOUT) :: tau_tj, tj, vec_omega_fit_gw
1256 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
1257 : INTENT(INOUT) :: vec_Sigma_x_gw
1258 : TYPE(one_dim_real_array), DIMENSION(2), INTENT(IN) :: ic_corr_list
1259 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :), &
1260 : INTENT(IN) :: weights_cos_tf_t_to_w, &
1261 : weights_sin_tf_t_to_w
1262 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff_occ_scaled, &
1263 : fm_mo_coeff_virt_scaled
1264 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mo_coeff_occ, fm_mo_coeff_virt
1265 : TYPE(cp_fm_type), INTENT(IN) :: fm_scaled_dm_occ_tau, &
1266 : fm_scaled_dm_virt_tau, mo_coeff
1267 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:), &
1268 : INTENT(IN) :: fm_mat_W
1269 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_RPA
1270 : TYPE(dbcsr_p_type), INTENT(IN) :: mat_dm, mat_MinvVMinv
1271 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_O
1272 : TYPE(dbt_type) :: t_3c_M, t_3c_overl_int_ao_mo
1273 : TYPE(hfx_compression_type), ALLOCATABLE, &
1274 : DIMENSION(:, :, :), INTENT(INOUT) :: t_3c_O_compressed
1275 : TYPE(hfx_compression_type), DIMENSION(:) :: t_3c_O_mo_compressed
1276 : TYPE(block_ind_type), ALLOCATABLE, &
1277 : DIMENSION(:, :, :), INTENT(INOUT) :: t_3c_O_ind
1278 : TYPE(two_dim_int_array), DIMENSION(:) :: t_3c_O_mo_ind
1279 : TYPE(dbt_type), DIMENSION(:) :: t_3c_overl_int_gw_RI, &
1280 : t_3c_overl_int_gw_AO
1281 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_im_mo_mo, &
1282 : matrix_berry_re_mo_mo
1283 : TYPE(dbcsr_type), POINTER :: mat_W
1284 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s
1285 : TYPE(kpoint_type), POINTER :: kpoints
1286 : TYPE(mp2_type) :: mp2_env
1287 : TYPE(qs_environment_type), POINTER :: qs_env
1288 : INTEGER, INTENT(IN) :: nkp_self_energy
1289 : LOGICAL, INTENT(IN) :: do_kpoints_cubic_RPA
1290 : INTEGER, DIMENSION(:), INTENT(IN) :: starts_array_mc, ends_array_mc
1291 :
1292 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_QP_energies'
1293 :
1294 : INTEGER :: count_ev_sc_GW_print, count_sc_GW0, count_sc_GW0_print, crossing_search, handle, &
1295 : idos, ikp, ispin, iunit, n_level_gw, ndos, nspins, num_points_corr, num_poles
1296 : LOGICAL :: do_kpoints_Sigma, my_open_shell
1297 : REAL(KIND=dp) :: dos_lower_bound, dos_precision, dos_upper_bound, E_CBM_GW, E_CBM_GW_beta, &
1298 : E_CBM_SCF, E_CBM_SCF_beta, E_VBM_GW, E_VBM_GW_beta, E_VBM_SCF, E_VBM_SCF_beta, stop_crit
1299 286 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_gw_dos
1300 286 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: m_value, vec_gw_energ, z_value
1301 : TYPE(cp_logger_type), POINTER :: logger
1302 : TYPE(kpoint_type), POINTER :: kpoints_Sigma
1303 :
1304 286 : CALL timeset(routineN, handle)
1305 :
1306 286 : nspins = SIZE(homo)
1307 286 : my_open_shell = (nspins == 2)
1308 :
1309 286 : do_kpoints_Sigma = mp2_env%ri_g0w0%do_kpoints_Sigma
1310 :
1311 356 : DO count_sc_GW0 = 1, iter_sc_GW0
1312 :
1313 : ! postprocessing for cubic scaling GW calculation
1314 300 : IF (do_im_time .AND. .NOT. do_kpoints_cubic_RPA .AND. .NOT. do_kpoints_Sigma) THEN
1315 56 : num_points_corr = mp2_env%ri_g0w0%num_omega_points
1316 :
1317 118 : DO ispin = 1, nspins
1318 : CALL compute_self_energy_cubic_gw(num_integ_points, nmo, tau_tj, tj, &
1319 : matrix_s, fm_mo_coeff_occ(ispin), &
1320 : fm_mo_coeff_virt(ispin), fm_mo_coeff_occ_scaled, &
1321 : fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, &
1322 : fm_scaled_dm_virt_tau, Eigenval(:, 1, ispin), eps_filter, &
1323 : e_fermi(ispin), fm_mat_W, &
1324 : gw_corr_lev_tot, gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), homo(ispin), &
1325 : count_ev_sc_GW, count_sc_GW0, &
1326 : t_3c_overl_int_ao_mo, t_3c_O_mo_compressed(ispin), &
1327 : t_3c_O_mo_ind(ispin)%array, &
1328 : t_3c_overl_int_gw_RI(ispin), t_3c_overl_int_gw_AO(ispin), &
1329 : mat_W, mat_MinvVMinv, mat_dm, &
1330 : weights_cos_tf_t_to_w, weights_sin_tf_t_to_w, vec_Sigma_c_gw(:, :, :, ispin), &
1331 : do_periodic, num_points_corr, delta_corr, qs_env, para_env, para_env_RPA, &
1332 : mp2_env, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
1333 : first_cycle_periodic_correction, kpoints, num_fit_points, mo_coeff, &
1334 118 : do_ri_Sigma_x, vec_Sigma_x_gw(:, :, ispin), unit_nr, ispin)
1335 : END DO
1336 :
1337 : END IF
1338 :
1339 282 : IF (do_kpoints_Sigma) THEN
1340 : CALL compute_self_energy_cubic_gw_kpoints(num_integ_points, tau_tj, tj, &
1341 : matrix_s, Eigenval(:, :, :), e_fermi, fm_mat_W, &
1342 : gw_corr_lev_tot, gw_corr_lev_occ, gw_corr_lev_virt, homo, &
1343 : count_ev_sc_GW, count_sc_GW0, &
1344 : t_3c_O, t_3c_M, t_3c_O_compressed, t_3c_O_ind, &
1345 : mat_W, mat_MinvVMinv, &
1346 : weights_cos_tf_t_to_w, weights_sin_tf_t_to_w, vec_Sigma_c_gw(:, :, :, :), &
1347 : qs_env, para_env, &
1348 : mp2_env, num_fit_points, mo_coeff, &
1349 : do_ri_Sigma_x, vec_Sigma_x_gw(:, :, :), unit_nr, nspins, &
1350 18 : starts_array_mc, ends_array_mc, eps_filter)
1351 :
1352 : END IF
1353 :
1354 300 : IF (do_periodic .AND. mp2_env%ri_g0w0%do_average_deg_levels) THEN
1355 :
1356 20 : DO ispin = 1, nspins
1357 : CALL average_degenerate_levels(vec_Sigma_c_gw(:, :, :, ispin), &
1358 : Eigenval(1 + homo(ispin) - gw_corr_lev_occ(ispin): &
1359 : homo(ispin) + gw_corr_lev_virt(ispin), 1, ispin), &
1360 20 : mp2_env%ri_g0w0%eps_eigenval)
1361 : END DO
1362 : END IF
1363 :
1364 300 : IF (.NOT. do_im_time) THEN
1365 447494 : CALL para_env%sum(vec_Sigma_c_gw)
1366 : END IF
1367 :
1368 300 : CALL para_env%sync()
1369 :
1370 300 : stop_crit = 1.0e-7
1371 300 : num_poles = mp2_env%ri_g0w0%num_poles
1372 300 : crossing_search = mp2_env%ri_g0w0%crossing_search
1373 :
1374 : ! arrays storing the correlation self-energy, stat. error and z-shot value
1375 1500 : ALLOCATE (vec_gw_energ(gw_corr_lev_tot, nkp_self_energy, nspins))
1376 5562 : vec_gw_energ = 0.0_dp
1377 1200 : ALLOCATE (z_value(gw_corr_lev_tot, nkp_self_energy, nspins))
1378 5562 : z_value = 0.0_dp
1379 1200 : ALLOCATE (m_value(gw_corr_lev_tot, nkp_self_energy, nspins))
1380 5562 : m_value = 0.0_dp
1381 300 : E_VBM_GW = -1.0E3
1382 300 : E_CBM_GW = 1.0E3
1383 300 : E_VBM_SCF = -1.0E3
1384 300 : E_CBM_SCF = 1.0E3
1385 300 : E_VBM_GW_beta = -1.0E3
1386 300 : E_CBM_GW_beta = 1.0E3
1387 300 : E_VBM_SCF_beta = -1.0E3
1388 300 : E_CBM_SCF_beta = 1.0E3
1389 :
1390 300 : ndos = 0
1391 300 : dos_precision = mp2_env%ri_g0w0%dos_prec
1392 300 : dos_upper_bound = mp2_env%ri_g0w0%dos_upper
1393 300 : dos_lower_bound = mp2_env%ri_g0w0%dos_lower
1394 :
1395 300 : IF (dos_lower_bound >= dos_upper_bound) THEN
1396 0 : CALL cp_abort(__LOCATION__, "Invalid settings for GW_DOS calculation!")
1397 : END IF
1398 :
1399 300 : IF (dos_precision /= 0) THEN
1400 0 : ndos = INT((dos_upper_bound - dos_lower_bound)/dos_precision)
1401 0 : ALLOCATE (vec_gw_dos(ndos))
1402 0 : vec_gw_dos = 0.0_dp
1403 : END IF
1404 :
1405 : ! for the normal code for molecules or Gamma only: nkp = 1
1406 718 : DO ikp = 1, nkp_self_energy
1407 :
1408 418 : kpoints_Sigma => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma
1409 :
1410 : ! fit the self-energy on imaginary frequency axis and evaluate the fit on the MO energy of the SCF
1411 4574 : DO n_level_gw = 1, gw_corr_lev_tot
1412 : ! processes perform different fits
1413 4156 : IF (MODULO(n_level_gw, para_env%num_pe) /= para_env%mepos) CYCLE
1414 :
1415 2520 : SELECT CASE (mp2_env%ri_g0w0%analytic_continuation)
1416 : CASE (gw_two_pole_model)
1417 : CALL fit_and_continuation_2pole(vec_gw_energ(:, ikp, 1), vec_omega_fit_gw, &
1418 : z_value(:, ikp, 1), m_value(:, ikp, 1), vec_Sigma_c_gw(:, :, ikp, 1), &
1419 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 1, ikp), &
1420 : Eigenval(:, ikp, 1), Eigenval_scf(:, ikp, 1), n_level_gw, &
1421 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), num_poles, &
1422 : num_fit_points, crossing_search, homo(1), stop_crit, &
1423 442 : fermi_level_offset, do_im_time)
1424 :
1425 : CASE (gw_pade_approx)
1426 : CALL continuation_pade(vec_gw_energ(:, ikp, 1), vec_omega_fit_gw, &
1427 : z_value(:, ikp, 1), m_value(:, ikp, 1), vec_Sigma_c_gw(:, :, ikp, 1), &
1428 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 1, ikp), &
1429 : Eigenval(:, ikp, 1), Eigenval_scf(:, ikp, 1), &
1430 : mp2_env%ri_g0w0%do_hedin_shift, n_level_gw, &
1431 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), mp2_env%ri_g0w0%nparam_pade, &
1432 : num_fit_points, crossing_search, homo(1), fermi_level_offset, &
1433 : do_im_time, mp2_env%ri_g0w0%print_self_energy, count_ev_sc_GW, &
1434 : vec_gw_dos, dos_lower_bound, dos_precision, ndos, &
1435 : mp2_env%ri_g0w0%min_level_self_energy, &
1436 : mp2_env%ri_g0w0%max_level_self_energy, mp2_env%ri_g0w0%dos_eta, &
1437 1636 : mp2_env%ri_g0w0%dos_min, mp2_env%ri_g0w0%dos_max)
1438 : CASE DEFAULT
1439 2078 : CPABORT("Only two-model and Pade approximation are implemented.")
1440 : END SELECT
1441 :
1442 2496 : IF (my_open_shell) THEN
1443 284 : SELECT CASE (mp2_env%ri_g0w0%analytic_continuation)
1444 : CASE (gw_two_pole_model)
1445 : CALL fit_and_continuation_2pole( &
1446 : vec_gw_energ(:, ikp, 2), vec_omega_fit_gw, &
1447 : z_value(:, ikp, 2), m_value(:, ikp, 2), vec_Sigma_c_gw(:, :, ikp, 2), &
1448 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 2, ikp), &
1449 : Eigenval(:, ikp, 2), Eigenval_scf(:, ikp, 2), n_level_gw, &
1450 : gw_corr_lev_occ(2), gw_corr_lev_virt(2), num_poles, &
1451 : num_fit_points, crossing_search, homo(2), stop_crit, &
1452 126 : fermi_level_offset, do_im_time)
1453 : CASE (gw_pade_approx)
1454 : CALL continuation_pade(vec_gw_energ(:, ikp, 2), vec_omega_fit_gw, &
1455 : z_value(:, ikp, 2), m_value(:, ikp, 2), vec_Sigma_c_gw(:, :, ikp, 2), &
1456 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 2, ikp), &
1457 : Eigenval(:, ikp, 2), Eigenval_scf(:, ikp, 2), &
1458 : mp2_env%ri_g0w0%do_hedin_shift, n_level_gw, &
1459 : gw_corr_lev_occ(2), gw_corr_lev_virt(2), mp2_env%ri_g0w0%nparam_pade, &
1460 : num_fit_points, crossing_search, homo(2), &
1461 : fermi_level_offset, do_im_time, &
1462 : mp2_env%ri_g0w0%print_self_energy, count_ev_sc_GW, &
1463 : vec_gw_dos, dos_lower_bound, dos_precision, ndos, &
1464 : mp2_env%ri_g0w0%min_level_self_energy, &
1465 : mp2_env%ri_g0w0%max_level_self_energy, mp2_env%ri_g0w0%dos_eta, &
1466 32 : mp2_env%ri_g0w0%dos_min, mp2_env%ri_g0w0%dos_max)
1467 : CASE DEFAULT
1468 158 : CPABORT("Only two-pole model and Pade approximation are implemented.")
1469 : END SELECT
1470 :
1471 : END IF
1472 :
1473 : END DO ! n_level_gw
1474 :
1475 418 : CALL para_env%sum(vec_gw_energ)
1476 418 : CALL para_env%sum(z_value)
1477 418 : CALL para_env%sum(m_value)
1478 :
1479 418 : IF (dos_precision /= 0.0_dp) THEN
1480 0 : CALL para_env%sum(vec_gw_dos)
1481 : END IF
1482 :
1483 418 : CALL check_NaN(vec_gw_energ, 0.0_dp)
1484 418 : CALL check_NaN(z_value, 1.0_dp)
1485 418 : CALL check_NaN(m_value, 0.0_dp)
1486 :
1487 418 : IF (do_im_time .OR. mp2_env%ri_g0w0%iter_sc_GW0 == 1) THEN
1488 314 : count_ev_sc_GW_print = count_ev_sc_GW
1489 314 : count_sc_GW0_print = count_sc_GW0
1490 : ELSE
1491 104 : count_ev_sc_GW_print = count_sc_GW0
1492 104 : count_sc_GW0_print = count_ev_sc_GW
1493 : END IF
1494 :
1495 : ! print the quasiparticle energies and update Eigenval in case you do eigenvalue self-consistent GW
1496 718 : IF (my_open_shell) THEN
1497 :
1498 : CALL print_and_update_for_ev_sc( &
1499 : vec_gw_energ(:, ikp, 1), &
1500 : z_value(:, ikp, 1), m_value(:, ikp, 1), mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 1, ikp), &
1501 : Eigenval(:, ikp, 1), Eigenval_last(:, ikp, 1), Eigenval_scf(:, ikp, 1), &
1502 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), gw_corr_lev_tot, &
1503 : crossing_search, homo(1), unit_nr, count_ev_sc_GW_print, count_sc_GW0_print, &
1504 50 : ikp, nkp_self_energy, kpoints_Sigma, 1, E_VBM_GW, E_CBM_GW, E_VBM_SCF, E_CBM_SCF)
1505 :
1506 : CALL print_and_update_for_ev_sc( &
1507 : vec_gw_energ(:, ikp, 2), &
1508 : z_value(:, ikp, 2), m_value(:, ikp, 2), mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 2, ikp), &
1509 : Eigenval(:, ikp, 2), Eigenval_last(:, ikp, 2), Eigenval_scf(:, ikp, 2), &
1510 : gw_corr_lev_occ(2), gw_corr_lev_virt(2), gw_corr_lev_tot, &
1511 : crossing_search, homo(2), unit_nr, count_ev_sc_GW_print, count_sc_GW0_print, &
1512 50 : ikp, nkp_self_energy, kpoints_Sigma, 2, E_VBM_GW_beta, E_CBM_GW_beta, E_VBM_SCF_beta, E_CBM_SCF_beta)
1513 :
1514 50 : IF (do_apply_ic_corr_to_gw .AND. count_ev_sc_GW == 1) THEN
1515 :
1516 : CALL apply_ic_corr(Eigenval(:, ikp, 1), Eigenval_scf(:, ikp, 1), ic_corr_list(1)%array, &
1517 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), gw_corr_lev_tot, &
1518 0 : homo(1), nmo, unit_nr, do_alpha=.TRUE.)
1519 :
1520 : CALL apply_ic_corr(Eigenval(:, ikp, 2), Eigenval_scf(:, ikp, 2), ic_corr_list(2)%array, &
1521 : gw_corr_lev_occ(2), gw_corr_lev_virt(2), gw_corr_lev_tot, &
1522 0 : homo(2), nmo, unit_nr, do_beta=.TRUE.)
1523 :
1524 : END IF
1525 :
1526 : ELSE
1527 :
1528 : CALL print_and_update_for_ev_sc( &
1529 : vec_gw_energ(:, ikp, 1), &
1530 : z_value(:, ikp, 1), m_value(:, ikp, 1), mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, 1, ikp), &
1531 : Eigenval(:, ikp, 1), Eigenval_last(:, ikp, 1), Eigenval_scf(:, ikp, 1), &
1532 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), gw_corr_lev_tot, &
1533 : crossing_search, homo(1), unit_nr, count_ev_sc_GW_print, count_sc_GW0_print, &
1534 368 : ikp, nkp_self_energy, kpoints_Sigma, 0, E_VBM_GW, E_CBM_GW, E_VBM_SCF, E_CBM_SCF)
1535 :
1536 368 : IF (do_apply_ic_corr_to_gw .AND. count_ev_sc_GW == 1) THEN
1537 :
1538 : CALL apply_ic_corr(Eigenval(:, ikp, 1), Eigenval_scf(:, ikp, 1), ic_corr_list(1)%array, &
1539 : gw_corr_lev_occ(1), gw_corr_lev_virt(1), gw_corr_lev_tot, &
1540 0 : homo(1), nmo, unit_nr)
1541 :
1542 : END IF
1543 :
1544 : END IF
1545 :
1546 : END DO ! ikp
1547 :
1548 300 : IF (nkp_self_energy > 1 .AND. unit_nr > 0) THEN
1549 :
1550 : CALL print_gaps(E_VBM_SCF, E_CBM_SCF, E_VBM_SCF_beta, E_CBM_SCF_beta, &
1551 9 : E_VBM_GW, E_CBM_GW, E_VBM_GW_beta, E_CBM_GW_beta, my_open_shell, unit_nr)
1552 :
1553 : END IF
1554 :
1555 : ! Decide whether to add spin-orbit splitting of bands, spin-orbit coupling strength comes from
1556 : ! Hartwigsen parametrization (1999) of GTH pseudopotentials
1557 300 : IF (mp2_env%ri_g0w0%soc_type /= soc_none) THEN
1558 : CALL calculate_and_print_soc(qs_env, Eigenval_scf, Eigenval_scf, gw_corr_lev_occ, gw_corr_lev_virt, &
1559 2 : homo, unit_nr, do_soc_gw=.FALSE., do_soc_scf=.TRUE.)
1560 : CALL calculate_and_print_soc(qs_env, Eigenval, Eigenval_scf, gw_corr_lev_occ, gw_corr_lev_virt, &
1561 2 : homo, unit_nr, do_soc_gw=.TRUE., do_soc_scf=.FALSE.)
1562 : END IF
1563 :
1564 300 : logger => cp_get_default_logger()
1565 300 : IF (logger%para_env%is_source()) THEN
1566 297 : iunit = cp_logger_get_default_unit_nr()
1567 : ELSE
1568 3 : iunit = -1
1569 : END IF
1570 :
1571 300 : IF (dos_precision /= 0.0_dp) THEN
1572 0 : IF (iunit > 0) THEN
1573 0 : CALL open_file('spectral.dat', unit_number=iunit, file_status="UNKNOWN", file_action="WRITE")
1574 0 : DO idos = 1, ndos
1575 : ! 1/pi
1576 : ! [1/Hartree] -> [1/evolt]
1577 0 : WRITE (iunit, '(E17.10, E17.10)') (dos_lower_bound + REAL(idos - 1, KIND=dp)*dos_precision)*evolt, &
1578 0 : vec_gw_dos(idos)/evolt/pi
1579 : END DO
1580 0 : CALL close_file(iunit)
1581 : END IF
1582 0 : DEALLOCATE (vec_gw_dos)
1583 : END IF
1584 :
1585 300 : DEALLOCATE (z_value)
1586 300 : DEALLOCATE (m_value)
1587 300 : DEALLOCATE (vec_gw_energ)
1588 :
1589 300 : exit_ev_gw = .FALSE.
1590 :
1591 : ! if HOMO-LUMO gap differs by less than mp2_env%ri_g0w0%eps_sc_iter, exit ev sc GW loop
1592 300 : IF (ABS(Eigenval(homo(1), 1, 1) - Eigenval_last(homo(1), 1, 1) - &
1593 : Eigenval(homo(1) + 1, 1, 1) + Eigenval_last(homo(1) + 1, 1, 1)) &
1594 : < mp2_env%ri_g0w0%eps_iter) THEN
1595 32 : IF (count_sc_GW0 == 1) exit_ev_gw = .TRUE.
1596 : EXIT
1597 : END IF
1598 :
1599 558 : DO ispin = 1, nspins
1600 : CALL shift_unshifted_levels(Eigenval(:, 1, ispin), Eigenval_last(:, 1, ispin), gw_corr_lev_occ(ispin), &
1601 558 : gw_corr_lev_virt(ispin), homo(ispin), nmo)
1602 : END DO
1603 :
1604 268 : IF (do_im_time .AND. do_kpoints_Sigma .AND. mp2_env%ri_g0w0%print_local_bandgap) THEN
1605 2 : CALL print_local_bandgap(qs_env, Eigenval, gw_corr_lev_occ(1), gw_corr_lev_virt(1), homo(1), "GW")
1606 2 : CALL print_local_bandgap(qs_env, Eigenval_scf, gw_corr_lev_occ(1), gw_corr_lev_virt(1), homo(1), "DFT")
1607 : END IF
1608 :
1609 : ! in case of N^4 scaling GW, the scGW0 cycle is the eigenvalue sc cycle
1610 324 : IF (.NOT. do_im_time) EXIT
1611 :
1612 : END DO ! scGW0
1613 :
1614 286 : CALL timestop(handle)
1615 :
1616 286 : END SUBROUTINE compute_QP_energies
1617 :
1618 : ! **************************************************************************************************
1619 : !> \brief ...
1620 : !> \param qs_env ...
1621 : !> \param Eigenval ...
1622 : !> \param Eigenval_scf ...
1623 : !> \param gw_corr_lev_occ ...
1624 : !> \param gw_corr_lev_virt ...
1625 : !> \param homo ...
1626 : !> \param unit_nr ...
1627 : !> \param do_soc_gw ...
1628 : !> \param do_soc_scf ...
1629 : ! **************************************************************************************************
1630 4 : SUBROUTINE calculate_and_print_soc(qs_env, Eigenval, Eigenval_scf, gw_corr_lev_occ, gw_corr_lev_virt, &
1631 4 : homo, unit_nr, do_soc_gw, do_soc_scf)
1632 : TYPE(qs_environment_type), POINTER :: qs_env
1633 : REAL(KIND=dp), DIMENSION(:, :, :) :: Eigenval, Eigenval_scf
1634 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo
1635 : INTEGER :: unit_nr
1636 : LOGICAL :: do_soc_gw, do_soc_scf
1637 :
1638 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_and_print_soc'
1639 :
1640 : INTEGER :: handle, i_dim, i_glob, i_row, ikp, j_col, j_glob, n_level_gw, nao, ncol_local, &
1641 : nder, nkind, nkp_self_energy, nrow_local, periodic(3), size_real_space
1642 4 : INTEGER, ALLOCATABLE, DIMENSION(:) :: index0
1643 4 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
1644 : LOGICAL :: calculate_forces, use_virial
1645 : REAL(KIND=dp) :: avg_occ_QP_shift, avg_virt_QP_shift, E_CBM_GW_SOC, E_GAP_GW_SOC, E_HOMO, &
1646 : E_HOMO_GW_SOC, E_i, E_j, E_LUMO, E_LUMO_GW_SOC, E_VBM_GW_SOC, E_window, eps_ppnl
1647 4 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eigenvalues_without_soc_sorted
1648 4 : REAL(KIND=dp), DIMENSION(:), POINTER :: eigenvalues
1649 4 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1650 : TYPE(cell_type), POINTER :: cell
1651 : TYPE(cp_cfm_type) :: cfm_mat_h_double, cfm_mat_h_ks, &
1652 : cfm_mat_s_double, cfm_mat_work_double, &
1653 : cfm_mo_coeff, cfm_mo_coeff_double
1654 : TYPE(cp_fm_type), POINTER :: imos, rmos
1655 4 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, matrix_s_desymm
1656 4 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_VSOC_l_nosymm, mat_VSOC_lx_kp, &
1657 4 : mat_VSOC_ly_kp, mat_VSOC_lz_kp, &
1658 4 : matrix_dummy, matrix_l, &
1659 4 : matrix_pot_dummy
1660 : TYPE(dft_control_type), POINTER :: dft_control
1661 : TYPE(kpoint_type), POINTER :: kpoints_Sigma
1662 : TYPE(mp_para_env_type), POINTER :: para_env
1663 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
1664 4 : POINTER :: sab_orb, sap_ppnl
1665 4 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1666 4 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
1667 4 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1668 : TYPE(scf_control_type), POINTER :: scf_control
1669 : TYPE(virial_type), POINTER :: virial
1670 :
1671 4 : CALL timeset(routineN, handle)
1672 :
1673 4 : CPASSERT(do_soc_gw .NEQV. do_soc_scf)
1674 :
1675 : CALL get_qs_env(qs_env=qs_env, &
1676 : matrix_s=matrix_s, &
1677 : para_env=para_env, &
1678 : qs_kind_set=qs_kind_set, &
1679 : sab_orb=sab_orb, &
1680 : atomic_kind_set=atomic_kind_set, &
1681 : particle_set=particle_set, &
1682 : sap_ppnl=sap_ppnl, &
1683 : dft_control=dft_control, &
1684 : cell=cell, &
1685 : nkind=nkind, &
1686 4 : scf_control=scf_control)
1687 :
1688 4 : calculate_forces = .FALSE.
1689 4 : use_virial = .FALSE.
1690 4 : nder = 0
1691 4 : eps_ppnl = dft_control%qs_control%eps_ppnl
1692 :
1693 4 : CALL get_cell(cell=cell, periodic=periodic)
1694 :
1695 4 : size_real_space = 3**(periodic(1) + periodic(2) + periodic(3))
1696 :
1697 4 : NULLIFY (matrix_l)
1698 4 : CALL dbcsr_allocate_matrix_set(matrix_l, 3, 1)
1699 16 : DO i_dim = 1, 3
1700 12 : ALLOCATE (matrix_l(i_dim, 1)%matrix)
1701 : CALL dbcsr_create(matrix_l(i_dim, 1)%matrix, template=matrix_s(1)%matrix, &
1702 12 : matrix_type=dbcsr_type_antisymmetric)
1703 12 : CALL cp_dbcsr_alloc_block_from_nbl(matrix_l(i_dim, 1)%matrix, sab_orb)
1704 16 : CALL dbcsr_set(matrix_l(i_dim, 1)%matrix, 0.0_dp)
1705 : END DO
1706 :
1707 4 : NULLIFY (matrix_pot_dummy)
1708 4 : CALL dbcsr_allocate_matrix_set(matrix_pot_dummy, 1, 1)
1709 4 : ALLOCATE (matrix_pot_dummy(1, 1)%matrix)
1710 4 : CALL dbcsr_create(matrix_pot_dummy(1, 1)%matrix, template=matrix_s(1)%matrix)
1711 4 : CALL cp_dbcsr_alloc_block_from_nbl(matrix_pot_dummy(1, 1)%matrix, sab_orb)
1712 4 : CALL dbcsr_set(matrix_pot_dummy(1, 1)%matrix, 0.0_dp)
1713 :
1714 : CALL build_core_ppnl(matrix_pot_dummy, matrix_dummy, force, virial, calculate_forces, use_virial, nder, &
1715 : qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, eps_ppnl, &
1716 4 : nimages=1, basis_type="ORB", matrix_l=matrix_l)
1717 :
1718 4 : CALL alloc_mat_set_2d(mat_VSOC_l_nosymm, 3, size_real_space, matrix_s(1)%matrix, explicitly_no_symmetry=.TRUE.)
1719 16 : DO i_dim = 1, 3
1720 16 : CALL dbcsr_desymmetrize(matrix_l(i_dim, 1)%matrix, mat_VSOC_l_nosymm(i_dim, 1)%matrix)
1721 : END DO
1722 :
1723 4 : kpoints_Sigma => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma
1724 :
1725 4 : CALL mat_kp_from_mat_gamma(qs_env, mat_VSOC_lx_kp, mat_VSOC_l_nosymm(1, 1)%matrix, kpoints_Sigma, 1, .FALSE.)
1726 4 : CALL mat_kp_from_mat_gamma(qs_env, mat_VSOC_ly_kp, mat_VSOC_l_nosymm(2, 1)%matrix, kpoints_Sigma, 1, .FALSE.)
1727 4 : CALL mat_kp_from_mat_gamma(qs_env, mat_VSOC_lz_kp, mat_VSOC_l_nosymm(3, 1)%matrix, kpoints_Sigma, 1, .FALSE.)
1728 :
1729 4 : nkp_self_energy = kpoints_Sigma%nkp
1730 :
1731 4 : CALL get_mo_set(kpoints_Sigma%kp_env(1)%kpoint_env%mos(1, 1), mo_coeff=rmos)
1732 :
1733 4 : CALL create_cfm_double_row_col_size(rmos, cfm_mat_h_double)
1734 4 : CALL create_cfm_double_row_col_size(rmos, cfm_mat_s_double)
1735 4 : CALL create_cfm_double_row_col_size(rmos, cfm_mo_coeff_double)
1736 4 : CALL create_cfm_double_row_col_size(rmos, cfm_mat_work_double)
1737 :
1738 4 : CALL cp_cfm_set_all(cfm_mo_coeff_double, z_zero)
1739 :
1740 4 : CALL cp_cfm_create(cfm_mo_coeff, rmos%matrix_struct)
1741 4 : CALL cp_cfm_create(cfm_mat_h_ks, rmos%matrix_struct)
1742 :
1743 4 : CALL cp_fm_get_info(matrix=rmos, nrow_global=nao)
1744 :
1745 4 : NULLIFY (matrix_s_desymm)
1746 4 : CALL dbcsr_allocate_matrix_set(matrix_s_desymm, 1)
1747 4 : ALLOCATE (matrix_s_desymm(1)%matrix)
1748 : CALL dbcsr_create(matrix=matrix_s_desymm(1)%matrix, template=matrix_s(1)%matrix, &
1749 4 : matrix_type=dbcsr_type_no_symmetry)
1750 4 : CALL dbcsr_desymmetrize(matrix_s(1)%matrix, matrix_s_desymm(1)%matrix)
1751 :
1752 12 : ALLOCATE (eigenvalues(2*nao))
1753 76 : eigenvalues = 0.0_dp
1754 8 : ALLOCATE (eigenvalues_without_soc_sorted(2*nao))
1755 :
1756 4 : E_window = qs_env%mp2_env%ri_g0w0%soc_energy_window
1757 4 : IF (unit_nr > 0) THEN
1758 2 : WRITE (unit_nr, '(T3,A)') ' '
1759 2 : WRITE (unit_nr, '(T3,A)') '------------------------------------------------------------------------------'
1760 2 : WRITE (unit_nr, '(T3,A)') ' '
1761 2 : WRITE (unit_nr, '(T3,A,F42.1)') 'GW_SOC_INFO | SOC energy window (eV)', E_window*evolt
1762 : END IF
1763 :
1764 4 : E_VBM_GW_SOC = -1000.0_dp
1765 4 : E_CBM_GW_SOC = 1000.0_dp
1766 :
1767 20 : DO ikp = 1, nkp_self_energy
1768 :
1769 16 : CALL get_mo_set(kpoints_Sigma%kp_env(ikp)%kpoint_env%mos(1, 1), mo_coeff=rmos)
1770 16 : CALL get_mo_set(kpoints_Sigma%kp_env(ikp)%kpoint_env%mos(2, 1), mo_coeff=imos)
1771 16 : CALL cp_fm_to_cfm(rmos, imos, cfm_mo_coeff)
1772 :
1773 : ! ispin = 1
1774 : avg_occ_QP_shift = SUM(Eigenval(homo(1) - gw_corr_lev_occ(1) + 1:homo(1), ikp, 1) - &
1775 32 : Eigenval_scf(homo(1) - gw_corr_lev_occ(1) + 1:homo(1), ikp, 1))/gw_corr_lev_occ(1)
1776 : avg_virt_QP_shift = SUM(Eigenval(homo(1):homo(1) + gw_corr_lev_virt(1), ikp, 1) - &
1777 48 : Eigenval_scf(homo(1):homo(1) + gw_corr_lev_virt(1), ikp, 1))/gw_corr_lev_virt(1)
1778 :
1779 16 : IF (gw_corr_lev_occ(1) < homo(1)) THEN
1780 : Eigenval(1:homo(1) - gw_corr_lev_occ(1), ikp, 1) = Eigenval_scf(1:homo(1) - gw_corr_lev_occ(1), ikp, 1) &
1781 64 : + avg_occ_QP_shift
1782 : END IF
1783 16 : IF (gw_corr_lev_virt(1) < nao - homo(1) + 1) THEN
1784 : Eigenval(homo(1) + gw_corr_lev_virt(1) + 1:nao, ikp, 1) = Eigenval_scf(homo(1) + gw_corr_lev_virt(1) + 1:nao, ikp, 1) &
1785 80 : + avg_virt_QP_shift
1786 : END IF
1787 :
1788 16 : CALL cp_cfm_set_all(cfm_mat_h_double, z_zero)
1789 16 : CALL add_dbcsr_submatrix(cfm_mat_h_double, mat_VSOC_lx_kp(ikp, 1:2), cfm_mat_h_ks, nao + 1, 1, z_one, .TRUE.)
1790 16 : CALL add_dbcsr_submatrix(cfm_mat_h_double, mat_VSOC_ly_kp(ikp, 1:2), cfm_mat_h_ks, nao + 1, 1, gaussi, .TRUE.)
1791 16 : CALL add_dbcsr_submatrix(cfm_mat_h_double, mat_VSOC_lz_kp(ikp, 1:2), cfm_mat_h_ks, 1, 1, z_one, .FALSE.)
1792 16 : CALL add_dbcsr_submatrix(cfm_mat_h_double, mat_VSOC_lz_kp(ikp, 1:2), cfm_mat_h_ks, nao + 1, nao + 1, -z_one, .FALSE.)
1793 :
1794 : ! trafo to MO basis
1795 2896 : cfm_mo_coeff_double%local_data = z_zero
1796 16 : CALL add_cfm_submatrix(cfm_mo_coeff_double, cfm_mo_coeff, 1, 1)
1797 16 : CALL add_cfm_submatrix(cfm_mo_coeff_double, cfm_mo_coeff, nao + 1, nao + 1)
1798 :
1799 : CALL cp_cfm_get_info(matrix=cfm_mat_h_double, &
1800 : nrow_local=nrow_local, &
1801 : ncol_local=ncol_local, &
1802 : row_indices=row_indices, &
1803 16 : col_indices=col_indices)
1804 :
1805 : CALL parallel_gemm(transa="N", transb="N", m=2*nao, n=2*nao, k=2*nao, alpha=z_one, &
1806 : matrix_a=cfm_mat_h_double, matrix_b=cfm_mo_coeff_double, beta=z_zero, &
1807 16 : matrix_c=cfm_mat_work_double)
1808 :
1809 : CALL parallel_gemm(transa="C", transb="N", m=2*nao, n=2*nao, k=2*nao, alpha=z_one, &
1810 : matrix_a=cfm_mo_coeff_double, matrix_b=cfm_mat_work_double, beta=z_zero, &
1811 16 : matrix_c=cfm_mat_h_double)
1812 :
1813 : CALL cp_cfm_get_info(matrix=cfm_mat_h_double, &
1814 : nrow_local=nrow_local, &
1815 : ncol_local=ncol_local, &
1816 : row_indices=row_indices, &
1817 16 : col_indices=col_indices)
1818 :
1819 16 : CALL cp_cfm_set_all(cfm_mat_s_double, z_zero)
1820 :
1821 16 : E_HOMO = Eigenval(homo(1), ikp, 1)
1822 16 : E_LUMO = Eigenval(homo(1) + 1, ikp, 1)
1823 :
1824 16 : CALL para_env%sync()
1825 :
1826 160 : DO i_row = 1, nrow_local
1827 2752 : DO j_col = 1, ncol_local
1828 2592 : i_glob = row_indices(i_row)
1829 2592 : j_glob = col_indices(j_col)
1830 2592 : IF (i_glob .LE. nao) THEN
1831 1296 : E_i = Eigenval(i_glob, ikp, 1)
1832 : ELSE
1833 1296 : E_i = Eigenval(i_glob - nao, ikp, 1)
1834 : END IF
1835 2592 : IF (j_glob .LE. nao) THEN
1836 1296 : E_j = Eigenval(j_glob, ikp, 1)
1837 : ELSE
1838 1296 : E_j = Eigenval(j_glob - nao, ikp, 1)
1839 : END IF
1840 :
1841 : ! add eigenvalues to diagonal entries
1842 2736 : IF (i_glob == j_glob) THEN
1843 144 : cfm_mat_h_double%local_data(i_row, j_col) = cfm_mat_h_double%local_data(i_row, j_col) + E_i*z_one
1844 144 : cfm_mat_s_double%local_data(i_row, j_col) = z_one
1845 : ELSE
1846 : IF (E_i < E_HOMO - 0.5_dp*E_window .OR. E_i > E_LUMO + 0.5_dp*E_window .OR. &
1847 2448 : E_j < E_HOMO - 0.5_dp*E_window .OR. E_j > E_LUMO + 0.5_dp*E_window) THEN
1848 2000 : cfm_mat_h_double%local_data(i_row, j_col) = z_zero
1849 : END IF
1850 : END IF
1851 :
1852 : END DO
1853 : END DO
1854 :
1855 16 : CALL para_env%sync()
1856 :
1857 304 : eigenvalues = 0.0_dp
1858 : CALL cp_cfm_geeig_canon(cfm_mat_h_double, cfm_mat_s_double, cfm_mo_coeff_double, eigenvalues, &
1859 16 : cfm_mat_work_double, scf_control%eps_eigval)
1860 :
1861 160 : eigenvalues_without_soc_sorted(1:nao) = Eigenval(:, ikp, 1)
1862 160 : eigenvalues_without_soc_sorted(nao + 1:2*nao) = Eigenval(:, ikp, 1)
1863 48 : ALLOCATE (index0(2*nao))
1864 16 : CALL sort(eigenvalues_without_soc_sorted, 2*nao, index0)
1865 16 : DEALLOCATE (index0)
1866 :
1867 64 : E_HOMO_GW_SOC = MAXVAL(eigenvalues(2*homo(1) - 2*gw_corr_lev_occ(1) + 1:2*homo(1)))
1868 64 : E_LUMO_GW_SOC = MINVAL(eigenvalues(2*homo(1) + 1:2*homo(1) + 2*gw_corr_lev_virt(1)))
1869 16 : E_GAP_GW_SOC = E_LUMO_GW_SOC - E_HOMO_GW_SOC
1870 16 : IF (E_HOMO_GW_SOC > E_VBM_GW_SOC) E_VBM_GW_SOC = E_HOMO_GW_SOC
1871 16 : IF (E_LUMO_GW_SOC < E_CBM_GW_SOC) E_CBM_GW_SOC = E_LUMO_GW_SOC
1872 :
1873 52 : IF (unit_nr > 0) THEN
1874 8 : WRITE (unit_nr, '(T3,A)') ' '
1875 8 : WRITE (unit_nr, '(T3,A7,I3,A3,I3,A8,3F7.3,A12,3F7.3)') 'Kpoint ', ikp, ' /', nkp_self_energy, &
1876 8 : ' xkp =', kpoints_Sigma%xkp(1, ikp), kpoints_Sigma%xkp(2, ikp), kpoints_Sigma%xkp(3, ikp), &
1877 16 : ' and xkp =', -kpoints_Sigma%xkp(1, ikp), -kpoints_Sigma%xkp(2, ikp), -kpoints_Sigma%xkp(3, ikp)
1878 8 : WRITE (unit_nr, '(T3,A)') ' '
1879 8 : IF (do_soc_gw) THEN
1880 4 : WRITE (unit_nr, '(T3,A)') ' '
1881 4 : WRITE (unit_nr, '(T3,A,F13.4)') 'GW_SOC_INFO | Average GW shift of occupied levels compared to SCF', &
1882 8 : avg_occ_QP_shift*evolt
1883 4 : WRITE (unit_nr, '(T3,A,F11.4)') 'GW_SOC_INFO | Average GW shift of unoccupied levels compared to SCF', &
1884 8 : avg_virt_QP_shift*evolt
1885 4 : WRITE (unit_nr, '(T3,A)') ' '
1886 4 : WRITE (unit_nr, '(T3,2A)') 'Molecular orbital E_GW with SOC (eV) E_GW without SOC (eV) SOC shift (eV)'
1887 : ELSE
1888 4 : WRITE (unit_nr, '(T3,2A)') 'Molecular orbital E_SCF with SOC (eV) E_SCF without SOC (eV) SOC shift (eV)'
1889 : END IF
1890 :
1891 24 : DO n_level_gw = 2*(homo(1) - gw_corr_lev_occ(1)) + 1, 2*homo(1)
1892 16 : WRITE (unit_nr, '(T3,I4,A,3F21.4)') n_level_gw, ' ( occ ) ', eigenvalues(n_level_gw)*evolt, &
1893 16 : eigenvalues_without_soc_sorted(n_level_gw)*evolt, &
1894 40 : (eigenvalues(n_level_gw) - eigenvalues_without_soc_sorted(n_level_gw))*evolt
1895 : END DO
1896 24 : DO n_level_gw = 2*homo(1) + 1, 2*(homo(1) + gw_corr_lev_virt(1))
1897 16 : WRITE (unit_nr, '(T3,I4,A,3F21.4)') n_level_gw, ' ( vir ) ', eigenvalues(n_level_gw)*evolt, &
1898 16 : eigenvalues_without_soc_sorted(n_level_gw)*evolt, &
1899 40 : (eigenvalues(n_level_gw) - eigenvalues_without_soc_sorted(n_level_gw))*evolt
1900 : END DO
1901 8 : WRITE (unit_nr, '(T3,A)') ' '
1902 8 : IF (do_soc_gw) THEN
1903 4 : WRITE (unit_nr, '(T3,A,F38.4)') 'GW+SOC direct gap at current kpoint (eV)', E_GAP_GW_SOC*evolt
1904 : ELSE
1905 4 : WRITE (unit_nr, '(T3,A,F37.4)') 'SCF+SOC direct gap at current kpoint (eV)', E_GAP_GW_SOC*evolt
1906 : END IF
1907 8 : WRITE (unit_nr, '(T3,A)') ' '
1908 8 : WRITE (unit_nr, '(T3,A)') '------------------------------------------------------------------------------'
1909 : END IF
1910 :
1911 : END DO
1912 :
1913 4 : IF (unit_nr > 0) THEN
1914 2 : WRITE (unit_nr, '(T3,A)') ' '
1915 2 : IF (do_soc_gw) THEN
1916 1 : WRITE (unit_nr, '(T3,A,F46.4)') 'GW+SOC valence band maximum (eV)', E_VBM_GW_SOC*evolt
1917 1 : WRITE (unit_nr, '(T3,A,F43.4)') 'GW+SOC conduction band minimum (eV)', E_CBM_GW_SOC*evolt
1918 1 : WRITE (unit_nr, '(T3,A,F59.4)') 'GW+SOC bandgap (eV)', (E_CBM_GW_SOC - E_VBM_GW_SOC)*evolt
1919 : ELSE
1920 1 : WRITE (unit_nr, '(T3,A,F45.4)') 'SCF+SOC valence band maximum (eV)', E_VBM_GW_SOC*evolt
1921 1 : WRITE (unit_nr, '(T3,A,F42.4)') 'SCF+SOC conduction band minimum (eV)', E_CBM_GW_SOC*evolt
1922 1 : WRITE (unit_nr, '(T3,A,F58.4)') 'SCF+SOC bandgap (eV)', (E_CBM_GW_SOC - E_VBM_GW_SOC)*evolt
1923 : END IF
1924 : END IF
1925 :
1926 4 : CALL dbcsr_deallocate_matrix_set(matrix_l)
1927 4 : CALL dbcsr_deallocate_matrix_set(mat_VSOC_l_nosymm)
1928 4 : CALL dbcsr_deallocate_matrix_set(matrix_pot_dummy)
1929 4 : CALL dbcsr_deallocate_matrix_set(mat_VSOC_lx_kp)
1930 4 : CALL dbcsr_deallocate_matrix_set(mat_VSOC_ly_kp)
1931 4 : CALL dbcsr_deallocate_matrix_set(mat_VSOC_lz_kp)
1932 4 : CALL dbcsr_deallocate_matrix_set(matrix_s_desymm)
1933 :
1934 4 : CALL cp_cfm_release(cfm_mat_h_double)
1935 4 : CALL cp_cfm_release(cfm_mat_s_double)
1936 4 : CALL cp_cfm_release(cfm_mo_coeff_double)
1937 4 : CALL cp_cfm_release(cfm_mo_coeff)
1938 4 : CALL cp_cfm_release(cfm_mat_h_ks)
1939 4 : CALL cp_cfm_release(cfm_mat_work_double)
1940 4 : DEALLOCATE (eigenvalues)
1941 :
1942 4 : CALL timestop(handle)
1943 :
1944 12 : END SUBROUTINE calculate_and_print_soc
1945 :
1946 : ! **************************************************************************************************
1947 : !> \brief ...
1948 : !> \param cfm_mat_target ...
1949 : !> \param mat_source ...
1950 : !> \param cfm_source_template ...
1951 : !> \param nstart_row ...
1952 : !> \param nstart_col ...
1953 : !> \param factor ...
1954 : !> \param add_also_herm_conj ...
1955 : ! **************************************************************************************************
1956 64 : SUBROUTINE add_dbcsr_submatrix(cfm_mat_target, mat_source, cfm_source_template, &
1957 : nstart_row, nstart_col, factor, add_also_herm_conj)
1958 : TYPE(cp_cfm_type) :: cfm_mat_target
1959 : TYPE(dbcsr_p_type), DIMENSION(:) :: mat_source
1960 : TYPE(cp_cfm_type) :: cfm_source_template
1961 : INTEGER :: nstart_row, nstart_col
1962 : COMPLEX(KIND=dp) :: factor
1963 : LOGICAL :: add_also_herm_conj
1964 :
1965 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_dbcsr_submatrix'
1966 :
1967 : INTEGER :: handle, nao
1968 : TYPE(cp_cfm_type) :: cfm_mat_work_double, &
1969 : cfm_mat_work_double_2
1970 : TYPE(cp_fm_type) :: fm_mat_work_double_im, &
1971 : fm_mat_work_double_re, fm_mat_work_im, &
1972 : fm_mat_work_re
1973 :
1974 64 : CALL timeset(routineN, handle)
1975 :
1976 64 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
1977 64 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
1978 64 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
1979 64 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
1980 :
1981 64 : CALL cp_cfm_create(cfm_mat_work_double, cfm_mat_target%matrix_struct)
1982 64 : CALL cp_cfm_create(cfm_mat_work_double_2, cfm_mat_target%matrix_struct)
1983 64 : CALL cp_cfm_set_all(cfm_mat_work_double, z_zero)
1984 64 : CALL cp_cfm_set_all(cfm_mat_work_double_2, z_zero)
1985 :
1986 64 : CALL cp_fm_create(fm_mat_work_re, cfm_source_template%matrix_struct)
1987 64 : CALL cp_fm_create(fm_mat_work_im, cfm_source_template%matrix_struct)
1988 :
1989 64 : CALL copy_dbcsr_to_fm(mat_source(1)%matrix, fm_mat_work_re)
1990 64 : CALL copy_dbcsr_to_fm(mat_source(2)%matrix, fm_mat_work_im)
1991 :
1992 64 : CALL cp_cfm_get_info(cfm_source_template, nrow_global=nao)
1993 :
1994 : CALL cp_fm_to_fm_submat(msource=fm_mat_work_re, mtarget=fm_mat_work_double_re, &
1995 : nrow=nao, ncol=nao, &
1996 : s_firstrow=1, s_firstcol=1, &
1997 64 : t_firstrow=nstart_row, t_firstcol=nstart_col)
1998 :
1999 : CALL cp_fm_to_fm_submat(msource=fm_mat_work_im, mtarget=fm_mat_work_double_im, &
2000 : nrow=nao, ncol=nao, &
2001 : s_firstrow=1, s_firstcol=1, &
2002 64 : t_firstrow=nstart_row, t_firstcol=nstart_col)
2003 :
2004 64 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_work_double, z_one, fm_mat_work_double_re)
2005 64 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_work_double, gaussi, fm_mat_work_double_im)
2006 :
2007 64 : CALL cp_cfm_scale(factor, cfm_mat_work_double)
2008 :
2009 64 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double)
2010 :
2011 64 : IF (add_also_herm_conj) THEN
2012 32 : CALL cp_cfm_transpose(cfm_mat_work_double, 'C', cfm_mat_work_double_2)
2013 32 : CALL cp_cfm_scale_and_add(z_one, cfm_mat_target, z_one, cfm_mat_work_double_2)
2014 : END IF
2015 :
2016 64 : CALL cp_fm_release(fm_mat_work_double_re)
2017 64 : CALL cp_fm_release(fm_mat_work_double_im)
2018 64 : CALL cp_cfm_release(cfm_mat_work_double)
2019 64 : CALL cp_cfm_release(cfm_mat_work_double_2)
2020 64 : CALL cp_fm_release(fm_mat_work_re)
2021 64 : CALL cp_fm_release(fm_mat_work_im)
2022 :
2023 64 : CALL timestop(handle)
2024 :
2025 64 : END SUBROUTINE
2026 :
2027 : ! **************************************************************************************************
2028 : !> \brief ...
2029 : !> \param cfm_mat_target ...
2030 : !> \param cfm_mat_source ...
2031 : !> \param nstart_row ...
2032 : !> \param nstart_col ...
2033 : ! **************************************************************************************************
2034 192 : SUBROUTINE add_cfm_submatrix(cfm_mat_target, cfm_mat_source, nstart_row, nstart_col)
2035 :
2036 : TYPE(cp_cfm_type) :: cfm_mat_target, cfm_mat_source
2037 : INTEGER :: nstart_row, nstart_col
2038 :
2039 : CHARACTER(LEN=*), PARAMETER :: routineN = 'add_cfm_submatrix'
2040 :
2041 : INTEGER :: handle, nao
2042 : TYPE(cp_fm_type) :: fm_mat_work_double_im, &
2043 : fm_mat_work_double_re, fm_mat_work_im, &
2044 : fm_mat_work_re
2045 :
2046 32 : CALL timeset(routineN, handle)
2047 :
2048 32 : CALL cp_fm_create(fm_mat_work_double_re, cfm_mat_target%matrix_struct)
2049 32 : CALL cp_fm_create(fm_mat_work_double_im, cfm_mat_target%matrix_struct)
2050 32 : CALL cp_fm_set_all(fm_mat_work_double_re, 0.0_dp)
2051 32 : CALL cp_fm_set_all(fm_mat_work_double_im, 0.0_dp)
2052 :
2053 32 : CALL cp_fm_create(fm_mat_work_re, cfm_mat_source%matrix_struct)
2054 32 : CALL cp_fm_create(fm_mat_work_im, cfm_mat_source%matrix_struct)
2055 32 : CALL cp_cfm_to_fm(cfm_mat_source, fm_mat_work_re, fm_mat_work_im)
2056 :
2057 32 : CALL cp_cfm_get_info(cfm_mat_source, nrow_global=nao)
2058 :
2059 : CALL cp_fm_to_fm_submat(msource=fm_mat_work_re, mtarget=fm_mat_work_double_re, &
2060 : nrow=nao, ncol=nao, &
2061 : s_firstrow=1, s_firstcol=1, &
2062 32 : t_firstrow=nstart_row, t_firstcol=nstart_col)
2063 :
2064 : CALL cp_fm_to_fm_submat(msource=fm_mat_work_im, mtarget=fm_mat_work_double_im, &
2065 : nrow=nao, ncol=nao, &
2066 : s_firstrow=1, s_firstcol=1, &
2067 32 : t_firstrow=nstart_row, t_firstcol=nstart_col)
2068 :
2069 32 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, z_one, fm_mat_work_double_re)
2070 32 : CALL cp_cfm_scale_and_add_fm(z_one, cfm_mat_target, gaussi, fm_mat_work_double_im)
2071 :
2072 32 : CALL cp_fm_release(fm_mat_work_double_re)
2073 32 : CALL cp_fm_release(fm_mat_work_double_im)
2074 32 : CALL cp_fm_release(fm_mat_work_re)
2075 32 : CALL cp_fm_release(fm_mat_work_im)
2076 :
2077 32 : CALL timestop(handle)
2078 :
2079 32 : END SUBROUTINE add_cfm_submatrix
2080 :
2081 : ! **************************************************************************************************
2082 : !> \brief ...
2083 : !> \param fm_orig ...
2084 : !> \param cfm_double ...
2085 : ! **************************************************************************************************
2086 48 : SUBROUTINE create_cfm_double_row_col_size(fm_orig, cfm_double)
2087 : TYPE(cp_fm_type) :: fm_orig
2088 : TYPE(cp_cfm_type) :: cfm_double
2089 :
2090 : CHARACTER(LEN=*), PARAMETER :: routineN = 'create_cfm_double_row_col_size'
2091 :
2092 : INTEGER :: handle, ncol_global_orig, &
2093 : nrow_global_orig
2094 : TYPE(cp_fm_struct_type), POINTER :: fm_struct_double
2095 :
2096 16 : CALL timeset(routineN, handle)
2097 :
2098 16 : CALL cp_fm_get_info(matrix=fm_orig, nrow_global=nrow_global_orig, ncol_global=ncol_global_orig)
2099 :
2100 : CALL cp_fm_struct_create(fm_struct_double, &
2101 : nrow_global=2*nrow_global_orig, &
2102 : ncol_global=2*ncol_global_orig, &
2103 16 : template_fmstruct=fm_orig%matrix_struct)
2104 :
2105 16 : CALL cp_cfm_create(cfm_double, fm_struct_double)
2106 :
2107 16 : CALL cp_fm_struct_release(fm_struct_double)
2108 :
2109 16 : CALL timestop(handle)
2110 :
2111 16 : END SUBROUTINE
2112 :
2113 : ! **************************************************************************************************
2114 : !> \brief ...
2115 : !> \param E_VBM_SCF ...
2116 : !> \param E_CBM_SCF ...
2117 : !> \param E_VBM_SCF_beta ...
2118 : !> \param E_CBM_SCF_beta ...
2119 : !> \param E_VBM_GW ...
2120 : !> \param E_CBM_GW ...
2121 : !> \param E_VBM_GW_beta ...
2122 : !> \param E_CBM_GW_beta ...
2123 : !> \param my_open_shell ...
2124 : !> \param unit_nr ...
2125 : ! **************************************************************************************************
2126 9 : SUBROUTINE print_gaps(E_VBM_SCF, E_CBM_SCF, E_VBM_SCF_beta, E_CBM_SCF_beta, &
2127 : E_VBM_GW, E_CBM_GW, E_VBM_GW_beta, E_CBM_GW_beta, my_open_shell, unit_nr)
2128 :
2129 : REAL(KIND=dp) :: E_VBM_SCF, E_CBM_SCF, E_VBM_SCF_beta, &
2130 : E_CBM_SCF_beta, E_VBM_GW, E_CBM_GW, &
2131 : E_VBM_GW_beta, E_CBM_GW_beta
2132 : LOGICAL :: my_open_shell
2133 : INTEGER :: unit_nr
2134 :
2135 9 : IF (my_open_shell) THEN
2136 2 : WRITE (unit_nr, '(T3,A)') ' '
2137 2 : WRITE (unit_nr, '(T3,A,F43.4)') 'Alpha SCF valence band maximum (eV)', E_VBM_SCF*evolt
2138 2 : WRITE (unit_nr, '(T3,A,F40.4)') 'Alpha SCF conduction band minimum (eV)', E_CBM_SCF*evolt
2139 2 : WRITE (unit_nr, '(T3,A,F56.4)') 'Alpha SCF bandgap (eV)', (E_CBM_SCF - E_VBM_SCF)*evolt
2140 2 : WRITE (unit_nr, '(T3,A)') ' '
2141 2 : WRITE (unit_nr, '(T3,A,F44.4)') 'Beta SCF valence band maximum (eV)', E_VBM_SCF_beta*evolt
2142 2 : WRITE (unit_nr, '(T3,A,F41.4)') 'Beta SCF conduction band minimum (eV)', E_CBM_SCF_beta*evolt
2143 2 : WRITE (unit_nr, '(T3,A,F57.4)') 'Beta SCF bandgap (eV)', (E_CBM_SCF_beta - E_VBM_SCF_beta)*evolt
2144 2 : WRITE (unit_nr, '(T3,A)') ' '
2145 2 : WRITE (unit_nr, '(T3,A,F44.4)') 'Alpha GW valence band maximum (eV)', E_VBM_GW*evolt
2146 2 : WRITE (unit_nr, '(T3,A,F41.4)') 'Alpha GW conduction band minimum (eV)', E_CBM_GW*evolt
2147 2 : WRITE (unit_nr, '(T3,A,F57.4)') 'Alpha GW bandgap (eV)', (E_CBM_GW - E_VBM_GW)*evolt
2148 2 : WRITE (unit_nr, '(T3,A)') ' '
2149 2 : WRITE (unit_nr, '(T3,A,F45.4)') 'Beta GW valence band maximum (eV)', E_VBM_GW_beta*evolt
2150 2 : WRITE (unit_nr, '(T3,A,F42.4)') 'Beta GW conduction band minimum (eV)', E_CBM_GW_beta*evolt
2151 2 : WRITE (unit_nr, '(T3,A,F58.4)') 'Beta GW bandgap (eV)', (E_CBM_GW_beta - E_VBM_GW_beta)*evolt
2152 : ELSE
2153 7 : WRITE (unit_nr, '(T3,A)') ' '
2154 7 : WRITE (unit_nr, '(T3,A,F49.4)') 'SCF valence band maximum (eV)', E_VBM_SCF*evolt
2155 7 : WRITE (unit_nr, '(T3,A,F46.4)') 'SCF conduction band minimum (eV)', E_CBM_SCF*evolt
2156 7 : WRITE (unit_nr, '(T3,A,F62.4)') 'SCF bandgap (eV)', (E_CBM_SCF - E_VBM_SCF)*evolt
2157 7 : WRITE (unit_nr, '(T3,A)') ' '
2158 7 : WRITE (unit_nr, '(T3,A,F50.4)') 'GW valence band maximum (eV)', E_VBM_GW*evolt
2159 7 : WRITE (unit_nr, '(T3,A,F47.4)') 'GW conduction band minimum (eV)', E_CBM_GW*evolt
2160 7 : WRITE (unit_nr, '(T3,A,F63.4)') 'GW bandgap (eV)', (E_CBM_GW - E_VBM_GW)*evolt
2161 : END IF
2162 :
2163 9 : END SUBROUTINE print_gaps
2164 :
2165 : ! **************************************************************************************************
2166 : !> \brief ...
2167 : !> \param array ...
2168 : !> \param real_value ...
2169 : ! **************************************************************************************************
2170 1254 : SUBROUTINE check_NaN(array, real_value)
2171 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
2172 : INTENT(INOUT) :: array
2173 : REAL(KIND=dp), INTENT(IN) :: real_value
2174 :
2175 : CHARACTER(LEN=*), PARAMETER :: routineN = 'check_NaN'
2176 :
2177 : INTEGER :: handle, i, j, k
2178 :
2179 1254 : CALL timeset(routineN, handle)
2180 :
2181 13722 : DO i = 1, SIZE(array, 1)
2182 31710 : DO j = 1, SIZE(array, 2)
2183 50736 : DO k = 1, SIZE(array, 3)
2184 :
2185 : ! check for NaN
2186 38268 : IF (array(i, j, k) .NE. array(i, j, k)) array(i, j, k) = real_value
2187 :
2188 : END DO
2189 : END DO
2190 : END DO
2191 :
2192 1254 : CALL timestop(handle)
2193 :
2194 1254 : END SUBROUTINE
2195 :
2196 : ! **************************************************************************************************
2197 : !> \brief ...
2198 : !> \param qs_env ...
2199 : !> \param Eigenval ...
2200 : !> \param gw_corr_lev_occ ...
2201 : !> \param gw_corr_lev_virt ...
2202 : !> \param homo ...
2203 : !> \param dft_gw_char ...
2204 : ! **************************************************************************************************
2205 4 : SUBROUTINE print_local_bandgap(qs_env, Eigenval, gw_corr_lev_occ, gw_corr_lev_virt, homo, dft_gw_char)
2206 : TYPE(qs_environment_type), POINTER :: qs_env
2207 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Eigenval
2208 : INTEGER :: gw_corr_lev_occ, gw_corr_lev_virt, homo
2209 : CHARACTER(len=*) :: dft_gw_char
2210 :
2211 : CHARACTER(LEN=*), PARAMETER :: routineN = 'print_local_bandgap'
2212 :
2213 : INTEGER :: handle, i_E
2214 : TYPE(pw_c1d_gs_type) :: rho_g_dummy
2215 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
2216 : TYPE(pw_r3d_rs_type) :: E_CBM_rspace, E_gap_rspace, E_VBM_rspace
2217 4 : TYPE(pw_r3d_rs_type), ALLOCATABLE, DIMENSION(:) :: LDOS
2218 :
2219 4 : CALL timeset(routineN, handle)
2220 :
2221 4 : CALL create_real_space_grids(E_gap_rspace, E_VBM_rspace, E_CBM_rspace, rho_g_dummy, LDOS, auxbas_pw_pool, qs_env)
2222 :
2223 : CALL calculate_E_gap_rspace(E_gap_rspace, E_VBM_rspace, E_CBM_rspace, rho_g_dummy, &
2224 4 : LDOS, qs_env, Eigenval, gw_corr_lev_occ, gw_corr_lev_virt, homo, dft_gw_char)
2225 :
2226 4 : CALL auxbas_pw_pool%give_back_pw(E_gap_rspace)
2227 4 : CALL auxbas_pw_pool%give_back_pw(E_VBM_rspace)
2228 4 : CALL auxbas_pw_pool%give_back_pw(E_CBM_rspace)
2229 4 : CALL auxbas_pw_pool%give_back_pw(rho_g_dummy)
2230 20 : DO i_E = 1, SIZE(LDOS)
2231 20 : CALL auxbas_pw_pool%give_back_pw(LDOS(i_E))
2232 : END DO
2233 4 : DEALLOCATE (LDOS)
2234 :
2235 4 : CALL timestop(handle)
2236 :
2237 4 : END SUBROUTINE print_local_bandgap
2238 :
2239 : ! **************************************************************************************************
2240 : !> \brief ...
2241 : !> \param E_gap_rspace ...
2242 : !> \param E_VBM_rspace ...
2243 : !> \param E_CBM_rspace ...
2244 : !> \param rho_g_dummy ...
2245 : !> \param LDOS ...
2246 : !> \param qs_env ...
2247 : !> \param Eigenval ...
2248 : !> \param gw_corr_lev_occ ...
2249 : !> \param gw_corr_lev_virt ...
2250 : !> \param homo ...
2251 : !> \param dft_gw_char ...
2252 : ! **************************************************************************************************
2253 4 : SUBROUTINE calculate_E_gap_rspace(E_gap_rspace, E_VBM_rspace, E_CBM_rspace, rho_g_dummy, &
2254 4 : LDOS, qs_env, Eigenval, gw_corr_lev_occ, gw_corr_lev_virt, homo, dft_gw_char)
2255 : TYPE(pw_r3d_rs_type) :: E_gap_rspace, E_VBM_rspace, E_CBM_rspace
2256 : TYPE(pw_c1d_gs_type) :: rho_g_dummy
2257 : TYPE(pw_r3d_rs_type), ALLOCATABLE, DIMENSION(:) :: LDOS
2258 : TYPE(qs_environment_type), POINTER :: qs_env
2259 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Eigenval
2260 : INTEGER :: gw_corr_lev_occ, gw_corr_lev_virt, homo
2261 : CHARACTER(len=*) :: dft_gw_char
2262 :
2263 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_E_gap_rspace'
2264 :
2265 : INTEGER :: handle, i_E, i_img, i_spin, i_x, i_y, i_z, ikp, imo, n_E, n_E_occ, n_x_end, &
2266 : n_x_start, n_y_end, n_y_start, n_z_end, n_z_start, nimg, nkp, nkp_self_energy
2267 : REAL(KIND=dp) :: avg_LDOS_occ, avg_LDOS_virt, d_E, E_CBM, &
2268 : E_CBM_at_k, E_diff, E_VBM, E_VBM_at_k
2269 4 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: E_array
2270 4 : REAL(KIND=dp), DIMENSION(:), POINTER :: occupation
2271 : TYPE(cp_fm_struct_type), POINTER :: matrix_struct
2272 4 : TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: fm_work
2273 4 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, rho_ao
2274 4 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: rho_ao_weighted
2275 : TYPE(dft_control_type), POINTER :: dft_control
2276 : TYPE(kpoint_type), POINTER :: kpoints_Sigma
2277 : TYPE(mp2_type), POINTER :: mp2_env
2278 : TYPE(mp_para_env_type), POINTER :: para_env
2279 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
2280 4 : POINTER :: sab_orb
2281 : TYPE(particle_list_type), POINTER :: particles
2282 : TYPE(qs_ks_env_type), POINTER :: ks_env
2283 : TYPE(qs_scf_env_type), POINTER :: scf_env
2284 : TYPE(qs_subsys_type), POINTER :: subsys
2285 : TYPE(section_vals_type), POINTER :: gw_section
2286 :
2287 4 : CALL timeset(routineN, handle)
2288 :
2289 : CALL get_qs_env(qs_env=qs_env, para_env=para_env, mp2_env=mp2_env, ks_env=ks_env, matrix_s=matrix_s, &
2290 4 : scf_env=scf_env, sab_orb=sab_orb, dft_control=dft_control, subsys=subsys)
2291 :
2292 : ! compute valence band maximum (VBM) and conduction band minimum (CBM)
2293 4 : nkp = SIZE(Eigenval, 2)
2294 4 : E_VBM = -1.0E3_dp
2295 4 : E_CBM = 1.0E3_dp
2296 :
2297 36 : DO ikp = 1, nkp
2298 :
2299 96 : E_VBM_at_k = MAXVAL(Eigenval(homo - gw_corr_lev_occ + 1:homo, ikp, 1))
2300 32 : IF (E_VBM_at_k > E_VBM) E_VBM = E_VBM_at_k
2301 :
2302 96 : E_CBM_at_k = MINVAL(Eigenval(homo + 1:homo + gw_corr_lev_virt, ikp, 1))
2303 36 : IF (E_CBM_at_k < E_CBM) E_CBM = E_CBM_at_k
2304 :
2305 : END DO
2306 :
2307 4 : d_E = mp2_env%ri_g0w0%energy_spacing_print_loc_bandgap
2308 :
2309 4 : n_E = INT(mp2_env%ri_g0w0%energy_window_print_loc_bandgap/d_E)
2310 :
2311 4 : n_E_occ = n_E/2
2312 12 : ALLOCATE (E_array(n_E))
2313 12 : DO i_E = 1, n_E_occ
2314 12 : E_array(i_E) = E_VBM - REAL(n_E_occ - i_E, KIND=dp)*d_E
2315 : END DO
2316 12 : DO i_E = n_E_occ + 1, n_E
2317 12 : E_array(i_E) = E_CBM + REAL(i_E - n_E_occ - 1, KIND=dp)*d_E
2318 : END DO
2319 :
2320 4 : kpoints_Sigma => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma
2321 :
2322 4 : nkp_self_energy = kpoints_Sigma%nkp
2323 4 : CPASSERT(nkp == nkp_self_energy)
2324 :
2325 4 : kpoints_Sigma%sab_nl => sab_orb
2326 :
2327 4 : DEALLOCATE (kpoints_Sigma%cell_to_index)
2328 : NULLIFY (kpoints_Sigma%cell_to_index)
2329 4 : CALL kpoint_init_cell_index(kpoints_Sigma, sab_orb, para_env, dft_control)
2330 :
2331 424 : nimg = MAXVAL(kpoints_Sigma%cell_to_index)
2332 :
2333 4 : NULLIFY (rho_ao_weighted)
2334 4 : CALL dbcsr_allocate_matrix_set(rho_ao_weighted, 2, nimg)
2335 :
2336 12 : DO i_spin = 1, 2
2337 236 : DO i_img = 1, nimg
2338 224 : ALLOCATE (rho_ao_weighted(i_spin, i_img)%matrix)
2339 224 : CALL dbcsr_create(matrix=rho_ao_weighted(i_spin, i_img)%matrix, template=matrix_s(1)%matrix)
2340 224 : CALL cp_dbcsr_alloc_block_from_nbl(rho_ao_weighted(i_spin, i_img)%matrix, sab_orb)
2341 232 : CALL dbcsr_set(rho_ao_weighted(i_spin, i_img)%matrix, 0.0_dp)
2342 : END DO
2343 : END DO
2344 :
2345 124 : ALLOCATE (fm_work(nimg))
2346 4 : matrix_struct => kpoints_Sigma%kp_env(1)%kpoint_env%mos(1, 1)%mo_coeff%matrix_struct
2347 116 : DO i_img = 1, nimg
2348 116 : CALL cp_fm_create(fm_work(i_img), matrix_struct)
2349 : END DO
2350 :
2351 20 : DO i_E = 1, n_E
2352 :
2353 : ! occupation = weight factor for computing LDOS
2354 144 : DO ikp = 1, nkp
2355 : CALL get_mo_set(kpoints_Sigma%kp_env(ikp)%kpoint_env%mos(1, 1), &
2356 128 : occupation_numbers=occupation)
2357 :
2358 3072 : occupation(:) = 0.0_dp
2359 400 : DO imo = homo - gw_corr_lev_occ + 1, homo + gw_corr_lev_virt
2360 256 : E_diff = E_array(i_E) - Eigenval(imo, ikp, 1)
2361 384 : occupation(imo) = EXP(-(E_diff/d_E)**2)
2362 : END DO
2363 :
2364 : END DO
2365 :
2366 : CALL get_mo_set(kpoints_Sigma%kp_env(1)%kpoint_env%mos(1, 1), &
2367 16 : occupation_numbers=occupation)
2368 :
2369 : ! density matrices
2370 16 : CALL kpoint_density_matrices(kpoints_Sigma)
2371 :
2372 : ! density matrices in real space
2373 : CALL kpoint_density_transform(kpoints_Sigma, rho_ao_weighted, .FALSE., &
2374 16 : matrix_s(1)%matrix, sab_orb, fm_work)
2375 :
2376 16 : rho_ao => rho_ao_weighted(1, :)
2377 :
2378 : CALL calculate_rho_elec(matrix_p_kp=rho_ao, &
2379 : rho=LDOS(i_E), &
2380 : rho_gspace=rho_g_dummy, &
2381 16 : ks_env=ks_env)
2382 :
2383 52 : DO i_spin = 1, 2
2384 944 : DO i_img = 1, nimg
2385 928 : CALL dbcsr_set(rho_ao_weighted(i_spin, i_img)%matrix, 0.0_dp)
2386 : END DO
2387 : END DO
2388 :
2389 : END DO
2390 :
2391 4 : n_x_start = LBOUND(LDOS(1)%array, 1)
2392 4 : n_x_end = UBOUND(LDOS(1)%array, 1)
2393 4 : n_y_start = LBOUND(LDOS(1)%array, 2)
2394 4 : n_y_end = UBOUND(LDOS(1)%array, 2)
2395 4 : n_z_start = LBOUND(LDOS(1)%array, 3)
2396 4 : n_z_end = UBOUND(LDOS(1)%array, 3)
2397 :
2398 4 : CALL pw_zero(E_VBM_rspace)
2399 4 : CALL pw_zero(E_CBM_rspace)
2400 :
2401 68 : DO i_x = n_x_start, n_x_end
2402 2116 : DO i_y = n_y_start, n_y_end
2403 94272 : DO i_z = n_z_start, n_z_end
2404 : ! compute average occ and virt LDOS
2405 : avg_LDOS_occ = 0.0_dp
2406 276480 : DO i_E = 1, n_E_occ
2407 276480 : avg_LDOS_occ = avg_LDOS_occ + LDOS(i_E)%array(i_x, i_y, i_z)
2408 : END DO
2409 92160 : avg_LDOS_occ = avg_LDOS_occ/REAL(n_E_occ, KIND=dp)
2410 :
2411 92160 : avg_LDOS_virt = 0.0_dp
2412 276480 : DO i_E = n_E_occ + 1, n_E
2413 276480 : avg_LDOS_virt = avg_LDOS_virt + LDOS(i_E)%array(i_x, i_y, i_z)
2414 : END DO
2415 92160 : avg_LDOS_virt = avg_LDOS_virt/REAL(n_E - n_E_occ, KIND=dp)
2416 :
2417 : ! compute local valence band maximum (VBM)
2418 117630 : DO i_E = n_E_occ, 1, -1
2419 117630 : IF (LDOS(i_E)%array(i_x, i_y, i_z) > mp2_env%ri_g0w0%ldos_thresh_print_loc_bandgap*avg_LDOS_occ) THEN
2420 79632 : E_VBM_rspace%array(i_x, i_y, i_z) = E_array(i_E)
2421 79632 : EXIT
2422 : END IF
2423 : END DO
2424 :
2425 : ! compute local valence band maximum (VBM)
2426 94304 : DO i_E = n_E_occ + 1, n_E
2427 92256 : IF (LDOS(i_E)%array(i_x, i_y, i_z) > mp2_env%ri_g0w0%ldos_thresh_print_loc_bandgap*avg_LDOS_virt) THEN
2428 92112 : E_CBM_rspace%array(i_x, i_y, i_z) = E_array(i_E)
2429 92112 : EXIT
2430 : END IF
2431 : END DO
2432 :
2433 : END DO
2434 : END DO
2435 : END DO
2436 :
2437 4 : CALL pw_scale(E_VBM_rspace, evolt)
2438 4 : CALL pw_scale(E_CBM_rspace, evolt)
2439 :
2440 4 : CALL pw_copy(E_CBM_rspace, E_gap_rspace)
2441 4 : CALL pw_axpy(E_VBM_rspace, E_gap_rspace, -1.0_dp)
2442 :
2443 4 : gw_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%WF_CORRELATION%RI_RPA%GW")
2444 4 : CALL qs_subsys_get(subsys, particles=particles)
2445 :
2446 4 : CALL print_file(E_gap_rspace, dft_gw_char//"_Gap_in_eV", gw_section, particles, mp2_env)
2447 4 : CALL print_file(E_VBM_rspace, dft_gw_char//"_VBM_in_eV", gw_section, particles, mp2_env)
2448 4 : CALL print_file(E_CBM_rspace, dft_gw_char//"_CBM_in_eV", gw_section, particles, mp2_env)
2449 4 : CALL print_file(LDOS(n_E_occ), dft_gw_char//"_LDOS_VBM_in_eV", gw_section, particles, mp2_env)
2450 4 : CALL print_file(LDOS(n_E_occ + 1), dft_gw_char//"_LDOS_CBM_in_eV", gw_section, particles, mp2_env)
2451 :
2452 4 : CALL dbcsr_deallocate_matrix_set(rho_ao_weighted)
2453 :
2454 4 : CALL cp_fm_release(fm_work)
2455 :
2456 4 : DEALLOCATE (E_array)
2457 :
2458 4 : NULLIFY (kpoints_Sigma%sab_nl)
2459 :
2460 4 : CALL timestop(handle)
2461 :
2462 8 : END SUBROUTINE calculate_E_gap_rspace
2463 :
2464 : ! **************************************************************************************************
2465 : !> \brief ...
2466 : !> \param pw_print ...
2467 : !> \param middle_name ...
2468 : !> \param gw_section ...
2469 : !> \param particles ...
2470 : !> \param mp2_env ...
2471 : ! **************************************************************************************************
2472 20 : SUBROUTINE print_file(pw_print, middle_name, gw_section, particles, mp2_env)
2473 : TYPE(pw_r3d_rs_type) :: pw_print
2474 : CHARACTER(len=*) :: middle_name
2475 : TYPE(section_vals_type), POINTER :: gw_section
2476 : TYPE(particle_list_type), POINTER :: particles
2477 : TYPE(mp2_type), POINTER :: mp2_env
2478 :
2479 : CHARACTER(LEN=*), PARAMETER :: routineN = 'print_file'
2480 :
2481 : INTEGER :: handle, unit_nr_cube
2482 : LOGICAL :: mpi_io
2483 : TYPE(cp_logger_type), POINTER :: logger
2484 :
2485 20 : CALL timeset(routineN, handle)
2486 :
2487 20 : NULLIFY (logger)
2488 20 : logger => cp_get_default_logger()
2489 20 : mpi_io = .TRUE.
2490 : unit_nr_cube = cp_print_key_unit_nr(logger, gw_section, "PRINT%LOCAL_BANDGAP", extension=".cube", &
2491 20 : middle_name=middle_name, file_form="FORMATTED", mpi_io=mpi_io)
2492 : CALL cp_pw_to_cube(pw_print, unit_nr_cube, middle_name, particles=particles, &
2493 20 : stride=mp2_env%ri_g0w0%stride_loc_bandgap, mpi_io=mpi_io)
2494 : CALL cp_print_key_finished_output(unit_nr_cube, logger, gw_section, &
2495 20 : "PRINT%LOCAL_BANDGAP", mpi_io=mpi_io)
2496 :
2497 20 : CALL timestop(handle)
2498 :
2499 20 : END SUBROUTINE print_file
2500 :
2501 : ! **************************************************************************************************
2502 : !> \brief ...
2503 : !> \param E_gap_rspace ...
2504 : !> \param E_VBM_rspace ...
2505 : !> \param E_CBM_rspace ...
2506 : !> \param rho_g_dummy ...
2507 : !> \param LDOS ...
2508 : !> \param auxbas_pw_pool ...
2509 : !> \param qs_env ...
2510 : ! **************************************************************************************************
2511 4 : SUBROUTINE create_real_space_grids(E_gap_rspace, E_VBM_rspace, E_CBM_rspace, rho_g_dummy, LDOS, auxbas_pw_pool, qs_env)
2512 : TYPE(pw_r3d_rs_type) :: E_gap_rspace, E_VBM_rspace, E_CBM_rspace
2513 : TYPE(pw_c1d_gs_type) :: rho_g_dummy
2514 : TYPE(pw_r3d_rs_type), ALLOCATABLE, DIMENSION(:) :: LDOS
2515 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
2516 : TYPE(qs_environment_type), POINTER :: qs_env
2517 :
2518 : CHARACTER(LEN=*), PARAMETER :: routineN = 'create_real_space_grids'
2519 :
2520 : INTEGER :: handle, i_E, n_E
2521 : TYPE(mp2_type), POINTER :: mp2_env
2522 : TYPE(pw_env_type), POINTER :: pw_env
2523 :
2524 4 : CALL timeset(routineN, handle)
2525 :
2526 4 : CALL get_qs_env(qs_env=qs_env, mp2_env=mp2_env, pw_env=pw_env)
2527 :
2528 4 : CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
2529 :
2530 4 : CALL auxbas_pw_pool%create_pw(E_gap_rspace)
2531 4 : CALL auxbas_pw_pool%create_pw(E_VBM_rspace)
2532 4 : CALL auxbas_pw_pool%create_pw(E_CBM_rspace)
2533 4 : CALL auxbas_pw_pool%create_pw(rho_g_dummy)
2534 :
2535 : n_E = INT(mp2_env%ri_g0w0%energy_window_print_loc_bandgap/ &
2536 4 : mp2_env%ri_g0w0%energy_spacing_print_loc_bandgap)
2537 :
2538 28 : ALLOCATE (LDOS(n_E))
2539 :
2540 20 : DO i_E = 1, n_E
2541 20 : CALL auxbas_pw_pool%create_pw(LDOS(i_E))
2542 : END DO
2543 :
2544 4 : CALL timestop(handle)
2545 :
2546 4 : END SUBROUTINE create_real_space_grids
2547 :
2548 : ! **************************************************************************************************
2549 : !> \brief ...
2550 : !> \param delta_corr ...
2551 : !> \param qs_env ...
2552 : !> \param para_env ...
2553 : !> \param para_env_RPA ...
2554 : !> \param kp_grid ...
2555 : !> \param homo ...
2556 : !> \param nmo ...
2557 : !> \param gw_corr_lev_occ ...
2558 : !> \param gw_corr_lev_virt ...
2559 : !> \param omega ...
2560 : !> \param fm_mo_coeff ...
2561 : !> \param Eigenval ...
2562 : !> \param matrix_berry_re_mo_mo ...
2563 : !> \param matrix_berry_im_mo_mo ...
2564 : !> \param first_cycle_periodic_correction ...
2565 : !> \param kpoints ...
2566 : !> \param do_mo_coeff_Gamma_only ...
2567 : !> \param num_kp_grids ...
2568 : !> \param eps_kpoint ...
2569 : !> \param do_extra_kpoints ...
2570 : !> \param do_aux_bas ...
2571 : !> \param frac_aux_mos ...
2572 : ! **************************************************************************************************
2573 260 : SUBROUTINE calc_periodic_correction(delta_corr, qs_env, para_env, para_env_RPA, kp_grid, homo, nmo, &
2574 260 : gw_corr_lev_occ, gw_corr_lev_virt, omega, fm_mo_coeff, Eigenval, &
2575 : matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
2576 : first_cycle_periodic_correction, kpoints, do_mo_coeff_Gamma_only, &
2577 : num_kp_grids, eps_kpoint, do_extra_kpoints, do_aux_bas, frac_aux_mos)
2578 :
2579 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
2580 : INTENT(INOUT) :: delta_corr
2581 : TYPE(qs_environment_type), POINTER :: qs_env
2582 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_RPA
2583 : INTEGER, DIMENSION(:), POINTER :: kp_grid
2584 : INTEGER, INTENT(IN) :: homo, nmo, gw_corr_lev_occ, &
2585 : gw_corr_lev_virt
2586 : REAL(KIND=dp), INTENT(IN) :: omega
2587 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff
2588 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval
2589 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_re_mo_mo, &
2590 : matrix_berry_im_mo_mo
2591 : LOGICAL, INTENT(INOUT) :: first_cycle_periodic_correction
2592 : TYPE(kpoint_type), POINTER :: kpoints
2593 : LOGICAL, INTENT(IN) :: do_mo_coeff_Gamma_only
2594 : INTEGER, INTENT(IN) :: num_kp_grids
2595 : REAL(KIND=dp), INTENT(IN) :: eps_kpoint
2596 : LOGICAL, INTENT(IN) :: do_extra_kpoints, do_aux_bas
2597 : REAL(KIND=dp), INTENT(IN) :: frac_aux_mos
2598 :
2599 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_periodic_correction'
2600 :
2601 : INTEGER :: handle
2602 260 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: eps_head, eps_inv_head
2603 : REAL(KIND=dp), DIMENSION(3, 3) :: h_inv
2604 :
2605 260 : CALL timeset(routineN, handle)
2606 :
2607 260 : IF (first_cycle_periodic_correction) THEN
2608 :
2609 : CALL get_kpoints(qs_env, kpoints, kp_grid, num_kp_grids, para_env, h_inv, nmo, do_mo_coeff_Gamma_only, &
2610 6 : do_extra_kpoints)
2611 :
2612 : CALL get_berry_phase(qs_env, kpoints, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, fm_mo_coeff, &
2613 : para_env, do_mo_coeff_Gamma_only, homo, nmo, gw_corr_lev_virt, eps_kpoint, do_aux_bas, &
2614 6 : frac_aux_mos)
2615 :
2616 : END IF
2617 :
2618 : CALL compute_eps_head_Berry(eps_head, kpoints, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, para_env_RPA, &
2619 260 : qs_env, homo, Eigenval, omega)
2620 :
2621 : CALL compute_eps_inv_head(eps_inv_head, eps_head, kpoints)
2622 :
2623 : CALL kpoint_sum_for_eps_inv_head_Berry(delta_corr, eps_inv_head, kpoints, qs_env, &
2624 : matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
2625 : homo, gw_corr_lev_occ, gw_corr_lev_virt, para_env_RPA, &
2626 260 : do_extra_kpoints)
2627 :
2628 260 : DEALLOCATE (eps_head, eps_inv_head)
2629 :
2630 260 : first_cycle_periodic_correction = .FALSE.
2631 :
2632 260 : CALL timestop(handle)
2633 :
2634 260 : END SUBROUTINE calc_periodic_correction
2635 :
2636 : ! **************************************************************************************************
2637 : !> \brief ...
2638 : !> \param eps_head ...
2639 : !> \param kpoints ...
2640 : !> \param matrix_berry_re_mo_mo ...
2641 : !> \param matrix_berry_im_mo_mo ...
2642 : !> \param para_env_RPA ...
2643 : !> \param qs_env ...
2644 : !> \param homo ...
2645 : !> \param Eigenval ...
2646 : !> \param omega ...
2647 : ! **************************************************************************************************
2648 260 : SUBROUTINE compute_eps_head_Berry(eps_head, kpoints, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, para_env_RPA, &
2649 260 : qs_env, homo, Eigenval, omega)
2650 :
2651 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
2652 : INTENT(OUT) :: eps_head
2653 : TYPE(kpoint_type), POINTER :: kpoints
2654 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN) :: matrix_berry_re_mo_mo, &
2655 : matrix_berry_im_mo_mo
2656 : TYPE(mp_para_env_type), INTENT(IN) :: para_env_RPA
2657 : TYPE(qs_environment_type), POINTER :: qs_env
2658 : INTEGER, INTENT(IN) :: homo
2659 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval
2660 : REAL(KIND=dp), INTENT(IN) :: omega
2661 :
2662 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_eps_head_Berry'
2663 :
2664 : INTEGER :: col, col_end_in_block, col_offset, col_size, handle, i_col, i_row, ikp, nkp, nmo, &
2665 : row, row_offset, row_size, row_start_in_block
2666 : REAL(KIND=dp) :: abs_k_square, cell_volume, &
2667 : correct_kpoint(3), cos_square, &
2668 : eigen_diff, relative_kpoint(3), &
2669 : sin_square
2670 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: P_head
2671 260 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
2672 : TYPE(cell_type), POINTER :: cell
2673 : TYPE(dbcsr_iterator_type) :: iter
2674 :
2675 260 : CALL timeset(routineN, handle)
2676 :
2677 260 : CALL get_qs_env(qs_env=qs_env, cell=cell)
2678 260 : CALL get_cell(cell=cell, deth=cell_volume)
2679 :
2680 260 : NULLIFY (data_block)
2681 :
2682 260 : nkp = kpoints%nkp
2683 :
2684 260 : nmo = SIZE(Eigenval)
2685 :
2686 780 : ALLOCATE (P_head(nkp))
2687 279620 : P_head(:) = 0.0_dp
2688 :
2689 520 : ALLOCATE (eps_head(nkp))
2690 279620 : eps_head(:) = 0.0_dp
2691 :
2692 279620 : DO ikp = 1, nkp
2693 :
2694 3631680 : relative_kpoint(1:3) = MATMUL(cell%hmat, kpoints%xkp(1:3, ikp))
2695 :
2696 1117440 : correct_kpoint(1:3) = twopi*kpoints%xkp(1:3, ikp)
2697 :
2698 279360 : abs_k_square = (correct_kpoint(1))**2 + (correct_kpoint(2))**2 + (correct_kpoint(3))**2
2699 :
2700 : ! real part of the Berry phase
2701 279360 : CALL dbcsr_iterator_start(iter, matrix_berry_re_mo_mo(ikp)%matrix)
2702 465120 : DO WHILE (dbcsr_iterator_blocks_left(iter))
2703 :
2704 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
2705 : row_size=row_size, col_size=col_size, &
2706 185760 : row_offset=row_offset, col_offset=col_offset)
2707 :
2708 185760 : IF (row_offset + row_size <= homo .OR. col_offset > homo) CYCLE
2709 :
2710 185760 : IF (row_offset <= homo) THEN
2711 139680 : row_start_in_block = homo - row_offset + 2
2712 : ELSE
2713 : row_start_in_block = 1
2714 : END IF
2715 :
2716 185760 : IF (col_offset + col_size - 1 > homo) THEN
2717 185760 : col_end_in_block = homo - col_offset + 1
2718 : ELSE
2719 : col_end_in_block = col_size
2720 : END IF
2721 :
2722 1929600 : DO i_row = row_start_in_block, MIN(row_size, nmo - row_offset + 1)
2723 :
2724 7508160 : DO i_col = 1, MIN(col_end_in_block, nmo - col_offset + 1)
2725 :
2726 5857920 : eigen_diff = Eigenval(i_col + col_offset - 1) - Eigenval(i_row + row_offset - 1)
2727 :
2728 5857920 : cos_square = (data_block(i_row, i_col))**2
2729 :
2730 7322400 : P_head(ikp) = P_head(ikp) + 2.0_dp*eigen_diff/(omega**2 + eigen_diff**2)*cos_square/abs_k_square
2731 :
2732 : END DO
2733 :
2734 : END DO
2735 :
2736 : END DO
2737 :
2738 279360 : CALL dbcsr_iterator_stop(iter)
2739 :
2740 : ! imaginary part of the Berry phase
2741 279360 : CALL dbcsr_iterator_start(iter, matrix_berry_im_mo_mo(ikp)%matrix)
2742 465120 : DO WHILE (dbcsr_iterator_blocks_left(iter))
2743 :
2744 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
2745 : row_size=row_size, col_size=col_size, &
2746 185760 : row_offset=row_offset, col_offset=col_offset)
2747 :
2748 185760 : IF (row_offset + row_size <= homo .OR. col_offset > homo) CYCLE
2749 :
2750 185760 : IF (row_offset <= homo) THEN
2751 139680 : row_start_in_block = homo - row_offset + 2
2752 : ELSE
2753 : row_start_in_block = 1
2754 : END IF
2755 :
2756 185760 : IF (col_offset + col_size - 1 > homo) THEN
2757 185760 : col_end_in_block = homo - col_offset + 1
2758 : ELSE
2759 : col_end_in_block = col_size
2760 : END IF
2761 :
2762 1929600 : DO i_row = row_start_in_block, MIN(row_size, nmo - row_offset + 1)
2763 :
2764 7508160 : DO i_col = 1, MIN(col_end_in_block, nmo - col_offset + 1)
2765 :
2766 5857920 : eigen_diff = Eigenval(i_col + col_offset - 1) - Eigenval(i_row + row_offset - 1)
2767 :
2768 5857920 : sin_square = (data_block(i_row, i_col))**2
2769 :
2770 7322400 : P_head(ikp) = P_head(ikp) + 2.0_dp*eigen_diff/(omega**2 + eigen_diff**2)*sin_square/abs_k_square
2771 :
2772 : END DO
2773 :
2774 : END DO
2775 :
2776 : END DO
2777 :
2778 838340 : CALL dbcsr_iterator_stop(iter)
2779 :
2780 : END DO
2781 :
2782 260 : CALL para_env_RPA%sum(P_head)
2783 :
2784 : ! normalize eps_head
2785 : ! 2.0_dp due to closed shell
2786 279620 : eps_head(:) = 1.0_dp - 2.0_dp*P_head(:)/cell_volume*fourpi
2787 :
2788 260 : DEALLOCATE (P_head)
2789 :
2790 260 : CALL timestop(handle)
2791 :
2792 520 : END SUBROUTINE compute_eps_head_Berry
2793 :
2794 : ! **************************************************************************************************
2795 : !> \brief ...
2796 : !> \param qs_env ...
2797 : !> \param kpoints ...
2798 : !> \param matrix_berry_re_mo_mo ...
2799 : !> \param matrix_berry_im_mo_mo ...
2800 : !> \param fm_mo_coeff ...
2801 : !> \param para_env ...
2802 : !> \param do_mo_coeff_Gamma_only ...
2803 : !> \param homo ...
2804 : !> \param nmo ...
2805 : !> \param gw_corr_lev_virt ...
2806 : !> \param eps_kpoint ...
2807 : !> \param do_aux_bas ...
2808 : !> \param frac_aux_mos ...
2809 : ! **************************************************************************************************
2810 6 : SUBROUTINE get_berry_phase(qs_env, kpoints, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, fm_mo_coeff, para_env, &
2811 : do_mo_coeff_Gamma_only, homo, nmo, gw_corr_lev_virt, eps_kpoint, do_aux_bas, &
2812 : frac_aux_mos)
2813 : TYPE(qs_environment_type), POINTER :: qs_env
2814 : TYPE(kpoint_type), POINTER :: kpoints
2815 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_re_mo_mo, &
2816 : matrix_berry_im_mo_mo
2817 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff
2818 : TYPE(mp_para_env_type), POINTER :: para_env
2819 : LOGICAL, INTENT(IN) :: do_mo_coeff_Gamma_only
2820 : INTEGER, INTENT(IN) :: homo, nmo, gw_corr_lev_virt
2821 : REAL(KIND=dp), INTENT(IN) :: eps_kpoint
2822 : LOGICAL, INTENT(IN) :: do_aux_bas
2823 : REAL(KIND=dp), INTENT(IN) :: frac_aux_mos
2824 :
2825 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_berry_phase'
2826 :
2827 : INTEGER :: col_index, handle, i_col_local, ikind, &
2828 : ikp, nao_aux, ncol_local, nkind, nkp, &
2829 : nmo_for_aux_bas
2830 6 : INTEGER, DIMENSION(:), POINTER :: col_indices
2831 : REAL(dp) :: abs_kpoint, correct_kpoint(3), &
2832 : scale_kpoint
2833 6 : REAL(KIND=dp), DIMENSION(:), POINTER :: evals_P, evals_P_sqrt_inv
2834 : TYPE(cell_type), POINTER :: cell
2835 : TYPE(cp_fm_struct_type), POINTER :: fm_struct_aux_aux
2836 : TYPE(cp_fm_type) :: fm_mat_eigv_P, fm_mat_P, fm_mat_P_sqrt_inv, fm_mat_s_aux_aux_inv, &
2837 : fm_mat_scaled_eigv_P, fm_mat_work_aux_aux
2838 6 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s, matrix_s_aux_aux, &
2839 6 : matrix_s_aux_orb
2840 : TYPE(dbcsr_type), POINTER :: cosmat, cosmat_desymm, mat_mo_coeff_aux, mat_mo_coeff_aux_2, &
2841 : mat_mo_coeff_Gamma_all, mat_mo_coeff_Gamma_occ_and_GW, mat_mo_coeff_im, mat_mo_coeff_re, &
2842 : mat_work_aux_orb, mat_work_aux_orb_2, matrix_P, matrix_P_sqrt, matrix_P_sqrt_inv, &
2843 : matrix_s_inv_aux_aux, sinmat, sinmat_desymm, tmp
2844 6 : TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER :: gw_aux_basis_set_list, orb_basis_set_list
2845 : TYPE(gto_basis_set_type), POINTER :: basis_set_gw_aux
2846 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
2847 6 : POINTER :: sab_orb, sab_orb_mic, sgwgw_list, &
2848 6 : sgworb_list
2849 6 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
2850 : TYPE(qs_kind_type), POINTER :: qs_kind
2851 : TYPE(qs_ks_env_type), POINTER :: ks_env
2852 :
2853 6 : CALL timeset(routineN, handle)
2854 :
2855 6 : nkp = kpoints%nkp
2856 :
2857 6 : NULLIFY (matrix_berry_re_mo_mo, matrix_s, cell, matrix_berry_im_mo_mo, sinmat, cosmat, tmp, &
2858 6 : cosmat_desymm, sinmat_desymm, qs_kind_set, orb_basis_set_list, sab_orb_mic)
2859 :
2860 : CALL get_qs_env(qs_env=qs_env, &
2861 : cell=cell, &
2862 : matrix_s=matrix_s, &
2863 : qs_kind_set=qs_kind_set, &
2864 : nkind=nkind, &
2865 : ks_env=ks_env, &
2866 6 : sab_orb=sab_orb)
2867 :
2868 30 : ALLOCATE (orb_basis_set_list(nkind))
2869 6 : CALL basis_set_list_setup(orb_basis_set_list, "ORB", qs_kind_set)
2870 :
2871 6 : CALL setup_neighbor_list(sab_orb_mic, orb_basis_set_list, qs_env=qs_env, mic=.FALSE.)
2872 :
2873 : ! create dbcsr matrix of mo_coeff for multiplcation
2874 6 : NULLIFY (mat_mo_coeff_re)
2875 6 : CALL dbcsr_init_p(mat_mo_coeff_re)
2876 : CALL dbcsr_create(matrix=mat_mo_coeff_re, &
2877 : template=matrix_s(1)%matrix, &
2878 6 : matrix_type=dbcsr_type_no_symmetry)
2879 :
2880 6 : NULLIFY (mat_mo_coeff_im)
2881 6 : CALL dbcsr_init_p(mat_mo_coeff_im)
2882 : CALL dbcsr_create(matrix=mat_mo_coeff_im, &
2883 : template=matrix_s(1)%matrix, &
2884 6 : matrix_type=dbcsr_type_no_symmetry)
2885 :
2886 6 : NULLIFY (mat_mo_coeff_Gamma_all)
2887 6 : CALL dbcsr_init_p(mat_mo_coeff_Gamma_all)
2888 : CALL dbcsr_create(matrix=mat_mo_coeff_Gamma_all, &
2889 : template=matrix_s(1)%matrix, &
2890 6 : matrix_type=dbcsr_type_no_symmetry)
2891 :
2892 6 : CALL copy_fm_to_dbcsr(fm_mo_coeff, mat_mo_coeff_Gamma_all, keep_sparsity=.FALSE.)
2893 :
2894 6 : NULLIFY (mat_mo_coeff_Gamma_occ_and_GW)
2895 6 : CALL dbcsr_init_p(mat_mo_coeff_Gamma_occ_and_GW)
2896 : CALL dbcsr_create(matrix=mat_mo_coeff_Gamma_occ_and_GW, &
2897 : template=matrix_s(1)%matrix, &
2898 6 : matrix_type=dbcsr_type_no_symmetry)
2899 :
2900 6 : CALL copy_fm_to_dbcsr(fm_mo_coeff, mat_mo_coeff_Gamma_occ_and_GW, keep_sparsity=.FALSE.)
2901 :
2902 6 : IF (.NOT. do_aux_bas) THEN
2903 :
2904 : ! allocate intermediate matrices
2905 4 : CALL dbcsr_init_p(cosmat)
2906 4 : CALL dbcsr_init_p(sinmat)
2907 4 : CALL dbcsr_init_p(tmp)
2908 4 : CALL dbcsr_init_p(cosmat_desymm)
2909 4 : CALL dbcsr_init_p(sinmat_desymm)
2910 4 : CALL dbcsr_create(matrix=cosmat, template=matrix_s(1)%matrix)
2911 4 : CALL dbcsr_create(matrix=sinmat, template=matrix_s(1)%matrix)
2912 : CALL dbcsr_create(matrix=tmp, &
2913 : template=matrix_s(1)%matrix, &
2914 4 : matrix_type=dbcsr_type_no_symmetry)
2915 : CALL dbcsr_create(matrix=cosmat_desymm, &
2916 : template=matrix_s(1)%matrix, &
2917 4 : matrix_type=dbcsr_type_no_symmetry)
2918 : CALL dbcsr_create(matrix=sinmat_desymm, &
2919 : template=matrix_s(1)%matrix, &
2920 4 : matrix_type=dbcsr_type_no_symmetry)
2921 4 : CALL dbcsr_copy(cosmat, matrix_s(1)%matrix)
2922 4 : CALL dbcsr_copy(sinmat, matrix_s(1)%matrix)
2923 4 : CALL dbcsr_set(cosmat, 0.0_dp)
2924 4 : CALL dbcsr_set(sinmat, 0.0_dp)
2925 :
2926 4 : CALL dbcsr_allocate_matrix_set(matrix_berry_re_mo_mo, nkp)
2927 4 : CALL dbcsr_allocate_matrix_set(matrix_berry_im_mo_mo, nkp)
2928 :
2929 : ELSE
2930 :
2931 2 : NULLIFY (gw_aux_basis_set_list)
2932 10 : ALLOCATE (gw_aux_basis_set_list(nkind))
2933 :
2934 6 : DO ikind = 1, nkind
2935 :
2936 4 : NULLIFY (gw_aux_basis_set_list(ikind)%gto_basis_set)
2937 :
2938 4 : NULLIFY (basis_set_gw_aux)
2939 :
2940 4 : qs_kind => qs_kind_set(ikind)
2941 4 : CALL get_qs_kind(qs_kind=qs_kind, basis_set=basis_set_gw_aux, basis_type="AUX_GW")
2942 4 : CPASSERT(ASSOCIATED(basis_set_gw_aux))
2943 :
2944 4 : basis_set_gw_aux%kind_radius = orb_basis_set_list(ikind)%gto_basis_set%kind_radius
2945 :
2946 6 : gw_aux_basis_set_list(ikind)%gto_basis_set => basis_set_gw_aux
2947 :
2948 : END DO
2949 :
2950 : ! neighbor lists
2951 2 : NULLIFY (sgwgw_list, sgworb_list)
2952 2 : CALL setup_neighbor_list(sgwgw_list, gw_aux_basis_set_list, qs_env=qs_env)
2953 2 : CALL setup_neighbor_list(sgworb_list, gw_aux_basis_set_list, orb_basis_set_list, qs_env=qs_env)
2954 :
2955 2 : NULLIFY (matrix_s_aux_aux, matrix_s_aux_orb)
2956 :
2957 : ! build overlap matrix in gw aux basis and the mixed gw aux basis-orb basis
2958 : CALL build_overlap_matrix_simple(ks_env, matrix_s_aux_aux, &
2959 2 : gw_aux_basis_set_list, gw_aux_basis_set_list, sgwgw_list)
2960 :
2961 : CALL build_overlap_matrix_simple(ks_env, matrix_s_aux_orb, &
2962 2 : gw_aux_basis_set_list, orb_basis_set_list, sgworb_list)
2963 :
2964 2 : CALL dbcsr_get_info(matrix_s_aux_aux(1)%matrix, nfullrows_total=nao_aux)
2965 :
2966 2 : nmo_for_aux_bas = FLOOR(frac_aux_mos*REAL(nao_aux, KIND=dp))
2967 :
2968 : CALL cp_fm_struct_create(fm_struct_aux_aux, &
2969 : context=fm_mo_coeff%matrix_struct%context, &
2970 : nrow_global=nao_aux, &
2971 : ncol_global=nao_aux, &
2972 2 : para_env=para_env)
2973 :
2974 2 : NULLIFY (mat_work_aux_orb)
2975 2 : CALL dbcsr_init_p(mat_work_aux_orb)
2976 : CALL dbcsr_create(matrix=mat_work_aux_orb, &
2977 : template=matrix_s_aux_orb(1)%matrix, &
2978 2 : matrix_type=dbcsr_type_no_symmetry)
2979 :
2980 2 : NULLIFY (mat_work_aux_orb_2)
2981 2 : CALL dbcsr_init_p(mat_work_aux_orb_2)
2982 : CALL dbcsr_create(matrix=mat_work_aux_orb_2, &
2983 : template=matrix_s_aux_orb(1)%matrix, &
2984 2 : matrix_type=dbcsr_type_no_symmetry)
2985 :
2986 2 : NULLIFY (mat_mo_coeff_aux)
2987 2 : CALL dbcsr_init_p(mat_mo_coeff_aux)
2988 : CALL dbcsr_create(matrix=mat_mo_coeff_aux, &
2989 : template=matrix_s_aux_orb(1)%matrix, &
2990 2 : matrix_type=dbcsr_type_no_symmetry)
2991 :
2992 2 : NULLIFY (mat_mo_coeff_aux_2)
2993 2 : CALL dbcsr_init_p(mat_mo_coeff_aux_2)
2994 : CALL dbcsr_create(matrix=mat_mo_coeff_aux_2, &
2995 : template=matrix_s_aux_orb(1)%matrix, &
2996 2 : matrix_type=dbcsr_type_no_symmetry)
2997 :
2998 2 : NULLIFY (matrix_s_inv_aux_aux)
2999 2 : CALL dbcsr_init_p(matrix_s_inv_aux_aux)
3000 : CALL dbcsr_create(matrix=matrix_s_inv_aux_aux, &
3001 : template=matrix_s_aux_aux(1)%matrix, &
3002 2 : matrix_type=dbcsr_type_no_symmetry)
3003 :
3004 2 : NULLIFY (matrix_P)
3005 2 : CALL dbcsr_init_p(matrix_P)
3006 : CALL dbcsr_create(matrix=matrix_P, &
3007 : template=matrix_s(1)%matrix, &
3008 2 : matrix_type=dbcsr_type_no_symmetry)
3009 :
3010 2 : NULLIFY (matrix_P_sqrt)
3011 2 : CALL dbcsr_init_p(matrix_P_sqrt)
3012 : CALL dbcsr_create(matrix=matrix_P_sqrt, &
3013 : template=matrix_s(1)%matrix, &
3014 2 : matrix_type=dbcsr_type_no_symmetry)
3015 :
3016 2 : NULLIFY (matrix_P_sqrt_inv)
3017 2 : CALL dbcsr_init_p(matrix_P_sqrt_inv)
3018 : CALL dbcsr_create(matrix=matrix_P_sqrt_inv, &
3019 : template=matrix_s(1)%matrix, &
3020 2 : matrix_type=dbcsr_type_no_symmetry)
3021 :
3022 2 : CALL cp_fm_create(fm_mat_s_aux_aux_inv, fm_struct_aux_aux, name="inverse overlap mat")
3023 2 : CALL cp_fm_create(fm_mat_work_aux_aux, fm_struct_aux_aux, name="work mat")
3024 2 : CALL cp_fm_create(fm_mat_P, fm_mo_coeff%matrix_struct)
3025 2 : CALL cp_fm_create(fm_mat_eigv_P, fm_mo_coeff%matrix_struct)
3026 2 : CALL cp_fm_create(fm_mat_scaled_eigv_P, fm_mo_coeff%matrix_struct)
3027 2 : CALL cp_fm_create(fm_mat_P_sqrt_inv, fm_mo_coeff%matrix_struct)
3028 :
3029 : NULLIFY (evals_P)
3030 6 : ALLOCATE (evals_P(nmo))
3031 :
3032 2 : NULLIFY (evals_P_sqrt_inv)
3033 4 : ALLOCATE (evals_P_sqrt_inv(nmo))
3034 :
3035 2 : CALL copy_dbcsr_to_fm(matrix_s_aux_aux(1)%matrix, fm_mat_s_aux_aux_inv)
3036 : ! Calculate S_inverse
3037 2 : CALL cp_fm_cholesky_decompose(fm_mat_s_aux_aux_inv)
3038 2 : CALL cp_fm_cholesky_invert(fm_mat_s_aux_aux_inv)
3039 : ! Symmetrize the guy
3040 2 : CALL cp_fm_uplo_to_full(fm_mat_s_aux_aux_inv, fm_mat_work_aux_aux)
3041 :
3042 2 : CALL copy_fm_to_dbcsr(fm_mat_s_aux_aux_inv, matrix_s_inv_aux_aux, keep_sparsity=.FALSE.)
3043 :
3044 : CALL dbcsr_multiply('N', 'N', 1.0_dp, matrix_s_inv_aux_aux, matrix_s_aux_orb(1)%matrix, 0.0_dp, mat_work_aux_orb, &
3045 2 : filter_eps=1.0E-15_dp)
3046 :
3047 : CALL dbcsr_multiply('N', 'N', 1.0_dp, mat_work_aux_orb, mat_mo_coeff_Gamma_all, 0.0_dp, mat_mo_coeff_aux_2, &
3048 2 : last_column=nmo_for_aux_bas, filter_eps=1.0E-15_dp)
3049 :
3050 : CALL dbcsr_multiply('N', 'N', 1.0_dp, matrix_s_aux_aux(1)%matrix, mat_mo_coeff_aux_2, 0.0_dp, mat_work_aux_orb, &
3051 2 : filter_eps=1.0E-15_dp)
3052 :
3053 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_aux_2, mat_work_aux_orb, 0.0_dp, matrix_P, &
3054 2 : filter_eps=1.0E-15_dp)
3055 :
3056 2 : CALL copy_dbcsr_to_fm(matrix_P, fm_mat_P)
3057 :
3058 2 : CALL cp_fm_syevd(fm_mat_P, fm_mat_eigv_P, evals_P)
3059 :
3060 : ! only invert the eigenvalues which correspond to the MOs used in the aux. basis
3061 62 : evals_P_sqrt_inv(1:nmo - nmo_for_aux_bas) = 0.0_dp
3062 46 : evals_P_sqrt_inv(nmo - nmo_for_aux_bas + 1:nmo) = 1.0_dp/SQRT(evals_P(nmo - nmo_for_aux_bas + 1:nmo))
3063 :
3064 2 : CALL cp_fm_to_fm(fm_mat_eigv_P, fm_mat_scaled_eigv_P)
3065 :
3066 : CALL cp_fm_get_info(matrix=fm_mat_scaled_eigv_P, &
3067 : ncol_local=ncol_local, &
3068 2 : col_indices=col_indices)
3069 :
3070 2 : CALL para_env%sync()
3071 :
3072 : ! multiply eigenvectors with inverse sqrt of eigenvalues
3073 84 : DO i_col_local = 1, ncol_local
3074 :
3075 82 : col_index = col_indices(i_col_local)
3076 :
3077 : fm_mat_scaled_eigv_P%local_data(:, i_col_local) = &
3078 1765 : fm_mat_scaled_eigv_P%local_data(:, i_col_local)*evals_P_sqrt_inv(col_index)
3079 :
3080 : END DO
3081 :
3082 2 : CALL para_env%sync()
3083 :
3084 : CALL parallel_gemm(transa="N", transb="T", m=nmo, n=nmo, k=nmo, alpha=1.0_dp, &
3085 : matrix_a=fm_mat_eigv_P, matrix_b=fm_mat_scaled_eigv_P, beta=0.0_dp, &
3086 2 : matrix_c=fm_mat_P_sqrt_inv)
3087 :
3088 2 : CALL copy_fm_to_dbcsr(fm_mat_P_sqrt_inv, matrix_P_sqrt_inv, keep_sparsity=.FALSE.)
3089 :
3090 : CALL dbcsr_multiply('N', 'N', 1.0_dp, mat_mo_coeff_aux_2, matrix_P_sqrt_inv, 0.0_dp, mat_mo_coeff_aux, &
3091 2 : filter_eps=1.0E-15_dp)
3092 :
3093 : ! allocate intermediate matrices
3094 2 : CALL dbcsr_init_p(cosmat)
3095 2 : CALL dbcsr_init_p(sinmat)
3096 2 : CALL dbcsr_init_p(tmp)
3097 2 : CALL dbcsr_init_p(cosmat_desymm)
3098 2 : CALL dbcsr_init_p(sinmat_desymm)
3099 2 : CALL dbcsr_create(matrix=cosmat, template=matrix_s_aux_aux(1)%matrix)
3100 2 : CALL dbcsr_create(matrix=sinmat, template=matrix_s_aux_aux(1)%matrix)
3101 : CALL dbcsr_create(matrix=tmp, &
3102 : template=matrix_s_aux_orb(1)%matrix, &
3103 2 : matrix_type=dbcsr_type_no_symmetry)
3104 : CALL dbcsr_create(matrix=cosmat_desymm, &
3105 : template=matrix_s_aux_aux(1)%matrix, &
3106 2 : matrix_type=dbcsr_type_no_symmetry)
3107 : CALL dbcsr_create(matrix=sinmat_desymm, &
3108 : template=matrix_s_aux_aux(1)%matrix, &
3109 2 : matrix_type=dbcsr_type_no_symmetry)
3110 2 : CALL dbcsr_copy(cosmat, matrix_s_aux_aux(1)%matrix)
3111 2 : CALL dbcsr_copy(sinmat, matrix_s_aux_aux(1)%matrix)
3112 2 : CALL dbcsr_set(cosmat, 0.0_dp)
3113 2 : CALL dbcsr_set(sinmat, 0.0_dp)
3114 :
3115 2 : CALL dbcsr_allocate_matrix_set(matrix_berry_re_mo_mo, nkp)
3116 2 : CALL dbcsr_allocate_matrix_set(matrix_berry_im_mo_mo, nkp)
3117 :
3118 : ! allocate the new MO coefficients in the aux basis
3119 2 : CALL dbcsr_release_p(mat_mo_coeff_Gamma_all)
3120 2 : CALL dbcsr_release_p(mat_mo_coeff_Gamma_occ_and_GW)
3121 :
3122 2 : NULLIFY (mat_mo_coeff_Gamma_all)
3123 2 : CALL dbcsr_init_p(mat_mo_coeff_Gamma_all)
3124 : CALL dbcsr_create(matrix=mat_mo_coeff_Gamma_all, &
3125 : template=matrix_s_aux_orb(1)%matrix, &
3126 2 : matrix_type=dbcsr_type_no_symmetry)
3127 :
3128 2 : CALL dbcsr_copy(mat_mo_coeff_Gamma_all, mat_mo_coeff_aux)
3129 :
3130 2 : NULLIFY (mat_mo_coeff_Gamma_occ_and_GW)
3131 2 : CALL dbcsr_init_p(mat_mo_coeff_Gamma_occ_and_GW)
3132 : CALL dbcsr_create(matrix=mat_mo_coeff_Gamma_occ_and_GW, &
3133 : template=matrix_s_aux_orb(1)%matrix, &
3134 2 : matrix_type=dbcsr_type_no_symmetry)
3135 :
3136 2 : CALL dbcsr_copy(mat_mo_coeff_Gamma_occ_and_GW, mat_mo_coeff_aux)
3137 :
3138 8 : DEALLOCATE (evals_P, evals_P_sqrt_inv)
3139 :
3140 : END IF
3141 :
3142 6 : CALL remove_unnecessary_blocks(mat_mo_coeff_Gamma_occ_and_GW, homo, gw_corr_lev_virt)
3143 :
3144 11166 : DO ikp = 1, nkp
3145 :
3146 11160 : ALLOCATE (matrix_berry_re_mo_mo(ikp)%matrix)
3147 11160 : CALL dbcsr_init_p(matrix_berry_re_mo_mo(ikp)%matrix)
3148 : CALL dbcsr_create(matrix_berry_re_mo_mo(ikp)%matrix, &
3149 : template=matrix_s(1)%matrix, &
3150 11160 : matrix_type=dbcsr_type_no_symmetry)
3151 11160 : CALL dbcsr_desymmetrize(matrix_s(1)%matrix, matrix_berry_re_mo_mo(ikp)%matrix)
3152 11160 : CALL dbcsr_set(matrix_berry_re_mo_mo(ikp)%matrix, 0.0_dp)
3153 :
3154 11160 : ALLOCATE (matrix_berry_im_mo_mo(ikp)%matrix)
3155 11160 : CALL dbcsr_init_p(matrix_berry_im_mo_mo(ikp)%matrix)
3156 : CALL dbcsr_create(matrix_berry_im_mo_mo(ikp)%matrix, &
3157 : template=matrix_s(1)%matrix, &
3158 11160 : matrix_type=dbcsr_type_no_symmetry)
3159 11160 : CALL dbcsr_desymmetrize(matrix_s(1)%matrix, matrix_berry_im_mo_mo(ikp)%matrix)
3160 11160 : CALL dbcsr_set(matrix_berry_im_mo_mo(ikp)%matrix, 0.0_dp)
3161 :
3162 44640 : correct_kpoint(1:3) = -twopi*kpoints%xkp(1:3, ikp)
3163 :
3164 11160 : abs_kpoint = SQRT(correct_kpoint(1)**2 + correct_kpoint(2)**2 + correct_kpoint(3)**2)
3165 :
3166 11160 : IF (abs_kpoint < eps_kpoint) THEN
3167 :
3168 0 : scale_kpoint = eps_kpoint/abs_kpoint
3169 0 : correct_kpoint(:) = correct_kpoint(:)*scale_kpoint
3170 :
3171 : END IF
3172 :
3173 : ! get the Berry phase
3174 11160 : IF (do_aux_bas) THEN
3175 : CALL build_berry_moment_matrix(qs_env, cosmat, sinmat, correct_kpoint, sab_orb_external=sab_orb_mic, &
3176 1944 : basis_type="AUX_GW")
3177 : ELSE
3178 : CALL build_berry_moment_matrix(qs_env, cosmat, sinmat, correct_kpoint, sab_orb_external=sab_orb_mic, &
3179 9216 : basis_type="ORB")
3180 : END IF
3181 :
3182 11160 : IF (do_mo_coeff_Gamma_only) THEN
3183 :
3184 11160 : CALL dbcsr_desymmetrize(cosmat, cosmat_desymm)
3185 :
3186 : CALL dbcsr_multiply('N', 'N', 1.0_dp, cosmat_desymm, mat_mo_coeff_Gamma_occ_and_GW, 0.0_dp, tmp, &
3187 11160 : filter_eps=1.0E-15_dp)
3188 :
3189 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_Gamma_all, tmp, 0.0_dp, &
3190 11160 : matrix_berry_re_mo_mo(ikp)%matrix, filter_eps=1.0E-15_dp)
3191 :
3192 11160 : CALL dbcsr_desymmetrize(sinmat, sinmat_desymm)
3193 :
3194 : CALL dbcsr_multiply('N', 'N', 1.0_dp, sinmat_desymm, mat_mo_coeff_Gamma_occ_and_GW, 0.0_dp, tmp, &
3195 11160 : filter_eps=1.0E-15_dp)
3196 :
3197 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_Gamma_all, tmp, 0.0_dp, &
3198 11160 : matrix_berry_im_mo_mo(ikp)%matrix, filter_eps=1.0E-15_dp)
3199 :
3200 : ELSE
3201 :
3202 : ! get mo coeff at the ikp
3203 : CALL copy_fm_to_dbcsr(kpoints%kp_env(ikp)%kpoint_env%mos(1, 1)%mo_coeff, &
3204 0 : mat_mo_coeff_re, keep_sparsity=.FALSE.)
3205 :
3206 : CALL copy_fm_to_dbcsr(kpoints%kp_env(ikp)%kpoint_env%mos(2, 1)%mo_coeff, &
3207 0 : mat_mo_coeff_im, keep_sparsity=.FALSE.)
3208 :
3209 0 : CALL dbcsr_desymmetrize(cosmat, cosmat_desymm)
3210 :
3211 0 : CALL dbcsr_desymmetrize(sinmat, sinmat_desymm)
3212 :
3213 : ! I.
3214 0 : CALL dbcsr_multiply('N', 'N', 1.0_dp, cosmat_desymm, mat_mo_coeff_re, 0.0_dp, tmp)
3215 :
3216 : ! I.1
3217 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_Gamma_all, tmp, 0.0_dp, &
3218 0 : matrix_berry_re_mo_mo(ikp)%matrix)
3219 :
3220 : ! II.
3221 0 : CALL dbcsr_multiply('N', 'N', 1.0_dp, sinmat_desymm, mat_mo_coeff_re, 0.0_dp, tmp)
3222 :
3223 : ! II.5
3224 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_Gamma_all, tmp, 0.0_dp, &
3225 0 : matrix_berry_im_mo_mo(ikp)%matrix)
3226 :
3227 : ! III.
3228 0 : CALL dbcsr_multiply('N', 'N', 1.0_dp, cosmat_desymm, mat_mo_coeff_im, 0.0_dp, tmp)
3229 :
3230 : ! III.7
3231 : CALL dbcsr_multiply('T', 'N', 1.0_dp, mat_mo_coeff_Gamma_all, tmp, 1.0_dp, &
3232 0 : matrix_berry_im_mo_mo(ikp)%matrix)
3233 :
3234 : ! IV.
3235 0 : CALL dbcsr_multiply('N', 'N', 1.0_dp, sinmat_desymm, mat_mo_coeff_im, 0.0_dp, tmp)
3236 :
3237 : ! IV.3
3238 : CALL dbcsr_multiply('T', 'N', -1.0_dp, mat_mo_coeff_Gamma_all, tmp, 1.0_dp, &
3239 0 : matrix_berry_re_mo_mo(ikp)%matrix)
3240 :
3241 : END IF
3242 :
3243 11166 : IF (abs_kpoint < eps_kpoint) THEN
3244 :
3245 0 : CALL dbcsr_scale(matrix_berry_im_mo_mo(ikp)%matrix, 1.0_dp/scale_kpoint)
3246 0 : CALL dbcsr_set(matrix_berry_re_mo_mo(ikp)%matrix, 0.0_dp)
3247 0 : CALL dbcsr_add_on_diag(matrix_berry_re_mo_mo(ikp)%matrix, 1.0_dp)
3248 :
3249 : END IF
3250 :
3251 : END DO
3252 :
3253 6 : CALL dbcsr_release_p(cosmat)
3254 6 : CALL dbcsr_release_p(sinmat)
3255 6 : CALL dbcsr_release_p(mat_mo_coeff_re)
3256 6 : CALL dbcsr_release_p(mat_mo_coeff_im)
3257 6 : CALL dbcsr_release_p(mat_mo_coeff_Gamma_all)
3258 6 : CALL dbcsr_release_p(mat_mo_coeff_Gamma_occ_and_GW)
3259 6 : CALL dbcsr_release_p(tmp)
3260 6 : CALL dbcsr_release_p(cosmat_desymm)
3261 6 : CALL dbcsr_release_p(sinmat_desymm)
3262 6 : DEALLOCATE (orb_basis_set_list)
3263 :
3264 6 : CALL release_neighbor_list_sets(sab_orb_mic)
3265 :
3266 6 : IF (do_aux_bas) THEN
3267 :
3268 2 : DEALLOCATE (gw_aux_basis_set_list)
3269 2 : CALL dbcsr_deallocate_matrix_set(matrix_s_aux_aux)
3270 2 : CALL dbcsr_deallocate_matrix_set(matrix_s_aux_orb)
3271 2 : CALL dbcsr_release_p(mat_work_aux_orb)
3272 2 : CALL dbcsr_release_p(mat_work_aux_orb_2)
3273 2 : CALL dbcsr_release_p(mat_mo_coeff_aux)
3274 2 : CALL dbcsr_release_p(mat_mo_coeff_aux_2)
3275 2 : CALL dbcsr_release_p(matrix_s_inv_aux_aux)
3276 2 : CALL dbcsr_release_p(matrix_P)
3277 2 : CALL dbcsr_release_p(matrix_P_sqrt)
3278 2 : CALL dbcsr_release_p(matrix_P_sqrt_inv)
3279 :
3280 2 : CALL cp_fm_struct_release(fm_struct_aux_aux)
3281 :
3282 2 : CALL cp_fm_release(fm_mat_s_aux_aux_inv)
3283 2 : CALL cp_fm_release(fm_mat_work_aux_aux)
3284 2 : CALL cp_fm_release(fm_mat_P)
3285 2 : CALL cp_fm_release(fm_mat_eigv_P)
3286 2 : CALL cp_fm_release(fm_mat_scaled_eigv_P)
3287 2 : CALL cp_fm_release(fm_mat_P_sqrt_inv)
3288 :
3289 : ! Deallocate the neighbor list structure
3290 2 : CALL release_neighbor_list_sets(sgwgw_list)
3291 2 : CALL release_neighbor_list_sets(sgworb_list)
3292 :
3293 : END IF
3294 :
3295 6 : CALL timestop(handle)
3296 :
3297 6 : END SUBROUTINE get_berry_phase
3298 :
3299 : ! **************************************************************************************************
3300 : !> \brief ...
3301 : !> \param mat_mo_coeff_Gamma_occ_and_GW ...
3302 : !> \param homo ...
3303 : !> \param gw_corr_lev_virt ...
3304 : ! **************************************************************************************************
3305 6 : SUBROUTINE remove_unnecessary_blocks(mat_mo_coeff_Gamma_occ_and_GW, homo, gw_corr_lev_virt)
3306 :
3307 : TYPE(dbcsr_type), POINTER :: mat_mo_coeff_Gamma_occ_and_GW
3308 : INTEGER, INTENT(IN) :: homo, gw_corr_lev_virt
3309 :
3310 : INTEGER :: col, col_offset, row
3311 6 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
3312 : TYPE(dbcsr_iterator_type) :: iter
3313 :
3314 6 : CALL dbcsr_iterator_start(iter, mat_mo_coeff_Gamma_occ_and_GW)
3315 :
3316 27 : DO WHILE (dbcsr_iterator_blocks_left(iter))
3317 :
3318 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
3319 21 : col_offset=col_offset)
3320 :
3321 27 : IF (col_offset > homo + gw_corr_lev_virt) THEN
3322 :
3323 532 : data_block = 0.0_dp
3324 :
3325 : END IF
3326 :
3327 : END DO
3328 :
3329 6 : CALL dbcsr_iterator_stop(iter)
3330 :
3331 6 : CALL dbcsr_filter(mat_mo_coeff_Gamma_occ_and_GW, 1.0E-15_dp)
3332 :
3333 6 : END SUBROUTINE remove_unnecessary_blocks
3334 :
3335 : ! **************************************************************************************************
3336 : !> \brief ...
3337 : !> \param delta_corr ...
3338 : !> \param eps_inv_head ...
3339 : !> \param kpoints ...
3340 : !> \param qs_env ...
3341 : !> \param matrix_berry_re_mo_mo ...
3342 : !> \param matrix_berry_im_mo_mo ...
3343 : !> \param homo ...
3344 : !> \param gw_corr_lev_occ ...
3345 : !> \param gw_corr_lev_virt ...
3346 : !> \param para_env_RPA ...
3347 : !> \param do_extra_kpoints ...
3348 : ! **************************************************************************************************
3349 260 : SUBROUTINE kpoint_sum_for_eps_inv_head_Berry(delta_corr, eps_inv_head, kpoints, qs_env, matrix_berry_re_mo_mo, &
3350 260 : matrix_berry_im_mo_mo, homo, gw_corr_lev_occ, gw_corr_lev_virt, &
3351 : para_env_RPA, do_extra_kpoints)
3352 :
3353 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
3354 : INTENT(INOUT) :: delta_corr
3355 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: eps_inv_head
3356 : TYPE(kpoint_type), POINTER :: kpoints
3357 : TYPE(qs_environment_type), POINTER :: qs_env
3358 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN) :: matrix_berry_re_mo_mo, &
3359 : matrix_berry_im_mo_mo
3360 : INTEGER, INTENT(IN) :: homo, gw_corr_lev_occ, gw_corr_lev_virt
3361 : TYPE(mp_para_env_type), INTENT(IN), OPTIONAL :: para_env_RPA
3362 : LOGICAL, INTENT(IN) :: do_extra_kpoints
3363 :
3364 : INTEGER :: col, col_offset, col_size, i_col, i_row, &
3365 : ikp, m_level, n_level_gw, nkp, row, &
3366 : row_offset, row_size
3367 : REAL(KIND=dp) :: abs_k_square, cell_volume, &
3368 : check_int_one_over_ksq, contribution, &
3369 : weight
3370 : REAL(KIND=dp), DIMENSION(3) :: correct_kpoint
3371 260 : REAL(KIND=dp), DIMENSION(:), POINTER :: delta_corr_extra
3372 260 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: data_block
3373 : TYPE(cell_type), POINTER :: cell
3374 : TYPE(dbcsr_iterator_type) :: iter, iter_new
3375 :
3376 260 : CALL get_qs_env(qs_env=qs_env, cell=cell)
3377 :
3378 260 : CALL get_cell(cell=cell, deth=cell_volume)
3379 :
3380 260 : nkp = kpoints%nkp
3381 :
3382 3800 : delta_corr = 0.0_dp
3383 :
3384 260 : IF (do_extra_kpoints) THEN
3385 260 : NULLIFY (delta_corr_extra)
3386 780 : ALLOCATE (delta_corr_extra(1 + homo - gw_corr_lev_occ:homo + gw_corr_lev_virt))
3387 3800 : delta_corr_extra = 0.0_dp
3388 : END IF
3389 :
3390 260 : check_int_one_over_ksq = 0.0_dp
3391 :
3392 279620 : DO ikp = 1, nkp
3393 :
3394 279360 : weight = kpoints%wkp(ikp)
3395 :
3396 1117440 : correct_kpoint(1:3) = twopi*kpoints%xkp(1:3, ikp)
3397 :
3398 279360 : abs_k_square = (correct_kpoint(1))**2 + (correct_kpoint(2))**2 + (correct_kpoint(3))**2
3399 :
3400 : ! cos part of the Berry phase
3401 279360 : CALL dbcsr_iterator_start(iter, matrix_berry_re_mo_mo(ikp)%matrix)
3402 465120 : DO WHILE (dbcsr_iterator_blocks_left(iter))
3403 :
3404 : CALL dbcsr_iterator_next_block(iter, row, col, data_block, &
3405 : row_size=row_size, col_size=col_size, &
3406 185760 : row_offset=row_offset, col_offset=col_offset)
3407 :
3408 2880000 : DO i_col = 1, col_size
3409 :
3410 31916160 : DO n_level_gw = 1 + homo - gw_corr_lev_occ, homo + gw_corr_lev_virt
3411 :
3412 31730400 : IF (n_level_gw == i_col + col_offset - 1) THEN
3413 :
3414 26619840 : DO i_row = 1, row_size
3415 :
3416 24481440 : contribution = weight*(eps_inv_head(ikp) - 1.0_dp)/abs_k_square*(data_block(i_row, i_col))**2
3417 :
3418 24481440 : m_level = i_row + row_offset - 1
3419 :
3420 : ! we only compute the correction for n=m
3421 24481440 : IF (m_level .NE. n_level_gw) CYCLE
3422 :
3423 3862080 : IF (.NOT. do_extra_kpoints) THEN
3424 :
3425 0 : delta_corr(n_level_gw) = delta_corr(n_level_gw) + contribution
3426 :
3427 : ELSE
3428 :
3429 1723680 : IF (ikp <= nkp*8/9) THEN
3430 :
3431 1532160 : delta_corr(n_level_gw) = delta_corr(n_level_gw) + contribution
3432 :
3433 : ELSE
3434 :
3435 191520 : delta_corr_extra(n_level_gw) = delta_corr_extra(n_level_gw) + contribution
3436 :
3437 : END IF
3438 :
3439 : END IF
3440 :
3441 : END DO
3442 :
3443 : END IF
3444 :
3445 : END DO
3446 :
3447 : END DO
3448 :
3449 : END DO
3450 :
3451 279360 : CALL dbcsr_iterator_stop(iter)
3452 :
3453 : ! the same for the im. part of the Berry phase
3454 279360 : CALL dbcsr_iterator_start(iter_new, matrix_berry_im_mo_mo(ikp)%matrix)
3455 465120 : DO WHILE (dbcsr_iterator_blocks_left(iter_new))
3456 :
3457 : CALL dbcsr_iterator_next_block(iter_new, row, col, data_block, &
3458 : row_size=row_size, col_size=col_size, &
3459 185760 : row_offset=row_offset, col_offset=col_offset)
3460 :
3461 2880000 : DO i_col = 1, col_size
3462 :
3463 31916160 : DO n_level_gw = 1 + homo - gw_corr_lev_occ, homo + gw_corr_lev_virt
3464 :
3465 31730400 : IF (n_level_gw == i_col + col_offset - 1) THEN
3466 :
3467 26619840 : DO i_row = 1, row_size
3468 :
3469 24481440 : m_level = i_row + row_offset - 1
3470 :
3471 24481440 : contribution = weight*(eps_inv_head(ikp) - 1.0_dp)/abs_k_square*(data_block(i_row, i_col))**2
3472 :
3473 : ! we only compute the correction for n=m
3474 24481440 : IF (m_level .NE. n_level_gw) CYCLE
3475 :
3476 3862080 : IF (.NOT. do_extra_kpoints) THEN
3477 :
3478 0 : delta_corr(n_level_gw) = delta_corr(n_level_gw) + contribution
3479 :
3480 : ELSE
3481 :
3482 1723680 : IF (ikp <= nkp*8/9) THEN
3483 :
3484 1532160 : delta_corr(n_level_gw) = delta_corr(n_level_gw) + contribution
3485 :
3486 : ELSE
3487 :
3488 191520 : delta_corr_extra(n_level_gw) = delta_corr_extra(n_level_gw) + contribution
3489 :
3490 : END IF
3491 :
3492 : END IF
3493 :
3494 : END DO
3495 :
3496 : END IF
3497 :
3498 : END DO
3499 :
3500 : END DO
3501 :
3502 : END DO
3503 :
3504 279360 : CALL dbcsr_iterator_stop(iter_new)
3505 :
3506 838340 : check_int_one_over_ksq = check_int_one_over_ksq + weight/abs_k_square
3507 :
3508 : END DO
3509 :
3510 : ! normalize by the cell volume
3511 3800 : delta_corr = delta_corr/cell_volume*fourpi
3512 :
3513 260 : check_int_one_over_ksq = check_int_one_over_ksq/cell_volume
3514 :
3515 260 : CALL para_env_RPA%sum(delta_corr)
3516 :
3517 260 : IF (do_extra_kpoints) THEN
3518 :
3519 3800 : delta_corr_extra = delta_corr_extra/cell_volume*fourpi
3520 :
3521 7340 : CALL para_env_RPA%sum(delta_corr_extra)
3522 :
3523 3800 : delta_corr(:) = delta_corr(:) + (delta_corr(:) - delta_corr_extra(:))
3524 :
3525 260 : DEALLOCATE (delta_corr_extra)
3526 :
3527 : END IF
3528 :
3529 260 : END SUBROUTINE kpoint_sum_for_eps_inv_head_Berry
3530 :
3531 : ! **************************************************************************************************
3532 : !> \brief ...
3533 : !> \param eps_inv_head ...
3534 : !> \param eps_head ...
3535 : !> \param kpoints ...
3536 : ! **************************************************************************************************
3537 260 : SUBROUTINE compute_eps_inv_head(eps_inv_head, eps_head, kpoints)
3538 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
3539 : INTENT(OUT) :: eps_inv_head
3540 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: eps_head
3541 : TYPE(kpoint_type), POINTER :: kpoints
3542 :
3543 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_eps_inv_head'
3544 :
3545 : INTEGER :: handle, ikp, nkp
3546 :
3547 260 : CALL timeset(routineN, handle)
3548 :
3549 260 : nkp = kpoints%nkp
3550 :
3551 780 : ALLOCATE (eps_inv_head(nkp))
3552 :
3553 279620 : DO ikp = 1, nkp
3554 :
3555 279620 : eps_inv_head(ikp) = 1.0_dp/eps_head(ikp)
3556 :
3557 : END DO
3558 :
3559 260 : CALL timestop(handle)
3560 :
3561 260 : END SUBROUTINE compute_eps_inv_head
3562 :
3563 : ! **************************************************************************************************
3564 : !> \brief ...
3565 : !> \param qs_env ...
3566 : !> \param kpoints ...
3567 : !> \param kp_grid ...
3568 : !> \param num_kp_grids ...
3569 : !> \param para_env ...
3570 : !> \param h_inv ...
3571 : !> \param nmo ...
3572 : !> \param do_mo_coeff_Gamma_only ...
3573 : !> \param do_extra_kpoints ...
3574 : ! **************************************************************************************************
3575 6 : SUBROUTINE get_kpoints(qs_env, kpoints, kp_grid, num_kp_grids, para_env, h_inv, nmo, &
3576 : do_mo_coeff_Gamma_only, do_extra_kpoints)
3577 : TYPE(qs_environment_type), POINTER :: qs_env
3578 : TYPE(kpoint_type), POINTER :: kpoints
3579 : INTEGER, DIMENSION(:), POINTER :: kp_grid
3580 : INTEGER, INTENT(IN) :: num_kp_grids
3581 : TYPE(mp_para_env_type), INTENT(IN) :: para_env
3582 : REAL(KIND=dp), DIMENSION(3, 3), INTENT(INOUT) :: h_inv
3583 : INTEGER, INTENT(IN) :: nmo
3584 : LOGICAL, INTENT(IN) :: do_mo_coeff_Gamma_only, do_extra_kpoints
3585 :
3586 : INTEGER :: end_kp, i, i_grid_level, ix, iy, iz, &
3587 : nkp_inner_grid, nkp_outer_grid, &
3588 : npoints, start_kp
3589 : INTEGER, DIMENSION(3) :: outer_kp_grid
3590 : REAL(KIND=dp) :: kpoint_weight_left, single_weight
3591 : REAL(KIND=dp), DIMENSION(3) :: kpt_latt, reducing_factor
3592 : TYPE(cell_type), POINTER :: cell
3593 6 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
3594 :
3595 6 : NULLIFY (kpoints, cell, particle_set)
3596 :
3597 : ! check whether kp_grid includes the Gamma point. If so, abort.
3598 6 : CPASSERT(MOD(kp_grid(1)*kp_grid(2)*kp_grid(3), 2) == 0)
3599 6 : IF (do_extra_kpoints) THEN
3600 6 : CPASSERT(do_mo_coeff_Gamma_only)
3601 : END IF
3602 :
3603 6 : IF (do_mo_coeff_Gamma_only) THEN
3604 :
3605 6 : outer_kp_grid(1) = kp_grid(1) - 1
3606 6 : outer_kp_grid(2) = kp_grid(2) - 1
3607 6 : outer_kp_grid(3) = kp_grid(3) - 1
3608 :
3609 6 : CALL get_qs_env(qs_env=qs_env, cell=cell, particle_set=particle_set)
3610 :
3611 6 : CALL get_cell(cell, h_inv=h_inv)
3612 :
3613 6 : CALL kpoint_create(kpoints)
3614 :
3615 6 : kpoints%kp_scheme = "GENERAL"
3616 6 : kpoints%symmetry = .FALSE.
3617 6 : kpoints%verbose = .FALSE.
3618 6 : kpoints%full_grid = .FALSE.
3619 6 : kpoints%use_real_wfn = .FALSE.
3620 6 : kpoints%eps_geo = 1.e-6_dp
3621 : npoints = kp_grid(1)*kp_grid(2)*kp_grid(3)/2 + &
3622 6 : (num_kp_grids - 1)*((outer_kp_grid(1) + 1)/2*outer_kp_grid(2)*outer_kp_grid(3) - 1)
3623 :
3624 6 : IF (do_extra_kpoints) THEN
3625 :
3626 6 : CPASSERT(num_kp_grids == 1)
3627 6 : CPASSERT(MOD(kp_grid(1), 4) == 0)
3628 6 : CPASSERT(MOD(kp_grid(2), 4) == 0)
3629 6 : CPASSERT(MOD(kp_grid(3), 4) == 0)
3630 :
3631 : END IF
3632 :
3633 6 : IF (do_extra_kpoints) THEN
3634 :
3635 6 : npoints = kp_grid(1)*kp_grid(2)*kp_grid(3)/2 + kp_grid(1)*kp_grid(2)*kp_grid(3)/2/8
3636 :
3637 : END IF
3638 :
3639 6 : kpoints%full_grid = .TRUE.
3640 6 : kpoints%nkp = npoints
3641 30 : ALLOCATE (kpoints%xkp(3, npoints), kpoints%wkp(npoints))
3642 44646 : kpoints%xkp = 0.0_dp
3643 11166 : kpoints%wkp = 0.0_dp
3644 :
3645 6 : nkp_outer_grid = outer_kp_grid(1)*outer_kp_grid(2)*outer_kp_grid(3)
3646 6 : nkp_inner_grid = kp_grid(1)*kp_grid(2)*kp_grid(3)
3647 :
3648 6 : i = 0
3649 24 : reducing_factor(:) = 1.0_dp
3650 : kpoint_weight_left = 1.0_dp
3651 :
3652 : ! the outer grids
3653 6 : DO i_grid_level = 1, num_kp_grids - 1
3654 :
3655 0 : single_weight = kpoint_weight_left/REAL(nkp_outer_grid, KIND=dp)
3656 :
3657 0 : start_kp = i + 1
3658 :
3659 0 : DO ix = 1, outer_kp_grid(1)
3660 0 : DO iy = 1, outer_kp_grid(2)
3661 0 : DO iz = 1, outer_kp_grid(3)
3662 :
3663 : ! exclude Gamma
3664 0 : IF (2*ix - outer_kp_grid(1) - 1 == 0 .AND. 2*iy - outer_kp_grid(2) - 1 == 0 .AND. &
3665 : 2*iz - outer_kp_grid(3) - 1 == 0) CYCLE
3666 :
3667 : ! use time reversal symmetry k<->-k
3668 0 : IF (2*ix - outer_kp_grid(1) - 1 < 0) CYCLE
3669 :
3670 0 : i = i + 1
3671 : kpt_latt(1) = REAL(2*ix - outer_kp_grid(1) - 1, KIND=dp)/(2._dp*REAL(outer_kp_grid(1), KIND=dp)) &
3672 0 : *reducing_factor(1)
3673 : kpt_latt(2) = REAL(2*iy - outer_kp_grid(2) - 1, KIND=dp)/(2._dp*REAL(outer_kp_grid(2), KIND=dp)) &
3674 0 : *reducing_factor(2)
3675 : kpt_latt(3) = REAL(2*iz - outer_kp_grid(3) - 1, KIND=dp)/(2._dp*REAL(outer_kp_grid(3), KIND=dp)) &
3676 0 : *reducing_factor(3)
3677 0 : kpoints%xkp(1:3, i) = MATMUL(TRANSPOSE(h_inv), kpt_latt(:))
3678 :
3679 0 : IF (2*ix - outer_kp_grid(1) - 1 == 0) THEN
3680 0 : kpoints%wkp(i) = single_weight
3681 : ELSE
3682 0 : kpoints%wkp(i) = 2._dp*single_weight
3683 : END IF
3684 :
3685 : END DO
3686 : END DO
3687 : END DO
3688 :
3689 0 : end_kp = i
3690 :
3691 0 : kpoint_weight_left = kpoint_weight_left - SUM(kpoints%wkp(start_kp:end_kp))
3692 :
3693 0 : reducing_factor(1) = reducing_factor(1)/REAL(outer_kp_grid(1), KIND=dp)
3694 0 : reducing_factor(2) = reducing_factor(2)/REAL(outer_kp_grid(2), KIND=dp)
3695 6 : reducing_factor(3) = reducing_factor(3)/REAL(outer_kp_grid(3), KIND=dp)
3696 :
3697 : END DO
3698 :
3699 6 : single_weight = kpoint_weight_left/REAL(nkp_inner_grid, KIND=dp)
3700 :
3701 : ! the inner grid
3702 94 : DO ix = 1, kp_grid(1)
3703 1406 : DO iy = 1, kp_grid(2)
3704 21240 : DO iz = 1, kp_grid(3)
3705 :
3706 : ! use time reversal symmetry k<->-k
3707 19840 : IF (2*ix - kp_grid(1) - 1 < 0) CYCLE
3708 :
3709 9920 : i = i + 1
3710 9920 : kpt_latt(1) = REAL(2*ix - kp_grid(1) - 1, KIND=dp)/(2._dp*REAL(kp_grid(1), KIND=dp))*reducing_factor(1)
3711 9920 : kpt_latt(2) = REAL(2*iy - kp_grid(2) - 1, KIND=dp)/(2._dp*REAL(kp_grid(2), KIND=dp))*reducing_factor(2)
3712 9920 : kpt_latt(3) = REAL(2*iz - kp_grid(3) - 1, KIND=dp)/(2._dp*REAL(kp_grid(3), KIND=dp))*reducing_factor(3)
3713 :
3714 39680 : kpoints%xkp(1:3, i) = MATMUL(TRANSPOSE(h_inv), kpt_latt(:))
3715 :
3716 21152 : kpoints%wkp(i) = 2._dp*single_weight
3717 :
3718 : END DO
3719 : END DO
3720 : END DO
3721 :
3722 6 : IF (do_extra_kpoints) THEN
3723 :
3724 6 : single_weight = kpoint_weight_left/REAL(kp_grid(1)*kp_grid(2)*kp_grid(3)/8, KIND=dp)
3725 :
3726 50 : DO ix = 1, kp_grid(1)/2
3727 378 : DO iy = 1, kp_grid(2)/2
3728 2852 : DO iz = 1, kp_grid(3)/2
3729 :
3730 : ! use time reversal symmetry k<->-k
3731 2480 : IF (2*ix - kp_grid(1)/2 - 1 < 0) CYCLE
3732 :
3733 1240 : i = i + 1
3734 1240 : kpt_latt(1) = REAL(2*ix - kp_grid(1)/2 - 1, KIND=dp)/(REAL(kp_grid(1), KIND=dp))
3735 1240 : kpt_latt(2) = REAL(2*iy - kp_grid(2)/2 - 1, KIND=dp)/(REAL(kp_grid(2), KIND=dp))
3736 1240 : kpt_latt(3) = REAL(2*iz - kp_grid(3)/2 - 1, KIND=dp)/(REAL(kp_grid(3), KIND=dp))
3737 :
3738 4960 : kpoints%xkp(1:3, i) = MATMUL(TRANSPOSE(h_inv), kpt_latt(:))
3739 :
3740 2808 : kpoints%wkp(i) = 2._dp*single_weight
3741 :
3742 : END DO
3743 : END DO
3744 : END DO
3745 :
3746 : END IF
3747 :
3748 : ! default: no symmetry settings
3749 11178 : ALLOCATE (kpoints%kp_sym(kpoints%nkp))
3750 11166 : DO i = 1, kpoints%nkp
3751 11160 : NULLIFY (kpoints%kp_sym(i)%kpoint_sym)
3752 11166 : CALL kpoint_sym_create(kpoints%kp_sym(i)%kpoint_sym)
3753 : END DO
3754 :
3755 : ELSE
3756 :
3757 : BLOCK
3758 : TYPE(qs_environment_type), POINTER :: qs_env_kp_Gamma_only
3759 0 : CALL create_kp_from_gamma(qs_env, qs_env_kp_Gamma_only)
3760 :
3761 0 : CALL get_qs_env(qs_env=qs_env, cell=cell, particle_set=particle_set)
3762 :
3763 : CALL calculate_kp_orbitals(qs_env_kp_Gamma_only, kpoints, "MONKHORST-PACK", nadd=nmo, mp_grid=kp_grid(1:3), &
3764 0 : group_size_ext=para_env%num_pe)
3765 :
3766 0 : CALL qs_env_release(qs_env_kp_Gamma_only)
3767 0 : DEALLOCATE (qs_env_kp_Gamma_only)
3768 : END BLOCK
3769 :
3770 : END IF
3771 :
3772 6 : END SUBROUTINE get_kpoints
3773 :
3774 : ! **************************************************************************************************
3775 : !> \brief ...
3776 : !> \param vec_Sigma_c_gw ...
3777 : !> \param Eigenval_DFT ...
3778 : !> \param eps_eigenval ...
3779 : ! **************************************************************************************************
3780 10 : PURE SUBROUTINE average_degenerate_levels(vec_Sigma_c_gw, Eigenval_DFT, eps_eigenval)
3781 : COMPLEX(KIND=dp), DIMENSION(:, :, :), &
3782 : INTENT(INOUT) :: vec_Sigma_c_gw
3783 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval_DFT
3784 : REAL(KIND=dp), INTENT(IN) :: eps_eigenval
3785 :
3786 10 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: avg_self_energy
3787 : INTEGER :: degeneracy, first_degenerate_level, i_deg_level, i_level_gw, j_deg_level, jquad, &
3788 : num_deg_levels, num_integ_points, num_levels_gw
3789 10 : INTEGER, ALLOCATABLE, DIMENSION(:) :: list_degenerate_levels
3790 :
3791 10 : num_levels_gw = SIZE(vec_Sigma_c_gw, 1)
3792 :
3793 30 : ALLOCATE (list_degenerate_levels(num_levels_gw))
3794 130 : list_degenerate_levels = 1
3795 :
3796 10 : num_integ_points = SIZE(vec_Sigma_c_gw, 2)
3797 :
3798 30 : ALLOCATE (avg_self_energy(num_integ_points))
3799 :
3800 120 : DO i_level_gw = 2, num_levels_gw
3801 :
3802 120 : IF (ABS(Eigenval_DFT(i_level_gw) - Eigenval_DFT(i_level_gw - 1)) < eps_eigenval) THEN
3803 :
3804 0 : list_degenerate_levels(i_level_gw) = list_degenerate_levels(i_level_gw - 1)
3805 :
3806 : ELSE
3807 :
3808 110 : list_degenerate_levels(i_level_gw) = list_degenerate_levels(i_level_gw - 1) + 1
3809 :
3810 : END IF
3811 :
3812 : END DO
3813 :
3814 10 : num_deg_levels = list_degenerate_levels(num_levels_gw)
3815 :
3816 130 : DO i_deg_level = 1, num_deg_levels
3817 :
3818 : degeneracy = 0
3819 :
3820 1624 : DO i_level_gw = 1, num_levels_gw
3821 :
3822 1504 : IF (degeneracy == 0 .AND. i_deg_level == list_degenerate_levels(i_level_gw)) THEN
3823 :
3824 120 : first_degenerate_level = i_level_gw
3825 :
3826 : END IF
3827 :
3828 1624 : IF (i_deg_level == list_degenerate_levels(i_level_gw)) THEN
3829 :
3830 120 : degeneracy = degeneracy + 1
3831 :
3832 : END IF
3833 :
3834 : END DO
3835 :
3836 3120 : DO jquad = 1, num_integ_points
3837 :
3838 : avg_self_energy(jquad) = SUM(vec_Sigma_c_gw(first_degenerate_level:first_degenerate_level + degeneracy - 1, jquad, 1)) &
3839 6120 : /REAL(degeneracy, KIND=dp)
3840 :
3841 : END DO
3842 :
3843 250 : DO j_deg_level = 0, degeneracy - 1
3844 :
3845 3240 : vec_Sigma_c_gw(first_degenerate_level + j_deg_level, :, 1) = avg_self_energy(:)
3846 :
3847 : END DO
3848 :
3849 : END DO
3850 :
3851 10 : END SUBROUTINE average_degenerate_levels
3852 :
3853 : ! **************************************************************************************************
3854 : !> \brief ...
3855 : !> \param vec_gw_energ ...
3856 : !> \param vec_omega_fit_gw ...
3857 : !> \param z_value ...
3858 : !> \param m_value ...
3859 : !> \param vec_Sigma_c_gw ...
3860 : !> \param vec_Sigma_x_minus_vxc_gw ...
3861 : !> \param Eigenval ...
3862 : !> \param Eigenval_scf ...
3863 : !> \param n_level_gw ...
3864 : !> \param gw_corr_lev_occ ...
3865 : !> \param gw_corr_lev_vir ...
3866 : !> \param num_poles ...
3867 : !> \param num_fit_points ...
3868 : !> \param crossing_search ...
3869 : !> \param homo ...
3870 : !> \param stop_crit ...
3871 : !> \param fermi_level_offset ...
3872 : !> \param do_gw_im_time ...
3873 : ! **************************************************************************************************
3874 568 : SUBROUTINE fit_and_continuation_2pole(vec_gw_energ, vec_omega_fit_gw, &
3875 1136 : z_value, m_value, vec_Sigma_c_gw, vec_Sigma_x_minus_vxc_gw, &
3876 1136 : Eigenval, Eigenval_scf, n_level_gw, &
3877 : gw_corr_lev_occ, gw_corr_lev_vir, num_poles, &
3878 : num_fit_points, crossing_search, homo, stop_crit, &
3879 : fermi_level_offset, do_gw_im_time)
3880 :
3881 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_gw_energ, vec_omega_fit_gw, z_value, &
3882 : m_value
3883 : COMPLEX(KIND=dp), DIMENSION(:, :), INTENT(IN) :: vec_Sigma_c_gw
3884 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec_Sigma_x_minus_vxc_gw, Eigenval, &
3885 : Eigenval_scf
3886 : INTEGER, INTENT(IN) :: n_level_gw, gw_corr_lev_occ, &
3887 : gw_corr_lev_vir, num_poles, &
3888 : num_fit_points, crossing_search, homo
3889 : REAL(KIND=dp), INTENT(IN) :: stop_crit, fermi_level_offset
3890 : LOGICAL, INTENT(IN) :: do_gw_im_time
3891 :
3892 : CHARACTER(LEN=*), PARAMETER :: routineN = 'fit_and_continuation_2pole'
3893 :
3894 : COMPLEX(KIND=dp) :: func_val, rho1
3895 568 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: dLambda, dLambda_2, Lambda, &
3896 568 : Lambda_without_offset, vec_b_gw, &
3897 568 : vec_b_gw_copy
3898 568 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: mat_A_gw, mat_B_gw
3899 : INTEGER :: handle4, ierr, iii, iiter, info, &
3900 : integ_range, jjj, jquad, kkk, &
3901 : max_iter_fit, n_level_gw_ref, num_var, &
3902 : xpos
3903 568 : INTEGER, ALLOCATABLE, DIMENSION(:) :: ipiv
3904 : LOGICAL :: could_exit
3905 : REAL(KIND=dp) :: chi2, chi2_old, delta, deriv_val_real, e_fermi, gw_energ, Ldown, &
3906 : level_energ_GW, Lup, range_step, ScalParam, sign_occ_virt, stat_error
3907 568 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Lambda_Im, Lambda_Re, stat_errors, &
3908 568 : vec_N_gw, vec_omega_fit_gw_sign
3909 568 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: mat_N_gw
3910 :
3911 568 : max_iter_fit = 10000
3912 :
3913 568 : num_var = 2*num_poles + 1
3914 1704 : ALLOCATE (Lambda(num_var))
3915 3408 : Lambda = z_zero
3916 1136 : ALLOCATE (Lambda_without_offset(num_var))
3917 3408 : Lambda_without_offset = z_zero
3918 1704 : ALLOCATE (Lambda_Re(num_var))
3919 3408 : Lambda_Re = 0.0_dp
3920 1136 : ALLOCATE (Lambda_Im(num_var))
3921 3408 : Lambda_Im = 0.0_dp
3922 :
3923 1704 : ALLOCATE (vec_omega_fit_gw_sign(num_fit_points))
3924 :
3925 568 : IF (n_level_gw <= gw_corr_lev_occ) THEN
3926 : sign_occ_virt = -1.0_dp
3927 : ELSE
3928 405 : sign_occ_virt = 1.0_dp
3929 : END IF
3930 :
3931 568 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
3932 :
3933 6630 : DO jquad = 1, num_fit_points
3934 6630 : vec_omega_fit_gw_sign(jquad) = ABS(vec_omega_fit_gw(jquad))*sign_occ_virt
3935 : END DO
3936 :
3937 : ! initial guess
3938 568 : range_step = (vec_omega_fit_gw_sign(num_fit_points) - vec_omega_fit_gw_sign(1))/(num_poles - 1)
3939 1704 : DO iii = 1, num_poles
3940 1704 : Lambda_Im(2*iii + 1) = vec_omega_fit_gw_sign(1) + (iii - 1)*range_step
3941 : END DO
3942 568 : range_step = (vec_omega_fit_gw_sign(num_fit_points) - vec_omega_fit_gw_sign(1))/num_poles
3943 1704 : DO iii = 1, num_poles
3944 1704 : Lambda_Re(2*iii + 1) = ABS(vec_omega_fit_gw_sign(1) + (iii - 0.5_dp)*range_step)
3945 : END DO
3946 :
3947 3408 : DO iii = 1, num_var
3948 3408 : Lambda(iii) = Lambda_Re(iii) + gaussi*Lambda_Im(iii)
3949 : END DO
3950 :
3951 : CALL calc_chi2(chi2_old, Lambda, vec_Sigma_c_gw, vec_omega_fit_gw_sign, num_poles, &
3952 568 : num_fit_points, n_level_gw)
3953 :
3954 2272 : ALLOCATE (mat_A_gw(num_poles + 1, num_poles + 1))
3955 1704 : ALLOCATE (vec_b_gw(num_poles + 1))
3956 1704 : ALLOCATE (ipiv(num_poles + 1))
3957 7384 : mat_A_gw = z_zero
3958 2272 : vec_b_gw = 0.0_dp
3959 :
3960 2272 : mat_A_gw(1:num_poles + 1, 1) = z_one
3961 568 : integ_range = num_fit_points/num_poles
3962 2272 : DO kkk = 1, num_poles + 1
3963 1704 : xpos = (kkk - 1)*integ_range + 1
3964 1704 : xpos = MIN(xpos, num_fit_points)
3965 : ! calculate coefficient at this point
3966 5112 : DO iii = 1, num_poles
3967 3408 : jjj = iii*2
3968 : func_val = z_one/(gaussi*vec_omega_fit_gw_sign(xpos) - &
3969 3408 : CMPLX(Lambda_Re(jjj + 1), Lambda_Im(jjj + 1), KIND=dp))
3970 5112 : mat_A_gw(kkk, iii + 1) = func_val
3971 : END DO
3972 2272 : vec_b_gw(kkk) = vec_Sigma_c_gw(n_level_gw, xpos)
3973 : END DO
3974 :
3975 : ! Solve system of linear equations
3976 568 : CALL ZGETRF(num_poles + 1, num_poles + 1, mat_A_gw, num_poles + 1, ipiv, info)
3977 :
3978 568 : CALL ZGETRS('N', num_poles + 1, 1, mat_A_gw, num_poles + 1, ipiv, vec_b_gw, num_poles + 1, info)
3979 :
3980 568 : Lambda_Re(1) = REAL(vec_b_gw(1))
3981 568 : Lambda_Im(1) = AIMAG(vec_b_gw(1))
3982 1704 : DO iii = 1, num_poles
3983 1136 : jjj = iii*2
3984 1136 : Lambda_Re(jjj) = REAL(vec_b_gw(iii + 1))
3985 1704 : Lambda_Im(jjj) = AIMAG(vec_b_gw(iii + 1))
3986 : END DO
3987 :
3988 568 : DEALLOCATE (mat_A_gw)
3989 568 : DEALLOCATE (vec_b_gw)
3990 568 : DEALLOCATE (ipiv)
3991 :
3992 2272 : ALLOCATE (mat_A_gw(num_var*2, num_var*2))
3993 2272 : ALLOCATE (mat_B_gw(num_fit_points, num_var*2))
3994 1704 : ALLOCATE (dLambda(num_fit_points))
3995 1136 : ALLOCATE (dLambda_2(num_fit_points))
3996 1704 : ALLOCATE (vec_b_gw(num_var*2))
3997 1136 : ALLOCATE (vec_b_gw_copy(num_var*2))
3998 1704 : ALLOCATE (ipiv(num_var*2))
3999 :
4000 : ScalParam = 0.01_dp
4001 : Ldown = 1.5_dp
4002 : Lup = 10.0_dp
4003 : could_exit = .FALSE.
4004 :
4005 : ! iteration loop for fitting
4006 1083686 : DO iiter = 1, max_iter_fit
4007 :
4008 1083659 : CALL timeset(routineN//"_fit_loop_1", handle4)
4009 :
4010 : ! calc delta lambda
4011 6501954 : DO iii = 1, num_var
4012 6501954 : Lambda(iii) = Lambda_Re(iii) + gaussi*Lambda_Im(iii)
4013 : END DO
4014 12309521 : dLambda = z_zero
4015 :
4016 12309521 : DO kkk = 1, num_fit_points
4017 11225862 : func_val = Lambda(1)
4018 33677586 : DO iii = 1, num_poles
4019 22451724 : jjj = iii*2
4020 33677586 : func_val = func_val + Lambda(jjj)/(vec_omega_fit_gw_sign(kkk)*gaussi - Lambda(jjj + 1))
4021 : END DO
4022 12309521 : dLambda(kkk) = vec_Sigma_c_gw(n_level_gw, kkk) - func_val
4023 : END DO
4024 12309521 : rho1 = SUM(dLambda*dLambda)
4025 :
4026 : ! fill matrix
4027 124178869 : mat_B_gw = z_zero
4028 12309521 : DO iii = 1, num_fit_points
4029 11225862 : mat_B_gw(iii, 1) = 1.0_dp
4030 12309521 : mat_B_gw(iii, num_var + 1) = gaussi
4031 : END DO
4032 3250977 : DO iii = 1, num_poles
4033 2167318 : jjj = iii*2
4034 25702701 : DO kkk = 1, num_fit_points
4035 22451724 : mat_B_gw(kkk, jjj) = 1.0_dp/(gaussi*vec_omega_fit_gw_sign(kkk) - Lambda(jjj + 1))
4036 22451724 : mat_B_gw(kkk, jjj + num_var) = gaussi/(gaussi*vec_omega_fit_gw_sign(kkk) - Lambda(jjj + 1))
4037 22451724 : mat_B_gw(kkk, jjj + 1) = Lambda(jjj)/(gaussi*vec_omega_fit_gw_sign(kkk) - Lambda(jjj + 1))**2
4038 : mat_B_gw(kkk, jjj + 1 + num_var) = (-Lambda_Im(jjj) + gaussi*Lambda_Re(jjj))/ &
4039 24619042 : (gaussi*vec_omega_fit_gw_sign(kkk) - Lambda(jjj + 1))**2
4040 : END DO
4041 : END DO
4042 :
4043 1083659 : CALL timestop(handle4)
4044 :
4045 1083659 : CALL timeset(routineN//"_fit_matmul_1", handle4)
4046 :
4047 : CALL zgemm('C', 'N', num_var*2, num_var*2, num_fit_points, z_one, mat_B_gw, num_fit_points, mat_B_gw, num_fit_points, &
4048 1083659 : z_zero, mat_A_gw, num_var*2)
4049 1083659 : CALL timestop(handle4)
4050 :
4051 1083659 : CALL timeset(routineN//"_fit_zgemv_1", handle4)
4052 : CALL zgemv('C', num_fit_points, num_var*2, z_one, mat_B_gw, num_fit_points, dLambda, 1, &
4053 1083659 : z_zero, vec_b_gw, 1)
4054 :
4055 1083659 : CALL timestop(handle4)
4056 :
4057 : ! scale diagonal elements of a_mat
4058 11920249 : DO iii = 1, num_var*2
4059 11920249 : mat_A_gw(iii, iii) = mat_A_gw(iii, iii) + ScalParam*mat_A_gw(iii, iii)
4060 : END DO
4061 :
4062 : ! solve linear system
4063 : ierr = 0
4064 11920249 : ipiv = 0
4065 :
4066 1083659 : CALL timeset(routineN//"_fit_lin_eq_2", handle4)
4067 :
4068 1083659 : CALL ZGETRF(2*num_var, 2*num_var, mat_A_gw, 2*num_var, ipiv, info)
4069 :
4070 1083659 : CALL ZGETRS('N', 2*num_var, 1, mat_A_gw, 2*num_var, ipiv, vec_b_gw, 2*num_var, info)
4071 :
4072 1083659 : CALL timestop(handle4)
4073 :
4074 6501954 : DO iii = 1, num_var
4075 6501954 : Lambda(iii) = Lambda_Re(iii) + gaussi*Lambda_Im(iii) + vec_b_gw(iii) + vec_b_gw(iii + num_var)
4076 : END DO
4077 :
4078 : ! calculate chi2
4079 : CALL calc_chi2(chi2, Lambda, vec_Sigma_c_gw, vec_omega_fit_gw_sign, num_poles, &
4080 1083659 : num_fit_points, n_level_gw)
4081 :
4082 : ! if the fit is already super accurate, exit. otherwise maybe issues when dividing by 0
4083 1083659 : IF (chi2 < 1.0E-30_dp) EXIT
4084 :
4085 1083595 : IF (chi2 < chi2_old) THEN
4086 920165 : ScalParam = MAX(ScalParam/Ldown, 1E-12_dp)
4087 5520990 : DO iii = 1, num_var
4088 4600825 : Lambda_Re(iii) = Lambda_Re(iii) + REAL(vec_b_gw(iii) + vec_b_gw(iii + num_var))
4089 5520990 : Lambda_Im(iii) = Lambda_Im(iii) + AIMAG(vec_b_gw(iii) + vec_b_gw(iii + num_var))
4090 : END DO
4091 920165 : IF (chi2_old/chi2 - 1.0_dp < stop_crit) could_exit = .TRUE.
4092 920165 : chi2_old = chi2
4093 : ELSE
4094 163430 : ScalParam = ScalParam*Lup
4095 : END IF
4096 1083595 : IF (ScalParam > 100.0_dp .AND. could_exit) EXIT
4097 :
4098 4335204 : IF (ScalParam > 1E+10_dp) ScalParam = 1E-4_dp
4099 :
4100 : END DO
4101 :
4102 568 : IF (.NOT. do_gw_im_time) THEN
4103 :
4104 : ! change a_0 [Lambda(1)], so that Sigma(i0) = Fit(i0)
4105 : ! do not do this for imaginary time since we do not have many fit points and the fit should be perfect
4106 420 : func_val = Lambda(1)
4107 1260 : DO iii = 1, num_poles
4108 840 : jjj = iii*2
4109 : ! calculate value of the fit function
4110 1260 : func_val = func_val + Lambda(jjj)/(-Lambda(jjj + 1))
4111 : END DO
4112 :
4113 420 : Lambda_Re(1) = Lambda_Re(1) - REAL(func_val) + REAL(vec_Sigma_c_gw(n_level_gw, num_fit_points))
4114 420 : Lambda_Im(1) = Lambda_Im(1) - AIMAG(func_val) + AIMAG(vec_Sigma_c_gw(n_level_gw, num_fit_points))
4115 :
4116 : END IF
4117 :
4118 3408 : Lambda_without_offset(:) = Lambda(:)
4119 :
4120 3408 : DO iii = 1, num_var
4121 3408 : Lambda(iii) = CMPLX(Lambda_Re(iii), Lambda_Im(iii), KIND=dp)
4122 : END DO
4123 :
4124 568 : IF (do_gw_im_time) THEN
4125 : ! for cubic-scaling GW, we have one Green's function for occ and virt states with the Fermi level
4126 : ! in the middle of homo and lumo
4127 148 : e_fermi = 0.5_dp*(Eigenval(homo) + Eigenval(homo + 1))
4128 : ELSE
4129 : ! in case of O(N^4) GW, we have the Fermi level differently for occ and virt states, see
4130 : ! Fig. 1 in JCTC 12, 3623-3635 (2016)
4131 420 : IF (n_level_gw <= gw_corr_lev_occ) THEN
4132 666 : e_fermi = MAXVAL(Eigenval(homo - gw_corr_lev_occ + 1:homo)) + fermi_level_offset
4133 : ELSE
4134 3738 : e_fermi = MINVAL(Eigenval(homo + 1:homo + gw_corr_lev_vir)) - fermi_level_offset
4135 : END IF
4136 : END IF
4137 :
4138 : ! either Z-shot or Newton/bisection crossing search for evaluating Sigma_c
4139 568 : IF (crossing_search == ri_rpa_g0w0_crossing_z_shot .OR. &
4140 : crossing_search == ri_rpa_g0w0_crossing_newton) THEN
4141 :
4142 : ! calculate Sigma_c_fit(e_n) and Z
4143 568 : func_val = Lambda(1)
4144 568 : z_value(n_level_gw) = 1.0_dp
4145 1704 : DO iii = 1, num_poles
4146 1136 : jjj = iii*2
4147 : z_value(n_level_gw) = z_value(n_level_gw) + REAL(Lambda(jjj)/ &
4148 1136 : (Eigenval(n_level_gw_ref) - e_fermi - Lambda(jjj + 1))**2)
4149 1704 : func_val = func_val + Lambda(jjj)/(Eigenval(n_level_gw_ref) - e_fermi - Lambda(jjj + 1))
4150 : END DO
4151 : ! m is the slope of the correl self-energy
4152 568 : m_value(n_level_gw) = 1.0_dp - z_value(n_level_gw)
4153 568 : z_value(n_level_gw) = 1.0_dp/z_value(n_level_gw)
4154 568 : gw_energ = REAL(func_val)
4155 568 : vec_gw_energ(n_level_gw) = gw_energ
4156 :
4157 : ! in case one wants to do Newton-Raphson on top of the Z-shot
4158 568 : IF (crossing_search == ri_rpa_g0w0_crossing_newton) THEN
4159 :
4160 : level_energ_GW = (Eigenval_scf(n_level_gw_ref) - &
4161 : m_value(n_level_gw)*Eigenval(n_level_gw_ref) + &
4162 : vec_gw_energ(n_level_gw) + &
4163 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref))* &
4164 32 : z_value(n_level_gw)
4165 :
4166 : ! Newton-Raphson iteration
4167 240 : DO kkk = 1, 1000
4168 :
4169 : ! calculate the value of the fit function for level_energ_GW
4170 240 : func_val = Lambda(1)
4171 240 : z_value(n_level_gw) = 1.0_dp
4172 720 : DO iii = 1, num_poles
4173 480 : jjj = iii*2
4174 720 : func_val = func_val + Lambda(jjj)/(level_energ_GW - e_fermi - Lambda(jjj + 1))
4175 : END DO
4176 :
4177 : ! calculate the derivative of the fit function for level_energ_GW
4178 240 : deriv_val_real = -1.0_dp
4179 720 : DO iii = 1, num_poles
4180 480 : jjj = iii*2
4181 : deriv_val_real = deriv_val_real + REAL(Lambda(jjj))/((ABS(level_energ_GW - e_fermi - Lambda(jjj + 1)))**2) &
4182 : - (REAL(Lambda(jjj))*(level_energ_GW - e_fermi) - REAL(Lambda(jjj)*CONJG(Lambda(jjj + 1))))* &
4183 : 2.0_dp*(level_energ_GW - e_fermi - REAL(Lambda(jjj + 1)))/ &
4184 720 : ((ABS(level_energ_GW - e_fermi - Lambda(jjj + 1)))**2)
4185 :
4186 : END DO
4187 :
4188 : delta = (Eigenval_scf(n_level_gw_ref) + vec_Sigma_x_minus_vxc_gw(n_level_gw_ref) + REAL(func_val) - level_energ_GW)/ &
4189 240 : deriv_val_real
4190 :
4191 240 : level_energ_GW = level_energ_GW - delta
4192 :
4193 240 : IF (ABS(delta) < 1.0E-08) EXIT
4194 :
4195 : END DO
4196 :
4197 : ! update the GW-energy by Newton-Raphson and set the Z-value to 1
4198 :
4199 32 : vec_gw_energ(n_level_gw) = REAL(func_val)
4200 32 : z_value(n_level_gw) = 1.0_dp
4201 32 : m_value(n_level_gw) = 0.0_dp
4202 :
4203 : END IF ! Newton-Raphson on top of Z-shot
4204 :
4205 : ELSE
4206 0 : CPABORT("Only NONE, ZSHOT and NEWTON implemented for 2-pole model")
4207 : END IF ! decision crossing search none, Z-shot
4208 :
4209 : ! --------------------------------------------
4210 : ! | calculate statistical error due to fitting |
4211 : ! --------------------------------------------
4212 :
4213 : ! estimate the statistical error of the calculated Sigma_c(i*omega)
4214 : ! by sqrt(chi2/n), where n is the number of fit points
4215 :
4216 : CALL calc_chi2(chi2, Lambda_without_offset, vec_Sigma_c_gw, vec_omega_fit_gw_sign, num_poles, &
4217 568 : num_fit_points, n_level_gw)
4218 :
4219 : ! Estimate the statistical error of every fit point
4220 568 : stat_error = SQRT(chi2/num_fit_points)
4221 :
4222 : ! allocate N array containing the second derivatives of chi^2
4223 1704 : ALLOCATE (vec_N_gw(num_var*2))
4224 6248 : vec_N_gw = 0.0_dp
4225 :
4226 2272 : ALLOCATE (mat_N_gw(num_var*2, num_var*2))
4227 63048 : mat_N_gw = 0.0_dp
4228 :
4229 6248 : DO iii = 1, num_var*2
4230 : CALL calc_mat_N(vec_N_gw(iii), Lambda_without_offset, vec_Sigma_c_gw, vec_omega_fit_gw_sign, &
4231 6248 : iii, iii, num_poles, num_fit_points, n_level_gw, 0.001_dp)
4232 : END DO
4233 :
4234 6248 : DO iii = 1, num_var*2
4235 63048 : DO jjj = 1, num_var*2
4236 : CALL calc_mat_N(mat_N_gw(iii, jjj), Lambda_without_offset, vec_Sigma_c_gw, vec_omega_fit_gw_sign, &
4237 62480 : iii, jjj, num_poles, num_fit_points, n_level_gw, 0.001_dp)
4238 : END DO
4239 : END DO
4240 :
4241 568 : CALL DGETRF(2*num_var, 2*num_var, mat_N_gw, 2*num_var, ipiv, info)
4242 :
4243 : ! vec_b_gw is only working array
4244 568 : CALL DGETRI(2*num_var, mat_N_gw, 2*num_var, ipiv, vec_b_gw, 2*num_var, info)
4245 :
4246 1136 : ALLOCATE (stat_errors(2*num_var))
4247 6248 : stat_errors = 0.0_dp
4248 :
4249 6248 : DO iii = 1, 2*num_var
4250 6248 : stat_errors(iii) = SQRT(ABS(mat_N_gw(iii, iii)))*stat_error
4251 : END DO
4252 :
4253 568 : DEALLOCATE (mat_N_gw)
4254 568 : DEALLOCATE (vec_N_gw)
4255 568 : DEALLOCATE (mat_A_gw)
4256 568 : DEALLOCATE (mat_B_gw)
4257 568 : DEALLOCATE (stat_errors)
4258 568 : DEALLOCATE (dLambda)
4259 568 : DEALLOCATE (dLambda_2)
4260 568 : DEALLOCATE (vec_b_gw)
4261 568 : DEALLOCATE (vec_b_gw_copy)
4262 568 : DEALLOCATE (ipiv)
4263 568 : DEALLOCATE (vec_omega_fit_gw_sign)
4264 568 : DEALLOCATE (Lambda)
4265 568 : DEALLOCATE (Lambda_without_offset)
4266 568 : DEALLOCATE (Lambda_Re)
4267 568 : DEALLOCATE (Lambda_Im)
4268 :
4269 568 : END SUBROUTINE fit_and_continuation_2pole
4270 :
4271 : ! **************************************************************************************************
4272 : !> \brief perform analytic continuation with pade approximation
4273 : !> \param vec_gw_energ real Sigma_c
4274 : !> \param vec_omega_fit_gw frequency points for Sigma_c(iomega)
4275 : !> \param z_value 1/(1-dev)
4276 : !> \param m_value derivative of real Sigma_c
4277 : !> \param vec_Sigma_c_gw complex Sigma_c(iomega)
4278 : !> \param vec_Sigma_x_minus_vxc_gw ...
4279 : !> \param Eigenval quasiparticle energy during ev self-consistent GW
4280 : !> \param Eigenval_scf KS/HF eigenvalue
4281 : !> \param do_hedin_shift ...
4282 : !> \param n_level_gw ...
4283 : !> \param gw_corr_lev_occ ...
4284 : !> \param gw_corr_lev_vir ...
4285 : !> \param nparam_pade number of pade parameters
4286 : !> \param num_fit_points number of fit points for Sigma_c(iomega)
4287 : !> \param crossing_search type ofr cross search to find quasiparticle energies
4288 : !> \param homo ...
4289 : !> \param fermi_level_offset ...
4290 : !> \param do_gw_im_time ...
4291 : !> \param print_self_energy ...
4292 : !> \param count_ev_sc_GW ...
4293 : !> \param vec_gw_dos ...
4294 : !> \param dos_lower_bound ...
4295 : !> \param dos_precision ...
4296 : !> \param ndos ...
4297 : !> \param min_level_self_energy ...
4298 : !> \param max_level_self_energy ...
4299 : !> \param dos_eta ...
4300 : !> \param dos_min ...
4301 : !> \param dos_max ...
4302 : !> \param e_fermi_ext ...
4303 : ! **************************************************************************************************
4304 3228 : SUBROUTINE continuation_pade(vec_gw_energ, vec_omega_fit_gw, &
4305 6456 : z_value, m_value, vec_Sigma_c_gw, vec_Sigma_x_minus_vxc_gw, &
4306 6456 : Eigenval, Eigenval_scf, do_hedin_shift, n_level_gw, &
4307 : gw_corr_lev_occ, gw_corr_lev_vir, &
4308 : nparam_pade, num_fit_points, crossing_search, homo, &
4309 : fermi_level_offset, do_gw_im_time, print_self_energy, count_ev_sc_GW, &
4310 : vec_gw_dos, dos_lower_bound, dos_precision, ndos, &
4311 : min_level_self_energy, max_level_self_energy, &
4312 : dos_eta, dos_min, dos_max, e_fermi_ext)
4313 :
4314 : ! Optional arguments for spectral function
4315 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_gw_energ
4316 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec_omega_fit_gw
4317 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: z_value, m_value
4318 : COMPLEX(KIND=dp), DIMENSION(:, :), INTENT(IN) :: vec_Sigma_c_gw
4319 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec_Sigma_x_minus_vxc_gw, Eigenval, &
4320 : Eigenval_scf
4321 : LOGICAL, INTENT(IN) :: do_hedin_shift
4322 : INTEGER, INTENT(IN) :: n_level_gw, gw_corr_lev_occ, &
4323 : gw_corr_lev_vir, nparam_pade, &
4324 : num_fit_points, crossing_search, homo
4325 : REAL(KIND=dp), INTENT(IN) :: fermi_level_offset
4326 : LOGICAL, INTENT(IN) :: do_gw_im_time, print_self_energy
4327 : INTEGER, INTENT(IN) :: count_ev_sc_GW
4328 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), OPTIONAL :: vec_gw_dos
4329 : REAL(KIND=dp), OPTIONAL :: dos_lower_bound, dos_precision
4330 : INTEGER, INTENT(IN), OPTIONAL :: ndos, min_level_self_energy, &
4331 : max_level_self_energy
4332 : REAL(KIND=dp), OPTIONAL :: dos_eta
4333 : INTEGER, INTENT(IN), OPTIONAL :: dos_min, dos_max
4334 : REAL(KIND=dp), OPTIONAL :: e_fermi_ext
4335 :
4336 : CHARACTER(LEN=*), PARAMETER :: routineN = 'continuation_pade'
4337 :
4338 : CHARACTER(LEN=5) :: string_level
4339 : CHARACTER(len=default_path_length) :: filename
4340 : COMPLEX(KIND=dp) :: sigma_c_pade, sigma_c_pade_im_freq
4341 3228 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: coeff_pade, omega_points_pade, &
4342 3228 : Sigma_c_gw_reorder
4343 : INTEGER :: handle, i_omega, idos, iunit, jquad, &
4344 : n_level_gw_ref, num_omega
4345 : REAL(KIND=dp) :: e_fermi, energy_val, hedin_shift, &
4346 : level_energ_GW_start, omega, &
4347 : omega_dos, omega_dos_pade_eval, &
4348 : sign_occ_virt
4349 3228 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: vec_omega_fit_gw_sign, &
4350 3228 : vec_omega_fit_gw_sign_reorder, &
4351 3228 : vec_sigma_imag, vec_sigma_real
4352 : TYPE(cp_logger_type), POINTER :: logger
4353 :
4354 3228 : CALL timeset(routineN, handle)
4355 :
4356 9684 : ALLOCATE (vec_omega_fit_gw_sign(num_fit_points))
4357 :
4358 3228 : IF (n_level_gw <= gw_corr_lev_occ) THEN
4359 : sign_occ_virt = -1.0_dp
4360 : ELSE
4361 2168 : sign_occ_virt = 1.0_dp
4362 : END IF
4363 :
4364 111160 : DO jquad = 1, num_fit_points
4365 111160 : vec_omega_fit_gw_sign(jquad) = ABS(vec_omega_fit_gw(jquad))*sign_occ_virt
4366 : END DO
4367 :
4368 3228 : IF (do_gw_im_time) THEN
4369 : ! for cubic-scaling GW, we have one Green's function for occ and virt states
4370 : ! with the Fermi level in the middle of homo and lumo
4371 1836 : e_fermi = 0.5_dp*(Eigenval(homo) + Eigenval(homo + 1))
4372 : ELSE
4373 : ! in case of O(N^4) GW, we have the Fermi level differently for occ and virt states, see
4374 : ! Fig. 1 in JCTC 12, 3623-3635 (2016)
4375 1392 : IF (n_level_gw <= gw_corr_lev_occ) THEN
4376 2136 : e_fermi = MAXVAL(Eigenval(homo - gw_corr_lev_occ + 1:homo)) + fermi_level_offset
4377 : ELSE
4378 14184 : e_fermi = MINVAL(Eigenval(homo + 1:homo + gw_corr_lev_vir)) - fermi_level_offset
4379 : END IF
4380 : END IF
4381 :
4382 3228 : IF (PRESENT(e_fermi_ext)) e_fermi = e_fermi_ext
4383 :
4384 3228 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
4385 :
4386 : !*** reorder, such that omega=i*0 is first entry
4387 9684 : ALLOCATE (Sigma_c_gw_reorder(num_fit_points))
4388 6456 : ALLOCATE (vec_omega_fit_gw_sign_reorder(num_fit_points))
4389 : ! for cubic scaling GW fit points are ordered differently than in N^4 GW
4390 3228 : IF (do_gw_im_time) THEN
4391 9640 : DO jquad = 1, num_fit_points
4392 7804 : Sigma_c_gw_reorder(jquad) = vec_Sigma_c_gw(n_level_gw, jquad)
4393 9640 : vec_omega_fit_gw_sign_reorder(jquad) = vec_omega_fit_gw_sign(jquad)
4394 : END DO
4395 : ELSE
4396 101520 : DO jquad = 1, num_fit_points
4397 100128 : Sigma_c_gw_reorder(jquad) = vec_Sigma_c_gw(n_level_gw, num_fit_points - jquad + 1)
4398 101520 : vec_omega_fit_gw_sign_reorder(jquad) = vec_omega_fit_gw_sign(num_fit_points - jquad + 1)
4399 : END DO
4400 : END IF
4401 :
4402 : !*** evaluate parameters for pade approximation
4403 9684 : ALLOCATE (coeff_pade(nparam_pade))
4404 6456 : ALLOCATE (omega_points_pade(nparam_pade))
4405 31680 : coeff_pade = 0.0_dp
4406 : CALL get_pade_parameters(Sigma_c_gw_reorder, vec_omega_fit_gw_sign_reorder, &
4407 3228 : num_fit_points, nparam_pade, omega_points_pade, coeff_pade)
4408 :
4409 : !*** calculate start_value for iterative cross-searching methods
4410 3228 : IF ((crossing_search == ri_rpa_g0w0_crossing_bisection) .OR. &
4411 : (crossing_search == ri_rpa_g0w0_crossing_newton)) THEN
4412 3228 : energy_val = Eigenval(n_level_gw_ref) - e_fermi
4413 : CALL evaluate_pade_function(energy_val, nparam_pade, omega_points_pade, &
4414 3228 : coeff_pade, sigma_c_pade)
4415 : CALL get_z_and_m_value_pade(energy_val, nparam_pade, omega_points_pade, &
4416 3228 : coeff_pade, z_value(n_level_gw), m_value(n_level_gw))
4417 : level_energ_GW_start = (Eigenval_scf(n_level_gw_ref) - &
4418 : m_value(n_level_gw)*Eigenval(n_level_gw_ref) + &
4419 : REAL(sigma_c_pade) + &
4420 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref))* &
4421 3228 : z_value(n_level_gw)
4422 :
4423 : ! calculate Hedin shift; the last line is for evGW0 and evGW
4424 3228 : hedin_shift = 0.0_dp
4425 3228 : IF (do_hedin_shift) hedin_shift = REAL(sigma_c_pade) + &
4426 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref) &
4427 60 : - Eigenval(n_level_gw_ref) + Eigenval_scf(n_level_gw_ref)
4428 : END IF
4429 :
4430 3228 : IF (PRESENT(min_level_self_energy) .AND. PRESENT(max_level_self_energy)) THEN
4431 1668 : IF (n_level_gw_ref >= min_level_self_energy .AND. &
4432 : n_level_gw_ref <= max_level_self_energy) THEN
4433 0 : ALLOCATE (vec_sigma_real(ndos))
4434 0 : ALLOCATE (vec_sigma_imag(ndos))
4435 0 : WRITE (string_level, "(I4)") n_level_gw_ref
4436 0 : string_level = ADJUSTL(string_level)
4437 : END IF
4438 : END IF
4439 :
4440 : !*** Calculate spectral function
4441 : !*** 1 \‾‾ |Im 𝚺ₘ(ω)|+η
4442 : !*** A(ω) = --- | ---------------------------------------------------
4443 : !*** π /__ [ω - eₘ^DFT - (Re 𝚺ₘ(ω) - vₘ^xc)]² + (|Im 𝚺ₘ(ω)|+η)²
4444 :
4445 3228 : IF (PRESENT(ndos)) THEN
4446 1668 : IF (ndos /= 0) THEN
4447 : ! Hedin shift not implemented
4448 0 : CPASSERT(.NOT. do_hedin_shift)
4449 0 : logger => cp_get_default_logger()
4450 0 : IF (logger%para_env%is_source()) THEN
4451 0 : iunit = cp_logger_get_default_unit_nr()
4452 : ELSE
4453 0 : iunit = -1
4454 : END IF
4455 0 : DO idos = 1, ndos
4456 0 : omega_dos = dos_lower_bound + REAL(idos - 1, KIND=dp)*dos_precision
4457 0 : omega_dos_pade_eval = omega_dos - e_fermi
4458 : CALL evaluate_pade_function(omega_dos_pade_eval, nparam_pade, omega_points_pade, &
4459 0 : coeff_pade, sigma_c_pade)
4460 :
4461 : IF (n_level_gw_ref >= min_level_self_energy .AND. &
4462 0 : n_level_gw_ref <= max_level_self_energy .AND. iunit > 0) THEN
4463 :
4464 0 : vec_sigma_real(idos) = (REAL(sigma_c_pade))
4465 0 : vec_sigma_imag(idos) = (AIMAG(sigma_c_pade))
4466 :
4467 : END IF
4468 :
4469 0 : IF (n_level_gw_ref >= dos_min .AND. &
4470 0 : (n_level_gw_ref <= dos_max .OR. dos_max == 0)) THEN
4471 : vec_gw_dos(idos) = vec_gw_dos(idos) + &
4472 : (ABS(AIMAG(sigma_c_pade)) + dos_eta) &
4473 : /( &
4474 : (omega_dos - Eigenval_scf(n_level_gw_ref) - &
4475 : (REAL(sigma_c_pade) + vec_Sigma_x_minus_vxc_gw(n_level_gw_ref)) &
4476 : )**2 &
4477 : + (ABS(AIMAG(sigma_c_pade)) + dos_eta)**2 &
4478 0 : )
4479 : END IF
4480 :
4481 : END DO
4482 : END IF
4483 : END IF
4484 :
4485 3228 : IF (PRESENT(min_level_self_energy) .AND. PRESENT(max_level_self_energy)) THEN
4486 1668 : logger => cp_get_default_logger()
4487 1668 : IF (logger%para_env%is_source()) THEN
4488 1644 : iunit = cp_logger_get_default_unit_nr()
4489 : ELSE
4490 24 : iunit = -1
4491 : END IF
4492 : IF (n_level_gw_ref >= min_level_self_energy .AND. &
4493 1668 : n_level_gw_ref <= max_level_self_energy .AND. iunit > 0) THEN
4494 :
4495 : CALL open_file('self_energy_re_'//TRIM(string_level)//'.dat', unit_number=iunit, &
4496 0 : file_status="UNKNOWN", file_action="WRITE")
4497 0 : DO idos = 1, ndos
4498 0 : omega_dos = dos_lower_bound + REAL(idos - 1, KIND=dp)*dos_precision
4499 0 : WRITE (iunit, '(F17.10, F17.10)') omega_dos*evolt, vec_sigma_real(idos)*evolt
4500 : END DO
4501 :
4502 0 : CALL close_file(iunit)
4503 :
4504 : CALL open_file('self_energy_im_'//TRIM(string_level)//'.dat', unit_number=iunit, &
4505 0 : file_status="UNKNOWN", file_action="WRITE")
4506 0 : DO idos = 1, ndos
4507 0 : omega_dos = dos_lower_bound + REAL(idos - 1, KIND=dp)*dos_precision
4508 0 : WRITE (iunit, '(F17.10, F17.10)') omega_dos*evolt, vec_sigma_imag(idos)*evolt
4509 : END DO
4510 :
4511 0 : CALL close_file(iunit)
4512 :
4513 0 : DEALLOCATE (vec_sigma_real)
4514 0 : DEALLOCATE (vec_sigma_imag)
4515 : END IF
4516 : END IF
4517 :
4518 : !*** perform crossing search
4519 0 : SELECT CASE (crossing_search)
4520 : CASE (ri_rpa_g0w0_crossing_z_shot)
4521 : ! Hedin shift not implemented
4522 0 : CPASSERT(.NOT. do_hedin_shift)
4523 0 : energy_val = Eigenval(n_level_gw_ref) - e_fermi
4524 : CALL evaluate_pade_function(energy_val, nparam_pade, omega_points_pade, &
4525 0 : coeff_pade, sigma_c_pade)
4526 0 : vec_gw_energ(n_level_gw) = REAL(sigma_c_pade)
4527 :
4528 : CALL get_z_and_m_value_pade(energy_val, nparam_pade, omega_points_pade, &
4529 0 : coeff_pade, z_value(n_level_gw), m_value(n_level_gw))
4530 :
4531 : CASE (ri_rpa_g0w0_crossing_bisection)
4532 : CALL get_sigma_c_bisection_pade(vec_gw_energ(n_level_gw), Eigenval_scf(n_level_gw_ref), &
4533 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref), e_fermi, &
4534 : nparam_pade, omega_points_pade, coeff_pade, &
4535 8 : level_energ_GW_start, hedin_shift)
4536 8 : z_value(n_level_gw) = 1.0_dp
4537 8 : m_value(n_level_gw) = 0.0_dp
4538 :
4539 : CASE (ri_rpa_g0w0_crossing_newton)
4540 : CALL get_sigma_c_newton_pade(vec_gw_energ(n_level_gw), Eigenval_scf(n_level_gw_ref), &
4541 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref), e_fermi, &
4542 : nparam_pade, omega_points_pade, coeff_pade, &
4543 3220 : level_energ_GW_start, hedin_shift)
4544 3220 : z_value(n_level_gw) = 1.0_dp
4545 3220 : m_value(n_level_gw) = 0.0_dp
4546 :
4547 : CASE DEFAULT
4548 3228 : CPABORT("Only Z_SHOT, NEWTON, and BISECTION crossing search implemented.")
4549 : END SELECT
4550 :
4551 3228 : IF (print_self_energy) THEN
4552 :
4553 0 : IF (count_ev_sc_GW == 1) THEN
4554 :
4555 0 : IF (n_level_gw_ref < 10) THEN
4556 0 : WRITE (filename, "(A26,I1)") "G0W0_self_energy_level_000", n_level_gw_ref
4557 0 : ELSE IF (n_level_gw_ref < 100) THEN
4558 0 : WRITE (filename, "(A25,I2)") "G0W0_self_energy_level_00", n_level_gw_ref
4559 0 : ELSE IF (n_level_gw_ref < 1000) THEN
4560 0 : WRITE (filename, "(A24,I3)") "G0W0_self_energy_level_0", n_level_gw_ref
4561 : ELSE
4562 0 : WRITE (filename, "(A23,I4)") "G0W0_self_energy_level_", n_level_gw_ref
4563 : END IF
4564 :
4565 : ELSE
4566 :
4567 0 : IF (n_level_gw_ref < 10) THEN
4568 0 : WRITE (filename, "(A11,I1,A22,I1)") "evGW_cycle_", count_ev_sc_GW, &
4569 0 : "_self_energy_level_000", n_level_gw_ref
4570 0 : ELSE IF (n_level_gw_ref < 100) THEN
4571 0 : WRITE (filename, "(A11,I1,A21,I2)") "evGW_cycle_", count_ev_sc_GW, &
4572 0 : "_self_energy_level_00", n_level_gw_ref
4573 0 : ELSE IF (n_level_gw_ref < 1000) THEN
4574 0 : WRITE (filename, "(A11,I1,A20,I3)") "evGW_cycle_", count_ev_sc_GW, &
4575 0 : "_self_energy_level_0", n_level_gw_ref
4576 : ELSE
4577 0 : WRITE (filename, "(A11,I1,A19,I4)") "evGW_cycle_", count_ev_sc_GW, &
4578 0 : "_self_energy_level_", n_level_gw_ref
4579 : END IF
4580 :
4581 : END IF
4582 :
4583 0 : logger => cp_get_default_logger()
4584 0 : IF (logger%para_env%is_source()) THEN
4585 0 : iunit = cp_logger_get_default_unit_nr()
4586 : ELSE
4587 0 : iunit = -1
4588 : END IF
4589 0 : CALL open_file(TRIM(filename), unit_number=iunit, file_status="UNKNOWN", file_action="WRITE")
4590 :
4591 0 : num_omega = 10000
4592 :
4593 0 : WRITE (iunit, "(2A42)") " omega (eV) Sigma(omega) (eV) ", &
4594 0 : " omega - e_n^DFT - Sigma_n^x - v_n^xc (eV)"
4595 :
4596 0 : DO i_omega = 0, num_omega
4597 :
4598 0 : omega = -50.0_dp/evolt + REAL(i_omega, KIND=dp)/REAL(num_omega, KIND=dp)*100.0_dp/evolt
4599 :
4600 : CALL evaluate_pade_function(omega - e_fermi, nparam_pade, omega_points_pade, &
4601 0 : coeff_pade, sigma_c_pade)
4602 :
4603 0 : WRITE (iunit, "(F12.2,2F17.5)") omega*evolt, REAL(sigma_c_pade)*evolt, &
4604 0 : (omega - Eigenval_scf(n_level_gw_ref) - vec_Sigma_x_minus_vxc_gw(n_level_gw_ref))*evolt
4605 :
4606 : END DO
4607 :
4608 0 : WRITE (iunit, "(A51,A39)") " w (eV) Re(Sigma(i*w)) (eV) Im(Sigma(i*w)) (eV) ", &
4609 0 : " Re(Fit(i*w)) (eV) Im(Fit(iw)) (eV)"
4610 :
4611 0 : DO jquad = 1, num_fit_points
4612 :
4613 : CALL evaluate_pade_function(vec_omega_fit_gw_sign_reorder(jquad), &
4614 : nparam_pade, omega_points_pade, &
4615 0 : coeff_pade, sigma_c_pade_im_freq, do_imag_freq=.TRUE.)
4616 :
4617 0 : WRITE (iunit, "(F12.2,4F17.5)") vec_omega_fit_gw_sign_reorder(jquad)*evolt, &
4618 0 : REAL(Sigma_c_gw_reorder(jquad)*evolt), &
4619 0 : AIMAG(Sigma_c_gw_reorder(jquad)*evolt), &
4620 0 : REAL(sigma_c_pade_im_freq*evolt), &
4621 0 : AIMAG(sigma_c_pade_im_freq*evolt)
4622 :
4623 : END DO
4624 :
4625 0 : CALL close_file(iunit)
4626 :
4627 : END IF
4628 :
4629 3228 : DEALLOCATE (vec_omega_fit_gw_sign)
4630 3228 : DEALLOCATE (Sigma_c_gw_reorder)
4631 3228 : DEALLOCATE (vec_omega_fit_gw_sign_reorder)
4632 3228 : DEALLOCATE (coeff_pade, omega_points_pade)
4633 :
4634 3228 : CALL timestop(handle)
4635 :
4636 6456 : END SUBROUTINE continuation_pade
4637 :
4638 : ! **************************************************************************************************
4639 : !> \brief calculate pade parameter recursively as in Eq. (A2) in J. Low Temp. Phys., Vol. 29,
4640 : !> 1977, pp. 179
4641 : !> \param y f(x), here: Sigma_c(iomega)
4642 : !> \param x the frequency points omega
4643 : !> \param num_fit_points ...
4644 : !> \param nparam number of pade parameters
4645 : !> \param xpoints set of points used in pade approximation, selection of x
4646 : !> \param coeff pade coefficients
4647 : ! **************************************************************************************************
4648 3228 : PURE SUBROUTINE get_pade_parameters(y, x, num_fit_points, nparam, xpoints, coeff)
4649 :
4650 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: y
4651 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: x
4652 : INTEGER, INTENT(IN) :: num_fit_points, nparam
4653 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(INOUT) :: xpoints, coeff
4654 :
4655 3228 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: ypoints
4656 3228 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: g_mat
4657 : INTEGER :: idat, iparam, nstep
4658 :
4659 3228 : nstep = INT(num_fit_points/(nparam - 1))
4660 :
4661 9684 : ALLOCATE (ypoints(nparam))
4662 : !omega=i0 is in element x(1)
4663 3228 : idat = 1
4664 28452 : DO iparam = 1, nparam - 1
4665 25224 : xpoints(iparam) = gaussi*x(idat)
4666 25224 : ypoints(iparam) = y(idat)
4667 28452 : idat = idat + nstep
4668 : END DO
4669 3228 : xpoints(nparam) = gaussi*x(num_fit_points)
4670 3228 : ypoints(nparam) = y(num_fit_points)
4671 :
4672 : !*** generate parameters recursively
4673 :
4674 12912 : ALLOCATE (g_mat(nparam, nparam))
4675 31680 : g_mat(:, 1) = ypoints(:)
4676 28452 : DO iparam = 2, nparam
4677 193534 : DO idat = iparam, nparam
4678 : g_mat(idat, iparam) = (g_mat(iparam - 1, iparam - 1) - g_mat(idat, iparam - 1))/ &
4679 190306 : ((xpoints(idat) - xpoints(iparam - 1))*g_mat(idat, iparam - 1))
4680 : END DO
4681 : END DO
4682 :
4683 31680 : DO iparam = 1, nparam
4684 31680 : coeff(iparam) = g_mat(iparam, iparam)
4685 : END DO
4686 :
4687 3228 : DEALLOCATE (ypoints)
4688 3228 : DEALLOCATE (g_mat)
4689 :
4690 3228 : END SUBROUTINE get_pade_parameters
4691 :
4692 : ! **************************************************************************************************
4693 : !> \brief evaluate pade function for a real value x_val
4694 : !> \param x_val real value
4695 : !> \param nparam number of pade parameters
4696 : !> \param xpoints selection of points of the original complex function, i.e. here of Sigma_c(iomega)
4697 : !> \param coeff pade coefficients
4698 : !> \param func_val function value
4699 : !> \param do_imag_freq ...
4700 : ! **************************************************************************************************
4701 12689 : PURE SUBROUTINE evaluate_pade_function(x_val, nparam, xpoints, coeff, func_val, do_imag_freq)
4702 :
4703 : REAL(KIND=dp), INTENT(IN) :: x_val
4704 : INTEGER, INTENT(IN) :: nparam
4705 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: xpoints, coeff
4706 : COMPLEX(KIND=dp), INTENT(OUT) :: func_val
4707 : LOGICAL, INTENT(IN), OPTIONAL :: do_imag_freq
4708 :
4709 : INTEGER :: iparam
4710 : LOGICAL :: my_do_imag_freq
4711 :
4712 12689 : my_do_imag_freq = .FALSE.
4713 12689 : IF (PRESENT(do_imag_freq)) my_do_imag_freq = do_imag_freq
4714 :
4715 12689 : func_val = z_one
4716 95285 : DO iparam = nparam, 2, -1
4717 95285 : IF (my_do_imag_freq) THEN
4718 0 : func_val = z_one + coeff(iparam)*(gaussi*x_val - xpoints(iparam - 1))/func_val
4719 : ELSE
4720 82596 : func_val = z_one + coeff(iparam)*(x_val*z_one - xpoints(iparam - 1))/func_val
4721 : END IF
4722 : END DO
4723 :
4724 12689 : func_val = coeff(1)/func_val
4725 :
4726 12689 : END SUBROUTINE evaluate_pade_function
4727 :
4728 : ! **************************************************************************************************
4729 : !> \brief get the z-value and the m-value (derivative) of the pade function
4730 : !> \param x_val real value
4731 : !> \param nparam number of pade parameters
4732 : !> \param xpoints selection of points of the original complex function, i.e. here of Sigma_c(iomega)
4733 : !> \param coeff pade coefficients
4734 : !> \param z_value 1/(1-dev)
4735 : !> \param m_value derivative
4736 : ! **************************************************************************************************
4737 12581 : PURE SUBROUTINE get_z_and_m_value_pade(x_val, nparam, xpoints, coeff, z_value, m_value)
4738 :
4739 : REAL(KIND=dp), INTENT(IN) :: x_val
4740 : INTEGER, INTENT(IN) :: nparam
4741 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: xpoints, coeff
4742 : REAL(KIND=dp), INTENT(OUT), OPTIONAL :: z_value, m_value
4743 :
4744 : COMPLEX(KIND=dp) :: denominator, dev_denominator, &
4745 : dev_numerator, dev_val, func_val, &
4746 : numerator
4747 : INTEGER :: iparam
4748 :
4749 12581 : func_val = z_one
4750 12581 : dev_val = z_zero
4751 95069 : DO iparam = nparam, 2, -1
4752 82488 : numerator = coeff(iparam)*(x_val*z_one - xpoints(iparam - 1))
4753 82488 : dev_numerator = coeff(iparam)*z_one
4754 82488 : denominator = func_val
4755 82488 : dev_denominator = dev_val
4756 82488 : dev_val = dev_numerator/denominator - (numerator*dev_denominator)/(denominator**2)
4757 95069 : func_val = z_one + coeff(iparam)*(x_val*z_one - xpoints(iparam - 1))/func_val
4758 : END DO
4759 :
4760 12581 : dev_val = -1.0_dp*coeff(1)/(func_val**2)*dev_val
4761 12581 : func_val = coeff(1)/func_val
4762 :
4763 12581 : IF (PRESENT(z_value)) THEN
4764 3228 : z_value = 1.0_dp - REAL(dev_val)
4765 3228 : z_value = 1.0_dp/z_value
4766 : END IF
4767 12581 : IF (PRESENT(m_value)) m_value = REAL(dev_val)
4768 :
4769 12581 : END SUBROUTINE get_z_and_m_value_pade
4770 :
4771 : ! **************************************************************************************************
4772 : !> \brief crossing search using the bisection method to find the quasiparticle energy
4773 : !> \param gw_energ real Sigma_c
4774 : !> \param Eigenval_scf Eigenvalue from the SCF
4775 : !> \param Sigma_x_minus_vxc_gw ...
4776 : !> \param e_fermi fermi level
4777 : !> \param nparam_pade number of pade parameters
4778 : !> \param omega_points_pade selection of frequency points of Sigma_c(iomega)
4779 : !> \param coeff_pade pade coefficients
4780 : !> \param start_val start value for the quasiparticle iteration
4781 : !> \param hedin_shift ...
4782 : ! **************************************************************************************************
4783 16 : SUBROUTINE get_sigma_c_bisection_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_gw, e_fermi, &
4784 8 : nparam_pade, omega_points_pade, coeff_pade, start_val, &
4785 : hedin_shift)
4786 :
4787 : REAL(KIND=dp), INTENT(OUT) :: gw_energ
4788 : REAL(KIND=dp), INTENT(IN) :: Eigenval_scf, Sigma_x_minus_vxc_gw, &
4789 : e_fermi
4790 : INTEGER, INTENT(IN) :: nparam_pade
4791 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: omega_points_pade, coeff_pade
4792 : REAL(KIND=dp), INTENT(IN) :: start_val, hedin_shift
4793 :
4794 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_sigma_c_bisection_pade'
4795 :
4796 : COMPLEX(KIND=dp) :: sigma_c
4797 : INTEGER :: handle, icount
4798 : REAL(KIND=dp) :: delta, energy_val, qp_energy, &
4799 : qp_energy_old, threshold
4800 :
4801 8 : CALL timeset(routineN, handle)
4802 :
4803 8 : threshold = 1.0E-7_dp
4804 :
4805 8 : qp_energy = start_val
4806 8 : qp_energy_old = start_val
4807 8 : delta = 1.0E-3_dp
4808 :
4809 8 : icount = 0
4810 116 : DO WHILE (ABS(delta) > threshold)
4811 108 : icount = icount + 1
4812 108 : qp_energy = qp_energy_old + 0.5_dp*delta
4813 108 : qp_energy_old = qp_energy
4814 108 : energy_val = qp_energy - e_fermi - hedin_shift
4815 : CALL evaluate_pade_function(energy_val, nparam_pade, omega_points_pade, &
4816 108 : coeff_pade, sigma_c)
4817 108 : qp_energy = Eigenval_scf + REAL(sigma_c) + Sigma_x_minus_vxc_gw
4818 108 : delta = qp_energy - qp_energy_old
4819 : ! Self-consistent quasi-particle solution has not been found
4820 116 : IF (icount > 500) EXIT
4821 : END DO
4822 :
4823 8 : gw_energ = REAL(sigma_c)
4824 :
4825 8 : CALL timestop(handle)
4826 :
4827 8 : END SUBROUTINE get_sigma_c_bisection_pade
4828 :
4829 : ! **************************************************************************************************
4830 : !> \brief crossing search using the Newton method to find the quasiparticle energy
4831 : !> \param gw_energ real Sigma_c
4832 : !> \param Eigenval_scf Eigenvalue from the SCF
4833 : !> \param Sigma_x_minus_vxc_gw ...
4834 : !> \param e_fermi fermi level
4835 : !> \param nparam_pade number of pade parameters
4836 : !> \param omega_points_pade selection of frequency points of Sigma_c(iomega)
4837 : !> \param coeff_pade pade coefficients
4838 : !> \param start_val start value for the quasiparticle iteration
4839 : !> \param hedin_shift ...
4840 : ! **************************************************************************************************
4841 6440 : SUBROUTINE get_sigma_c_newton_pade(gw_energ, Eigenval_scf, Sigma_x_minus_vxc_gw, e_fermi, &
4842 3220 : nparam_pade, omega_points_pade, coeff_pade, start_val, &
4843 : hedin_shift)
4844 :
4845 : REAL(KIND=dp), INTENT(OUT) :: gw_energ
4846 : REAL(KIND=dp), INTENT(IN) :: Eigenval_scf, Sigma_x_minus_vxc_gw, &
4847 : e_fermi
4848 : INTEGER, INTENT(IN) :: nparam_pade
4849 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: omega_points_pade, coeff_pade
4850 : REAL(KIND=dp), INTENT(IN) :: start_val, hedin_shift
4851 :
4852 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_sigma_c_newton_pade'
4853 :
4854 : COMPLEX(KIND=dp) :: sigma_c
4855 : INTEGER :: handle, icount
4856 : REAL(KIND=dp) :: delta, energy_val, m_value, qp_energy, &
4857 : qp_energy_old, threshold
4858 :
4859 3220 : CALL timeset(routineN, handle)
4860 :
4861 3220 : threshold = 1.0E-7_dp
4862 :
4863 3220 : qp_energy = start_val
4864 3220 : qp_energy_old = start_val
4865 3220 : delta = 1.0E-3_dp
4866 :
4867 3220 : icount = 0
4868 12573 : DO WHILE (ABS(delta) > threshold)
4869 9353 : icount = icount + 1
4870 9353 : energy_val = qp_energy - e_fermi - hedin_shift
4871 : CALL evaluate_pade_function(energy_val, nparam_pade, omega_points_pade, &
4872 9353 : coeff_pade, sigma_c)
4873 : !get m_value --> derivative of function
4874 : CALL get_z_and_m_value_pade(energy_val, nparam_pade, omega_points_pade, &
4875 9353 : coeff_pade, m_value=m_value)
4876 9353 : qp_energy_old = qp_energy
4877 : qp_energy = qp_energy - (Eigenval_scf + Sigma_x_minus_vxc_gw + REAL(sigma_c) - qp_energy)/ &
4878 9353 : (m_value - 1.0_dp)
4879 9353 : delta = qp_energy - qp_energy_old
4880 : ! Self-consistent quasi-particle solution has not been found
4881 12573 : IF (icount > 500) EXIT
4882 : END DO
4883 :
4884 3220 : gw_energ = REAL(sigma_c)
4885 :
4886 3220 : CALL timestop(handle)
4887 :
4888 3220 : END SUBROUTINE get_sigma_c_newton_pade
4889 :
4890 : ! **************************************************************************************************
4891 : !> \brief Prints the GW stuff to the output and optinally to an external file.
4892 : !> Also updates the eigenvalues for eigenvalue-self-consistent GW
4893 : !> \param vec_gw_energ ...
4894 : !> \param z_value ...
4895 : !> \param m_value ...
4896 : !> \param vec_Sigma_x_minus_vxc_gw ...
4897 : !> \param Eigenval ...
4898 : !> \param Eigenval_last ...
4899 : !> \param Eigenval_scf ...
4900 : !> \param gw_corr_lev_occ ...
4901 : !> \param gw_corr_lev_virt ...
4902 : !> \param gw_corr_lev_tot ...
4903 : !> \param crossing_search ...
4904 : !> \param homo ...
4905 : !> \param unit_nr ...
4906 : !> \param count_ev_sc_GW ...
4907 : !> \param count_sc_GW0 ...
4908 : !> \param ikp ...
4909 : !> \param nkp_self_energy ...
4910 : !> \param kpoints ...
4911 : !> \param ispin requested spin-state (1 for alpha, 2 for beta, else closed-shell)
4912 : !> \param E_VBM_GW ...
4913 : !> \param E_CBM_GW ...
4914 : !> \param E_VBM_SCF ...
4915 : !> \param E_CBM_SCF ...
4916 : ! **************************************************************************************************
4917 1872 : SUBROUTINE print_and_update_for_ev_sc(vec_gw_energ, &
4918 468 : z_value, m_value, vec_Sigma_x_minus_vxc_gw, Eigenval, &
4919 468 : Eigenval_last, Eigenval_scf, &
4920 : gw_corr_lev_occ, gw_corr_lev_virt, gw_corr_lev_tot, &
4921 : crossing_search, homo, unit_nr, count_ev_sc_GW, count_sc_GW0, &
4922 : ikp, nkp_self_energy, kpoints, ispin, E_VBM_GW, E_CBM_GW, &
4923 : E_VBM_SCF, E_CBM_SCF)
4924 :
4925 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec_gw_energ, z_value, m_value
4926 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_Sigma_x_minus_vxc_gw, Eigenval, &
4927 : Eigenval_last, Eigenval_scf
4928 : INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, gw_corr_lev_tot, crossing_search, &
4929 : homo, unit_nr, count_ev_sc_GW, count_sc_GW0, ikp, nkp_self_energy
4930 : TYPE(kpoint_type), INTENT(IN), POINTER :: kpoints
4931 : INTEGER, INTENT(IN) :: ispin
4932 : REAL(KIND=dp), INTENT(INOUT), OPTIONAL :: E_VBM_GW, E_CBM_GW, E_VBM_SCF, E_CBM_SCF
4933 :
4934 : CHARACTER(LEN=*), PARAMETER :: routineN = 'print_and_update_for_ev_sc'
4935 :
4936 : CHARACTER(4) :: occ_virt
4937 : INTEGER :: handle, n_level_gw, n_level_gw_ref
4938 : LOGICAL :: do_alpha, do_beta, do_closed_shell, &
4939 : do_kpoints, is_energy_okay
4940 : REAL(KIND=dp) :: E_GAP_GW, E_HOMO_GW, E_HOMO_SCF, &
4941 : E_LUMO_GW, E_LUMO_SCF, new_energy
4942 :
4943 468 : CALL timeset(routineN, handle)
4944 :
4945 468 : do_alpha = (ispin == 1)
4946 468 : do_beta = (ispin == 2)
4947 468 : do_closed_shell = .NOT. (do_alpha .OR. do_beta)
4948 468 : do_kpoints = (nkp_self_energy > 1)
4949 :
4950 10658 : Eigenval_last(:) = Eigenval(:)
4951 :
4952 468 : IF (unit_nr > 0) THEN
4953 :
4954 234 : IF (count_ev_sc_GW == 1 .AND. count_sc_GW0 == 1 .AND. ikp == 1) THEN
4955 :
4956 65 : WRITE (unit_nr, *) ' '
4957 :
4958 65 : IF (do_alpha .OR. do_closed_shell) THEN
4959 58 : WRITE (unit_nr, *) ' '
4960 58 : WRITE (unit_nr, '(T3,A)') '******************************************************************************'
4961 58 : WRITE (unit_nr, '(T3,A)') '** **'
4962 58 : WRITE (unit_nr, '(T3,A)') '** GW QUASIPARTICLE ENERGIES **'
4963 58 : WRITE (unit_nr, '(T3,A)') '** **'
4964 58 : WRITE (unit_nr, '(T3,A)') '******************************************************************************'
4965 58 : WRITE (unit_nr, '(T3,A)') ' '
4966 58 : WRITE (unit_nr, '(T3,A)') ' '
4967 58 : WRITE (unit_nr, '(T3,A)') 'The GW quasiparticle energies are calculated according to: '
4968 :
4969 58 : IF (crossing_search == ri_rpa_g0w0_crossing_z_shot) THEN
4970 16 : WRITE (unit_nr, '(T3,A)') 'E_GW = E_SCF + Z * ( Sigc(E_SCF) + Sigx - vxc )'
4971 : ELSE
4972 42 : WRITE (unit_nr, '(T3,A)') ' '
4973 42 : WRITE (unit_nr, '(T3,A)') ' E_GW = E_SCF + Sigc(E_GW) + Sigx - vxc '
4974 42 : WRITE (unit_nr, '(T3,A)') ' '
4975 42 : WRITE (unit_nr, '(T3,A)') 'Upper equation is solved self-consistently for E_GW, see Eq. (12) in J. Phys.'
4976 42 : WRITE (unit_nr, '(T3,A)') 'Chem. Lett. 9, 306 (2018), doi: 10.1021/acs.jpclett.7b02740'
4977 : END IF
4978 58 : WRITE (unit_nr, *) ' '
4979 58 : WRITE (unit_nr, *) ' '
4980 58 : WRITE (unit_nr, '(T3,A)') '------------'
4981 58 : WRITE (unit_nr, '(T3,A)') 'G0W0 results'
4982 58 : WRITE (unit_nr, '(T3,A)') '------------'
4983 :
4984 : END IF
4985 :
4986 65 : IF (.NOT. do_kpoints) THEN
4987 54 : IF (do_alpha) THEN
4988 5 : WRITE (unit_nr, *) ' '
4989 5 : WRITE (unit_nr, '(T3,A)') '---------------------------------------'
4990 5 : WRITE (unit_nr, '(T3,A)') 'GW quasiparticle energies of alpha spins'
4991 5 : WRITE (unit_nr, '(T3,A)') '----------------------------------------'
4992 49 : ELSE IF (do_beta) THEN
4993 5 : WRITE (unit_nr, *) ' '
4994 5 : WRITE (unit_nr, '(T3,A)') '---------------------------------------'
4995 5 : WRITE (unit_nr, '(T3,A)') 'GW quasiparticle energies of beta spins'
4996 5 : WRITE (unit_nr, '(T3,A)') '---------------------------------------'
4997 : END IF
4998 : END IF
4999 :
5000 : END IF
5001 :
5002 234 : IF (count_ev_sc_GW > 1) THEN
5003 49 : WRITE (unit_nr, *) ' '
5004 49 : WRITE (unit_nr, '(T3,A)') '---------------------------------------'
5005 49 : WRITE (unit_nr, '(T3,A,I4)') 'Eigenvalue-selfconsistency cycle: ', count_ev_sc_GW
5006 49 : WRITE (unit_nr, '(T3,A)') '---------------------------------------'
5007 : END IF
5008 :
5009 234 : IF (count_sc_GW0 > 1) THEN
5010 48 : WRITE (unit_nr, '(T3,A)') '----------------------------------'
5011 48 : WRITE (unit_nr, '(T3,A,I4)') 'scGW0 selfconsistency cycle: ', count_sc_GW0
5012 48 : WRITE (unit_nr, '(T3,A)') '----------------------------------'
5013 : END IF
5014 :
5015 234 : IF (do_kpoints) THEN
5016 84 : WRITE (unit_nr, *) ' '
5017 84 : WRITE (unit_nr, '(T3,A7,I3,A3,I3,A8,3F7.3,A12,3F7.3)') 'Kpoint ', ikp, ' /', nkp_self_energy, &
5018 84 : ' xkp =', kpoints%xkp(1, ikp), kpoints%xkp(2, ikp), kpoints%xkp(3, ikp), &
5019 168 : ' and xkp =', -kpoints%xkp(1, ikp), -kpoints%xkp(2, ikp), -kpoints%xkp(3, ikp)
5020 84 : WRITE (unit_nr, '(T3,A72)') '(Relative Brillouin zone size: [-0.5, 0.5] x [-0.5, 0.5] x [-0.5, 0.5])'
5021 84 : WRITE (unit_nr, *) ' '
5022 84 : IF (do_alpha) THEN
5023 16 : WRITE (unit_nr, '(T3,A)') 'GW quasiparticle energies of alpha spins:'
5024 68 : ELSE IF (do_beta) THEN
5025 16 : WRITE (unit_nr, '(T3,A)') 'GW quasiparticle energies of beta spins:'
5026 : END IF
5027 : END IF
5028 :
5029 : END IF
5030 :
5031 4940 : DO n_level_gw = 1, gw_corr_lev_tot
5032 :
5033 4472 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
5034 :
5035 : new_energy = (Eigenval_scf(n_level_gw_ref) - &
5036 : m_value(n_level_gw)*Eigenval(n_level_gw_ref) + &
5037 : vec_gw_energ(n_level_gw) + &
5038 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref))* &
5039 4472 : z_value(n_level_gw)
5040 :
5041 4472 : is_energy_okay = .TRUE.
5042 :
5043 4472 : IF (n_level_gw_ref > homo .AND. new_energy < Eigenval(homo)) THEN
5044 : is_energy_okay = .FALSE.
5045 : END IF
5046 :
5047 468 : IF (is_energy_okay) THEN
5048 4472 : Eigenval(n_level_gw_ref) = new_energy
5049 : END IF
5050 :
5051 : END DO
5052 :
5053 468 : IF (unit_nr > 0) THEN
5054 234 : WRITE (unit_nr, '(T3,A)') ' '
5055 234 : IF (crossing_search == ri_rpa_g0w0_crossing_z_shot) THEN
5056 39 : WRITE (unit_nr, '(T13,2A)') 'MO E_SCF (eV) Sigc (eV) Sigx-vxc (eV) Z E_GW (eV)'
5057 : ELSE
5058 195 : WRITE (unit_nr, '(T3,2A)') 'Molecular orbital E_SCF (eV) Sigc (eV) Sigx-vxc (eV) E_GW (eV)'
5059 : END IF
5060 : END IF
5061 :
5062 4940 : DO n_level_gw = 1, gw_corr_lev_tot
5063 4472 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
5064 4472 : IF (n_level_gw <= gw_corr_lev_occ) THEN
5065 1266 : occ_virt = 'occ'
5066 : ELSE
5067 3206 : occ_virt = 'vir'
5068 : END IF
5069 :
5070 4940 : IF (unit_nr > 0) THEN
5071 2236 : IF (crossing_search == ri_rpa_g0w0_crossing_z_shot) THEN
5072 : WRITE (unit_nr, '(T3,I4,3A,5F13.4)') &
5073 536 : n_level_gw_ref, ' ( ', occ_virt, ') ', &
5074 536 : Eigenval_last(n_level_gw_ref)*evolt, &
5075 536 : vec_gw_energ(n_level_gw)*evolt, &
5076 536 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref)*evolt, &
5077 536 : z_value(n_level_gw), &
5078 1072 : Eigenval(n_level_gw_ref)*evolt
5079 : ELSE
5080 : WRITE (unit_nr, '(T3,I4,3A,4F16.4)') &
5081 1700 : n_level_gw_ref, ' ( ', occ_virt, ') ', &
5082 1700 : Eigenval_last(n_level_gw_ref)*evolt, &
5083 1700 : vec_gw_energ(n_level_gw)*evolt, &
5084 1700 : vec_Sigma_x_minus_vxc_gw(n_level_gw_ref)*evolt, &
5085 3400 : Eigenval(n_level_gw_ref)*evolt
5086 : END IF
5087 : END IF
5088 : END DO
5089 :
5090 2202 : E_HOMO_SCF = MAXVAL(Eigenval_last(homo - gw_corr_lev_occ + 1:homo))
5091 4142 : E_LUMO_SCF = MINVAL(Eigenval_last(homo + 1:homo + gw_corr_lev_virt))
5092 :
5093 2202 : E_HOMO_GW = MAXVAL(Eigenval(homo - gw_corr_lev_occ + 1:homo))
5094 4142 : E_LUMO_GW = MINVAL(Eigenval(homo + 1:homo + gw_corr_lev_virt))
5095 468 : E_GAP_GW = E_LUMO_GW - E_HOMO_GW
5096 :
5097 : IF (PRESENT(E_VBM_SCF) .AND. PRESENT(E_CBM_SCF) .AND. &
5098 468 : PRESENT(E_VBM_GW) .AND. PRESENT(E_CBM_GW)) THEN
5099 468 : IF (E_HOMO_SCF > E_VBM_SCF) E_VBM_SCF = E_HOMO_SCF
5100 468 : IF (E_LUMO_SCF < E_CBM_SCF) E_CBM_SCF = E_LUMO_SCF
5101 468 : IF (E_HOMO_GW > E_VBM_GW) E_VBM_GW = E_HOMO_GW
5102 468 : IF (E_LUMO_GW < E_CBM_GW) E_CBM_GW = E_LUMO_GW
5103 : END IF
5104 :
5105 468 : IF (unit_nr > 0) THEN
5106 :
5107 234 : IF (do_kpoints) THEN
5108 84 : IF (do_closed_shell) THEN
5109 52 : WRITE (unit_nr, '(T3,A)') ' '
5110 52 : WRITE (unit_nr, '(T3,A,F42.4)') 'GW direct gap at current kpoint (eV)', E_GAP_GW*evolt
5111 32 : ELSE IF (do_alpha) THEN
5112 16 : WRITE (unit_nr, '(T3,A)') ' '
5113 16 : WRITE (unit_nr, '(T3,A,F36.4)') 'Alpha GW direct gap at current kpoint (eV)', &
5114 32 : E_GAP_GW*evolt
5115 16 : ELSE IF (do_beta) THEN
5116 16 : WRITE (unit_nr, '(T3,A)') ' '
5117 16 : WRITE (unit_nr, '(T3,A,F37.4)') 'Beta GW direct gap at current kpoint (eV)', &
5118 32 : E_GAP_GW*evolt
5119 : END IF
5120 : ELSE
5121 150 : IF (do_closed_shell) THEN
5122 132 : WRITE (unit_nr, '(T3,A)') ' '
5123 132 : IF (count_ev_sc_GW > 1) THEN
5124 41 : WRITE (unit_nr, '(T3,A,I3,A,F39.4)') 'HOMO-LUMO gap in evGW iteration', &
5125 82 : count_ev_sc_GW, ' (eV)', E_GAP_GW*evolt
5126 91 : ELSE IF (count_sc_GW0 > 1) THEN
5127 47 : WRITE (unit_nr, '(T3,A,I3,A,F38.4)') 'HOMO-LUMO gap in evGW0 iteration', &
5128 94 : count_sc_GW0, ' (eV)', E_GAP_GW*evolt
5129 : ELSE
5130 44 : WRITE (unit_nr, '(T3,A,F55.4)') 'G0W0 HOMO-LUMO gap (eV)', E_GAP_GW*evolt
5131 : END IF
5132 18 : ELSE IF (do_alpha) THEN
5133 9 : WRITE (unit_nr, '(T3,A)') ' '
5134 9 : WRITE (unit_nr, '(T3,A,F51.4)') 'Alpha GW HOMO-LUMO gap (eV)', E_GAP_GW*evolt
5135 9 : ELSE IF (do_beta) THEN
5136 9 : WRITE (unit_nr, '(T3,A)') ' '
5137 9 : WRITE (unit_nr, '(T3,A,F52.4)') 'Beta GW HOMO-LUMO gap (eV)', E_GAP_GW*evolt
5138 : END IF
5139 : END IF
5140 : END IF
5141 :
5142 468 : IF (unit_nr > 0) THEN
5143 234 : WRITE (unit_nr, *) ' '
5144 234 : WRITE (unit_nr, '(T3,A)') '------------------------------------------------------------------------------'
5145 : END IF
5146 :
5147 468 : CALL timestop(handle)
5148 :
5149 468 : END SUBROUTINE print_and_update_for_ev_sc
5150 :
5151 : ! **************************************************************************************************
5152 : !> \brief ...
5153 : !> \param Eigenval ...
5154 : !> \param Eigenval_last ...
5155 : !> \param gw_corr_lev_occ ...
5156 : !> \param gw_corr_lev_virt ...
5157 : !> \param homo ...
5158 : !> \param nmo ...
5159 : ! **************************************************************************************************
5160 290 : PURE SUBROUTINE shift_unshifted_levels(Eigenval, Eigenval_last, gw_corr_lev_occ, gw_corr_lev_virt, &
5161 : homo, nmo)
5162 :
5163 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: Eigenval, Eigenval_last
5164 : INTEGER, INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo, &
5165 : nmo
5166 :
5167 : INTEGER :: n_level_gw, n_level_gw_ref
5168 : REAL(KIND=dp) :: eigen_diff
5169 :
5170 : ! for eigenvalue self-consistent GW, all eigenvalues have to be corrected
5171 : ! 1) the occupied; check if there are occupied MOs not being corrected by GW
5172 290 : IF (gw_corr_lev_occ < homo .AND. gw_corr_lev_occ > 0) THEN
5173 :
5174 : ! calculate average GW correction for occupied orbitals
5175 : eigen_diff = 0.0_dp
5176 :
5177 88 : DO n_level_gw = 1, gw_corr_lev_occ
5178 44 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
5179 88 : eigen_diff = eigen_diff + Eigenval(n_level_gw_ref) - Eigenval_last(n_level_gw_ref)
5180 : END DO
5181 44 : eigen_diff = eigen_diff/gw_corr_lev_occ
5182 :
5183 : ! correct the eigenvalues of the occupied orbitals which have not been corrected by GW
5184 168 : DO n_level_gw = 1, homo - gw_corr_lev_occ
5185 168 : Eigenval(n_level_gw) = Eigenval(n_level_gw) + eigen_diff
5186 : END DO
5187 :
5188 : END IF
5189 :
5190 : ! 2) the virtual: check if there are virtual orbitals not being corrected by GW
5191 290 : IF (gw_corr_lev_virt < nmo - homo .AND. gw_corr_lev_virt > 0) THEN
5192 :
5193 : ! calculate average GW correction for virtual orbitals
5194 : eigen_diff = 0.0_dp
5195 2996 : DO n_level_gw = 1, gw_corr_lev_virt
5196 2706 : n_level_gw_ref = n_level_gw + homo
5197 2996 : eigen_diff = eigen_diff + Eigenval(n_level_gw_ref) - Eigenval_last(n_level_gw_ref)
5198 : END DO
5199 290 : eigen_diff = eigen_diff/gw_corr_lev_virt
5200 :
5201 : ! correct the eigenvalues of the virtual orbitals which have not been corrected by GW
5202 3090 : DO n_level_gw = homo + gw_corr_lev_virt + 1, nmo
5203 3090 : Eigenval(n_level_gw) = Eigenval(n_level_gw) + eigen_diff
5204 : END DO
5205 :
5206 : END IF
5207 :
5208 290 : END SUBROUTINE shift_unshifted_levels
5209 :
5210 : ! **************************************************************************************************
5211 : !> \brief Calculate the matrix mat_N_gw containing the second derivatives
5212 : !> with respect to the fitting parameters. The second derivatives are
5213 : !> calculated numerically by finite differences.
5214 : !> \param N_ij matrix element
5215 : !> \param Lambda fitting parameters
5216 : !> \param Sigma_c ...
5217 : !> \param vec_omega_fit_gw ...
5218 : !> \param i ...
5219 : !> \param j ...
5220 : !> \param num_poles ...
5221 : !> \param num_fit_points ...
5222 : !> \param n_level_gw ...
5223 : !> \param h ...
5224 : ! **************************************************************************************************
5225 62480 : SUBROUTINE calc_mat_N(N_ij, Lambda, Sigma_c, vec_omega_fit_gw, i, j, &
5226 : num_poles, num_fit_points, n_level_gw, h)
5227 : REAL(KIND=dp), INTENT(OUT) :: N_ij
5228 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:), &
5229 : INTENT(IN) :: Lambda
5230 : COMPLEX(KIND=dp), DIMENSION(:, :), INTENT(IN) :: Sigma_c
5231 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
5232 : INTENT(IN) :: vec_omega_fit_gw
5233 : INTEGER, INTENT(IN) :: i, j, num_poles, num_fit_points, &
5234 : n_level_gw
5235 : REAL(KIND=dp), INTENT(IN) :: h
5236 :
5237 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calc_mat_N'
5238 :
5239 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: Lambda_tmp
5240 : INTEGER :: handle, num_var
5241 : REAL(KIND=dp) :: chi2, chi2_sum
5242 :
5243 62480 : CALL timeset(routineN, handle)
5244 :
5245 62480 : num_var = 2*num_poles + 1
5246 187440 : ALLOCATE (Lambda_tmp(num_var))
5247 374880 : Lambda_tmp = z_zero
5248 62480 : chi2_sum = 0.0_dp
5249 :
5250 : !test
5251 374880 : Lambda_tmp(:) = Lambda(:)
5252 : CALL calc_chi2(chi2, Lambda_tmp, Sigma_c, vec_omega_fit_gw, num_poles, &
5253 62480 : num_fit_points, n_level_gw)
5254 :
5255 : ! Fitting parameters with offset h
5256 374880 : Lambda_tmp(:) = Lambda(:)
5257 62480 : IF (MODULO(i, 2) == 0) THEN
5258 31240 : Lambda_tmp(i/2) = Lambda_tmp(i/2) + h*z_one
5259 : ELSE
5260 31240 : Lambda_tmp((i + 1)/2) = Lambda_tmp((i + 1)/2) + h*gaussi
5261 : END IF
5262 62480 : IF (MODULO(j, 2) == 0) THEN
5263 31240 : Lambda_tmp(j/2) = Lambda_tmp(j/2) + h*z_one
5264 : ELSE
5265 31240 : Lambda_tmp((j + 1)/2) = Lambda_tmp((j + 1)/2) + h*gaussi
5266 : END IF
5267 : CALL calc_chi2(chi2, Lambda_tmp, Sigma_c, vec_omega_fit_gw, num_poles, &
5268 62480 : num_fit_points, n_level_gw)
5269 62480 : chi2_sum = chi2_sum + chi2
5270 :
5271 62480 : IF (MODULO(i, 2) == 0) THEN
5272 31240 : Lambda_tmp(i/2) = Lambda_tmp(i/2) - 2.0_dp*h*z_one
5273 : ELSE
5274 31240 : Lambda_tmp((i + 1)/2) = Lambda_tmp((i + 1)/2) - 2.0_dp*h*gaussi
5275 : END IF
5276 : CALL calc_chi2(chi2, Lambda_tmp, Sigma_c, vec_omega_fit_gw, num_poles, &
5277 62480 : num_fit_points, n_level_gw)
5278 62480 : chi2_sum = chi2_sum - chi2
5279 :
5280 62480 : IF (MODULO(j, 2) == 0) THEN
5281 31240 : Lambda_tmp(j/2) = Lambda_tmp(j/2) - 2.0_dp*h*z_one
5282 : ELSE
5283 31240 : Lambda_tmp((j + 1)/2) = Lambda_tmp((j + 1)/2) - 2.0_dp*h*gaussi
5284 : END IF
5285 : CALL calc_chi2(chi2, Lambda_tmp, Sigma_c, vec_omega_fit_gw, num_poles, &
5286 62480 : num_fit_points, n_level_gw)
5287 62480 : chi2_sum = chi2_sum + chi2
5288 :
5289 62480 : IF (MODULO(i, 2) == 0) THEN
5290 31240 : Lambda_tmp(i/2) = Lambda_tmp(i/2) + 2.0_dp*h*z_one
5291 : ELSE
5292 31240 : Lambda_tmp((i + 1)/2) = Lambda_tmp((i + 1)/2) + 2.0_dp*h*gaussi
5293 : END IF
5294 : CALL calc_chi2(chi2, Lambda_tmp, Sigma_c, vec_omega_fit_gw, num_poles, &
5295 62480 : num_fit_points, n_level_gw)
5296 62480 : chi2_sum = chi2_sum - chi2
5297 :
5298 : ! Second derivative with symmetric difference quotient
5299 62480 : N_ij = 1.0_dp/2.0_dp*chi2_sum/(4.0_dp*h*h)
5300 :
5301 62480 : DEALLOCATE (Lambda_tmp)
5302 :
5303 62480 : CALL timestop(handle)
5304 :
5305 62480 : END SUBROUTINE calc_mat_N
5306 :
5307 : ! **************************************************************************************************
5308 : !> \brief Calculate chi2
5309 : !> \param chi2 ...
5310 : !> \param Lambda fitting parameters
5311 : !> \param Sigma_c ...
5312 : !> \param vec_omega_fit_gw ...
5313 : !> \param num_poles ...
5314 : !> \param num_fit_points ...
5315 : !> \param n_level_gw ...
5316 : ! **************************************************************************************************
5317 1397195 : PURE SUBROUTINE calc_chi2(chi2, Lambda, Sigma_c, vec_omega_fit_gw, num_poles, &
5318 : num_fit_points, n_level_gw)
5319 : REAL(KIND=dp), INTENT(OUT) :: chi2
5320 : COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: Lambda
5321 : COMPLEX(KIND=dp), DIMENSION(:, :), INTENT(IN) :: Sigma_c
5322 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: vec_omega_fit_gw
5323 : INTEGER, INTENT(IN) :: num_poles, num_fit_points, n_level_gw
5324 :
5325 : COMPLEX(KIND=dp) :: func_val
5326 : INTEGER :: iii, jjj, kkk
5327 :
5328 1397195 : chi2 = 0.0_dp
5329 15969281 : DO kkk = 1, num_fit_points
5330 14572086 : func_val = Lambda(1)
5331 43716258 : DO iii = 1, num_poles
5332 29144172 : jjj = iii*2
5333 : ! calculate value of the fit function
5334 43716258 : func_val = func_val + Lambda(jjj)/(gaussi*vec_omega_fit_gw(kkk) - Lambda(jjj + 1))
5335 : END DO
5336 15969281 : chi2 = chi2 + (ABS(Sigma_c(n_level_gw, kkk) - func_val))**2
5337 : END DO
5338 :
5339 1397195 : END SUBROUTINE calc_chi2
5340 :
5341 : ! **************************************************************************************************
5342 : !> \brief ...
5343 : !> \param num_integ_points ...
5344 : !> \param nmo ...
5345 : !> \param tau_tj ...
5346 : !> \param tj ...
5347 : !> \param matrix_s ...
5348 : !> \param fm_mo_coeff_occ ...
5349 : !> \param fm_mo_coeff_virt ...
5350 : !> \param fm_mo_coeff_occ_scaled ...
5351 : !> \param fm_mo_coeff_virt_scaled ...
5352 : !> \param fm_scaled_dm_occ_tau ...
5353 : !> \param fm_scaled_dm_virt_tau ...
5354 : !> \param Eigenval ...
5355 : !> \param eps_filter ...
5356 : !> \param e_fermi ...
5357 : !> \param fm_mat_W ...
5358 : !> \param gw_corr_lev_tot ...
5359 : !> \param gw_corr_lev_occ ...
5360 : !> \param gw_corr_lev_virt ...
5361 : !> \param homo ...
5362 : !> \param count_ev_sc_GW ...
5363 : !> \param count_sc_GW0 ...
5364 : !> \param t_3c_overl_int_ao_mo ...
5365 : !> \param t_3c_O_mo_compressed ...
5366 : !> \param t_3c_O_mo_ind ...
5367 : !> \param t_3c_overl_int_gw_RI ...
5368 : !> \param t_3c_overl_int_gw_AO ...
5369 : !> \param mat_W ...
5370 : !> \param mat_MinvVMinv ...
5371 : !> \param mat_dm ...
5372 : !> \param weights_cos_tf_t_to_w ...
5373 : !> \param weights_sin_tf_t_to_w ...
5374 : !> \param vec_Sigma_c_gw ...
5375 : !> \param do_periodic ...
5376 : !> \param num_points_corr ...
5377 : !> \param delta_corr ...
5378 : !> \param qs_env ...
5379 : !> \param para_env ...
5380 : !> \param para_env_RPA ...
5381 : !> \param mp2_env ...
5382 : !> \param matrix_berry_re_mo_mo ...
5383 : !> \param matrix_berry_im_mo_mo ...
5384 : !> \param first_cycle_periodic_correction ...
5385 : !> \param kpoints ...
5386 : !> \param num_fit_points ...
5387 : !> \param fm_mo_coeff ...
5388 : !> \param do_ri_Sigma_x ...
5389 : !> \param vec_Sigma_x_gw ...
5390 : !> \param unit_nr ...
5391 : !> \param ispin ...
5392 : ! **************************************************************************************************
5393 62 : SUBROUTINE compute_self_energy_cubic_gw(num_integ_points, nmo, tau_tj, tj, &
5394 62 : matrix_s, fm_mo_coeff_occ, fm_mo_coeff_virt, fm_mo_coeff_occ_scaled, &
5395 : fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, &
5396 124 : fm_scaled_dm_virt_tau, Eigenval, eps_filter, &
5397 62 : e_fermi, fm_mat_W, &
5398 : gw_corr_lev_tot, gw_corr_lev_occ, gw_corr_lev_virt, homo, &
5399 : count_ev_sc_GW, count_sc_GW0, &
5400 62 : t_3c_overl_int_ao_mo, t_3c_O_mo_compressed, t_3c_O_mo_ind, &
5401 : t_3c_overl_int_gw_RI, t_3c_overl_int_gw_AO, &
5402 : mat_W, mat_MinvVMinv, mat_dm, &
5403 124 : weights_cos_tf_t_to_w, weights_sin_tf_t_to_w, vec_Sigma_c_gw, &
5404 : do_periodic, num_points_corr, delta_corr, qs_env, para_env, para_env_RPA, &
5405 : mp2_env, matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
5406 : first_cycle_periodic_correction, kpoints, num_fit_points, fm_mo_coeff, &
5407 62 : do_ri_Sigma_x, vec_Sigma_x_gw, unit_nr, ispin)
5408 : INTEGER, INTENT(IN) :: num_integ_points, nmo
5409 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
5410 : INTENT(IN) :: tau_tj, tj
5411 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN) :: matrix_s
5412 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff_occ, fm_mo_coeff_virt, fm_mo_coeff_occ_scaled, &
5413 : fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, fm_scaled_dm_virt_tau
5414 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval
5415 : REAL(KIND=dp), INTENT(IN) :: eps_filter
5416 : REAL(KIND=dp), INTENT(INOUT) :: e_fermi
5417 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_W
5418 : INTEGER, INTENT(IN) :: gw_corr_lev_tot, gw_corr_lev_occ, &
5419 : gw_corr_lev_virt, homo, &
5420 : count_ev_sc_GW, count_sc_GW0
5421 : TYPE(dbt_type) :: t_3c_overl_int_ao_mo
5422 : TYPE(hfx_compression_type) :: t_3c_O_mo_compressed
5423 : INTEGER, DIMENSION(:, :) :: t_3c_O_mo_ind
5424 : TYPE(dbt_type) :: t_3c_overl_int_gw_RI, &
5425 : t_3c_overl_int_gw_AO
5426 : TYPE(dbcsr_type), INTENT(INOUT), TARGET :: mat_W
5427 : TYPE(dbcsr_p_type) :: mat_MinvVMinv, mat_dm
5428 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: weights_cos_tf_t_to_w, &
5429 : weights_sin_tf_t_to_w
5430 : COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(OUT) :: vec_Sigma_c_gw
5431 : LOGICAL, INTENT(IN) :: do_periodic
5432 : INTEGER, INTENT(IN) :: num_points_corr
5433 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
5434 : INTENT(INOUT) :: delta_corr
5435 : TYPE(qs_environment_type), POINTER :: qs_env
5436 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_RPA
5437 : TYPE(mp2_type), INTENT(INOUT) :: mp2_env
5438 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_berry_re_mo_mo, &
5439 : matrix_berry_im_mo_mo
5440 : LOGICAL, INTENT(INOUT) :: first_cycle_periodic_correction
5441 : TYPE(kpoint_type), POINTER :: kpoints
5442 : INTEGER, INTENT(IN) :: num_fit_points
5443 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff
5444 : LOGICAL, INTENT(IN) :: do_ri_Sigma_x
5445 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT) :: vec_Sigma_x_gw
5446 : INTEGER, INTENT(IN) :: unit_nr, ispin
5447 :
5448 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_self_energy_cubic_gw'
5449 :
5450 62 : COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: delta_corr_omega
5451 : INTEGER :: gw_lev_end, gw_lev_start, handle, handle3, i, iblk_mo, iquad, jquad, mo_end, &
5452 : mo_start, n_level_gw, n_level_gw_ref, nblk_mo, unit_nr_prv
5453 62 : INTEGER, ALLOCATABLE, DIMENSION(:) :: batch_range_mo, dist1, dist2, mo_bsizes, &
5454 124 : mo_offsets, sizes_AO, sizes_RI
5455 : INTEGER, DIMENSION(2) :: mo_bounds, pdims_2d
5456 : LOGICAL :: memory_info
5457 : REAL(KIND=dp) :: ext_scaling, omega, omega_i, omega_sign, &
5458 : sign_occ_virt, t_i_Clenshaw, tau, &
5459 : weight_cos, weight_i, weight_sin
5460 62 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: vec_Sigma_c_gw_cos_omega, &
5461 62 : vec_Sigma_c_gw_cos_tau, vec_Sigma_c_gw_neg_tau, vec_Sigma_c_gw_pos_tau, &
5462 62 : vec_Sigma_c_gw_sin_omega, vec_Sigma_c_gw_sin_tau
5463 : TYPE(dbcsr_type), TARGET :: mat_greens_fct_occ, mat_greens_fct_virt
5464 186 : TYPE(dbt_pgrid_type) :: pgrid_2d
5465 1178 : TYPE(dbt_type) :: t_3c_ctr_AO, t_3c_ctr_RI, t_AO_tmp, &
5466 806 : t_dm, t_greens_fct_occ, &
5467 806 : t_greens_fct_virt, t_RI_tmp, &
5468 806 : t_SinvVSinv, t_W
5469 :
5470 62 : CALL timeset(routineN, handle)
5471 :
5472 : CALL decompress_tensor(t_3c_overl_int_ao_mo, t_3c_O_mo_ind, t_3c_O_mo_compressed, &
5473 62 : mp2_env%ri_rpa_im_time%eps_compress)
5474 :
5475 62 : CALL dbt_copy(t_3c_overl_int_ao_mo, t_3c_overl_int_gw_RI)
5476 62 : CALL dbt_copy(t_3c_overl_int_ao_mo, t_3c_overl_int_gw_AO, order=[2, 1, 3], move_data=.TRUE.)
5477 :
5478 62 : memory_info = mp2_env%ri_rpa_im_time%memory_info
5479 62 : IF (memory_info) THEN
5480 0 : unit_nr_prv = unit_nr
5481 : ELSE
5482 62 : unit_nr_prv = 0
5483 : END IF
5484 :
5485 62 : mo_start = homo - gw_corr_lev_occ + 1
5486 62 : mo_end = homo + gw_corr_lev_virt
5487 62 : CPASSERT(mo_end - mo_start + 1 == gw_corr_lev_tot)
5488 :
5489 4502 : vec_Sigma_c_gw = z_zero
5490 248 : ALLOCATE (vec_Sigma_c_gw_pos_tau(gw_corr_lev_tot, num_integ_points))
5491 8382 : vec_Sigma_c_gw_pos_tau = 0.0_dp
5492 186 : ALLOCATE (vec_Sigma_c_gw_neg_tau(gw_corr_lev_tot, num_integ_points))
5493 8382 : vec_Sigma_c_gw_neg_tau = 0.0_dp
5494 186 : ALLOCATE (vec_Sigma_c_gw_cos_tau(gw_corr_lev_tot, num_integ_points))
5495 8382 : vec_Sigma_c_gw_cos_tau = 0.0_dp
5496 186 : ALLOCATE (vec_Sigma_c_gw_sin_tau(gw_corr_lev_tot, num_integ_points))
5497 8382 : vec_Sigma_c_gw_sin_tau = 0.0_dp
5498 :
5499 186 : ALLOCATE (vec_Sigma_c_gw_cos_omega(gw_corr_lev_tot, num_integ_points))
5500 8382 : vec_Sigma_c_gw_cos_omega = 0.0_dp
5501 186 : ALLOCATE (vec_Sigma_c_gw_sin_omega(gw_corr_lev_tot, num_integ_points))
5502 8382 : vec_Sigma_c_gw_sin_omega = 0.0_dp
5503 :
5504 248 : ALLOCATE (delta_corr_omega(1 + homo - gw_corr_lev_occ:homo + gw_corr_lev_virt, num_integ_points))
5505 8382 : delta_corr_omega(:, :) = z_zero
5506 :
5507 : CALL dbcsr_create(matrix=mat_greens_fct_occ, &
5508 : template=matrix_s(1)%matrix, &
5509 62 : matrix_type=dbcsr_type_no_symmetry)
5510 :
5511 : CALL dbcsr_create(matrix=mat_greens_fct_virt, &
5512 : template=matrix_s(1)%matrix, &
5513 62 : matrix_type=dbcsr_type_no_symmetry)
5514 :
5515 62 : e_fermi = 0.5_dp*(Eigenval(homo) + Eigenval(homo + 1))
5516 :
5517 62 : nblk_mo = dbt_nblks_total(t_3c_overl_int_gw_AO, 3)
5518 186 : ALLOCATE (mo_offsets(nblk_mo))
5519 124 : ALLOCATE (mo_bsizes(nblk_mo))
5520 186 : ALLOCATE (batch_range_mo(nblk_mo - 1))
5521 62 : CALL dbt_get_info(t_3c_overl_int_gw_AO, blk_offset_3=mo_offsets, blk_size_3=mo_bsizes)
5522 :
5523 62 : pdims_2d = 0
5524 62 : CALL dbt_pgrid_create(para_env, pdims_2d, pgrid_2d)
5525 186 : ALLOCATE (sizes_RI(dbt_nblks_total(t_3c_overl_int_gw_RI, 1)))
5526 62 : CALL dbt_get_info(t_3c_overl_int_gw_RI, blk_size_1=sizes_RI)
5527 :
5528 : CALL create_2c_tensor(t_W, dist1, dist2, pgrid_2d, sizes_RI, sizes_RI, name="(RI|RI)")
5529 :
5530 62 : DEALLOCATE (dist1, dist2)
5531 :
5532 62 : CALL dbt_create(mat_W, t_RI_tmp, name="(RI|RI)")
5533 :
5534 62 : CALL dbt_create(t_3c_overl_int_gw_RI, t_3c_ctr_RI)
5535 62 : CALL dbt_create(t_3c_overl_int_gw_AO, t_3c_ctr_AO)
5536 :
5537 186 : ALLOCATE (sizes_AO(dbt_nblks_total(t_3c_overl_int_gw_AO, 1)))
5538 62 : CALL dbt_get_info(t_3c_overl_int_gw_AO, blk_size_1=sizes_AO)
5539 : CALL create_2c_tensor(t_greens_fct_occ, dist1, dist2, pgrid_2d, sizes_AO, sizes_AO, name="(AO|AO)")
5540 62 : DEALLOCATE (dist1, dist2)
5541 : CALL create_2c_tensor(t_greens_fct_virt, dist1, dist2, pgrid_2d, sizes_AO, sizes_AO, name="(AO|AO)")
5542 62 : DEALLOCATE (dist1, dist2)
5543 :
5544 742 : DO jquad = 1, num_integ_points
5545 :
5546 : CALL compute_Greens_function_time(mat_greens_fct_occ, mat_greens_fct_virt, &
5547 : fm_mo_coeff_occ, fm_mo_coeff_virt, &
5548 : fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, &
5549 : fm_scaled_dm_occ_tau, fm_scaled_dm_virt_tau, Eigenval, &
5550 680 : nmo, eps_filter, e_fermi, tau_tj(jquad), para_env)
5551 :
5552 680 : CALL dbcsr_set(mat_W, 0.0_dp)
5553 680 : CALL copy_fm_to_dbcsr(fm_mat_W(jquad), mat_W, keep_sparsity=.FALSE.)
5554 :
5555 680 : IF (jquad == 1) CALL dbt_create(mat_greens_fct_occ, t_AO_tmp, name="(AO|AO)")
5556 :
5557 680 : CALL dbt_copy_matrix_to_tensor(mat_W, t_RI_tmp)
5558 680 : CALL dbt_copy(t_RI_tmp, t_W)
5559 680 : CALL dbt_copy_matrix_to_tensor(mat_greens_fct_occ, t_AO_tmp)
5560 680 : CALL dbt_copy(t_AO_tmp, t_greens_fct_occ)
5561 680 : CALL dbt_copy_matrix_to_tensor(mat_greens_fct_virt, t_AO_tmp)
5562 680 : CALL dbt_copy(t_AO_tmp, t_greens_fct_virt)
5563 :
5564 3400 : batch_range_mo(:) = [(i, i=2, nblk_mo)]
5565 680 : CALL dbt_batched_contract_init(t_3c_overl_int_gw_AO, batch_range_3=batch_range_mo)
5566 680 : CALL dbt_batched_contract_init(t_3c_overl_int_gw_RI, batch_range_3=batch_range_mo)
5567 680 : CALL dbt_batched_contract_init(t_3c_ctr_AO, batch_range_3=batch_range_mo)
5568 680 : CALL dbt_batched_contract_init(t_3c_ctr_RI, batch_range_3=batch_range_mo)
5569 680 : CALL dbt_batched_contract_init(t_W)
5570 680 : CALL dbt_batched_contract_init(t_greens_fct_occ)
5571 680 : CALL dbt_batched_contract_init(t_greens_fct_virt)
5572 :
5573 : ! in iteration over MO blocks skip first and last block because they correspond to the MO s
5574 : ! outside of the GW range of required MOs
5575 1360 : DO iblk_mo = 2, nblk_mo - 1
5576 2040 : mo_bounds = [mo_offsets(iblk_mo), mo_offsets(iblk_mo) + mo_bsizes(iblk_mo) - 1]
5577 : CALL contract_cubic_gw(t_3c_overl_int_gw_AO, t_3c_overl_int_gw_RI, &
5578 : t_greens_fct_occ, t_W, [1.0_dp, -1.0_dp], &
5579 : mo_bounds, unit_nr_prv, &
5580 680 : t_3c_ctr_RI, t_3c_ctr_AO, calculate_ctr_ri=.TRUE.)
5581 680 : CALL trace_sigma_gw(t_3c_ctr_AO, t_3c_ctr_RI, vec_Sigma_c_gw_neg_tau(:, jquad), mo_start, mo_bounds, para_env)
5582 :
5583 : CALL contract_cubic_gw(t_3c_overl_int_gw_AO, t_3c_overl_int_gw_RI, &
5584 : t_greens_fct_virt, t_W, [1.0_dp, 1.0_dp], &
5585 : mo_bounds, unit_nr_prv, &
5586 680 : t_3c_ctr_RI, t_3c_ctr_AO, calculate_ctr_ri=.FALSE.)
5587 :
5588 1360 : CALL trace_sigma_gw(t_3c_ctr_AO, t_3c_ctr_RI, vec_Sigma_c_gw_pos_tau(:, jquad), mo_start, mo_bounds, para_env)
5589 : END DO
5590 680 : CALL dbt_batched_contract_finalize(t_3c_overl_int_gw_AO)
5591 680 : CALL dbt_batched_contract_finalize(t_3c_overl_int_gw_RI)
5592 680 : CALL dbt_batched_contract_finalize(t_3c_ctr_AO)
5593 680 : CALL dbt_batched_contract_finalize(t_3c_ctr_RI)
5594 680 : CALL dbt_batched_contract_finalize(t_W)
5595 680 : CALL dbt_batched_contract_finalize(t_greens_fct_occ)
5596 680 : CALL dbt_batched_contract_finalize(t_greens_fct_virt)
5597 :
5598 680 : CALL dbt_clear(t_3c_ctr_AO)
5599 680 : CALL dbt_clear(t_3c_ctr_RI)
5600 :
5601 : vec_Sigma_c_gw_cos_tau(:, jquad) = 0.5_dp*(vec_Sigma_c_gw_pos_tau(:, jquad) + &
5602 8320 : vec_Sigma_c_gw_neg_tau(:, jquad))
5603 :
5604 : vec_Sigma_c_gw_sin_tau(:, jquad) = 0.5_dp*(vec_Sigma_c_gw_pos_tau(:, jquad) - &
5605 8382 : vec_Sigma_c_gw_neg_tau(:, jquad))
5606 :
5607 : END DO ! jquad (tau)
5608 62 : CALL dbt_destroy(t_W)
5609 :
5610 62 : CALL dbt_destroy(t_greens_fct_occ)
5611 62 : CALL dbt_destroy(t_greens_fct_virt)
5612 :
5613 : ! Fourier transform from time to frequency
5614 404 : DO jquad = 1, num_fit_points
5615 :
5616 6424 : DO iquad = 1, num_integ_points
5617 :
5618 6020 : omega = tj(jquad)
5619 6020 : tau = tau_tj(iquad)
5620 6020 : weight_cos = weights_cos_tf_t_to_w(jquad, iquad)*COS(omega*tau)
5621 6020 : weight_sin = weights_sin_tf_t_to_w(jquad, iquad)*SIN(omega*tau)
5622 :
5623 : vec_Sigma_c_gw_cos_omega(:, jquad) = vec_Sigma_c_gw_cos_omega(:, jquad) + &
5624 86140 : weight_cos*vec_Sigma_c_gw_cos_tau(:, iquad)
5625 :
5626 : vec_Sigma_c_gw_sin_omega(:, jquad) = vec_Sigma_c_gw_sin_omega(:, jquad) + &
5627 86482 : weight_sin*vec_Sigma_c_gw_sin_tau(:, iquad)
5628 :
5629 : END DO
5630 :
5631 : END DO
5632 :
5633 : ! for occupied levels, we need the correlation self-energy for negative omega. Therefore, weight_sin
5634 : ! should be computed with -omega, which results in an additional minus for vec_Sigma_c_gw_sin_omega:
5635 2922 : vec_Sigma_c_gw_sin_omega(1:gw_corr_lev_occ, :) = -vec_Sigma_c_gw_sin_omega(1:gw_corr_lev_occ, :)
5636 :
5637 : vec_Sigma_c_gw(:, 1:num_fit_points, 1) = vec_Sigma_c_gw_cos_omega(:, 1:num_fit_points) + &
5638 4440 : gaussi*vec_Sigma_c_gw_sin_omega(:, 1:num_fit_points)
5639 :
5640 62 : CALL dbcsr_release(mat_greens_fct_occ)
5641 62 : CALL dbcsr_release(mat_greens_fct_virt)
5642 :
5643 66 : IF (do_ri_Sigma_x .AND. count_ev_sc_GW == 1 .AND. count_sc_GW0 == 1) THEN
5644 :
5645 2 : CALL timeset(routineN//"_RI_HFX_operation_1", handle3)
5646 :
5647 : ! get density matrix
5648 : CALL parallel_gemm(transa="N", transb="T", m=nmo, n=nmo, k=nmo, alpha=1.0_dp, &
5649 : matrix_a=fm_mo_coeff_occ, matrix_b=fm_mo_coeff_occ, beta=0.0_dp, &
5650 2 : matrix_c=fm_scaled_dm_occ_tau)
5651 :
5652 2 : CALL timestop(handle3)
5653 :
5654 2 : CALL timeset(routineN//"_RI_HFX_operation_2", handle3)
5655 :
5656 : CALL copy_fm_to_dbcsr(fm_scaled_dm_occ_tau, &
5657 : mat_dm%matrix, &
5658 2 : keep_sparsity=.FALSE.)
5659 :
5660 2 : CALL timestop(handle3)
5661 :
5662 : CALL create_2c_tensor(t_dm, dist1, dist2, pgrid_2d, sizes_AO, sizes_AO, name="(AO|AO)")
5663 2 : DEALLOCATE (dist1, dist2)
5664 :
5665 2 : CALL dbt_copy_matrix_to_tensor(mat_dm%matrix, t_AO_tmp)
5666 2 : CALL dbt_copy(t_AO_tmp, t_dm)
5667 :
5668 : CALL create_2c_tensor(t_SinvVSinv, dist1, dist2, pgrid_2d, sizes_RI, sizes_RI, name="(RI|RI)")
5669 2 : DEALLOCATE (dist1, dist2)
5670 :
5671 2 : CALL dbt_copy_matrix_to_tensor(mat_MinvVMinv%matrix, t_RI_tmp)
5672 2 : CALL dbt_copy(t_RI_tmp, t_SinvVSinv)
5673 :
5674 2 : CALL dbt_batched_contract_init(t_3c_overl_int_gw_AO, batch_range_3=batch_range_mo)
5675 2 : CALL dbt_batched_contract_init(t_3c_overl_int_gw_RI, batch_range_3=batch_range_mo)
5676 2 : CALL dbt_batched_contract_init(t_3c_ctr_RI, batch_range_3=batch_range_mo)
5677 2 : CALL dbt_batched_contract_init(t_3c_ctr_AO, batch_range_3=batch_range_mo)
5678 2 : CALL dbt_batched_contract_init(t_dm)
5679 2 : CALL dbt_batched_contract_init(t_SinvVSinv)
5680 :
5681 4 : DO iblk_mo = 2, nblk_mo - 1
5682 6 : mo_bounds = [mo_offsets(iblk_mo), mo_offsets(iblk_mo) + mo_bsizes(iblk_mo) - 1]
5683 :
5684 : CALL contract_cubic_gw(t_3c_overl_int_gw_AO, t_3c_overl_int_gw_RI, &
5685 : t_dm, t_SinvVSinv, [1.0_dp, -1.0_dp], &
5686 : mo_bounds, unit_nr_prv, &
5687 2 : t_3c_ctr_RI, t_3c_ctr_AO, calculate_ctr_ri=.TRUE.)
5688 :
5689 4 : CALL trace_sigma_gw(t_3c_ctr_AO, t_3c_ctr_RI, vec_Sigma_x_gw(mo_start:mo_end, 1), mo_start, mo_bounds, para_env)
5690 : END DO
5691 2 : CALL dbt_batched_contract_finalize(t_3c_overl_int_gw_AO)
5692 2 : CALL dbt_batched_contract_finalize(t_3c_overl_int_gw_RI)
5693 2 : CALL dbt_batched_contract_finalize(t_dm)
5694 2 : CALL dbt_batched_contract_finalize(t_SinvVSinv)
5695 2 : CALL dbt_batched_contract_finalize(t_3c_ctr_RI)
5696 2 : CALL dbt_batched_contract_finalize(t_3c_ctr_AO)
5697 :
5698 2 : CALL dbt_destroy(t_dm)
5699 2 : CALL dbt_destroy(t_SinvVSinv)
5700 :
5701 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, ispin, 1) = &
5702 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, ispin, 1) + &
5703 48 : vec_Sigma_x_gw(:, 1)
5704 :
5705 : END IF
5706 :
5707 62 : CALL dbt_pgrid_destroy(pgrid_2d)
5708 :
5709 62 : CALL dbt_destroy(t_3c_ctr_RI)
5710 62 : CALL dbt_destroy(t_3c_ctr_AO)
5711 62 : CALL dbt_destroy(t_AO_tmp)
5712 62 : CALL dbt_destroy(t_RI_tmp)
5713 :
5714 : ! compute and add the periodic correction
5715 62 : IF (do_periodic) THEN
5716 :
5717 4 : ext_scaling = 0.2_dp
5718 :
5719 : ! loop over omega' (integration)
5720 24 : DO iquad = 1, num_points_corr
5721 :
5722 : ! use the Clenshaw-grid
5723 20 : t_i_Clenshaw = iquad*pi/(2.0_dp*num_points_corr)
5724 20 : omega_i = ext_scaling/TAN(t_i_Clenshaw)
5725 :
5726 20 : IF (iquad < num_points_corr) THEN
5727 16 : weight_i = ext_scaling*pi/(num_points_corr*SIN(t_i_Clenshaw)**2)
5728 : ELSE
5729 4 : weight_i = ext_scaling*pi/(2.0_dp*num_points_corr*SIN(t_i_Clenshaw)**2)
5730 : END IF
5731 :
5732 : CALL calc_periodic_correction(delta_corr, qs_env, para_env, para_env_RPA, &
5733 : mp2_env%ri_g0w0%kp_grid, homo, nmo, gw_corr_lev_occ, &
5734 : gw_corr_lev_virt, omega_i, fm_mo_coeff, Eigenval, &
5735 : matrix_berry_re_mo_mo, matrix_berry_im_mo_mo, &
5736 : first_cycle_periodic_correction, kpoints, &
5737 : mp2_env%ri_g0w0%do_mo_coeff_gamma, &
5738 : mp2_env%ri_g0w0%num_kp_grids, mp2_env%ri_g0w0%eps_kpoint, &
5739 : mp2_env%ri_g0w0%do_extra_kpoints, &
5740 20 : mp2_env%ri_g0w0%do_aux_bas_gw, mp2_env%ri_g0w0%frac_aux_mos)
5741 :
5742 204 : DO n_level_gw = 1, gw_corr_lev_tot
5743 :
5744 180 : n_level_gw_ref = n_level_gw + homo - gw_corr_lev_occ
5745 :
5746 180 : IF (n_level_gw <= gw_corr_lev_occ) THEN
5747 : sign_occ_virt = -1.0_dp
5748 : ELSE
5749 100 : sign_occ_virt = 1.0_dp
5750 : END IF
5751 :
5752 2000 : DO jquad = 1, num_integ_points
5753 :
5754 1800 : omega_sign = tj(jquad)*sign_occ_virt
5755 :
5756 : delta_corr_omega(n_level_gw_ref, jquad) = &
5757 : delta_corr_omega(n_level_gw_ref, jquad) - &
5758 : 0.5_dp/pi*weight_i/2.0_dp*delta_corr(n_level_gw_ref)* &
5759 : (1.0_dp/(gaussi*(omega_i + omega_sign) + e_fermi - Eigenval(n_level_gw_ref)) + &
5760 1980 : 1.0_dp/(gaussi*(-omega_i + omega_sign) + e_fermi - Eigenval(n_level_gw_ref)))
5761 :
5762 : END DO
5763 :
5764 : END DO
5765 :
5766 : END DO
5767 :
5768 4 : gw_lev_start = 1 + homo - gw_corr_lev_occ
5769 4 : gw_lev_end = homo + gw_corr_lev_virt
5770 :
5771 : ! add the periodic correction
5772 : vec_Sigma_c_gw(1:gw_corr_lev_tot, :, 1) = vec_Sigma_c_gw(1:gw_corr_lev_tot, :, 1) + &
5773 164 : delta_corr_omega(gw_lev_start:gw_lev_end, 1:num_fit_points)
5774 :
5775 : END IF
5776 :
5777 62 : DEALLOCATE (vec_Sigma_c_gw_pos_tau)
5778 62 : DEALLOCATE (vec_Sigma_c_gw_neg_tau)
5779 62 : DEALLOCATE (vec_Sigma_c_gw_cos_tau)
5780 62 : DEALLOCATE (vec_Sigma_c_gw_sin_tau)
5781 62 : DEALLOCATE (vec_Sigma_c_gw_cos_omega)
5782 62 : DEALLOCATE (vec_Sigma_c_gw_sin_omega)
5783 62 : DEALLOCATE (delta_corr_omega)
5784 :
5785 62 : CALL timestop(handle)
5786 :
5787 372 : END SUBROUTINE compute_self_energy_cubic_gw
5788 :
5789 : ! **************************************************************************************************
5790 : !> \brief ...
5791 : !> \param num_integ_points ...
5792 : !> \param tau_tj ...
5793 : !> \param tj ...
5794 : !> \param matrix_s ...
5795 : !> \param Eigenval ...
5796 : !> \param e_fermi ...
5797 : !> \param fm_mat_W ...
5798 : !> \param gw_corr_lev_tot ...
5799 : !> \param gw_corr_lev_occ ...
5800 : !> \param gw_corr_lev_virt ...
5801 : !> \param homo ...
5802 : !> \param count_ev_sc_GW ...
5803 : !> \param count_sc_GW0 ...
5804 : !> \param t_3c_O ...
5805 : !> \param t_3c_M ...
5806 : !> \param t_3c_O_compressed ...
5807 : !> \param t_3c_O_ind ...
5808 : !> \param mat_W ...
5809 : !> \param mat_MinvVMinv ...
5810 : !> \param weights_cos_tf_t_to_w ...
5811 : !> \param weights_sin_tf_t_to_w ...
5812 : !> \param vec_Sigma_c_gw ...
5813 : !> \param qs_env ...
5814 : !> \param para_env ...
5815 : !> \param mp2_env ...
5816 : !> \param num_fit_points ...
5817 : !> \param fm_mo_coeff ...
5818 : !> \param do_ri_Sigma_x ...
5819 : !> \param vec_Sigma_x_gw ...
5820 : !> \param unit_nr ...
5821 : !> \param nspins ...
5822 : !> \param starts_array_mc ...
5823 : !> \param ends_array_mc ...
5824 : !> \param eps_filter ...
5825 : ! **************************************************************************************************
5826 18 : SUBROUTINE compute_self_energy_cubic_gw_kpoints(num_integ_points, tau_tj, tj, &
5827 18 : matrix_s, Eigenval, e_fermi, fm_mat_W, &
5828 18 : gw_corr_lev_tot, gw_corr_lev_occ, gw_corr_lev_virt, homo, &
5829 : count_ev_sc_GW, count_sc_GW0, &
5830 : t_3c_O, t_3c_M, t_3c_O_compressed, t_3c_O_ind, &
5831 : mat_W, mat_MinvVMinv, &
5832 36 : weights_cos_tf_t_to_w, weights_sin_tf_t_to_w, vec_Sigma_c_gw, &
5833 : qs_env, para_env, &
5834 : mp2_env, num_fit_points, fm_mo_coeff, &
5835 18 : do_ri_Sigma_x, vec_Sigma_x_gw, unit_nr, nspins, &
5836 18 : starts_array_mc, ends_array_mc, eps_filter)
5837 :
5838 : INTEGER, INTENT(IN) :: num_integ_points
5839 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:), &
5840 : INTENT(IN) :: tau_tj, tj
5841 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN) :: matrix_s
5842 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: Eigenval
5843 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: e_fermi
5844 : TYPE(cp_fm_type), DIMENSION(:), INTENT(IN) :: fm_mat_W
5845 : INTEGER, INTENT(IN) :: gw_corr_lev_tot
5846 : INTEGER, DIMENSION(:), INTENT(IN) :: gw_corr_lev_occ, gw_corr_lev_virt, homo
5847 : INTEGER, INTENT(IN) :: count_ev_sc_GW, count_sc_GW0
5848 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_O
5849 : TYPE(dbt_type) :: t_3c_M
5850 : TYPE(hfx_compression_type), ALLOCATABLE, &
5851 : DIMENSION(:, :, :) :: t_3c_O_compressed
5852 : TYPE(block_ind_type), ALLOCATABLE, &
5853 : DIMENSION(:, :, :), INTENT(INOUT) :: t_3c_O_ind
5854 : TYPE(dbcsr_type), INTENT(INOUT), TARGET :: mat_W
5855 : TYPE(dbcsr_p_type) :: mat_MinvVMinv
5856 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: weights_cos_tf_t_to_w, &
5857 : weights_sin_tf_t_to_w
5858 : COMPLEX(KIND=dp), DIMENSION(:, :, :, :), &
5859 : INTENT(OUT) :: vec_Sigma_c_gw
5860 : TYPE(qs_environment_type), POINTER :: qs_env
5861 : TYPE(mp_para_env_type), POINTER :: para_env
5862 : TYPE(mp2_type), INTENT(INOUT) :: mp2_env
5863 : INTEGER, INTENT(IN) :: num_fit_points
5864 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff
5865 : LOGICAL, INTENT(IN) :: do_ri_Sigma_x
5866 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: vec_Sigma_x_gw
5867 : INTEGER, INTENT(IN) :: unit_nr, nspins
5868 : INTEGER, DIMENSION(:), INTENT(IN) :: starts_array_mc, ends_array_mc
5869 : REAL(KIND=dp), INTENT(IN) :: eps_filter
5870 :
5871 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_self_energy_cubic_gw_kpoints'
5872 :
5873 : INTEGER :: cut_memory, handle, handle2, i_mem, &
5874 : iquad, ispin, j_mem, jquad, &
5875 : nkp_self_energy, num_points, &
5876 : unit_nr_prv
5877 36 : INTEGER, ALLOCATABLE, DIMENSION(:) :: dist1, dist2, sizes_AO, sizes_RI
5878 : INTEGER, DIMENSION(2) :: mo_end, mo_start, pdims_2d
5879 : INTEGER, DIMENSION(2, 1) :: bounds_RI_i
5880 : INTEGER, DIMENSION(2, 2) :: bounds_ao_ao_j
5881 : INTEGER, DIMENSION(3) :: dims_3c
5882 : LOGICAL :: memory_info
5883 : REAL(KIND=dp) :: omega, t1, t2, tau, weight_cos, &
5884 : weight_sin
5885 18 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :, :) :: vec_Sigma_c_gw_cos_omega, &
5886 18 : vec_Sigma_c_gw_cos_tau, vec_Sigma_c_gw_neg_tau, vec_Sigma_c_gw_pos_tau, &
5887 18 : vec_Sigma_c_gw_sin_omega, vec_Sigma_c_gw_sin_tau
5888 18 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_p_greens_fct_occ, &
5889 18 : mat_p_greens_fct_virt
5890 : TYPE(dbcsr_type), TARGET :: mat_greens_fct_occ, mat_greens_fct_virt, mat_mo_coeff, &
5891 : mat_self_energy_ao_ao_neg_tau, mat_self_energy_ao_ao_pos_tau
5892 54 : TYPE(dbt_pgrid_type) :: pgrid_2d
5893 342 : TYPE(dbt_type) :: t_3c_M_W_tmp, t_3c_O_all, t_3c_O_W, &
5894 234 : t_AO_tmp, t_greens_fct_occ, &
5895 342 : t_greens_fct_virt, t_RI_tmp, t_W
5896 :
5897 18 : CALL timeset(routineN, handle)
5898 :
5899 18 : memory_info = mp2_env%ri_rpa_im_time%memory_info
5900 18 : IF (memory_info) THEN
5901 0 : unit_nr_prv = unit_nr
5902 : ELSE
5903 18 : unit_nr_prv = 0
5904 : END IF
5905 :
5906 18 : cut_memory = mp2_env%ri_rpa_im_time%cut_memory
5907 :
5908 40 : DO ispin = 1, nspins
5909 22 : mo_start(ispin) = homo(ispin) - gw_corr_lev_occ(ispin) + 1
5910 22 : mo_end(ispin) = homo(ispin) + gw_corr_lev_virt(ispin)
5911 40 : CPASSERT(mo_end(ispin) - mo_start(ispin) + 1 == gw_corr_lev_tot)
5912 : END DO
5913 :
5914 18 : nkp_self_energy = mp2_env%ri_g0w0%nkp_self_energy
5915 :
5916 1672 : vec_Sigma_c_gw = z_zero
5917 108 : ALLOCATE (vec_Sigma_c_gw_pos_tau(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5918 3232 : vec_Sigma_c_gw_pos_tau = 0.0_dp
5919 90 : ALLOCATE (vec_Sigma_c_gw_neg_tau(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5920 3232 : vec_Sigma_c_gw_neg_tau = 0.0_dp
5921 90 : ALLOCATE (vec_Sigma_c_gw_cos_tau(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5922 3232 : vec_Sigma_c_gw_cos_tau = 0.0_dp
5923 90 : ALLOCATE (vec_Sigma_c_gw_sin_tau(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5924 3232 : vec_Sigma_c_gw_sin_tau = 0.0_dp
5925 :
5926 90 : ALLOCATE (vec_Sigma_c_gw_cos_omega(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5927 3232 : vec_Sigma_c_gw_cos_omega = 0.0_dp
5928 90 : ALLOCATE (vec_Sigma_c_gw_sin_omega(gw_corr_lev_tot, num_integ_points, nkp_self_energy, nspins))
5929 3232 : vec_Sigma_c_gw_sin_omega = 0.0_dp
5930 :
5931 : CALL dbcsr_create(matrix=mat_greens_fct_occ, &
5932 : template=matrix_s(1)%matrix, &
5933 18 : matrix_type=dbcsr_type_no_symmetry)
5934 :
5935 : CALL dbcsr_create(matrix=mat_greens_fct_virt, &
5936 : template=matrix_s(1)%matrix, &
5937 18 : matrix_type=dbcsr_type_no_symmetry)
5938 :
5939 : CALL dbcsr_create(matrix=mat_self_energy_ao_ao_neg_tau, &
5940 : template=matrix_s(1)%matrix, &
5941 18 : matrix_type=dbcsr_type_no_symmetry)
5942 :
5943 : CALL dbcsr_create(matrix=mat_self_energy_ao_ao_pos_tau, &
5944 : template=matrix_s(1)%matrix, &
5945 18 : matrix_type=dbcsr_type_no_symmetry)
5946 :
5947 : CALL dbcsr_create(matrix=mat_mo_coeff, &
5948 : template=matrix_s(1)%matrix, &
5949 18 : matrix_type=dbcsr_type_no_symmetry)
5950 :
5951 18 : CALL copy_fm_to_dbcsr(fm_mo_coeff, mat_mo_coeff, keep_sparsity=.FALSE.)
5952 :
5953 40 : DO ispin = 1, nspins
5954 870 : e_fermi(ispin) = 0.5_dp*(MAXVAL(Eigenval(homo, :, ispin)) + MINVAL(Eigenval(homo + 1, :, ispin)))
5955 : END DO
5956 :
5957 18 : pdims_2d = 0
5958 18 : CALL dbt_pgrid_create(para_env, pdims_2d, pgrid_2d)
5959 54 : ALLOCATE (sizes_RI(dbt_nblks_total(t_3c_O(1, 1), 1)))
5960 18 : CALL dbt_get_info(t_3c_O(1, 1), blk_size_1=sizes_RI)
5961 :
5962 18 : CALL create_2c_tensor(t_W, dist1, dist2, pgrid_2d, sizes_RI, sizes_RI, name="(RI|RI)")
5963 18 : DEALLOCATE (dist1, dist2)
5964 :
5965 18 : CALL dbt_create(mat_W, t_RI_tmp, name="(RI|RI)")
5966 :
5967 54 : ALLOCATE (sizes_AO(dbt_nblks_total(t_3c_O(1, 1), 2)))
5968 18 : CALL dbt_get_info(t_3c_O(1, 1), blk_size_2=sizes_AO)
5969 : CALL create_2c_tensor(t_greens_fct_occ, dist1, dist2, pgrid_2d, sizes_AO, sizes_AO, name="(AO|AO)")
5970 :
5971 18 : DEALLOCATE (dist1, dist2)
5972 : CALL create_2c_tensor(t_greens_fct_virt, dist1, dist2, pgrid_2d, sizes_AO, sizes_AO, name="(AO|AO)")
5973 18 : DEALLOCATE (dist1, dist2)
5974 :
5975 18 : CALL dbt_get_info(t_3c_M, nfull_total=dims_3c)
5976 :
5977 18 : CALL dbt_create(t_3c_O(1, 1), t_3c_O_all, name="O (RI AO | AO)")
5978 :
5979 : ! get full 3c tensor
5980 82 : DO i_mem = 1, cut_memory
5981 : CALL decompress_tensor(t_3c_O(1, 1), &
5982 : t_3c_O_ind(1, 1, i_mem)%ind, &
5983 : t_3c_O_compressed(1, 1, i_mem), &
5984 64 : mp2_env%ri_rpa_im_time%eps_compress)
5985 82 : CALL dbt_copy(t_3c_O(1, 1), t_3c_O_all, summation=.TRUE., move_data=.TRUE.)
5986 : END DO
5987 :
5988 18 : CALL dbt_create(t_3c_M, t_3c_M_W_tmp, name="M W (RI | AO AO)")
5989 18 : CALL dbt_create(t_3c_O(1, 1), t_3c_O_W, name="M W (RI AO | AO)")
5990 :
5991 18 : CALL dbt_create(mat_greens_fct_occ, t_AO_tmp, name="(AO|AO)")
5992 :
5993 18 : IF (count_ev_sc_GW == 1 .AND. count_sc_GW0 == 1 .AND. do_ri_Sigma_x) THEN
5994 14 : num_points = num_integ_points + 1
5995 : ELSE
5996 4 : num_points = num_integ_points
5997 : END IF
5998 :
5999 140 : DO jquad = 1, num_points
6000 :
6001 122 : t1 = m_walltime()
6002 :
6003 122 : IF (jquad <= num_integ_points) THEN
6004 108 : tau = tau_tj(jquad)
6005 :
6006 108 : IF (unit_nr > 0) WRITE (unit_nr, '(/T3,A,1X,I3)') &
6007 54 : 'GW_INFO| Computing self-energy time point', jquad
6008 : ELSE
6009 14 : tau = 0.0_dp
6010 :
6011 14 : IF (unit_nr > 0) WRITE (unit_nr, '(/T3,A,1X,I3)') &
6012 7 : 'GW_INFO| Computing exchange self-energy'
6013 : END IF
6014 :
6015 122 : IF (jquad <= num_integ_points) THEN
6016 108 : CALL dbcsr_set(mat_W, 0.0_dp)
6017 108 : CALL copy_fm_to_dbcsr(fm_mat_W(jquad), mat_W, keep_sparsity=.FALSE.)
6018 108 : CALL dbt_copy_matrix_to_tensor(mat_W, t_RI_tmp)
6019 : ELSE
6020 14 : CALL dbt_copy_matrix_to_tensor(mat_MinvVMinv%matrix, t_RI_tmp)
6021 : END IF
6022 :
6023 122 : CALL dbt_copy(t_RI_tmp, t_W)
6024 :
6025 272 : DO ispin = 1, nspins
6026 :
6027 : CALL compute_periodic_dm(mat_p_greens_fct_occ, qs_env, &
6028 : ispin, num_points, jquad, e_fermi(ispin), tau, &
6029 : remove_occ=.FALSE., remove_virt=.TRUE., &
6030 282 : alloc_dm=(jquad == 1 .AND. ispin == 1))
6031 :
6032 : CALL compute_periodic_dm(mat_p_greens_fct_virt, qs_env, &
6033 : ispin, num_points, jquad, e_fermi(ispin), tau, &
6034 : remove_occ=.TRUE., remove_virt=.FALSE., &
6035 282 : alloc_dm=(jquad == 1 .AND. ispin == 1))
6036 :
6037 150 : CALL dbcsr_set(mat_greens_fct_occ, 0.0_dp)
6038 150 : CALL dbcsr_copy(mat_greens_fct_occ, mat_p_greens_fct_occ(jquad, 1)%matrix)
6039 :
6040 150 : CALL dbcsr_set(mat_greens_fct_virt, 0.0_dp)
6041 150 : CALL dbcsr_copy(mat_greens_fct_virt, mat_p_greens_fct_virt(jquad, 1)%matrix)
6042 :
6043 150 : CALL dbt_copy_matrix_to_tensor(mat_greens_fct_occ, t_AO_tmp)
6044 150 : CALL dbt_copy(t_AO_tmp, t_greens_fct_occ)
6045 :
6046 150 : CALL dbt_copy_matrix_to_tensor(mat_greens_fct_virt, t_AO_tmp)
6047 150 : CALL dbt_copy(t_AO_tmp, t_greens_fct_virt)
6048 :
6049 150 : CALL dbcsr_set(mat_self_energy_ao_ao_neg_tau, 0.0_dp)
6050 150 : CALL dbcsr_set(mat_self_energy_ao_ao_pos_tau, 0.0_dp)
6051 :
6052 150 : CALL dbt_copy(t_3c_O_all, t_3c_M)
6053 :
6054 150 : CALL dbt_batched_contract_init(t_3c_O_W)
6055 : ! CALL dbt_batched_contract_init(t_3c_O_G)
6056 : ! CALL dbt_batched_contract_init(t_self_energy)
6057 :
6058 666 : DO i_mem = 1, cut_memory ! memory cut for RI index
6059 :
6060 : ! CALL dbt_batched_contract_init(t_W)
6061 : ! CALL dbt_batched_contract_init(t_3c_M)
6062 : ! CALL dbt_batched_contract_init(t_3c_M_W_tmp)
6063 :
6064 : bounds_RI_i(:, 1) = [qs_env%mp2_env%ri_rpa_im_time%starts_array_mc_RI(i_mem), &
6065 1548 : qs_env%mp2_env%ri_rpa_im_time%ends_array_mc_RI(i_mem)]
6066 :
6067 2506 : DO j_mem = 1, cut_memory ! memory cut for ao index
6068 :
6069 5520 : bounds_ao_ao_j(:, 1) = [starts_array_mc(j_mem), ends_array_mc(j_mem)]
6070 5520 : bounds_ao_ao_j(:, 2) = [1, dims_3c(3)]
6071 :
6072 1840 : CALL timeset("tensor_operation_3c_W", handle2)
6073 :
6074 : CALL dbt_contract(1.0_dp, t_W, t_3c_M, 0.0_dp, &
6075 : t_3c_M_W_tmp, &
6076 : contract_1=[2], notcontract_1=[1], &
6077 : contract_2=[1], notcontract_2=[2, 3], &
6078 : map_1=[1], map_2=[2, 3], &
6079 : bounds_2=bounds_RI_i, &
6080 : bounds_3=bounds_ao_ao_j, &
6081 : filter_eps=eps_filter, &
6082 1840 : unit_nr=unit_nr_prv)
6083 :
6084 1840 : CALL dbt_copy(t_3c_M_W_tmp, t_3c_O_W, order=[1, 2, 3], move_data=.TRUE.)
6085 :
6086 1840 : CALL timestop(handle2)
6087 :
6088 : CALL contract_to_self_energy(t_3c_O_all, t_greens_fct_occ, t_3c_O_W, &
6089 : mat_self_energy_ao_ao_neg_tau, &
6090 : bounds_ao_ao_j, bounds_RI_i, unit_nr_prv, &
6091 1840 : eps_filter, do_occ=.TRUE., do_virt=.FALSE.)
6092 :
6093 : CALL contract_to_self_energy(t_3c_O_all, t_greens_fct_virt, t_3c_O_W, &
6094 : mat_self_energy_ao_ao_pos_tau, &
6095 : bounds_ao_ao_j, bounds_RI_i, unit_nr_prv, &
6096 4196 : eps_filter, do_occ=.FALSE., do_virt=.TRUE.)
6097 :
6098 : END DO ! j_mem
6099 :
6100 : ! CALL dbt_batched_contract_finalize(t_W)
6101 : ! CALL dbt_batched_contract_finalize(t_3c_M)
6102 : ! CALL dbt_batched_contract_finalize(t_3c_M_W_tmp)
6103 :
6104 : END DO ! i_mem
6105 :
6106 150 : CALL dbt_batched_contract_finalize(t_3c_O_W)
6107 : ! CALL dbt_batched_contract_finalize(t_3c_O_G)
6108 : ! CALL dbt_batched_contract_finalize(t_self_energy)
6109 :
6110 272 : IF (jquad <= num_integ_points) THEN
6111 :
6112 : CALL trafo_to_mo_and_kpoints(qs_env, mat_self_energy_ao_ao_neg_tau, vec_Sigma_c_gw_neg_tau(:, jquad, :, ispin), &
6113 132 : homo(ispin), gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), ispin)
6114 :
6115 : CALL trafo_to_mo_and_kpoints(qs_env, mat_self_energy_ao_ao_pos_tau, vec_Sigma_c_gw_pos_tau(:, jquad, :, ispin), &
6116 132 : homo(ispin), gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), ispin)
6117 :
6118 : vec_Sigma_c_gw_cos_tau(:, jquad, :, ispin) = 0.5_dp*(vec_Sigma_c_gw_pos_tau(:, jquad, :, ispin) + &
6119 3156 : vec_Sigma_c_gw_neg_tau(:, jquad, :, ispin))
6120 :
6121 : vec_Sigma_c_gw_sin_tau(:, jquad, :, ispin) = 0.5_dp*(vec_Sigma_c_gw_pos_tau(:, jquad, :, ispin) - &
6122 3156 : vec_Sigma_c_gw_neg_tau(:, jquad, :, ispin))
6123 : ELSE
6124 :
6125 : CALL trafo_to_mo_and_kpoints(qs_env, mat_self_energy_ao_ao_neg_tau, &
6126 : vec_Sigma_x_gw(mo_start(ispin):mo_end(ispin), :, ispin), &
6127 18 : homo(ispin), gw_corr_lev_occ(ispin), gw_corr_lev_virt(ispin), ispin)
6128 :
6129 : END IF
6130 :
6131 : END DO ! spins
6132 :
6133 122 : t2 = m_walltime()
6134 :
6135 140 : IF (unit_nr > 0) WRITE (unit_nr, '(T6,A,T56,F25.1)') 'Execution time (s):', t2 - t1
6136 :
6137 : END DO ! jquad (tau)
6138 :
6139 18 : IF (count_ev_sc_GW == 1 .AND. count_sc_GW0 == 1) THEN
6140 :
6141 18 : CALL compute_minus_vxc_kpoints(qs_env)
6142 :
6143 18 : IF (do_ri_Sigma_x) THEN
6144 32 : DO ispin = 1, nspins
6145 : mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, ispin, :) = mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, ispin, :) + &
6146 2672 : vec_Sigma_x_gw(:, :, ispin)
6147 : END DO
6148 : END IF
6149 :
6150 : END IF
6151 :
6152 : ! Fourier transform from time to frequency
6153 70 : DO jquad = 1, num_fit_points
6154 :
6155 382 : DO iquad = 1, num_integ_points
6156 :
6157 312 : omega = tj(jquad)
6158 312 : tau = tau_tj(iquad)
6159 312 : weight_cos = weights_cos_tf_t_to_w(jquad, iquad)*COS(omega*tau)
6160 312 : weight_sin = weights_sin_tf_t_to_w(jquad, iquad)*SIN(omega*tau)
6161 :
6162 : vec_Sigma_c_gw_cos_omega(:, jquad, :, :) = vec_Sigma_c_gw_cos_omega(:, jquad, :, :) + &
6163 9480 : weight_cos*vec_Sigma_c_gw_cos_tau(:, iquad, :, :)
6164 :
6165 : vec_Sigma_c_gw_sin_omega(:, jquad, :, :) = vec_Sigma_c_gw_sin_omega(:, jquad, :, :) + &
6166 9532 : weight_sin*vec_Sigma_c_gw_sin_tau(:, iquad, :, :)
6167 :
6168 : END DO
6169 :
6170 : END DO
6171 :
6172 : ! for occupied levels, we need the correlation self-energy for negative omega. Therefore, weight_sin
6173 : ! should be computed with -omega, which results in an additional minus for vec_Sigma_c_gw_sin_omega:
6174 40 : DO ispin = 1, nspins
6175 : vec_Sigma_c_gw_sin_omega(1:gw_corr_lev_occ(ispin), :, :, ispin) = &
6176 2224 : -vec_Sigma_c_gw_sin_omega(1:gw_corr_lev_occ(ispin), :, :, ispin)
6177 : END DO
6178 :
6179 : vec_Sigma_c_gw(:, 1:num_fit_points, :, :) = vec_Sigma_c_gw_cos_omega(:, 1:num_fit_points, :, :) + &
6180 1672 : gaussi*vec_Sigma_c_gw_sin_omega(:, 1:num_fit_points, :, :)
6181 :
6182 18 : CALL dbt_pgrid_destroy(pgrid_2d)
6183 :
6184 18 : CALL dbcsr_release(mat_greens_fct_occ)
6185 18 : CALL dbcsr_release(mat_greens_fct_virt)
6186 18 : CALL dbcsr_release(mat_self_energy_ao_ao_neg_tau)
6187 18 : CALL dbcsr_release(mat_self_energy_ao_ao_pos_tau)
6188 18 : CALL dbcsr_release(mat_mo_coeff)
6189 :
6190 18 : CALL dbcsr_deallocate_matrix_set(mat_p_greens_fct_occ)
6191 18 : CALL dbcsr_deallocate_matrix_set(mat_p_greens_fct_virt)
6192 :
6193 18 : CALL dbt_destroy(t_W)
6194 18 : CALL dbt_destroy(t_RI_tmp)
6195 18 : CALL dbt_destroy(t_greens_fct_occ)
6196 18 : CALL dbt_destroy(t_greens_fct_virt)
6197 18 : CALL dbt_destroy(t_AO_tmp)
6198 18 : CALL dbt_destroy(t_3c_O_all)
6199 18 : CALL dbt_destroy(t_3c_M_W_tmp)
6200 18 : CALL dbt_destroy(t_3c_O_W)
6201 :
6202 18 : DEALLOCATE (vec_Sigma_c_gw_pos_tau)
6203 18 : DEALLOCATE (vec_Sigma_c_gw_neg_tau)
6204 18 : DEALLOCATE (vec_Sigma_c_gw_cos_tau)
6205 18 : DEALLOCATE (vec_Sigma_c_gw_sin_tau)
6206 18 : DEALLOCATE (vec_Sigma_c_gw_cos_omega)
6207 18 : DEALLOCATE (vec_Sigma_c_gw_sin_omega)
6208 :
6209 18 : CALL timestop(handle)
6210 :
6211 108 : END SUBROUTINE compute_self_energy_cubic_gw_kpoints
6212 :
6213 : ! **************************************************************************************************
6214 : !> \brief ...
6215 : !> \param qs_env ...
6216 : ! **************************************************************************************************
6217 18 : SUBROUTINE compute_minus_vxc_kpoints(qs_env)
6218 : TYPE(qs_environment_type), POINTER :: qs_env
6219 :
6220 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_minus_vxc_kpoints'
6221 :
6222 : INTEGER :: handle, ikp, ispin, nkp_self_energy, &
6223 : nmo, nspins
6224 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: diag_Sigma_x_minus_vxc_mo_mo
6225 : TYPE(cp_cfm_type) :: cfm_mo_coeff, ks_mat_ao_ao, &
6226 : ks_mat_no_xc_ao_ao, vxc_ao_ao, &
6227 : vxc_ao_mo, vxc_mo_mo
6228 : TYPE(cp_fm_struct_type), POINTER :: matrix_struct
6229 : TYPE(cp_fm_type) :: fm_dummy, fm_Sigma_x_minus_vxc_mo_mo, &
6230 : fm_tmp_im, fm_tmp_re
6231 : TYPE(dft_control_type), POINTER :: dft_control
6232 : TYPE(kpoint_type), POINTER :: kpoints_Sigma, kpoints_Sigma_no_xc
6233 : TYPE(mp_para_env_type), POINTER :: para_env
6234 :
6235 18 : CALL timeset(routineN, handle)
6236 :
6237 18 : CALL get_qs_env(qs_env, para_env=para_env, dft_control=dft_control)
6238 :
6239 18 : kpoints_Sigma => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma
6240 :
6241 18 : kpoints_Sigma_no_xc => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma_no_xc
6242 :
6243 18 : nkp_self_energy = kpoints_Sigma%nkp
6244 :
6245 18 : nspins = dft_control%nspins
6246 :
6247 18 : matrix_struct => kpoints_Sigma%kp_env(1)%kpoint_env%wmat(1, 1)%matrix_struct
6248 :
6249 18 : CALL cp_cfm_create(ks_mat_ao_ao, matrix_struct)
6250 18 : CALL cp_cfm_create(ks_mat_no_xc_ao_ao, matrix_struct)
6251 18 : CALL cp_cfm_create(vxc_ao_ao, matrix_struct)
6252 18 : CALL cp_cfm_create(vxc_ao_mo, matrix_struct)
6253 18 : CALL cp_cfm_create(vxc_mo_mo, matrix_struct)
6254 18 : CALL cp_cfm_create(cfm_mo_coeff, matrix_struct)
6255 18 : CALL cp_fm_create(fm_Sigma_x_minus_vxc_mo_mo, matrix_struct)
6256 18 : CALL cp_fm_create(fm_tmp_re, matrix_struct)
6257 18 : CALL cp_fm_create(fm_tmp_im, matrix_struct)
6258 :
6259 18 : CALL cp_cfm_get_info(cfm_mo_coeff, nrow_global=nmo)
6260 54 : ALLOCATE (diag_Sigma_x_minus_vxc_mo_mo(nmo))
6261 :
6262 18 : DEALLOCATE (qs_env%mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw)
6263 :
6264 72 : ALLOCATE (qs_env%mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(nmo, 2, nkp_self_energy))
6265 :
6266 154 : DO ikp = 1, nkp_self_energy
6267 :
6268 322 : DO ispin = 1, nspins
6269 :
6270 : ASSOCIATE (mos => kpoints_Sigma%kp_env(ikp)%kpoint_env%mos)
6271 168 : IF (ASSOCIATED(mos(1, ispin)%mo_coeff)) THEN
6272 168 : CALL cp_fm_copy_general(mos(1, ispin)%mo_coeff, fm_tmp_re, para_env)
6273 : ELSE
6274 0 : CALL cp_fm_copy_general(fm_dummy, fm_tmp_re, para_env)
6275 : END IF
6276 336 : IF (ASSOCIATED(mos(2, ispin)%mo_coeff)) THEN
6277 168 : CALL cp_fm_copy_general(mos(2, ispin)%mo_coeff, fm_tmp_im, para_env)
6278 : ELSE
6279 0 : CALL cp_fm_copy_general(fm_dummy, fm_tmp_im, para_env)
6280 : END IF
6281 : END ASSOCIATE
6282 :
6283 168 : CALL cp_fm_to_cfm(fm_tmp_re, fm_tmp_im, cfm_mo_coeff)
6284 :
6285 : CALL cp_fm_to_cfm(kpoints_Sigma%kp_env(ikp)%kpoint_env%wmat(1, ispin), &
6286 168 : kpoints_Sigma%kp_env(ikp)%kpoint_env%wmat(2, ispin), ks_mat_ao_ao)
6287 : ASSOCIATE (wmat => kpoints_Sigma_no_xc%kp_env(ikp)%kpoint_env%wmat)
6288 168 : IF (ASSOCIATED(wmat(1, ispin)%matrix_struct)) THEN
6289 168 : CALL cp_fm_copy_general(wmat(1, ispin), fm_tmp_re, para_env)
6290 : ELSE
6291 0 : CALL cp_fm_copy_general(fm_dummy, fm_tmp_re, para_env)
6292 : END IF
6293 336 : IF (ASSOCIATED(wmat(2, ispin)%matrix_struct)) THEN
6294 168 : CALL cp_fm_copy_general(wmat(2, ispin), fm_tmp_im, para_env)
6295 : ELSE
6296 0 : CALL cp_fm_copy_general(fm_dummy, fm_tmp_im, para_env)
6297 : END IF
6298 : END ASSOCIATE
6299 :
6300 168 : CALL cp_fm_to_cfm(fm_tmp_re, fm_tmp_im, vxc_ao_ao)
6301 :
6302 168 : CALL parallel_gemm('N', 'N', nmo, nmo, nmo, z_one, vxc_ao_ao, cfm_mo_coeff, z_zero, vxc_ao_mo)
6303 168 : CALL parallel_gemm('C', 'N', nmo, nmo, nmo, z_one, cfm_mo_coeff, vxc_ao_mo, z_zero, vxc_mo_mo)
6304 :
6305 168 : CALL cp_cfm_to_fm(vxc_mo_mo, fm_Sigma_x_minus_vxc_mo_mo)
6306 :
6307 168 : CALL cp_fm_get_diag(fm_Sigma_x_minus_vxc_mo_mo, diag_Sigma_x_minus_vxc_mo_mo)
6308 :
6309 3544 : qs_env%mp2_env%ri_g0w0%vec_Sigma_x_minus_vxc_gw(:, ispin, ikp) = diag_Sigma_x_minus_vxc_mo_mo(:)
6310 :
6311 : END DO
6312 :
6313 : END DO
6314 :
6315 18 : CALL cp_cfm_release(ks_mat_ao_ao)
6316 18 : CALL cp_cfm_release(ks_mat_no_xc_ao_ao)
6317 18 : CALL cp_cfm_release(vxc_ao_ao)
6318 18 : CALL cp_cfm_release(vxc_ao_mo)
6319 18 : CALL cp_cfm_release(vxc_mo_mo)
6320 18 : CALL cp_cfm_release(cfm_mo_coeff)
6321 18 : CALL cp_fm_release(fm_Sigma_x_minus_vxc_mo_mo)
6322 18 : CALL cp_fm_release(fm_tmp_re)
6323 18 : CALL cp_fm_release(fm_tmp_im)
6324 :
6325 18 : DEALLOCATE (diag_Sigma_x_minus_vxc_mo_mo)
6326 :
6327 18 : CALL timestop(handle)
6328 :
6329 36 : END SUBROUTINE compute_minus_vxc_kpoints
6330 :
6331 : ! **************************************************************************************************
6332 : !> \brief ...
6333 : !> \param qs_env ...
6334 : !> \param mat_self_energy_ao_ao ...
6335 : !> \param vec_Sigma ...
6336 : !> \param homo ...
6337 : !> \param gw_corr_lev_occ ...
6338 : !> \param gw_corr_lev_virt ...
6339 : !> \param ispin ...
6340 : ! **************************************************************************************************
6341 282 : SUBROUTINE trafo_to_mo_and_kpoints(qs_env, mat_self_energy_ao_ao, vec_Sigma, &
6342 : homo, gw_corr_lev_occ, gw_corr_lev_virt, ispin)
6343 : TYPE(qs_environment_type), POINTER :: qs_env
6344 : TYPE(dbcsr_type), TARGET :: mat_self_energy_ao_ao
6345 : REAL(KIND=dp), DIMENSION(:, :) :: vec_Sigma
6346 : INTEGER :: homo, gw_corr_lev_occ, gw_corr_lev_virt, &
6347 : ispin
6348 :
6349 : CHARACTER(LEN=*), PARAMETER :: routineN = 'trafo_to_mo_and_kpoints'
6350 :
6351 : INTEGER :: handle, ikp, nkp_self_energy, nmo, &
6352 : periodic(3), size_real_space
6353 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: diag_self_energy
6354 : TYPE(cell_type), POINTER :: cell
6355 : TYPE(cp_cfm_type) :: cfm_mo_coeff, cfm_self_energy_ao_ao, &
6356 : cfm_self_energy_ao_mo, &
6357 : cfm_self_energy_mo_mo
6358 : TYPE(cp_fm_struct_type), POINTER :: matrix_struct
6359 : TYPE(cp_fm_type) :: fm_self_energy_mo_mo
6360 282 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: mat_self_energy_ao_ao_kp_im, &
6361 282 : mat_self_energy_ao_ao_kp_re, mat_self_energy_ao_ao_real_space
6362 : TYPE(kpoint_type), POINTER :: kpoints_Sigma
6363 : TYPE(mp_para_env_type), POINTER :: para_env
6364 :
6365 282 : CALL timeset(routineN, handle)
6366 :
6367 282 : CALL get_qs_env(qs_env, cell=cell, para_env=para_env)
6368 282 : CALL get_cell(cell=cell, periodic=periodic)
6369 :
6370 282 : size_real_space = 3**(periodic(1) + periodic(2) + periodic(3))
6371 :
6372 282 : CALL alloc_mat_set(mat_self_energy_ao_ao_real_space, size_real_space, mat_self_energy_ao_ao)
6373 :
6374 282 : CALL dbcsr_copy(mat_self_energy_ao_ao_real_space(1)%matrix, mat_self_energy_ao_ao)
6375 :
6376 282 : kpoints_Sigma => qs_env%mp2_env%ri_rpa_im_time%kpoints_Sigma
6377 :
6378 282 : CALL get_mat_cell_T_from_mat_gamma(mat_self_energy_ao_ao_real_space, qs_env, kpoints_Sigma, 0, 0)
6379 :
6380 282 : nkp_self_energy = kpoints_Sigma%nkp
6381 :
6382 282 : CALL alloc_mat_set(mat_self_energy_ao_ao_kp_re, nkp_self_energy, mat_self_energy_ao_ao)
6383 282 : CALL alloc_mat_set(mat_self_energy_ao_ao_kp_im, nkp_self_energy, mat_self_energy_ao_ao)
6384 :
6385 : CALL real_space_to_kpoint_transform_rpa(mat_self_energy_ao_ao_kp_re, mat_self_energy_ao_ao_kp_im, &
6386 282 : mat_self_energy_ao_ao_real_space, kpoints_Sigma, 1.0E-50_dp)
6387 :
6388 282 : CALL dbcsr_get_info(mat_self_energy_ao_ao, nfullrows_total=nmo)
6389 846 : ALLOCATE (diag_self_energy(nmo))
6390 :
6391 282 : matrix_struct => kpoints_Sigma%kp_env(1)%kpoint_env%mos(1, 1)%mo_coeff%matrix_struct
6392 :
6393 282 : CALL cp_cfm_create(cfm_self_energy_ao_ao, matrix_struct)
6394 282 : CALL cp_cfm_create(cfm_self_energy_ao_mo, matrix_struct)
6395 282 : CALL cp_cfm_create(cfm_self_energy_mo_mo, matrix_struct)
6396 282 : CALL cp_cfm_set_all(cfm_self_energy_ao_ao, z_zero)
6397 282 : CALL cp_cfm_set_all(cfm_self_energy_ao_mo, z_zero)
6398 282 : CALL cp_cfm_set_all(cfm_self_energy_mo_mo, z_zero)
6399 :
6400 282 : CALL cp_fm_create(fm_self_energy_mo_mo, matrix_struct)
6401 282 : CALL cp_cfm_create(cfm_mo_coeff, matrix_struct)
6402 :
6403 2434 : DO ikp = 1, nkp_self_energy
6404 :
6405 : CALL dbcsr_to_cfm(mat_self_energy_ao_ao_kp_re(ikp)%matrix, &
6406 2152 : mat_self_energy_ao_ao_kp_im(ikp)%matrix, cfm_self_energy_ao_ao)
6407 :
6408 : CALL cp_fm_to_cfm(kpoints_Sigma%kp_env(ikp)%kpoint_env%mos(1, ispin)%mo_coeff, &
6409 2152 : kpoints_Sigma%kp_env(ikp)%kpoint_env%mos(2, ispin)%mo_coeff, cfm_mo_coeff)
6410 :
6411 : CALL parallel_gemm('N', 'N', nmo, nmo, nmo, z_one, cfm_self_energy_ao_ao, cfm_mo_coeff, &
6412 2152 : z_zero, cfm_self_energy_ao_mo)
6413 :
6414 : CALL parallel_gemm('C', 'N', nmo, nmo, nmo, z_one, cfm_mo_coeff, cfm_self_energy_ao_mo, &
6415 2152 : z_zero, cfm_self_energy_mo_mo)
6416 :
6417 2152 : CALL cp_cfm_to_fm(cfm_self_energy_mo_mo, fm_self_energy_mo_mo)
6418 :
6419 2152 : CALL cp_fm_get_diag(fm_self_energy_mo_mo, diag_self_energy)
6420 :
6421 6738 : vec_Sigma(:, ikp) = diag_self_energy(homo - gw_corr_lev_occ + 1:homo + gw_corr_lev_virt)
6422 :
6423 : END DO
6424 :
6425 282 : CALL dbcsr_deallocate_matrix_set(mat_self_energy_ao_ao_real_space)
6426 282 : CALL dbcsr_deallocate_matrix_set(mat_self_energy_ao_ao_kp_re)
6427 282 : CALL dbcsr_deallocate_matrix_set(mat_self_energy_ao_ao_kp_im)
6428 :
6429 282 : CALL cp_cfm_release(cfm_self_energy_ao_ao)
6430 282 : CALL cp_cfm_release(cfm_self_energy_ao_mo)
6431 282 : CALL cp_cfm_release(cfm_self_energy_mo_mo)
6432 282 : CALL cp_cfm_release(cfm_mo_coeff)
6433 282 : CALL cp_fm_release(fm_self_energy_mo_mo)
6434 :
6435 282 : DEALLOCATE (diag_self_energy)
6436 :
6437 282 : CALL timestop(handle)
6438 :
6439 1128 : END SUBROUTINE trafo_to_mo_and_kpoints
6440 :
6441 : ! **************************************************************************************************
6442 : !> \brief ...
6443 : !> \param dbcsr_re ...
6444 : !> \param dbcsr_im ...
6445 : !> \param cfm_mat ...
6446 : ! **************************************************************************************************
6447 6456 : SUBROUTINE dbcsr_to_cfm(dbcsr_re, dbcsr_im, cfm_mat)
6448 :
6449 : TYPE(dbcsr_type), POINTER :: dbcsr_re, dbcsr_im
6450 : TYPE(cp_cfm_type), INTENT(IN) :: cfm_mat
6451 :
6452 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbcsr_to_cfm'
6453 :
6454 : INTEGER :: handle
6455 : TYPE(cp_fm_type) :: fm_mat_im, fm_mat_re
6456 :
6457 2152 : CALL timeset(routineN, handle)
6458 :
6459 2152 : CALL cp_fm_create(fm_mat_re, cfm_mat%matrix_struct)
6460 2152 : CALL cp_fm_create(fm_mat_im, cfm_mat%matrix_struct)
6461 2152 : CALL cp_fm_set_all(fm_mat_re, 0.0_dp)
6462 2152 : CALL cp_fm_set_all(fm_mat_im, 0.0_dp)
6463 :
6464 2152 : CALL copy_dbcsr_to_fm(dbcsr_re, fm_mat_re)
6465 2152 : CALL copy_dbcsr_to_fm(dbcsr_im, fm_mat_im)
6466 :
6467 2152 : CALL cp_fm_to_cfm(fm_mat_re, fm_mat_im, cfm_mat)
6468 :
6469 2152 : CALL cp_fm_release(fm_mat_re)
6470 2152 : CALL cp_fm_release(fm_mat_im)
6471 :
6472 2152 : CALL timestop(handle)
6473 :
6474 2152 : END SUBROUTINE dbcsr_to_cfm
6475 :
6476 : ! **************************************************************************************************
6477 : !> \brief ...
6478 : !> \param mat_set ...
6479 : !> \param mat_size ...
6480 : !> \param template ...
6481 : !> \param explicitly_no_symmetry ...
6482 : ! **************************************************************************************************
6483 846 : SUBROUTINE alloc_mat_set(mat_set, mat_size, template, explicitly_no_symmetry)
6484 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: mat_set
6485 : INTEGER, INTENT(IN) :: mat_size
6486 : TYPE(dbcsr_type), TARGET :: template
6487 : LOGICAL, OPTIONAL :: explicitly_no_symmetry
6488 :
6489 : CHARACTER(LEN=*), PARAMETER :: routineN = 'alloc_mat_set'
6490 :
6491 : INTEGER :: handle, i_size
6492 : LOGICAL :: my_explicitly_no_symmetry
6493 :
6494 846 : CALL timeset(routineN, handle)
6495 :
6496 846 : my_explicitly_no_symmetry = .FALSE.
6497 846 : IF (PRESENT(explicitly_no_symmetry)) my_explicitly_no_symmetry = explicitly_no_symmetry
6498 :
6499 846 : NULLIFY (mat_set)
6500 846 : CALL dbcsr_allocate_matrix_set(mat_set, mat_size)
6501 7688 : DO i_size = 1, mat_size
6502 6842 : ALLOCATE (mat_set(i_size)%matrix)
6503 6842 : IF (my_explicitly_no_symmetry) THEN
6504 : CALL dbcsr_create(matrix=mat_set(i_size)%matrix, template=template, &
6505 0 : matrix_type=dbcsr_type_no_symmetry)
6506 : ELSE
6507 6842 : CALL dbcsr_create(matrix=mat_set(i_size)%matrix, template=template)
6508 : END IF
6509 6842 : CALL dbcsr_copy(mat_set(i_size)%matrix, template)
6510 7688 : CALL dbcsr_set(mat_set(i_size)%matrix, 0.0_dp)
6511 : END DO
6512 :
6513 846 : CALL timestop(handle)
6514 :
6515 846 : END SUBROUTINE alloc_mat_set
6516 :
6517 : ! **************************************************************************************************
6518 : !> \brief ...
6519 : !> \param mat_set ...
6520 : !> \param mat_size_1 ...
6521 : !> \param mat_size_2 ...
6522 : !> \param template ...
6523 : !> \param explicitly_no_symmetry ...
6524 : ! **************************************************************************************************
6525 4 : SUBROUTINE alloc_mat_set_2d(mat_set, mat_size_1, mat_size_2, template, explicitly_no_symmetry)
6526 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mat_set
6527 : INTEGER, INTENT(IN) :: mat_size_1, mat_size_2
6528 : TYPE(dbcsr_type), TARGET :: template
6529 : LOGICAL, OPTIONAL :: explicitly_no_symmetry
6530 :
6531 : CHARACTER(LEN=*), PARAMETER :: routineN = 'alloc_mat_set_2d'
6532 :
6533 : INTEGER :: handle, i_size, j_size
6534 : LOGICAL :: my_explicitly_no_symmetry
6535 :
6536 4 : CALL timeset(routineN, handle)
6537 :
6538 4 : my_explicitly_no_symmetry = .FALSE.
6539 4 : IF (PRESENT(explicitly_no_symmetry)) my_explicitly_no_symmetry = explicitly_no_symmetry
6540 :
6541 4 : NULLIFY (mat_set)
6542 4 : CALL dbcsr_allocate_matrix_set(mat_set, mat_size_1, mat_size_2)
6543 16 : DO i_size = 1, mat_size_1
6544 124 : DO j_size = 1, mat_size_2
6545 108 : ALLOCATE (mat_set(i_size, j_size)%matrix)
6546 108 : IF (my_explicitly_no_symmetry) THEN
6547 : CALL dbcsr_create(matrix=mat_set(i_size, j_size)%matrix, template=template, &
6548 108 : matrix_type=dbcsr_type_no_symmetry)
6549 : ELSE
6550 0 : CALL dbcsr_create(matrix=mat_set(i_size, j_size)%matrix, template=template)
6551 : END IF
6552 108 : CALL dbcsr_copy(mat_set(i_size, j_size)%matrix, template)
6553 120 : CALL dbcsr_set(mat_set(i_size, j_size)%matrix, 0.0_dp)
6554 : END DO
6555 : END DO
6556 :
6557 4 : CALL timestop(handle)
6558 :
6559 4 : END SUBROUTINE alloc_mat_set_2d
6560 :
6561 : ! **************************************************************************************************
6562 : !> \brief ...
6563 : !> \param t_3c_O_all ...
6564 : !> \param t_greens_fct ...
6565 : !> \param t_3c_O_W ...
6566 : !> \param mat_self_energy_ao_ao ...
6567 : !> \param bounds_ao_ao_j ...
6568 : !> \param bounds_RI_i ...
6569 : !> \param unit_nr ...
6570 : !> \param eps_filter ...
6571 : !> \param do_occ ...
6572 : !> \param do_virt ...
6573 : ! **************************************************************************************************
6574 3680 : SUBROUTINE contract_to_self_energy(t_3c_O_all, t_greens_fct, t_3c_O_W, &
6575 : mat_self_energy_ao_ao, bounds_ao_ao_j, bounds_RI_i, &
6576 : unit_nr, eps_filter, do_occ, do_virt)
6577 :
6578 : TYPE(dbt_type) :: t_3c_O_all, t_greens_fct, t_3c_O_W
6579 : TYPE(dbcsr_type), TARGET :: mat_self_energy_ao_ao
6580 : INTEGER, DIMENSION(2, 2) :: bounds_ao_ao_j
6581 : INTEGER, DIMENSION(2, 1) :: bounds_RI_i
6582 : INTEGER :: unit_nr
6583 : REAL(KIND=dp) :: eps_filter
6584 : LOGICAL :: do_occ, do_virt
6585 :
6586 : CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_to_self_energy'
6587 :
6588 : INTEGER :: handle
6589 : INTEGER, DIMENSION(2, 1) :: bounds_ao_j
6590 : INTEGER, DIMENSION(2, 2) :: bounds_ao_all_RI_i, bounds_RI_i_ao_j
6591 : REAL(KIND=dp) :: sign_self_energy
6592 92000 : TYPE(dbt_type) :: t_3c_O_G, t_3c_O_G_tmp, t_self_energy, &
6593 33120 : t_self_energy_tmp
6594 :
6595 3680 : CALL timeset(routineN, handle)
6596 :
6597 3680 : CPASSERT(do_occ .EQV. (.NOT. do_virt))
6598 :
6599 3680 : CALL dbt_create(t_3c_O_all, t_3c_O_G, name="M occ (RI AO | AO)")
6600 3680 : CALL dbt_create(t_3c_O_all, t_3c_O_G_tmp, name="M occ (RI AO | AO)")
6601 3680 : CALL dbt_create(t_greens_fct, t_self_energy, name="(AO|AO)")
6602 3680 : CALL dbt_create(mat_self_energy_ao_ao, t_self_energy_tmp)
6603 :
6604 11040 : bounds_ao_j(:, 1) = bounds_ao_ao_j(:, 1)
6605 11040 : bounds_ao_all_RI_i(:, 1) = bounds_RI_i(:, 1)
6606 11040 : bounds_ao_all_RI_i(:, 2) = bounds_ao_ao_j(:, 2)
6607 :
6608 : CALL dbt_contract(1.0_dp, t_greens_fct, t_3c_O_all, 0.0_dp, &
6609 : t_3c_O_G_tmp, &
6610 : contract_1=[2], notcontract_1=[1], &
6611 : contract_2=[3], notcontract_2=[1, 2], &
6612 : map_1=[3], map_2=[1, 2], &
6613 : bounds_2=bounds_ao_j, &
6614 : bounds_3=bounds_ao_all_RI_i, &
6615 : filter_eps=eps_filter, &
6616 3680 : unit_nr=unit_nr)
6617 :
6618 3680 : CALL dbt_copy(t_3c_O_G_tmp, t_3c_O_G, order=[1, 3, 2], move_data=.TRUE.)
6619 :
6620 3680 : IF (do_occ) sign_self_energy = -1.0_dp
6621 3680 : IF (do_virt) sign_self_energy = 1.0_dp
6622 :
6623 11040 : bounds_RI_i_ao_j(:, 1) = bounds_RI_i(:, 1)
6624 11040 : bounds_RI_i_ao_j(:, 2) = bounds_ao_ao_j(:, 1)
6625 :
6626 : CALL dbt_contract(sign_self_energy, t_3c_O_W, t_3c_O_G, 0.0_dp, &
6627 : t_self_energy, &
6628 : contract_1=[1, 2], notcontract_1=[3], &
6629 : contract_2=[1, 2], notcontract_2=[3], &
6630 : map_1=[1], map_2=[2], &
6631 : bounds_1=bounds_RI_i_ao_j, &
6632 : filter_eps=eps_filter, &
6633 3680 : unit_nr=unit_nr)
6634 :
6635 3680 : CALL dbt_copy(t_self_energy, t_self_energy_tmp)
6636 3680 : CALL dbt_clear(t_self_energy)
6637 :
6638 3680 : CALL dbt_copy_tensor_to_matrix(t_self_energy_tmp, mat_self_energy_ao_ao, summation=.TRUE.)
6639 :
6640 3680 : CALL dbt_destroy(t_3c_O_G)
6641 3680 : CALL dbt_destroy(t_3c_O_G_tmp)
6642 3680 : CALL dbt_destroy(t_self_energy)
6643 3680 : CALL dbt_destroy(t_self_energy_tmp)
6644 :
6645 3680 : CALL timestop(handle)
6646 :
6647 3680 : END SUBROUTINE contract_to_self_energy
6648 :
6649 : ! **************************************************************************************************
6650 : !> \brief ...
6651 : !> \param t_3c_overl_int_gw_AO ...
6652 : !> \param t_3c_overl_int_gw_RI ...
6653 : !> \param t_AO ...
6654 : !> \param t_RI ...
6655 : !> \param prefac ...
6656 : !> \param mo_bounds ...
6657 : !> \param unit_nr ...
6658 : !> \param t_3c_ctr_RI ...
6659 : !> \param t_3c_ctr_AO ...
6660 : !> \param calculate_ctr_RI ...
6661 : ! **************************************************************************************************
6662 1362 : SUBROUTINE contract_cubic_gw(t_3c_overl_int_gw_AO, t_3c_overl_int_gw_RI, &
6663 : t_AO, t_RI, prefac, &
6664 : mo_bounds, unit_nr, &
6665 : t_3c_ctr_RI, t_3c_ctr_AO, calculate_ctr_RI)
6666 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_overl_int_gw_AO, &
6667 : t_3c_overl_int_gw_RI, t_AO, t_RI
6668 : REAL(dp), DIMENSION(2), INTENT(IN) :: prefac
6669 : INTEGER, DIMENSION(2), INTENT(IN) :: mo_bounds
6670 : INTEGER, INTENT(IN) :: unit_nr
6671 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_ctr_RI, t_3c_ctr_AO
6672 : LOGICAL, INTENT(IN) :: calculate_ctr_RI
6673 :
6674 : CHARACTER(LEN=*), PARAMETER :: routineN = 'contract_cubic_gw'
6675 :
6676 : INTEGER :: handle
6677 : INTEGER, DIMENSION(2, 2) :: ctr_bounds_mo
6678 : INTEGER, DIMENSION(3) :: bounds_3c
6679 :
6680 1362 : CALL timeset(routineN, handle)
6681 :
6682 1362 : IF (calculate_ctr_RI) THEN
6683 682 : CALL dbt_get_info(t_3c_overl_int_gw_RI, nfull_total=bounds_3c)
6684 2046 : ctr_bounds_mo(:, 1) = [1, bounds_3c(2)]
6685 2046 : ctr_bounds_mo(:, 2) = mo_bounds
6686 :
6687 : CALL dbt_contract(prefac(1), t_RI, t_3c_overl_int_gw_RI, 0.0_dp, &
6688 : t_3c_ctr_RI, &
6689 : contract_1=[2], notcontract_1=[1], &
6690 : contract_2=[1], notcontract_2=[2, 3], &
6691 : map_1=[1], map_2=[2, 3], &
6692 : bounds_3=ctr_bounds_mo, &
6693 682 : unit_nr=unit_nr)
6694 :
6695 : END IF
6696 :
6697 1362 : CALL dbt_get_info(t_3c_overl_int_gw_AO, nfull_total=bounds_3c)
6698 4086 : ctr_bounds_mo(:, 1) = [1, bounds_3c(2)]
6699 4086 : ctr_bounds_mo(:, 2) = mo_bounds
6700 :
6701 : CALL dbt_contract(prefac(2), t_AO, t_3c_overl_int_gw_AO, 0.0_dp, &
6702 : t_3c_ctr_AO, &
6703 : contract_1=[2], notcontract_1=[1], &
6704 : contract_2=[1], notcontract_2=[2, 3], &
6705 : map_1=[1], map_2=[2, 3], &
6706 : bounds_3=ctr_bounds_mo, &
6707 1362 : unit_nr=unit_nr)
6708 :
6709 1362 : CALL timestop(handle)
6710 :
6711 1362 : END SUBROUTINE
6712 :
6713 : ! **************************************************************************************************
6714 : !> \brief ...
6715 : !> \param t3c_1 ...
6716 : !> \param t3c_2 ...
6717 : !> \param vec_sigma ...
6718 : !> \param mo_offset ...
6719 : !> \param mo_bounds ...
6720 : !> \param para_env ...
6721 : ! **************************************************************************************************
6722 1362 : SUBROUTINE trace_sigma_gw(t3c_1, t3c_2, vec_sigma, mo_offset, mo_bounds, para_env)
6723 : TYPE(dbt_type), INTENT(INOUT) :: t3c_1, t3c_2
6724 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: vec_Sigma
6725 : INTEGER, INTENT(IN) :: mo_offset
6726 : INTEGER, DIMENSION(2), INTENT(IN) :: mo_bounds
6727 : TYPE(mp_para_env_type), INTENT(IN) :: para_env
6728 :
6729 : CHARACTER(LEN=*), PARAMETER :: routineN = 'trace_sigma_gw'
6730 :
6731 : INTEGER :: handle, n, n_end, n_end_block, n_start, &
6732 : n_start_block
6733 : INTEGER, DIMENSION(1) :: trace_shape
6734 : INTEGER, DIMENSION(2) :: mo_bounds_off
6735 : INTEGER, DIMENSION(3) :: boff, bsize, ind
6736 : LOGICAL :: found
6737 1362 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: block_1, block_2
6738 : REAL(KIND=dp), &
6739 2724 : DIMENSION(mo_bounds(2)-mo_bounds(1)+1) :: vec_Sigma_prv
6740 : TYPE(dbt_iterator_type) :: iter
6741 12258 : TYPE(dbt_type) :: t3c_1_redist
6742 :
6743 1362 : CALL timeset(routineN, handle)
6744 :
6745 1362 : CALL dbt_create(t3c_2, t3c_1_redist)
6746 1362 : CALL dbt_copy(t3c_1, t3c_1_redist, order=[2, 1, 3], move_data=.TRUE.)
6747 :
6748 16646 : vec_Sigma_prv = 0.0_dp
6749 :
6750 : !$OMP PARALLEL DEFAULT(NONE) REDUCTION(+:vec_Sigma_prv) &
6751 : !$OMP SHARED(t3c_1_redist,t3c_2,mo_bounds) &
6752 : !$OMP PRIVATE(iter,ind,bsize,boff,block_1,block_2,found) &
6753 1362 : !$OMP PRIVATE(n_start_block,n_start,n_end_block,n_end,trace_shape)
6754 : CALL dbt_iterator_start(iter, t3c_1_redist)
6755 : DO WHILE (dbt_iterator_blocks_left(iter))
6756 : CALL dbt_iterator_next_block(iter, ind, blk_size=bsize, blk_offset=boff)
6757 : CALL dbt_get_block(t3c_1_redist, ind, block_1, found)
6758 : CPASSERT(found)
6759 : CALL dbt_get_block(t3c_2, ind, block_2, found)
6760 : IF (.NOT. found) CYCLE
6761 :
6762 : IF (boff(3) < mo_bounds(1)) THEN
6763 : n_start_block = mo_bounds(1) - boff(3) + 1
6764 : n_start = 1
6765 : ELSE
6766 : n_start_block = 1
6767 : n_start = boff(3) - mo_bounds(1) + 1
6768 : END IF
6769 :
6770 : IF (boff(3) + bsize(3) - 1 > mo_bounds(2)) THEN
6771 : n_end_block = mo_bounds(2) - boff(3) + 1
6772 : n_end = mo_bounds(2) - mo_bounds(1) + 1
6773 : ELSE
6774 : n_end_block = bsize(3)
6775 : n_end = boff(3) + bsize(3) - mo_bounds(1)
6776 : END IF
6777 :
6778 : trace_shape(1) = SIZE(block_1, 1)*SIZE(block_1, 2)
6779 : vec_Sigma_prv(n_start:n_end) = &
6780 : vec_Sigma_prv(n_start:n_end) + &
6781 : (/(DOT_PRODUCT(RESHAPE(block_1(:, :, n), trace_shape), &
6782 : RESHAPE(block_2(:, :, n), trace_shape)), &
6783 : n=n_start_block, n_end_block)/)
6784 : DEALLOCATE (block_1, block_2)
6785 : END DO
6786 : CALL dbt_iterator_stop(iter)
6787 : !$OMP END PARALLEL
6788 :
6789 1362 : CALL dbt_destroy(t3c_1_redist)
6790 :
6791 1362 : CALL para_env%sum(vec_Sigma_prv)
6792 :
6793 4086 : mo_bounds_off = mo_bounds - mo_offset + 1
6794 : vec_Sigma(mo_bounds_off(1):mo_bounds_off(2)) = &
6795 16646 : vec_Sigma(mo_bounds_off(1):mo_bounds_off(2)) + vec_Sigma_prv
6796 :
6797 1362 : CALL timestop(handle)
6798 2724 : END SUBROUTINE
6799 :
6800 : ! **************************************************************************************************
6801 : !> \brief ...
6802 : !> \param mat_greens_fct_occ ...
6803 : !> \param mat_greens_fct_virt ...
6804 : !> \param fm_mo_coeff_occ ...
6805 : !> \param fm_mo_coeff_virt ...
6806 : !> \param fm_mo_coeff_occ_scaled ...
6807 : !> \param fm_mo_coeff_virt_scaled ...
6808 : !> \param fm_scaled_dm_occ_tau ...
6809 : !> \param fm_scaled_dm_virt_tau ...
6810 : !> \param Eigenval ...
6811 : !> \param nmo ...
6812 : !> \param eps_filter ...
6813 : !> \param e_fermi ...
6814 : !> \param tau ...
6815 : !> \param para_env ...
6816 : ! **************************************************************************************************
6817 2040 : SUBROUTINE compute_Greens_function_time(mat_greens_fct_occ, mat_greens_fct_virt, fm_mo_coeff_occ, fm_mo_coeff_virt, &
6818 : fm_mo_coeff_occ_scaled, fm_mo_coeff_virt_scaled, &
6819 680 : fm_scaled_dm_occ_tau, fm_scaled_dm_virt_tau, Eigenval, nmo, &
6820 : eps_filter, e_fermi, tau, para_env)
6821 :
6822 : TYPE(dbcsr_type), INTENT(INOUT) :: mat_greens_fct_occ, mat_greens_fct_virt
6823 : TYPE(cp_fm_type), INTENT(IN) :: fm_mo_coeff_occ, fm_mo_coeff_virt, fm_mo_coeff_occ_scaled, &
6824 : fm_mo_coeff_virt_scaled, fm_scaled_dm_occ_tau, fm_scaled_dm_virt_tau
6825 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: Eigenval
6826 : INTEGER, INTENT(IN) :: nmo
6827 : REAL(KIND=dp), INTENT(IN) :: eps_filter, e_fermi, tau
6828 : TYPE(mp_para_env_type), INTENT(IN) :: para_env
6829 :
6830 : CHARACTER(LEN=*), PARAMETER :: routineN = 'compute_Greens_function_time'
6831 :
6832 : INTEGER :: handle, i_global, iiB, jjB, ncol_local, &
6833 : nrow_local
6834 680 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
6835 : REAL(KIND=dp) :: stabilize_exp
6836 :
6837 680 : CALL timeset(routineN, handle)
6838 :
6839 680 : CALL para_env%sync()
6840 :
6841 : ! get info of fm_mo_coeff_occ
6842 : CALL cp_fm_get_info(matrix=fm_mo_coeff_occ, &
6843 : nrow_local=nrow_local, &
6844 : ncol_local=ncol_local, &
6845 : row_indices=row_indices, &
6846 680 : col_indices=col_indices)
6847 :
6848 : ! Multiply the occupied and the virtual MO coefficients with the factor exp((-e_i-e_F)*tau/2).
6849 : ! Then, we simply get the sum over all occ states and virt. states by a simple matrix-matrix
6850 : ! multiplication.
6851 :
6852 680 : stabilize_exp = 70.0_dp
6853 :
6854 : ! first, the occ
6855 9890 : DO jjB = 1, nrow_local
6856 325840 : DO iiB = 1, ncol_local
6857 315950 : i_global = col_indices(iiB)
6858 :
6859 325160 : IF (ABS(tau*0.5_dp*(Eigenval(i_global) - e_fermi)) < stabilize_exp) THEN
6860 : fm_mo_coeff_occ_scaled%local_data(jjB, iiB) = &
6861 249734 : fm_mo_coeff_occ%local_data(jjB, iiB)*EXP(tau*0.5_dp*(Eigenval(i_global) - e_fermi))
6862 : ELSE
6863 66216 : fm_mo_coeff_occ_scaled%local_data(jjB, iiB) = 0.0_dp
6864 : END IF
6865 :
6866 : END DO
6867 : END DO
6868 :
6869 : ! the same for virt
6870 9890 : DO jjB = 1, nrow_local
6871 325840 : DO iiB = 1, ncol_local
6872 315950 : i_global = col_indices(iiB)
6873 :
6874 325160 : IF (ABS(tau*0.5_dp*(Eigenval(i_global) - e_fermi)) < stabilize_exp) THEN
6875 : fm_mo_coeff_virt_scaled%local_data(jjB, iiB) = &
6876 249734 : fm_mo_coeff_virt%local_data(jjB, iiB)*EXP(-tau*0.5_dp*(Eigenval(i_global) - e_fermi))
6877 : ELSE
6878 66216 : fm_mo_coeff_virt_scaled%local_data(jjB, iiB) = 0.0_dp
6879 : END IF
6880 :
6881 : END DO
6882 : END DO
6883 :
6884 680 : CALL para_env%sync()
6885 :
6886 : CALL parallel_gemm(transa="N", transb="T", m=nmo, n=nmo, k=nmo, alpha=1.0_dp, &
6887 : matrix_a=fm_mo_coeff_occ_scaled, matrix_b=fm_mo_coeff_occ_scaled, beta=0.0_dp, &
6888 680 : matrix_c=fm_scaled_dm_occ_tau)
6889 :
6890 : CALL parallel_gemm(transa="N", transb="T", m=nmo, n=nmo, k=nmo, alpha=1.0_dp, &
6891 : matrix_a=fm_mo_coeff_virt_scaled, matrix_b=fm_mo_coeff_virt_scaled, beta=0.0_dp, &
6892 680 : matrix_c=fm_scaled_dm_virt_tau)
6893 :
6894 680 : CALL dbcsr_set(mat_greens_fct_occ, 0.0_dp)
6895 :
6896 : CALL copy_fm_to_dbcsr(fm_scaled_dm_occ_tau, &
6897 : mat_greens_fct_occ, &
6898 680 : keep_sparsity=.FALSE.)
6899 :
6900 680 : CALL dbcsr_filter(mat_greens_fct_occ, eps_filter)
6901 :
6902 680 : CALL dbcsr_set(mat_greens_fct_virt, 0.0_dp)
6903 :
6904 : CALL copy_fm_to_dbcsr(fm_scaled_dm_virt_tau, &
6905 : mat_greens_fct_virt, &
6906 680 : keep_sparsity=.FALSE.)
6907 :
6908 680 : CALL dbcsr_filter(mat_greens_fct_virt, eps_filter)
6909 :
6910 680 : CALL timestop(handle)
6911 :
6912 680 : END SUBROUTINE compute_Greens_function_time
6913 :
6914 : END MODULE rpa_gw
6915 :
|
