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