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