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