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