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