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