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