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