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