Line data Source code
1 : !!****m* ABINIT/m_gwr
2 : !! NAME
3 : !! m_gwr
4 : !!
5 : !! FUNCTION
6 : !! Objects and procedures implementing the GW method in real-space and imaginary time.
7 : !!
8 : !! NOTES
9 : !! Memory and workload are distributed using a 4D cartesian grid: (g/r, tau, k-points, spin).
10 : !!
11 : !! Inside the g/r communicator, we use PBLAS matrices to store G, tchi and W
12 : !! using a 1D processor grid and block distribution along columns.
13 : !! A 2D grid, indeed, would require MPI-FFT or some communication before performing the FFTs along columns.
14 : !!
15 : !! Let's assume for simplicity that we have only two MPI procs in the g/r communicator.
16 : !! Matrices in (g,g') space are distributed along columns so that the g-index is local
17 : !! and we can use sequential zero-padded FFTs to transform from g to r in the unit cell:
18 : !!
19 : !! g'-axis
20 : !! |--------------------
21 : !! | | |
22 : !! g-axis | P0 | P1 |
23 : !! | | |
24 : !! |--------------------
25 : !!
26 : !! The results of the FFT transform along g are stored in another PBLAS matrix with the same layout:
27 : !!
28 : !! g'-axis
29 : !! |--------------------
30 : !! | | |
31 : !! r-axis | P0 | P1 |
32 : !! | | |
33 : !! |--------------------
34 : !!
35 : !! At this point, we call ptrans to MPI transpose the (r, g') matrix, and we end up with:
36 : !!
37 : !! r-axis
38 : !! |--------------------
39 : !! | | |
40 : !! g'-axis | P0 | P1 |
41 : !! | | |
42 : !! |--------------------
43 : !!
44 : !! Differences with respect to the quartic GW code formulated in frequency-domain (real axis)
45 : !!
46 : !! - in GWR, the k-mesh must be Gamma-centered when the supercell-method is used.
47 : !! Convolutions can use shifted k-meshes, although this part should be tests.
48 : !! - All the two-point functions are defined on k/q-centered g-spheres while GW uses a single Gamma-centered sphere.
49 : !! - The frequency/tau meshes are automatically defined by gwr_ntau and the KS energies up to nband (minimax meshes).
50 : !!
51 : !! Technical problems:
52 : !!
53 : !! - it's not clear to me that one can use vc(Sq, SG) when a cutoff is used as the cutoff breaks
54 : !! the spherical symmetry of vc(r). Besides, when symmetries are used to reconstruct the term for q in the BZ,
55 : !! one might have to take into account umklapps. Use cache?
56 : !!
57 : !! - Treatment of the anisotropic behaviour of Wc. This part is badly coded in GW, in the sense that
58 : !! we use a finite small q when computing Wc for q --> 0. This breaks the symmetry of the system
59 : !! and QP degeneracies. The equations needed to express the angular dependency of W(q) for q --> 0
60 : !! are well known but one has to pass through the Adler-Wiser expression.
61 : !! Possible solution: Compute heads and wings using a WFK_fine wavefunction file with dense k-mesh and less bands.
62 : !! The dipole matrix elements are computed with the DFPT routines, still we need to
63 : !! recode a lot of stuff that is already done in cchi0q0, especially symmetries.
64 : !! Note, however, that tchi is Hermitian along the imaginary axis, expect for omega = 0 in metals
65 : !! but I don't think the minmax grids contain omega = 0.
66 : !!
67 : !! - In principle, it's possible to compute QP correction along a k-path if a new WFK file is provided.
68 : !! The correlated part is evaluated in real-space in the super-cell.
69 : !! For Sigma_x, we need a specialized routine that can handle arbitrary q, especially at the level of v(q, G)
70 : !! but I don't know if this approach will give smooth bands
71 : !! as we don't have q --> 0 when k does not belong to the k-mesh.
72 : !!
73 : !! - New routine to compute oscillator matrix elements with NC/PAW and PBLAS matrices.
74 : !! It can be used to compute tchi head/wings as well as Sigma_x + interface with coupled-cluster codes.
75 : !!
76 : !! - Decide whether we should use VASP conventions for G and the analytic continuation or the "standard" ones by Godby.
77 : !! The standard ones are consistent with Hedin's notations and correspond to the ones used in the legacy GW code.
78 : !! On the other hand, VASP notations make life easier if one has to implement PAW as all the equations
79 : !! have been already derived.
80 : !!
81 : !! - Address nspinor = 2 and PBLAS distribution as MPI proc can have both spinors in memory
82 : !! In other words, we should store the first/last index in gvec for each spinor
83 : !!
84 : !! - Optimization for Gamma-only. Memory and c -> r FFTs
85 : !!
86 : !! - Need to extend FFT API to avoid scaling if isign = -1. Also fft_ug and fft_ur should accept isign
87 : !! optional argument. Refactoring of all the FFT routines used in the GW code is needed
88 : !! in order to exploit R2C, C2R (e.g. chi0(q=0) and GPU version.
89 : !!
90 : !! - Use round-robin distribution instead of blocked-distribution to improve load balance?
91 : !!
92 : !! - For nspinor = 2, we use 4 Scalapack matrices to store G^k_ab(g,g') instead of a single matrix of shape (2*npw, 2*npw)
93 : !!
94 : !! - Memory peaks:
95 : !!
96 : !! (env3.9) [magianto@uan01 /scratch/project_465000061/magianto/DDIAGO_ZnO]
97 : !! $~/git_repos/abinit/tests/Scripts/abimem.py peaks abimem_rank0.mocc
98 : !! [0] <var=gt_scbox, A@m_gwr.F90:3395, addr=0x14aa53673010, size_mb=379.688>
99 : !! [1] <var=xsum, A@xmpi_sum.finc:2551, addr=0x14aa2fce9010, size_mb=379.688>
100 : !! [2] <var=gt_scbox, A@m_gwr.F90:4338, addr=0x14aa4f64f010, size_mb=379.688>
101 : !! [3] <var=allcg_k, A@m_wfd.F90:4631, addr=0x14aa56b57010, size_mb=217.865>
102 : !! [5] <var=wct_scbox, A@m_gwr.F90:4339, addr=0x14aa43876010, size_mb=189.844>
103 : !! [6] <var=xsum, A@xmpi_sum.finc:2476, addr=0x14aa31bb0010, size_mb=189.844>
104 : !! [7] <var=cg_k, A@m_wfd.F90:4623, addr=0x14aa64535010, size_mb=108.932>
105 : !!
106 : !! TODO
107 : !! - Remove cryst%timrev, use kptopt and qptopt
108 : !! - Sig_c breaks QP degeneracies due to fixed q0.
109 : !!
110 : !! NOTES:
111 : !!
112 : !! 1) _slk_mat_t is a CPP macro defined in abi_common.h that allows us to use PBLAS in single/double precision
113 : !! Be careful when using c_f_pointer because there's no type checking.
114 : !!
115 : !! COPYRIGHT
116 : !! Copyright (C) 1999-2026 ABINIT group (MG)
117 : !! This file is distributed under the terms of the
118 : !! GNU General Public License, see ~abinit/COPYING
119 : !! or http://www.gnu.org/copyleft/gpl.txt .
120 : !!
121 : !! SOURCE
122 :
123 : #if defined HAVE_CONFIG_H
124 : #include "config.h"
125 : #endif
126 :
127 : #include "abi_common.h"
128 :
129 : ! nvtx related macro definition
130 : #include "nvtx_macros.h"
131 :
132 : module m_gwr
133 :
134 : use, intrinsic :: iso_c_binding
135 : use defs_basis
136 : use m_abicore
137 : use m_errors
138 : use m_xmpi
139 : use m_xomp
140 : use m_hdr
141 : use m_ebands
142 : use netcdf
143 : use m_nctk
144 : use m_dtfil
145 : use m_yaml
146 : use m_sigtk
147 : use m_hide_blas
148 : #if defined(HAVE_GPU_MARKERS)
149 : use m_nvtx_data
150 : #endif
151 :
152 : use defs_datatypes, only : pseudopotential_type
153 : use defs_abitypes, only : mpi_type
154 : use m_gwdefs, only : GW_TOL_DOCC, GW_TOLQ0, GW_TOL_W0, GW_Q0_DEFAULT, cone_gw, czero_gw, j_gw, sigijtab_t, &
155 : sigijtab_free, g0g0w
156 : use m_time, only : cwtime, cwtime_report, sec2str, timab
157 : use m_io_tools, only : iomode_from_fname, get_unit, file_exists, open_file, write_units
158 : use m_pstat, only : pstat_proc
159 : use m_numeric_tools, only : blocked_loop, get_diag, isdiagmat, arth, print_arr, imin_loc, imax_loc, &
160 : c2r, linfit, bisect, hermitianize
161 : use m_copy, only : alloc_copy
162 : use m_geometry, only : normv, vdotw, spinrot_cmat
163 : use m_fstrings, only : sjoin, itoa, strcat, ktoa, ltoa, ftoa, string_in, yesno
164 : use m_sort, only : sort_rvals, sort_gvecs, sort_dp
165 : use m_krank, only : krank_t, get_ibz2bz, star_from_ibz_idx
166 : use m_crystal, only : crystal_t
167 : use m_dtset, only : dataset_type
168 : use m_cplxtools, only : cplx_mat_plus_bc
169 : use m_fftcore, only : get_kg, sphereboundary, getng, print_ngfft, fftcore_set_mixprec, ngfft_seq
170 : use m_cgtk, only : cgtk_rotate
171 : use m_cgtools, only : cg_zdotc
172 : use m_mpinfo, only : initmpi_seq, destroy_mpi_enreg
173 : use m_kg, only : getcut
174 : use m_fft, only : fftbox_plan3_t, uplan_t, fft_ug, fft_ur, fourdp
175 : use m_fft_mesh, only : calc_ceikr, calc_ceigr
176 : use m_kpts, only : kpts_ibz_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map, kpts_map_print, kpts_pack_in_stars
177 : use m_bz_mesh, only : littlegroup_t, findqg0, kmesh_t
178 : use m_gsphere, only : kg_map, gsphere_t
179 : use m_melemts, only : melements_t
180 : use m_ioarr, only : fftdatar_write
181 : use m_slk, only : slkmat_dp_t, slkmat_sp_t, slk_processor_t, slk_array_free, slk_array_set_zero, slk_array_gpu_set_zero,&
182 : slk_array_locmem_mb, block_dist_1d, slk_pgemm
183 : use m_wfk, only : wfk_read_ebands, wfk_t
184 : use m_wfd, only : wfd_t, wfdgw_t
185 : use m_ddk, only : ddkop_t
186 : use m_pawtab, only : pawtab_type
187 : use m_pawcprj, only : pawcprj_type
188 : use m_vcoul, only : vcgen_t
189 : use m_vkbr, only : vkbr_t, vkbr_free, vkbr_init, nc_ihr_comm
190 : use m_chi0tk, only : chi0_bbp_mask, accumulate_head_wings_imagw, symmetrize_afm_chi0
191 : use m_sigx, only : sigx_symmetrize
192 : use m_dyson_solver, only : sigma_pade_t
193 : use minimax_grids, only : gx_minimax_grid
194 : use m_occ, only : get_fact_spin_tol_empty
195 :
196 : implicit none
197 :
198 : private
199 : !!***
200 :
201 : !!****t* m_gwr/desc_t
202 : !! NAME
203 : !! desc_t
204 : !!
205 : !! FUNCTION
206 : !! Parameters related to a two-point function such as
207 : !! gvectors, tables used for zero padded FFTs and matrix elements of the Coulomb interaction.
208 : !!
209 : !! SOURCE
210 :
211 : type,public :: desc_t
212 :
213 : integer :: istwfk = 1
214 : ! Storage mode for this k/q point.
215 :
216 : integer :: npw = -1
217 : ! Total number of plane-waves for this k/q-point.
218 :
219 : integer :: ig0 = -1
220 : ! Index of g=0 in gvec.
221 :
222 : logical :: kin_sorted
223 : ! True if gvec are sorted by |k+g|^2/2
224 :
225 : integer,allocatable :: gvec(:,:)
226 : ! (3, npw)
227 : ! G-vectors in reduced coordinates.
228 : ! Note that this array is global i.e. it is not MPI-distributed inside the PBLAS communicator.
229 :
230 : integer,allocatable :: gbound(:,:)
231 : ! (2*mgfft+8, 2)
232 : ! sphere boundary info for zero-padded FFT
233 :
234 : integer,allocatable :: g2box(:)
235 : ! (npw)
236 : ! Index of gvec in the supercell FFT box.
237 :
238 : integer :: cached_sc_ngfft(6) = -1
239 :
240 : complex(gwp),allocatable :: vc_sqrt_eps(:)
241 : ! (npw)
242 : ! Square root of the Coulomb interaction in reciprocal space.
243 : ! Allocated and computed for tchi/W descriptors.
244 : ! A Coulomb cutoff might be applied but NOT the MC technique
245 :
246 : complex(gwp),allocatable :: vc_sqrt_sigma(:)
247 : ! (npw)
248 : ! Square root of the Coulomb interaction in reciprocal space.
249 : ! Allocated and computed for Sigma descriptors.
250 : ! A Coulomb cutoff might be applied. MC technique can be used here
251 :
252 : integer,allocatable :: rottb(:,:,:)
253 : ! rottb(ng,timrev,nsym)
254 : ! rottb(G,I,S) is the index of (SI) G in the array gvec
255 : ! where I is either the identity or the inversion.
256 :
257 : integer,allocatable :: rottbm1(:,:,:)
258 : ! rottb(ng,timrev,nsym)
259 : ! rottbm1(G,I,S) is the index of IS{^-1} G in the array gvec
260 :
261 : complex(gwp),allocatable :: phmGt(:,:)
262 : ! phmGt(ng,nsym)
263 : ! Phase factor e^{-i2\pi(G.\tau)} where $\tau$ is the fractional translation associated to isym.
264 :
265 : complex(gwp),allocatable :: phmSGt(:,:)
266 : ! phmSGt(ng,nsym)
267 : ! Phase factor e^{-i2\pi(SG.\tau)} where S is one of the symmetry properties in reciprocal space.
268 :
269 : contains
270 :
271 : procedure :: init => desc_init
272 : ! Initialize the object
273 :
274 : procedure :: copy => desc_copy
275 : ! Copy object.
276 :
277 : procedure :: to_scbox => desc_to_scbox
278 : ! Insert cg_k array defined on the k-centered g-sphere with npw vectors inside the FFT box.
279 :
280 : procedure :: get_vc_sqrt => desc_get_vc_sqrt
281 : ! Compute square root of vc(q,g).
282 :
283 : procedure :: free => desc_free
284 : ! Free memory.
285 : end type desc_t
286 :
287 : interface desc_array_free
288 : module procedure desc_array1_free
289 : end interface desc_array_free
290 : !!***
291 :
292 : !----------------------------------------------------------------------
293 :
294 : !!****t* m_gwr/est_t
295 : !! NAME
296 : !! est_t
297 : !!
298 : !! FUNCTION
299 : !! Memory is given in Mb
300 : !!
301 : !! SOURCE
302 :
303 : type, public :: est_t
304 :
305 : real(dp) :: mem_green_gg = zero
306 : real(dp) :: mem_green_rg = zero
307 : real(dp) :: mem_chi_gg = zero
308 : real(dp) :: mem_chi_rg = zero
309 : real(dp) :: mem_ugb = zero
310 : real(dp) :: mem_total = zero
311 : real(dp) :: efficiency = zero
312 : real(dp) :: speedup = zero
313 :
314 : contains
315 : procedure :: print => est_print
316 : end type est_t
317 : !!***
318 :
319 : !----------------------------------------------------------------------
320 :
321 : !!****t* m_gwr/gwr_t
322 : !! NAME
323 : !! gwr_t
324 : !!
325 : !! FUNCTION
326 : !! This object provides the high-level API used to perform the different steps of the GWR algorithm.
327 : !!
328 : !! SOURCE
329 :
330 : type, public :: gwr_t
331 :
332 : integer :: nsppol = 1, nspinor = -1, nsig_ab = -1, nspden = -1
333 : ! Number of independent spin polarizations, number of spinor components and spin densities.
334 :
335 : integer :: natom = -1
336 : ! Number of atoms
337 :
338 : integer :: usepaw = -1
339 : ! 0 if NC pseudos. 1 if PAW is used (not yet supported).
340 :
341 : integer :: my_nspins = -1
342 : ! Number of independent spin polarizations treated by this MPI proc
343 :
344 : integer :: nkbz = -1, nkibz = -1
345 : ! Number of k-points in the BZ/IBZ
346 :
347 : integer :: my_nkibz = -1, my_nkbz = -1
348 : ! Number of k-points in the IBZ/BZ stored by this MPI proc.
349 :
350 : integer :: uc_batch_size = -1
351 : ! Max number of unit cell FFT-transforms done in batch mode.
352 :
353 : integer :: sc_batch_size = -1
354 : ! Max number of supercell-cell FFT-transforms done in batch mode.
355 :
356 : integer,allocatable :: my_kbz_inds(:)
357 : ! (my_nkbz)
358 : ! List of k-BZ indices treated by this proc.
359 :
360 : integer,allocatable :: my_kibz_inds(:)
361 : ! (my_nkibz)
362 : ! List of k-IBZ indices treated by this proc.
363 :
364 : integer :: nqbz = -1, nqibz = -1
365 : ! Number of q-points in the BZ/IBZ
366 :
367 : integer :: my_nqibz = -1, my_nqbz = -1
368 : ! Number of q-points in the IBZ/BZ stored by this MPI proc.
369 :
370 : integer,allocatable :: my_qibz_inds(:)
371 : ! (my_nqibz)
372 : ! List of q-IBZ indices treated by this proc.
373 :
374 : integer,allocatable :: my_qbz_inds(:)
375 : ! (my_nqbz)
376 : ! List of q-IBZ indices treated by this proc.
377 :
378 : integer :: ntau = -1
379 : ! Total number of imaginary time points.
380 :
381 : integer :: my_ntau = -1
382 : ! Number of imaginary time/frequency points treated by this MPI rank.
383 :
384 : integer :: nkcalc
385 : ! Number of Sigma_nk k-points computed
386 : ! TODO: Should be spin dependent + max_nkcalc
387 :
388 : integer :: max_nbcalc
389 : ! Maximum number of bands computed (max over nkcalc and spin).
390 :
391 : integer :: nwr = -1
392 : ! Number of frequency points along the real axis for Sigma(w) and spectral function A(w)
393 : ! Odd number so that the mesh is centered on the KS energy.
394 :
395 : !real(dp) :: i_sz = huge(one)
396 : ! Value of the integration of the Coulomb singularity 4\pi/V_BZ \int_BZ d^3q 1/q^2
397 :
398 : real(dp) :: wr_step = -one
399 : ! Step of the linear mesh along the real axis (Ha units).
400 :
401 : real(dp) :: q0(3) = GW_Q0_DEFAULT
402 : ! The small q for the treatment of q --> 0
403 :
404 : real(dp),allocatable :: kcalc(:,:)
405 : ! kcalc(3, nkcalc)
406 : ! List of k-points where the self-energy is computed.
407 :
408 : logical :: idle_proc = .False.
409 : ! True if there are idle procs i.e. if processes in the input_comm have been excluded.
410 :
411 : !logical :: use_shmem_for_k = .False.
412 : !logical :: use_mpi_for_k = .False.
413 :
414 : integer,allocatable :: bstart_ks(:,:)
415 : ! bstart_ks(nkcalc, nsppol)
416 : ! Initial KS band index included in self-energy matrix elements for each k-point in kcalc.
417 : ! Depends on spin because all degenerate states should be included when symsigma /= 0 is used.
418 :
419 : integer,allocatable :: bstop_ks(:,:)
420 : ! bstop_ks(nkcalc, nsppol)
421 :
422 : integer,allocatable :: nbcalc_ks(:,:)
423 : ! nbcalc_ks(nkcalc, nsppol)
424 : ! Number of bands included in self-energy matrix elements for each k-point in kcalc.
425 : ! Depends on spin because all degenerate states should be included when symsigma /= 0 is used.
426 :
427 : integer,allocatable :: kcalc2ibz(:,:)
428 : !kcalc2ibz(nkcalc, 6))
429 : ! Mapping ikcalc --> IBZ as reported by listkk.
430 :
431 : logical :: use_supercell_for_tchi = .True.
432 : ! True if we are using the supercell formalism for tchi
433 : ! False if we are using the mixed-space approach with convolutions in k-space.
434 :
435 : logical :: use_supercell_for_sigma = .True.
436 : ! True if we are using the supercell formalism for sigma
437 : ! False if we are using the mixed-space approach with convolutions in k-space.
438 :
439 : integer :: ngkpt(3) = -1, ngqpt(3) = -1
440 : ! Number of divisions in k/q meshes.
441 :
442 : integer,allocatable :: my_spins(:)
443 : ! (my_nspins)
444 : ! Indirect table giving the spin indices treated by this MPI rank.
445 : ! Used only in the collinear case with nsppol = 2.
446 :
447 : integer,allocatable :: my_itaus(:)
448 : ! (my_ntau)
449 : ! Indirect table giving the tau indices treated by this MPI rank.
450 :
451 : integer,allocatable :: tau_master(:)
452 : ! (ntau)
453 : ! The rank of the MPI proc in tau_comm treating itau.
454 :
455 : integer, allocatable :: np_qibz(:)
456 : ! (nqibz)
457 : ! Number of processors in kpt_comm treating iq_ibz
458 :
459 : integer, allocatable :: np_kibz(:)
460 : ! (nkibz)
461 : ! Number of processors in kpt_comm treating ik_ibz
462 :
463 : logical, allocatable :: itreat_ikibz(:)
464 : ! (nkibz)
465 : ! True if this MPI rank treats ik_ibz
466 :
467 : logical, allocatable :: itreat_iqibz(:)
468 : ! (nqibz)
469 : ! True if this MPI rank treats iq_ibz
470 :
471 : real(dp),allocatable :: tau_mesh(:), tau_wgs(:)
472 : ! (ntau)
473 : ! Imaginary tau mesh and integration weights.
474 :
475 : real(dp),allocatable :: iw_mesh(:), iw_wgs(:)
476 : ! (ntau)
477 : ! Imaginary frequency mesh and integration weights
478 :
479 : real(dp),allocatable :: cosft_wt(:,:)
480 : ! (ntau, ntau)
481 : ! weights for cosine transform. (i tau --> i omega)
482 :
483 : real(dp),allocatable :: cosft_tw(:,:)
484 : ! (ntau, ntau)
485 : ! weights for sine transform (i iomega --> i tau)
486 :
487 : real(dp),allocatable :: sinft_wt(:,:)
488 : ! (ntau, ntau)
489 : ! weights for sine transform (i tau --> i omega)
490 :
491 : real(dp) :: te_min = -one, te_max = one
492 : ! min and Max transition energy in Ha.
493 :
494 : real(dp) :: ft_max_error(3) = -one
495 : ! Max error due to inhomogenous FT.
496 :
497 : real(dp) :: cosft_duality_error = -one
498 : ! Max_{ij} |CT CT^{-1} - I|
499 :
500 : integer :: green_mpw = -1
501 : ! Max number of g-vectors for Green's function over k-points.
502 :
503 : integer :: tchi_mpw = -1
504 : ! Max number of g-vectors for tchi over q-points.
505 :
506 : !integer :: sigma_mpw = -1
507 : ! Max number of g-vectors for Sigma over q-points.
508 :
509 : integer :: g_ngfft(18) = -1, g_mgfft = -1, g_nfft = -1
510 : ! FFT mesh for the Green's function.
511 :
512 : !integer :: chi_ngfft(18) = -1, chi_mgfft = -1, chi_nfft = -1
513 : !integer :: sig_ngfft(18) = -1, sig_mgfft = -1, sig_nfft = -1
514 :
515 : integer :: mg0(3) = [2, 2, 2]
516 : ! Max shifts to account for umklapps.
517 :
518 : type(desc_t),allocatable :: green_desc_kibz(:)
519 : ! (nkibz)
520 : ! Descriptor for Green's functions
521 :
522 : type(desc_t),allocatable :: tchi_desc_qibz(:)
523 : ! (nqibz)
524 : ! Descriptor for tchi. NB: The g-vectors are sorted by |q+g|^2/2
525 :
526 : integer,allocatable :: chinpw_qibz(:)
527 : ! Number of PWs in tchi for each q-point in the IBZ (available on all procs)
528 :
529 : !type(desc_t),allocatable :: sigma_desc_kibz(:)
530 : ! (nkibz)
531 : ! Descriptor for self-energy
532 :
533 : integer :: coords_stgk(4) = 0
534 : ! Cartesian coordinates of this processor in the Cartesian grid.
535 :
536 : type(xcomm_t) :: comm
537 : ! Communicator with all MPI procs involved in the computation
538 : ! NB: gwr%comm%value is not necessarly the same as the input_comm
539 : ! we may decide to remove some procs from input_comm before createring the Cartesian grid.
540 :
541 : type(xcomm_t) :: spin_comm
542 : ! MPI communicator over spins.
543 :
544 : type(xcomm_t) :: kpt_comm
545 : ! MPI communicator for k/q-point distribution.
546 :
547 : type(xcomm_t) :: g_comm
548 : ! MPI communicator for g/r distribution
549 :
550 : type(xcomm_t) :: tau_comm
551 : ! MPI communicator for imag time distribution
552 :
553 : type(xcomm_t) :: gtau_comm
554 : ! MPI communicator for g/tau 2D subgrid.
555 :
556 : type(xcomm_t) :: kg_comm
557 : ! MPI communicator for g/g 2D subgrid.
558 :
559 : type(xcomm_t) :: kts_comm
560 : ! MPI communicator for tau/kpoint/spin 3D grid
561 :
562 : type(xcomm_t) :: kgt_comm
563 : ! MPI communicator for g/tau/kpoint 3D grid
564 :
565 : type(dataset_type), pointer :: dtset => null()
566 : ! Input variables.
567 :
568 : type(datafiles_type), pointer :: dtfil => null()
569 : ! Names of input/output files and prefixes.
570 :
571 : type(crystal_t), pointer :: cryst => null()
572 : ! Crystal structure.
573 :
574 : integer :: scf_iteration = 1
575 : ! Internal counter used to implement self-consistency
576 : ! For the time being, only self-consistency in energies is supported.
577 :
578 : integer,allocatable :: ks_vbik(:,:)
579 : ! (gwr%ks_ebands%nkpt, gwr%ks_ebands%nsppol)
580 : ! KS valence band indices.
581 :
582 : type(ebands_t), pointer :: ks_ebands => null()
583 : ! initial KS energies
584 :
585 : type(gaps_t) :: ks_gaps
586 : ! Info on the KS gaps.
587 :
588 : type(ebands_t) :: qp_ebands
589 : ! QP energies
590 :
591 : type(ebands_t) :: qp_ebands_prev
592 : ! QP energies of the previous iteration. Used if self-consistency.
593 :
594 : type(pseudopotential_type), pointer :: psps => null()
595 : ! NC Pseudos data
596 :
597 : type(pawtab_type), pointer :: pawtab(:) => null()
598 : ! PAW data
599 :
600 : type(mpi_type),pointer :: mpi_enreg => null()
601 : ! Sequential mpi_type needed to invoke ABINIT routines requiring it.
602 :
603 : type(slk_processor_t) :: g_slkproc
604 : ! 1D PBLAS grid to block-distribute matrices along columns inside gcomm.
605 :
606 : type(__slkmat_t),allocatable :: gt_kibz(:,:,:,:,:)
607 : ! (2, nkibz, ntau, nsppol, nsig_ab)
608 : ! Occupied/Empty Green's function G_k(g,g')
609 :
610 : type(__slkmat_t),allocatable :: tchi_qibz(:,:,:)
611 : ! (nqibz, ntau, nsppol)
612 : ! Irreducible polarizability tchi_q(g,g')
613 :
614 : character(len=10) :: tchi_space = "none"
615 : ! Defines if the tchi_qibz matrix stores Chi in tau or iomega domain.
616 : ! "none", "itau", "iomega"
617 :
618 : type(__slkmat_t),allocatable :: wc_qibz(:,:,:)
619 : ! (nqibz, ntau, nsppol)
620 : ! Correlated screened Coulomb interaction summed over collinear spins
621 : ! Replicated across spin_comm if nsppol == 2.
622 :
623 : character(len=10) :: wc_space = "none"
624 : ! Defines if the wc_qibz matrix stores W in tau or iomega domain.
625 : ! "none", "itau", "iomega"
626 :
627 : !type(__slkmat_t),allocatable :: em1_qibz(:,:,:)
628 : ! Inverse dielectric matrix at omega = 0
629 : ! (nqibz, nsppol)
630 : ! Replicated across the tau comm and the spin comm if nsppol == 2.
631 :
632 : type(__slkmat_t),allocatable :: sigc_kibz(:,:,:,:,:)
633 : ! (2, nkibz, ntau, nsppol, nsig_ab)
634 :
635 : character(len=10) :: sigc_space = "none"
636 : ! Defines if the sigc_kibz matrix stores Sigma in tau or iomega domain.
637 : ! "none", "itau", "iomega"
638 :
639 : type(__slkmat_t),allocatable :: ugb(:,:) !, nato_ugb(:,:)
640 : ! (nkibz, nsppol)
641 : ! Fourier components of the KS wavefunctions stored in a PBLAS matrix
642 : ! Bands are distributed in the g_comm communicator in a round-robin fashion.
643 : ! hence they are REPLICATED over tau_comm as this leads to better scalability in terms of flops.
644 : ! Distributing bands inside the 2D gtau_comm, indeed, allows one to reduce memory further
645 : ! but then the pzgemm used to build G explodes. Also. tau parallelism is high-level in GWR so it's not a good idea
646 : ! to mix it with low-level just to make memory for ugb scale better.
647 : ! The size of ugb is negligible when compared to G and Chi.
648 :
649 : type(slk_processor_t) :: gtau_slkproc
650 : ! Scalapack grid with (g,tau) processors
651 :
652 : integer :: ugb_nband = -1
653 : ! Number of bands in ugb.
654 :
655 : type(vcgen_t) :: vcgen_eps
656 : ! Object used to compute Coulomb term vc(q,g) in epsilon.
657 :
658 : type(vcgen_t) :: vcgen_sigma
659 : ! Object used to compute Coulomb term vc(q,g) in Sigma
660 :
661 : logical :: has_vcgen_sigma = .False.
662 : ! True if vcgen_sigma is allocated
663 :
664 : character(len=fnlen) :: gwrnc_path = ABI_NOFILE
665 : ! Path to the GWR.nc file with output results.
666 :
667 : logical :: gwrnc_write = .True.
668 : ! Activate/deactivate the output of the GWR.nc file.
669 :
670 : real(dp),allocatable :: kbz(:,:)
671 : ! (3, nkbz)
672 : ! Reduced coordinates of the k-points in the full BZ.
673 :
674 : real(dp), contiguous, pointer :: kibz(:,:) => null()
675 : ! (3, nkibz)
676 : ! Reduced coordinates of the k-points in the IBZ
677 :
678 : integer,allocatable :: kbz2ibz(:,:)
679 : ! (6, nkbz)
680 : ! Mapping kBZ to IBZ (symrec conventions)
681 :
682 : integer,allocatable :: kbz2ibz_symrel(:,:)
683 : ! (6, nkbz)
684 : ! Mapping kBZ to IBZ (symrel conventions)
685 :
686 : real(dp), contiguous, pointer :: wtk(:) => null()
687 : ! (nkibz)
688 : ! Weights of the k-points in the IBZ (normalized to one).
689 :
690 : real(dp),allocatable :: qbz(:,:)
691 : ! (3, nqbz)
692 : ! Reduced coordinates of the q-points in the full BZ.
693 :
694 : integer,allocatable :: qbz2ibz(:,:)
695 : ! (6, nqbz)
696 : ! Mapping qBZ to IBZ (symrec conventions)
697 :
698 : real(dp),allocatable :: qibz(:,:)
699 : ! (3, nqibz)
700 : ! Reduced coordinates of the q-points in the IBZ (full symmetry of the system).
701 :
702 : real(dp),allocatable :: wtq(:)
703 : ! (nqibz)
704 : ! Weights of the q-points in the IBZ (normalized to one).
705 :
706 : complex(dp),allocatable :: chi0_head_myw(:,:,:)
707 : ! (3,3,my_ntau)
708 : ! Head of the irred. polarizability in i.omega space.
709 : ! Note that spins have been summed over.
710 :
711 : complex(dp),allocatable :: chi0_uwing_myw(:,:,:), chi0_lwing_myw(:,:,:)
712 : ! (3, npw_chi_gamma, my_ntau)
713 : ! Upper wings of the irred. polarizability in i omega space.
714 : ! Note that spins have been summed over.
715 :
716 : type(wfdgw_t) :: kcalc_wfd
717 : ! wavefunction descriptor with the KS states where QP corrections are wanted.
718 :
719 : type(hdr_type) :: wfk_hdr
720 : ! header of the WFK file
721 : ! IMPORTANT: Don't use wkf_hdr%npwarr to get the number of PW as we might have used ecutwfn < ecut.
722 :
723 : type(melements_t) :: ks_me !, qp_me
724 : ! Matrix elements of the different potentials in the KS basis set.
725 :
726 : type(degtab_t),allocatable :: degtab(:,:)
727 : ! (nkcalc, nsppol)
728 : ! Table used to average QP results in the degenerate subspace if symsigma == 1
729 :
730 : integer :: b1gw = -1, b2gw = -1
731 : ! b1gw = minval(gwr%bstart_ks); b2gw = maxval(gwr%bstop_ks)
732 :
733 : logical :: sig_diago
734 : ! True if Sigma_ matrices are diagonal in the band indices (default)
735 :
736 : complex(dp),allocatable :: sigx_mat(:,:,:,:)
737 : ! (b1gw:b2gw, ?, nkcalc, nsppol)
738 : ! Matrix elements of <i|\Sigma_x|j>. The second dimension depends on sig_diago
739 :
740 : !complex(dp),allocatable :: sigc_it_mat(:,:,:,:,:)
741 : ! (2, ntau, max_nbcalc, nkcalc, nsppol*nsig_ab))
742 : ! Matrix elements of <i|\Sigma_c(itau)|j>. The second dimension depends on sig_diago
743 :
744 : complex(dp),allocatable :: sigc_iw_mat(:,:,:,:,:)
745 : ! Matrix elements of <i|\Sigma_c(i omega)|j>
746 : ! (ntau, b1gw:b2gw, ?, nkcalc, nsppol). The second dimension depends on sig_diago
747 :
748 : contains
749 :
750 : procedure :: init => gwr_init
751 : ! Initialize the object.
752 :
753 : procedure :: rotate_gpm => gwr_rotate_gpm
754 : ! Reconstruct the Green's functions in the BZ from the IBZ.
755 :
756 : procedure :: gk_to_scbox => gwr_gk_to_scbox
757 : ! Insert G_k(g',r) in the FFT box of the supercell: k+g' index.
758 :
759 : procedure :: wcq_to_scbox => gwr_wcq_to_scbox
760 : ! Insert W_q(g',r) in the FFT box of the supercell: q+g' index.
761 :
762 : procedure :: get_myk_green_gpr => gwr_get_myk_green_gpr
763 : ! G_k(g,g') --> G_k(g',r) for each k in the BZ treated by this MPI proc for given spin and tau.
764 :
765 : procedure :: get_gkbz_rpr_pm => gwr_get_gkbz_rpr_pm
766 : ! Compute G_k(r',r) with (r, r') in the unit cell and k in the full BZ.
767 :
768 : procedure :: rotate_wc => gwr_rotate_wc
769 : ! Reconstruct Wc(q) in the BZ from the IBZ.
770 :
771 : procedure :: get_myq_wc_gpr => gwr_get_myq_wc_gpr
772 : ! W_q(g,g') --> W_q(g',r) for each q in the BZ treated by this MPI procs for given spin and tau.
773 :
774 : procedure :: get_wc_rpr_qbz => gwr_get_wc_rpr_qbz
775 : ! Compute Wc_q(r',r') with q in the BZ
776 :
777 : procedure :: rpr_to_ggp => gwr_rpr_to_ggp
778 : ! F_{r',r} --> F_{g,g'}
779 :
780 : procedure :: cos_transform => gwr_cos_transform
781 : ! Inhomogeneous cosine transform.
782 :
783 : procedure :: malloc_free_mats => gwr_malloc_free_mats
784 : ! Allocate/Deallocate matrices for G/tchi/Sigma
785 :
786 : procedure :: free => gwr_free
787 : ! Free memory.
788 :
789 : procedure :: print => gwr_print
790 : ! Print info on the object.
791 :
792 : procedure :: print_mem => gwr_print_mem
793 : ! Print memory required by PBLAS matrices.
794 :
795 : procedure :: print_trace => gwr_print_trace
796 : ! Print trace of matrices for testing purposes.
797 :
798 : procedure :: load_kcalc_wfd => gwr_load_kcalc_wfd
799 : ! Load the KS states for Sigma_nk from the WFK file
800 :
801 : procedure :: read_ugb_from_wfk => gwr_read_ugb_from_wfk
802 : ! Read wavefunctions from WFK file.
803 :
804 : procedure :: build_green => gwr_build_green
805 : ! Build Green's functions in imaginary time from the %ugb matrices stored in memory.
806 :
807 : procedure :: build_tchi => gwr_build_tchi
808 : ! Build the irreducible polarizability
809 :
810 : procedure :: redistrib_gt_kibz => gwr_redistrib_gt_kibz
811 : ! Redistribute/deallocate G_k
812 :
813 : procedure :: redistrib_mats_qibz => gwr_redistrib_mats_qibz
814 : ! Redistribute/deallocate tchi_q or Wc_q
815 :
816 : procedure :: build_wc => gwr_build_wc
817 : ! Build the correlated part of the screened interaction.
818 :
819 : procedure :: build_sigmac => gwr_build_sigmac
820 : ! Build the correlated part of the self-energy GWc
821 : ! and compute matrix elements in the KS representation.
822 :
823 : procedure :: rpa_energy => gwr_rpa_energy
824 : ! Compute RPA energy.
825 :
826 : procedure :: gamma_gw => gwr_gamma_gw
827 : ! TODO: Work in progress.
828 :
829 : procedure :: build_chi0_head_and_wings => gwr_build_chi0_head_and_wings
830 : ! Compute head and wings of chi0
831 :
832 : procedure :: build_sigxme => gwr_build_sigxme
833 : ! Compute matrix elements of the exchange part.
834 :
835 : procedure :: get_u_ngfft => gwr_get_u_ngfft
836 : ! Compute FFT mesh from boxcutmin
837 :
838 : procedure :: run_g0w0 => gwr_run_g0w0
839 : ! Compute QP corrections with one-shot G0W0.
840 :
841 : procedure :: run_chi0 => gwr_run_chi0
842 : ! Compute CHI0 only.
843 :
844 : procedure :: run_energy_scf => gwr_run_energy_scf
845 : ! Compute QP corrections with energy-only self-consistent GW
846 :
847 : procedure :: check_scf_cycle => gwr_check_scf_cycle
848 : ! Check SCF cycle for convergence.
849 :
850 : procedure :: ncwrite_tchi_wc => gwr_ncwrite_tchi_wc
851 : ! Write tchi or wc to netcdf file
852 :
853 : end type gwr_t
854 : !!***
855 :
856 : ! Handy named costants (private stuff)
857 : integer,private,parameter :: LOG_MODR = 500, LOG_MODK = 5
858 : integer,private,parameter :: istwfk1 = 1, ndat1 = 1, me_fft0 = 0, paral_fft0 = 0, nproc_fft1 = 1
859 : integer,private,parameter :: OP_COPY = 0, OP_ACC = 1
860 : integer,private,parameter :: CHI_FIT = 1, SIGMA_FIT = 2
861 :
862 : contains
863 : !!***
864 :
865 : !----------------------------------------------------------------------
866 :
867 : !!****f* m_gwr/gwr_init
868 : !! NAME
869 : !! gwr_init
870 : !!
871 : !! FUNCTION
872 : !! Initialize the gwr object.
873 : !!
874 : !! INPUTS
875 : !! dtset<dataset_type>=All input variables for this dataset.
876 : !! dtfil<datafiles_type>=Variables related to files.
877 : !! cryst=Crystalline structure
878 : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
879 : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
880 : !! ke_ebands=KS energies
881 : !! mpi_enreg=information about MPI parallelization (FAKE one as GWR has its own MPI algo)
882 : !! input_comm=MPI communicator
883 : !!
884 : !! OUTPUT
885 : !!
886 : !! SOURCE
887 :
888 0 : subroutine gwr_init(gwr, dtset, dtfil, cryst, psps, pawtab, ks_ebands, mpi_enreg, input_comm)
889 :
890 : !Arguments ------------------------------------
891 : !scalars
892 : class(gwr_t),target,intent(out) :: gwr
893 : type(dataset_type),target,intent(in) :: dtset
894 : type(datafiles_type),target,intent(in) :: dtfil
895 : type(crystal_t),target,intent(in) :: cryst
896 : type(pseudopotential_type),target,intent(in) :: psps
897 : type(pawtab_type),target,intent(in) :: pawtab(psps%ntypat*psps%usepaw)
898 : type(ebands_t),target,intent(in) :: ks_ebands
899 : type(mpi_type),target,intent(in) :: mpi_enreg
900 : integer,intent(inout) :: input_comm
901 :
902 : !Local variables-------------------------------
903 : !scalars
904 : integer,parameter :: qptopt1 = 1, master = 0, ndims = 4
905 : integer :: my_it, my_ikf, ii, kptopt, my_iki, my_iqi, itau, spin, my_iqf
906 : integer :: my_nshiftq, iq_bz, iq_ibz, npw_, ncid, smat_bsize1, smat_bsize2
907 : integer :: comm_cart, me_cart, ierr, all_nproc, my_rank, qprange_, gap_err, ncerr, omp_nt
908 : integer :: cnt, ikcalc, ndeg, mband, bstop, nbsum, jj, gw_icutcoul_
909 : integer :: ik_ibz, ik_bz, isym_k, trev_k, g0_k(3)
910 : integer :: ip_g, ip_k, ip_t, ip_s, np_g, np_k, np_t, np_s, isym, itim
911 : real(dp) :: cpu, wall, gflops, wmax, vc_ecut, delta, abs_rerr, exact_int, eval_int, drude_plasmon_freq
912 : real(dp) :: prev_efficiency, prev_speedup, regterm, prev_dual_error
913 : logical :: isirr_k, changed, q_is_gamma, reorder, can_use_kshifts
914 : character(len=5000) :: msg
915 0 : type(krank_t) :: qrank, krank_ibz
916 : type(est_t) :: est
917 0 : type(kmesh_t) :: Kmesh, Qmesh
918 : !arrays
919 : integer :: qptrlatt(3,3), dims_kgts(ndims), try_dims_kgts(ndims), indkk_k(6,1), units(2)
920 0 : integer,allocatable :: gvec_(:,:),degblock(:,:), degblock_all(:,:,:,:), ndeg_all(:,:), iwork(:,:), got(:)
921 : real(dp) :: my_shiftq(3,1), kk_ibz(3), kk_bz(3), qq_bz(3), qq_ibz(3), kk(3), tsec(2), qbz(3), sq(3)
922 0 : real(dp),allocatable :: wtk(:), kibz(:,:)
923 : logical :: periods(ndims), keepdim(ndims)
924 : ! *************************************************************************
925 :
926 0 : call cwtime(cpu, wall, gflops, "start")
927 0 : call timab(1920, 1, tsec)
928 :
929 0 : all_nproc = xmpi_comm_size(input_comm); my_rank = xmpi_comm_rank(input_comm)
930 0 : units = [std_out, ab_out]
931 :
932 : ! Keep a reference to other objects to simplify the internal API.
933 0 : gwr%dtset => dtset; gwr%dtfil => dtfil; gwr%cryst => cryst; gwr%psps => psps; gwr%pawtab => pawtab
934 0 : gwr%ks_ebands => ks_ebands; gwr%kibz => ks_ebands%kptns; gwr%wtk => ks_ebands%wtk; gwr%mpi_enreg => mpi_enreg
935 :
936 : ! Initialize qp_ebands with KS values.
937 0 : call ks_ebands%copy(gwr%qp_ebands)
938 0 : call ks_ebands%copy(gwr%qp_ebands_prev)
939 :
940 0 : ABI_MALLOC(gwr%ks_vbik, (gwr%ks_ebands%nkpt, gwr%ks_ebands%nsppol))
941 0 : gwr%ks_vbik(:,:) = gwr%ks_ebands%get_valence_idx()
942 :
943 : ! Useful dimensions.
944 0 : gwr%nspinor = dtset%nspinor; gwr%nsppol = dtset%nsppol; gwr%nspden = dtset%nspden
945 0 : gwr%nsig_ab = gwr%nspinor ** 2 !! TODO HT: One day we only need 3
946 0 : gwr%natom = dtset%natom; gwr%usepaw = dtset%usepaw
947 0 : gwr%sig_diago = .True.
948 0 : if (string_in(gwr%dtset%gwr_task, "GAMMA_GW")) gwr%sig_diago = .False.
949 :
950 : ! Decide whether one should use supercells or convolutions in the BZ.
951 0 : gwr%use_supercell_for_tchi = .True.
952 0 : if (gwr%dtset%gwr_chi_algo == 0) then
953 : ! Automatic selection
954 0 : ABI_ERROR("Not implemented Error")
955 : else
956 0 : gwr%use_supercell_for_tchi = gwr%dtset%gwr_chi_algo == 1
957 : end if
958 :
959 0 : if (gwr%dtset%gwr_sigma_algo == 0) then
960 : ! Automatic selection
961 0 : ABI_ERROR("Not implemented Error")
962 : else
963 0 : gwr%use_supercell_for_sigma = gwr%dtset%gwr_sigma_algo == 1
964 : end if
965 :
966 : ! Set q0 for long-wavelength limit
967 0 : if (dtset%gw_nqlwl /= 0) gwr%q0 = dtset%gw_qlwl(:, 1)
968 :
969 0 : mband = ks_ebands%mband; nbsum = dtset%nband(1)
970 0 : ABI_CHECK_IRANGE(nbsum, 1, mband, "Invalid nbsum")
971 :
972 : ! Define frequency mesh for sigma(w_real) and spectral functions.
973 : ! Note that in GWR computing quantities on the real-axis is really cheap
974 : ! so we can use very dense meshes without affecting performance.
975 : ! The default for nfresp and freqspmax is zero.
976 : ! Here we compute wr_step and nwrt so that we have e0 +- the expected plasmom frequency
977 0 : drude_plasmon_freq = sqrt(four_pi * ks_ebands%nelect / cryst%ucvol)
978 0 : wmax = dtset%freqspmax; if (abs(wmax) < tol6) wmax = two * drude_plasmon_freq
979 0 : gwr%nwr = dtset%nfreqsp
980 0 : if (gwr%nwr == 0) gwr%nwr = nint(wmax / (0.05_dp * eV_Ha))
981 0 : if (mod(gwr%nwr, 2) == 0) gwr%nwr = gwr%nwr + 1
982 0 : gwr%wr_step = wmax / (gwr%nwr - 1)
983 :
984 : ! =======================
985 : ! Setup k-mesh and q-mesh
986 : ! =======================
987 :
988 : ! Get full kBZ associated to ks_ebands
989 : call kpts_ibz_from_kptrlatt(cryst, ks_ebands%kptrlatt, ks_ebands%kptopt, ks_ebands%nshiftk, ks_ebands%shiftk, &
990 0 : gwr%nkibz, kibz, wtk, gwr%nkbz, gwr%kbz) !, bz2ibz=bz2ibz)
991 : !new_kptrlatt=gwr%kptrlatt, new_shiftk=gwr%kshift,
992 : !bz2ibz=new%ind_qbz2ibz) # FIXME
993 0 : ABI_FREE(wtk)
994 :
995 : ! In principle kibz should be equal to ks_ebands%kptns.
996 0 : ABI_CHECK_IEQ(gwr%nkibz, ks_ebands%nkpt, "nkibz != ks_ebands%nkpt")
997 0 : ABI_CHECK(all(abs(ks_ebands%kptns - kibz) < tol12), "ks_ebands%kibz != kibz")
998 :
999 0 : can_use_kshifts = .not. gwr%use_supercell_for_tchi .and. .not. gwr%use_supercell_for_sigma
1000 : !can_use_kshifts = .False.
1001 :
1002 0 : if (.not. (isdiagmat(ks_ebands%kptrlatt) .and. ks_ebands%nshiftk == 1) .and. .not. can_use_kshifts) then
1003 0 : ABI_ERROR("GWR code requires ngkpt with one shift!")
1004 : end if
1005 0 : gwr%ngkpt = get_diag(ks_ebands%kptrlatt)
1006 :
1007 : ! Note symrec convention here.
1008 0 : kptopt = ks_ebands%kptopt
1009 0 : call krank_ibz%from_kptrlatt(gwr%nkibz, kibz, ks_ebands%kptrlatt, compute_invrank=.False.)
1010 :
1011 0 : ABI_MALLOC(gwr%kbz2ibz, (6, gwr%nkbz))
1012 0 : if (kpts_map("symrec", kptopt, cryst, krank_ibz, gwr%nkbz, gwr%kbz, gwr%kbz2ibz) /= 0) then
1013 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
1014 : end if
1015 :
1016 : ! Order kbz by stars and rearrange entries in kbz2ibz table.
1017 0 : call kpts_pack_in_stars(gwr%nkbz, gwr%kbz, gwr%kbz2ibz)
1018 0 : if (my_rank == master) then
1019 0 : call kpts_map_print(units, " Mapping kBZ --> kIBZ", "symrec", gwr%kbz, kibz, gwr%kbz2ibz, gwr%dtset%prtvol)
1020 : end if
1021 :
1022 : !call get_ibz2bz(gwr%nkibz, gwr%nkbz, gwr%kbz2ibz, kibz2bz, msg, ierr)
1023 : !ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
1024 :
1025 : ! Table with symrel conventions for the symmetrization of the wfs.
1026 0 : ABI_MALLOC(gwr%kbz2ibz_symrel, (6, gwr%nkbz))
1027 0 : if (kpts_map("symrel", kptopt, cryst, krank_ibz, gwr%nkbz, gwr%kbz, gwr%kbz2ibz_symrel) /= 0) then
1028 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
1029 : end if
1030 :
1031 : ! Here we set up the q-mesh for chi and w and the corresponding symmetry tables.
1032 : ! Supercell algos require Gamma-centered meshes with ngqpt so that we can easily insert q+G in the FFT box
1033 : ! Convolution algos can handle multiple shifts in the k-mesh.
1034 : ! After this block we should know IBZ, BZ, weights and qbz2ibz mapping
1035 0 : if (.not. can_use_kshifts) then
1036 :
1037 : ! Setup IBZ q-points, weights and BZ. Always use q --> -q symmetry even in systems without inversion
1038 0 : my_nshiftq = 1; my_shiftq = zero; qptrlatt = ks_ebands%kptrlatt
1039 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt1, my_nshiftq, my_shiftq, & ! in
1040 0 : gwr%nqibz, gwr%qibz, gwr%wtq, gwr%nqbz, gwr%qbz) ! out
1041 :
1042 0 : ABI_CHECK(all(abs(gwr%qibz(:,1)) < tol16), "First qpoint in qibz should be Gamma!")
1043 0 : gwr%ngqpt = get_diag(qptrlatt)
1044 :
1045 : ! Table with symrec conventions for the symmetrization of chi.
1046 0 : ABI_MALLOC(gwr%qbz2ibz, (6, gwr%nqbz))
1047 :
1048 0 : call qrank%from_kptrlatt(gwr%nqibz, gwr%qibz, qptrlatt, compute_invrank=.False.)
1049 0 : if (kpts_map("symrec", qptopt1, cryst, qrank, gwr%nqbz, gwr%qbz, gwr%qbz2ibz) /= 0) then
1050 0 : ABI_ERROR("Cannot map qBZ to IBZ!")
1051 : end if
1052 0 : call qrank%free()
1053 :
1054 : else
1055 : ! === Create basic data types for the calculation ===
1056 : ! Kmesh defines the k-point sampling for the wavefunctions.
1057 : ! Qmesh defines the q-point sampling for chi0, all possible differences k1-k2 reduced to the IBZ.
1058 : ! TODO Kmesh%bz should be in [-half, half[ but this modification is painful!
1059 0 : call Kmesh%init(cryst, gwr%nkibz, kibz, dtset%kptopt, wrap_1zone=.FALSE.)
1060 :
1061 : ! Some required information are not filled up inside kmesh_init. So doing it here, even though it is not clean
1062 0 : Kmesh%kptrlatt(:,:) = Dtset%kptrlatt(:,:)
1063 0 : Kmesh%nshift = Dtset%nshiftk
1064 0 : ABI_MALLOC(Kmesh%shift, (3, Kmesh%nshift))
1065 0 : Kmesh%shift(:,:) = Dtset%shiftk(:,1:Dtset%nshiftk)
1066 : !call Kmesh%print(units, header="K-mesh for the wavefunctions", prtvol=Dtset%prtvol)
1067 :
1068 : ! === Find Q-mesh ===
1069 : ! Stop if a nonzero umklapp is needed to reconstruct the BZ.
1070 : ! epsilon^-1(Sq) indeed should be symmetrized in csigme using a different expression (G-G_o is needed)
1071 0 : call qmesh%find_qmesh(cryst, Kmesh)
1072 : !call qmesh%print(units, "Q-mesh for the screening function", prtvol=dtset%prtvol)
1073 :
1074 : ! Transfer data from qmesh to gwr.
1075 0 : gwr%nqibz = qmesh%nibz
1076 0 : gwr%nqbz = qmesh%nbz
1077 :
1078 0 : call alloc_copy(qmesh%ibz, gwr%qibz)
1079 0 : call alloc_copy(qmesh%wt, gwr%wtq)
1080 0 : call alloc_copy(qmesh%bz, gwr%qbz)
1081 :
1082 0 : ABI_CHECK(all(abs(gwr%qibz(:,1)) < tol16), "First qpoint in qibz should be Gamma!")
1083 0 : gwr%ngqpt = -1
1084 :
1085 : ! Table with symrec conventions for the symmetrization of chi.
1086 0 : ABI_MALLOC(gwr%qbz2ibz, (6, gwr%nqbz))
1087 :
1088 0 : do iq_bz=1,Qmesh%nbz
1089 0 : call qmesh%get_bz_item(iq_bz, qbz, iq_ibz, isym, itim)
1090 0 : gwr%qbz2ibz(1, iq_bz) = iq_ibz
1091 0 : gwr%qbz2ibz(2, iq_bz) = isym
1092 0 : gwr%qbz2ibz(3:5, iq_bz) = zero
1093 : ! Note different conventions from itim between the Qmesh routines used in conventional GW and Abinit routines.
1094 0 : gwr%qbz2ibz(6, iq_bz) = merge(0, 1, itim == 1)
1095 0 : sq = (3-2*itim) * MATMUL(cryst%symrec(:,:,isym), qmesh%ibz(:,iq_ibz))
1096 0 : if (ANY(ABS(qbz-sq) > 1.0d-4)) then
1097 : write(msg,'(a,3f6.3,a,3f6.3,2a,9i3,a,i2,2a)')&
1098 0 : ' qpoint ',qbz,' is the symmetric of ',qmesh%ibz(:,iq_ibz),ch10,&
1099 0 : ' through operation ',cryst%symrec(:,:,isym),' and itim ',itim,ch10,&
1100 0 : ' however a non zero umklapp G_o vector is required and this is not yet allowed'
1101 0 : ABI_ERROR(msg)
1102 : end if
1103 : end do
1104 0 : call kmesh%free(); call qmesh%free()
1105 : end if
1106 :
1107 : ! Order qbz by stars and rearrange entries in qbz2ibz table.
1108 0 : call kpts_pack_in_stars(gwr%nqbz, gwr%qbz, gwr%qbz2ibz)
1109 0 : if (my_rank == master) then
1110 0 : call kpts_map_print(units, " Mapping qBZ --> qIBZ", "symrec", gwr%qbz, gwr%qibz, gwr%qbz2ibz, gwr%dtset%prtvol)
1111 : end if
1112 :
1113 : ! ==========================
1114 : ! Setup k-points in Sigma_nk
1115 : ! ==========================
1116 0 : gwr%ks_gaps = ks_ebands%get_gaps(gap_err)
1117 :
1118 0 : if (my_rank == master) call gwr%ks_gaps%print(units, header="Kohn-Sham gaps and band edges from IBZ mesh")
1119 :
1120 : ! TODO: nkcalc should be spin dependent.
1121 : ! This piece of code is taken from m_sigmaph.
1122 : ! In principle one should use the same algorithm in setup_sigma (legacy GW code).
1123 0 : if (dtset%nkptgw /= 0) then
1124 : ! Treat the k-points and bands specified in the input file via kptgw and bdgw.
1125 0 : call sigtk_kcalc_from_nkptgw(dtset, mband, gwr%nkcalc, gwr%kcalc, gwr%bstart_ks, gwr%nbcalc_ks)
1126 :
1127 : else
1128 0 : if (any(abs(dtset%sigma_erange) > zero)) then
1129 : ! Use sigma_erange and (optionally) sigma_ngkpt
1130 : call sigtk_kcalc_from_erange(dtset, cryst, ks_ebands, gwr%ks_gaps, &
1131 0 : gwr%nkcalc, gwr%kcalc, gwr%bstart_ks, gwr%nbcalc_ks, input_comm)
1132 :
1133 : else
1134 : ! Use qp_range to select the interesting k-points and the corresponding bands.
1135 : !
1136 : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
1137 : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
1138 : ! bands above and below the Fermi level.
1139 : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
1140 : ! Include all occupied states and `num` empty states.
1141 :
1142 0 : qprange_ = dtset%gw_qprange
1143 0 : if (gap_err /= 0 .and. qprange_ == 0) then
1144 0 : ABI_WARNING("Cannot compute fundamental and direct gap (likely metal). Will replace qprange 0 with qprange 1")
1145 0 : qprange_ = 1
1146 : end if
1147 :
1148 0 : if (qprange_ /= 0) then
1149 0 : call sigtk_kcalc_from_qprange(dtset, cryst, ks_ebands, qprange_, gwr%nkcalc, gwr%kcalc, gwr%bstart_ks, gwr%nbcalc_ks)
1150 : else
1151 : ! qprange is not specified in the input.
1152 : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
1153 0 : call sigtk_kcalc_from_gaps(dtset, ks_ebands, gwr%ks_gaps, gwr%nkcalc, gwr%kcalc, gwr%bstart_ks, gwr%nbcalc_ks)
1154 : end if
1155 : end if
1156 :
1157 : end if ! nkptgw /= 0
1158 :
1159 : ! Include all degenerate states and map kcalc to the IBZ. NB: This part is copied from sigmaph.
1160 :
1161 : ! The k-point and the symmetries connecting the BZ k-point to the IBZ.
1162 0 : ABI_MALLOC(gwr%kcalc2ibz, (gwr%nkcalc, 6))
1163 :
1164 : ! Workspace arrays used to compute degeneracy tables.
1165 0 : ABI_ICALLOC(degblock_all, (2, mband, gwr%nkcalc, gwr%nsppol))
1166 0 : ABI_ICALLOC(ndeg_all, (gwr%nkcalc, gwr%nsppol))
1167 :
1168 0 : ierr = 0
1169 0 : do ikcalc=1,gwr%nkcalc
1170 : ! Note symrel and use_symrel.
1171 : ! These are the conventions for the symmetrization of the wavefunctions used in cgtk_rotate.
1172 0 : kk = gwr%kcalc(:, ikcalc)
1173 :
1174 0 : if (kpts_map("symrel", kptopt, cryst, krank_ibz, 1, kk, indkk_k) /= 0) then
1175 : write(msg, '(5a)' ) &
1176 0 : "The WFK file cannot be used to compute self-energy corrections at k-point: ",trim(ktoa(kk)),ch10,&
1177 0 : "The k-point cannot be generated from a symmetrical one.", ch10
1178 0 : ABI_ERROR(msg)
1179 : end if
1180 :
1181 : ! TODO: Invert dims and update abipy
1182 0 : gwr%kcalc2ibz(ikcalc, :) = indkk_k(:, 1)
1183 :
1184 0 : ik_ibz = indkk_k(1,1); isym_k = indkk_k(2,1)
1185 0 : trev_k = indkk_k(6,1); g0_k = indkk_k(3:5,1)
1186 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
1187 : !kk_ibz = ks_ebands%kptns(:,ik_ibz)
1188 : if (.not. isirr_k) then
1189 0 : ABI_WARNING(sjoin("The k-point in Sigma_{nk} must be in the IBZ but got:", ktoa(kk)))
1190 0 : ierr = ierr + 1
1191 : end if
1192 :
1193 : ! We will have to average the QP corrections over degenerate states if symsigma=1 is used.
1194 : ! Here we make sure that all the degenerate states are included.
1195 : ! Store also band indices of the degenerate sets, used to average final results.
1196 0 : if (abs(gwr%dtset%symsigma) == 1) then
1197 0 : cnt = 0
1198 0 : do spin=1,gwr%nsppol
1199 0 : bstop = gwr%bstart_ks(ikcalc, spin) + gwr%nbcalc_ks(ikcalc, spin) - 1
1200 : call ks_ebands%enclose_degbands(ik_ibz, spin, gwr%bstart_ks(ikcalc, spin), bstop, changed, gwr%dtset%symsigma_de, &
1201 0 : degblock=degblock)
1202 0 : if (changed) then
1203 0 : gwr%nbcalc_ks(ikcalc, spin) = bstop - gwr%bstart_ks(ikcalc, spin) + 1
1204 0 : cnt = cnt + 1
1205 0 : if (cnt < 5) then
1206 : write(msg,'(2(a,i0),2a,2(1x,i0))') &
1207 0 : "Not all the degenerate states for ikcalc: ",ikcalc,", spin: ",spin,ch10, &
1208 0 : "were included in the bdgw set. bdgw has been automatically changed to: ",gwr%bstart_ks(ikcalc, spin), bstop
1209 0 : ABI_COMMENT(msg)
1210 : end if
1211 : write(msg,'(2(a,i0),2a)') &
1212 0 : "The number of included states: ", bstop, &
1213 0 : " is larger than the number of bands in the input ",dtset%nband(ik_ibz + (spin-1)*ks_ebands%nkpt),ch10,&
1214 0 : "Action: Increase nband."
1215 0 : ABI_CHECK(bstop <= dtset%nband(ik_ibz + (spin-1)*ks_ebands%nkpt), msg)
1216 : end if
1217 :
1218 : ! Store band indices used for averaging (shifted by bstart_ks)
1219 0 : ndeg = size(degblock, dim=2)
1220 0 : ndeg_all(ikcalc, spin) = ndeg
1221 0 : degblock_all(:, 1:ndeg, ikcalc, spin) = degblock(:, 1:ndeg)
1222 :
1223 0 : ABI_FREE(degblock)
1224 : end do
1225 : end if ! symsigma
1226 : end do ! ikcalc
1227 :
1228 0 : ABI_CHECK(ierr == 0, "kptgw wavevectors must be in the IBZ read from the WFK file.")
1229 :
1230 : ! Build degtab tables to average self-energy matrix element if symsigma /= 0
1231 0 : if (abs(gwr%dtset%symsigma) == 1) then
1232 0 : ABI_MALLOC(gwr%degtab, (gwr%nkcalc, gwr%nsppol))
1233 0 : do ikcalc=1,gwr%nkcalc
1234 0 : do spin=1,gwr%nsppol
1235 0 : ndeg = ndeg_all(ikcalc, spin)
1236 0 : ABI_MALLOC(gwr%degtab(ikcalc, spin)%bids, (ndeg))
1237 0 : do ii=1,ndeg
1238 0 : cnt = degblock_all(2, ii, ikcalc, spin) - degblock_all(1, ii, ikcalc, spin) + 1
1239 0 : ABI_MALLOC(gwr%degtab(ikcalc, spin)%bids(ii)%vals, (cnt))
1240 : ! Note that we start to count bands from bstart_ks(ikcalc, spin)
1241 : gwr%degtab(ikcalc, spin)%bids(ii)%vals = [(jj, jj= &
1242 0 : degblock_all(1, ii, ikcalc, spin), degblock_all(2, ii, ikcalc, spin))]
1243 : end do
1244 : end do
1245 : end do
1246 : end if
1247 :
1248 0 : ABI_FREE(degblock_all)
1249 0 : ABI_FREE(ndeg_all)
1250 :
1251 : ! Now we can finally compute max_nbcalc.
1252 0 : gwr%max_nbcalc = maxval(gwr%nbcalc_ks)
1253 0 : ABI_MALLOC(gwr%bstop_ks, (gwr%nkcalc, gwr%nsppol))
1254 0 : gwr%bstop_ks = gwr%bstart_ks + gwr%nbcalc_ks - 1
1255 0 : gwr%b1gw = minval(gwr%bstart_ks); gwr%b2gw = maxval(gwr%bstop_ks)
1256 :
1257 0 : call krank_ibz%free()
1258 0 : ABI_FREE(kibz) ! Deallocate kibz here because krank_ibz keeps a reference to this array.
1259 :
1260 : ! ================================
1261 : ! Setup tau/omega mesh and weights
1262 : ! ================================
1263 : ! Compute min/max transition energy taking into account nsppol if any.
1264 0 : gwr%te_min = minval(gwr%ks_gaps%cb_min - gwr%ks_gaps%vb_max)
1265 0 : gwr%te_max = maxval(ks_ebands%eig(nbsum,:,:) - ks_ebands%eig(1,:,:))
1266 0 : if (gwr%te_min <= tol6) then
1267 0 : gwr%te_min = tol6
1268 0 : ABI_ERROR("System is metallic or with a very small fundamental gap! Check energies in WFK file!")
1269 : end if
1270 0 : gwr%ntau = dtset%gwr_ntau
1271 :
1272 0 : regterm = dtset%gwr_regterm
1273 0 : if (regterm > -tol16) then
1274 0 : call wrtout(std_out, sjoin("Computing minimax grid with user-provided regterm:", ftoa(regterm)))
1275 : call gx_minimax_grid(gwr%ntau, gwr%te_min, gwr%te_max, & ! in
1276 : gwr%tau_mesh, gwr%tau_wgs, gwr%iw_mesh, gwr%iw_wgs, & ! out args allocated by the routine.
1277 : gwr%cosft_wt, gwr%cosft_tw, gwr%sinft_wt, &
1278 0 : gwr%ft_max_error, gwr%cosft_duality_error, ierr, regterm=regterm)
1279 0 : ABI_CHECK(ierr == 0, "Error in gx_minimax_grid")
1280 : else
1281 0 : regterm = zero
1282 0 : call wrtout(std_out, sjoin("Computing minimax grid with user-provided regterm:", ftoa(regterm)))
1283 : call gx_minimax_grid(gwr%ntau, gwr%te_min, gwr%te_max, & ! in
1284 : gwr%tau_mesh, gwr%tau_wgs, gwr%iw_mesh, gwr%iw_wgs, & ! out args allocated by the routine.
1285 : gwr%cosft_wt, gwr%cosft_tw, gwr%sinft_wt, &
1286 0 : gwr%ft_max_error, gwr%cosft_duality_error, ierr, regterm=regterm)
1287 0 : ABI_CHECK(ierr == 0, "Error in gx_minimax_grid")
1288 :
1289 : ! If duality error is big, use regterm = 1e-6
1290 0 : if (gwr%cosft_duality_error > half) then
1291 0 : ABI_SFREE(gwr%tau_mesh)
1292 0 : ABI_SFREE(gwr%tau_wgs)
1293 0 : ABI_SFREE(gwr%iw_mesh)
1294 0 : ABI_SFREE(gwr%iw_wgs)
1295 0 : ABI_SFREE(gwr%cosft_wt)
1296 0 : ABI_SFREE(gwr%cosft_tw)
1297 0 : ABI_SFREE(gwr%sinft_wt)
1298 0 : regterm = tol6
1299 0 : call wrtout(std_out, sjoin("LARGE duality error -> recomputing minimax grid with regterm:", ftoa(regterm)))
1300 0 : prev_dual_error = gwr%cosft_duality_error
1301 : call gx_minimax_grid(gwr%ntau, gwr%te_min, gwr%te_max, & ! in
1302 : gwr%tau_mesh, gwr%tau_wgs, gwr%iw_mesh, gwr%iw_wgs, & ! out args allocated by the routine.
1303 : gwr%cosft_wt, gwr%cosft_tw, gwr%sinft_wt, &
1304 0 : gwr%ft_max_error, gwr%cosft_duality_error, ierr, regterm=regterm)
1305 0 : ABI_CHECK(ierr == 0, "Error in gx_minimax_grid")
1306 :
1307 0 : if (gwr%cosft_duality_error > prev_dual_error) then
1308 0 : ABI_WARNING("Using regterm didn't decrease the duality error")
1309 : end if
1310 : end if
1311 : end if
1312 :
1313 0 : if (gwr%comm%me == 0) then
1314 : ! Print some info on errors.
1315 0 : write(std_out, "(3a)")ch10, " Computing F(delta) = \int_0^{\infty} dw / (w^2 + delta^2) = pi/2/delta ", ch10
1316 0 : write(std_out, "(*(a12,2x))")"delta", "numeric", "exact", "abs_rerr (%)"
1317 0 : do ii=1,10
1318 0 : delta = (ii * gwr%te_min)
1319 0 : eval_int = sum(gwr%iw_wgs(:) / (gwr%iw_mesh(:)**2 + delta**2))
1320 0 : exact_int = pi / (two * delta)
1321 0 : abs_rerr = 100 * abs(eval_int - exact_int) / exact_int
1322 0 : write(std_out, "(*(es12.5,2x))") delta, eval_int, exact_int, abs_rerr
1323 : end do
1324 :
1325 0 : write(std_out, "(3a)")ch10," Computing F(w) = \int_0^{\infty} e^{-w tau} dtau", ch10
1326 0 : write(std_out, "(*(a12,2x))")"w", "numeric", "exact", "abs_rerr (%)"
1327 0 : do itau=1,gwr%ntau
1328 0 : eval_int = sum(gwr%tau_wgs(:) * exp(-gwr%tau_mesh(:) * gwr%iw_mesh(itau)))
1329 0 : exact_int = one / gwr%iw_mesh(itau)
1330 0 : abs_rerr = 100 * abs(eval_int - exact_int) / exact_int
1331 0 : write(std_out, "(*(es12.5,2x))") gwr%iw_mesh(itau), eval_int, exact_int, abs_rerr
1332 : end do
1333 0 : write(std_out, "(a)")
1334 : end if
1335 :
1336 : ! =========================================
1337 : ! Find FFT mesh and max number of g-vectors
1338 : ! =========================================
1339 : ! Note the usage of gwr_boxcutmin and the loops over the full BZ.
1340 0 : gwr%g_ngfft = gwr%dtset%ngfft; gwr%g_ngfft(1:6) = 0 ! Allow user to specify fftalg
1341 :
1342 0 : gwr%green_mpw = -1
1343 0 : do ik_bz=1,gwr%nkbz
1344 0 : kk_bz = gwr%kbz(:, ik_bz)
1345 0 : call get_kg(kk_bz, istwfk1, dtset%ecutwfn, gwr%cryst%gmet, npw_, gvec_)
1346 0 : ABI_FREE(gvec_)
1347 : call getng(dtset%gwr_boxcutmin, dtset%chksymtnons, dtset%ecutwfn, cryst%gmet, &
1348 : kk_bz, me_fft0, gwr%g_mgfft, gwr%g_nfft, gwr%g_ngfft, nproc_fft1, cryst%nsym, paral_fft0, &
1349 0 : cryst%symrel, cryst%tnons, gpu_option=gwr%dtset%gpu_option, unit=dev_null)
1350 0 : gwr%green_mpw = max(gwr%green_mpw, npw_)
1351 : end do
1352 :
1353 0 : gwr%tchi_mpw = -1
1354 0 : do iq_bz=1,gwr%nqbz
1355 0 : qq_bz = gwr%qbz(:, iq_bz)
1356 0 : call get_kg(qq_bz, istwfk1, dtset%ecuteps, gwr%cryst%gmet, npw_, gvec_)
1357 0 : ABI_FREE(gvec_)
1358 : call getng(dtset%gwr_boxcutmin, dtset%chksymtnons, dtset%ecuteps, cryst%gmet, &
1359 : qq_bz, me_fft0, gwr%g_mgfft, gwr%g_nfft, gwr%g_ngfft, nproc_fft1, cryst%nsym, &
1360 0 : paral_fft0, cryst%symrel, cryst%tnons, gpu_option=gwr%dtset%gpu_option, unit=dev_null)
1361 0 : gwr%tchi_mpw = max(gwr%tchi_mpw, npw_)
1362 0 : if (iq_bz == 1) then
1363 0 : ABI_CHECK(all(abs(qq_bz) < tol16), "First qpoint in the qbz should be Gamma!")
1364 : end if
1365 : end do
1366 :
1367 : ! No augmentation of workspace arrays.
1368 0 : gwr%g_ngfft(4:6) = gwr%g_ngfft(1:3)
1369 :
1370 : ! ========================
1371 : ! === MPI DISTRIBUTION ===
1372 : ! ========================
1373 : !
1374 : ! Here we define the following quantities:
1375 : ! - np_k, np_g, np_t, np_s
1376 : ! - gwr%comm and gwr%idle_proc
1377 : !
1378 : ! NB: Do not use input_comm after this section as idle processors return immediately.
1379 :
1380 0 : if (any(dtset%gwr_np_kgts /= 0)) then
1381 : ! Use grid from input file.
1382 0 : np_k = dtset%gwr_np_kgts(1); np_g = dtset%gwr_np_kgts(2); np_t = dtset%gwr_np_kgts(3); np_s = dtset%gwr_np_kgts(4)
1383 : !call xmpi_comm_multiple_of(product(dtset%gwr_np_kgts), input_comm, gwr%idle_proc, gwr%comm)
1384 : !if (gwr%idle_proc) return
1385 0 : gwr%comm = xcomm_from_mpi_int(input_comm)
1386 0 : all_nproc = gwr%comm%nproc
1387 :
1388 : else
1389 : ! Automatic grid generation.
1390 : !
1391 : ! Priorities | MPI Scalability | Memory
1392 : ! ==================================================================================================
1393 : ! spin (if any) | excellent | scales
1394 : ! g/r (PBLAS) | network-intensive ! scales
1395 : ! tau | excellent | scales
1396 : ! kbz | newtwork-intensive | scales (depends on the BZ -> IBZ mapping)
1397 :
1398 0 : gwr%comm = xcomm_from_mpi_int(input_comm)
1399 0 : all_nproc = gwr%comm%nproc
1400 : !call xmpi_comm_multiple_of(gwr%ntau * gwr%dtset%nsppol, input_comm, gwr%idle_proc, gwr%comm)
1401 : !if (gwr%idle_proc) return
1402 : !all_nproc = xmpi_comm_size(gwr%comm)
1403 :
1404 : ! Start from a configuration that minimizes memory i.e use all procs for g-parallelism,
1405 : ! then check whether it's possible to move some procs to the other levels
1406 : ! without spoiling parallel efficiency and/or increasing memory per MPI proc.
1407 : ! Only master rank works here for consistency reasons.
1408 0 : if (my_rank == master) then
1409 0 : dims_kgts = [1, all_nproc, 1, 1]
1410 0 : est = estimate(gwr, dims_kgts)
1411 0 : prev_efficiency = est%efficiency; prev_speedup = est%speedup
1412 0 : call wrtout(units, sjoin("- Optimizing MPI grid with mem_per_cpu_mb:", ftoa(mem_per_cpu_mb), "[Mb]"), pre_newlines=1)
1413 0 : call wrtout(units, "- Use `abinit run.abi --mem-per-cpu=4G` to set mem_per_cpu_mb in the submission script")
1414 0 : write(msg, "(a,4(a4,2x),3(a12,2x))") "- ", "np_k", "np_g", "np_t", "np_s", "memb_per_cpu", "efficiency", "speedup"
1415 0 : call wrtout(units, msg)
1416 0 : ip_k = dims_kgts(1); ip_g = dims_kgts(2); ip_t = dims_kgts(3); ip_s = dims_kgts(4)
1417 0 : write(msg, "(a,4(i4,2x),3(es12.5,2x))") "- ", ip_k, ip_g, ip_t, ip_s, est%mem_total, est%efficiency, est%speedup
1418 0 : call wrtout(units, msg)
1419 :
1420 0 : do ip_s=1,gwr%nsppol
1421 0 : do ip_t=1,gwr%ntau
1422 0 : if (mod(gwr%ntau, ip_t) /= 0) cycle ! ip_t should divide gwr%ntau.
1423 0 : do ip_k=1,gwr%nkbz
1424 0 : if (mod(gwr%nkbz, ip_k) /= 0) cycle ! ip_k is should divide gwr%nkbz.
1425 0 : do ip_g=1,gwr%green_mpw
1426 0 : try_dims_kgts = [ip_k, ip_g, ip_t, ip_s]
1427 0 : if (product(try_dims_kgts) /= all_nproc .or. all(try_dims_kgts == dims_kgts)) cycle
1428 : !ABI_CHECK(block_dist_1d(gwr%green_mpw, ip_g, col_bsize, msg), msg)
1429 0 : est = estimate(gwr, try_dims_kgts)
1430 : !if (est%mem_total < mem_per_cpu_mb * 0.8_dp .and. est%efficiency > prev_efficiency) then
1431 0 : if (est%mem_total < mem_per_cpu_mb * 0.8_dp .and. est%speedup > prev_speedup) then
1432 0 : prev_efficiency = est%efficiency; prev_speedup = est%speedup; dims_kgts = try_dims_kgts
1433 : end if
1434 0 : write(msg,"(a,4(i4,2x),3(es12.5,2x))")"- ", ip_k, ip_g, ip_t, ip_s, est%mem_total, est%efficiency, est%speedup
1435 0 : call wrtout(units, msg)
1436 : end do
1437 : end do
1438 : end do
1439 : end do
1440 : end if ! master
1441 :
1442 0 : call xmpi_bcast(dims_kgts, master, gwr%comm%value, ierr)
1443 0 : np_k = dims_kgts(1); np_g = dims_kgts(2); np_t = dims_kgts(3); np_s = dims_kgts(4)
1444 :
1445 0 : if (my_rank == master) then
1446 0 : est = estimate(gwr, dims_kgts)
1447 0 : call wrtout(units, "-")
1448 0 : call wrtout(units, "- Selected MPI grid:")
1449 0 : ip_k = dims_kgts(1); ip_g = dims_kgts(2); ip_t = dims_kgts(3); ip_s = dims_kgts(4)
1450 0 : write(msg, "(a,4(a4,2x),3(a12,2x))") "- ", "np_k", "np_g", "np_t", "np_s", "memb_per_cpu", "efficiency", "speedup"
1451 0 : call wrtout(units, msg)
1452 0 : write(msg, "(a,4(i4,2x),3(es12.5,2x))")"- ", ip_k, ip_g, ip_t, ip_s, est%mem_total, est%efficiency, est%speedup
1453 0 : call wrtout(units, msg, newlines=1)
1454 0 : call est%print(units)
1455 : end if
1456 : end if
1457 :
1458 : ! ================================
1459 : ! Build MPI grid and communicators
1460 : ! ================================
1461 0 : dims_kgts = [np_k, np_g, np_t, np_s]
1462 0 : gwr%dtset%gwr_np_kgts = dims_kgts
1463 0 : periods(:) = .False.; reorder = .False.
1464 :
1465 : ! Consistency check.
1466 0 : if (product(dims_kgts) /= all_nproc) then
1467 : write(msg, "(a,i0,3a, 5(a,1x,i0))") &
1468 0 : "Cannot create 4D Cartesian grid with total nproc: ", all_nproc, ch10, &
1469 0 : "Idle MPI processes are not supported. The product of the `nproc_*` vars should be equal to nproc while is it:", ch10, &
1470 0 : "k_nproc (", np_k, ") x g_nproc (", np_g, ") x tau_nproc (", np_t,") x spin_nproc (", np_s, ") == ", product(dims_kgts)
1471 0 : ABI_ERROR(msg)
1472 : end if
1473 :
1474 : !!! FIXME HT: rewrite spin logic in redistribution routines
1475 0 : if (gwr%nspinor == 2 .and. np_s == 2) then
1476 0 : ABI_ERROR("Spin parallelism is not supported for nspinor=2 for now!")
1477 : end if
1478 :
1479 : #ifdef HAVE_MPI
1480 : block
1481 : !integer,parameter :: k=1, g=2, t=3, s=4 ! Bad placement
1482 : integer,parameter :: k=4, g=3, t=2, s=1 ! Much better placement
1483 0 : dims_kgts = dims_kgts(4:1:-1)
1484 0 : call MPI_CART_CREATE(gwr%comm%value, ndims, dims_kgts, periods, reorder, comm_cart, ierr)
1485 :
1486 : ! Find the index and coordinates of the current processor
1487 0 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
1488 0 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, gwr%coords_stgk, ierr)
1489 :
1490 : ! k-point communicator
1491 0 : keepdim = .False.; keepdim(k) = .True.; call gwr%kpt_comm%from_cart_sub(comm_cart, keepdim)
1492 : ! g-communicator
1493 0 : keepdim = .False.; keepdim(g) = .True.; call gwr%g_comm%from_cart_sub(comm_cart, keepdim)
1494 : ! tau-communicator
1495 0 : keepdim = .False.; keepdim(t) = .True.; call gwr%tau_comm%from_cart_sub(comm_cart, keepdim)
1496 : ! spin-communicator
1497 0 : keepdim = .False.; keepdim(s) = .True.; call gwr%spin_comm%from_cart_sub(comm_cart, keepdim)
1498 : ! Communicator for the g-tau 2D grid.
1499 0 : keepdim = .False.; keepdim(g) = .True.; keepdim(t) = .True.; call gwr%gtau_comm%from_cart_sub(comm_cart, keepdim)
1500 : ! Communicator for the k-g 2D grid.
1501 0 : keepdim = .False.; keepdim(k) = .True.; keepdim(g) = .True.; call gwr%kg_comm%from_cart_sub(comm_cart, keepdim)
1502 : ! Communicator for the k-g-tau 3D subgrid.
1503 0 : keepdim = .True.; keepdim(s) = .False.; call gwr%kgt_comm%from_cart_sub(comm_cart, keepdim)
1504 : ! Communicator for the k-tau-spin 3D subgrid.
1505 0 : keepdim = .True.; keepdim(g) = .False.; call gwr%kts_comm%from_cart_sub(comm_cart, keepdim)
1506 0 : call xmpi_comm_free(comm_cart)
1507 : end block
1508 : #endif
1509 :
1510 0 : call wrtout(units, sjoin("P kpt_comm can use shmem:", yesno(gwr%kpt_comm%can_use_shmem())))
1511 0 : call wrtout(units, sjoin("P g_comm can use shmem:", yesno(gwr%g_comm%can_use_shmem())))
1512 0 : call wrtout(units, sjoin("P tau_comm can use shmem:", yesno(gwr%tau_comm%can_use_shmem())))
1513 0 : call wrtout(units, sjoin("P spin_comm can use shmem", yesno(gwr%spin_comm%can_use_shmem())))
1514 : !call gwr%kpt_comm%print_names(); call gwr%g_comm%print_names()
1515 :
1516 : ! Define batch sizes for FFT transforms taking into account k-point parallelism, OpenMP threads and GPUs.
1517 0 : omp_nt = xomp_get_num_threads(open_parallel=.True.)
1518 :
1519 0 : if (gwr%dtset%gwr_ucsc_batch(1) > 0) then
1520 : ! Take it from input file (user is always right)
1521 0 : gwr%uc_batch_size = gwr%dtset%gwr_ucsc_batch(1) * omp_nt
1522 : else
1523 : ! Automatic detection
1524 0 : gwr%uc_batch_size = 1 * omp_nt
1525 0 : if (gwr%dtset%gpu_option /= ABI_GPU_DISABLED) then
1526 : ! TODO: Optimize
1527 0 : gwr%uc_batch_size = 4 * omp_nt
1528 : !gwr%uc_batch_size = 1
1529 : end if
1530 : end if
1531 :
1532 0 : if (gwr%dtset%gwr_ucsc_batch(2) > 0) then
1533 : ! Take it from input file (user is always right)
1534 0 : gwr%sc_batch_size = gwr%dtset%gwr_ucsc_batch(2) * omp_nt
1535 : else
1536 : ! Automatic detection
1537 0 : gwr%sc_batch_size = 1 * omp_nt
1538 0 : if (gwr%dtset%gpu_option /= ABI_GPU_DISABLED) then
1539 : ! TODO: Optimize
1540 0 : gwr%sc_batch_size = 4 * omp_nt
1541 : !gwr%sc_batch_size = 1
1542 : end if
1543 : end if
1544 :
1545 : ! Make sure all procs agree.
1546 : !call xmpi_min_ip(gwr%sc_batch_size, gwr%comm%value, ierr)
1547 : !call xmpi_min_ip(gwr%uc_batch_size, gwr%comm%value, ierr)
1548 :
1549 0 : if (my_rank == master) then
1550 0 : call print_ngfft([std_out], gwr%g_ngfft, header="FFT mesh for Green's function")
1551 0 : call wrtout(units, sjoin("- FFT uc_batch_size:", itoa(gwr%uc_batch_size)))
1552 0 : call wrtout(units, sjoin("- FFT sc_batch_size:", itoa(gwr%sc_batch_size)))
1553 : end if
1554 :
1555 : ! Block-distribute dimensions and allocate redirection table local index --> global index.
1556 0 : call xmpi_split_block(gwr%ntau, gwr%tau_comm%value, gwr%my_ntau, gwr%my_itaus)
1557 0 : ABI_CHECK(gwr%my_ntau > 0, "my_ntau == 0, decrease number of procs for tau level")
1558 :
1559 : ! Store the rank of the MPI proc in tau_comm treating the itau index.
1560 0 : ABI_MALLOC(gwr%tau_master, (gwr%ntau))
1561 0 : gwr%tau_master = -1
1562 0 : do my_it=1,gwr%my_ntau
1563 0 : itau = gwr%my_itaus(my_it); gwr%tau_master(itau) = gwr%tau_comm%me
1564 : end do
1565 0 : call xmpi_max_ip(gwr%tau_master, gwr%tau_comm%value, ierr)
1566 0 : ABI_CHECK(all(gwr%tau_master > -1), "tau_master!")
1567 :
1568 0 : call xmpi_split_block(gwr%nsppol, gwr%spin_comm%value, gwr%my_nspins, gwr%my_spins)
1569 0 : ABI_CHECK(gwr%my_nspins > 0, "my_nspins == 0, decrease number of MPI procs for spin level")
1570 :
1571 : ! Distribute k-points in the full BZ and build redirection tables.
1572 : ! Finally, find the number of IBZ k-points treated by this MPI rank.
1573 0 : call xmpi_split_block(gwr%nkbz, gwr%kpt_comm%value, gwr%my_nkbz, gwr%my_kbz_inds)
1574 0 : ABI_CHECK(gwr%my_nkbz > 0, "my_nkbz == 0, decrease number of MPI procs for k-point level")
1575 :
1576 : ! Compute np_kibz
1577 0 : ABI_ICALLOC(gwr%np_kibz, (gwr%nkibz))
1578 0 : do my_ikf=1,gwr%my_nkbz
1579 0 : ik_bz = gwr%my_kbz_inds(my_ikf); ik_ibz = gwr%kbz2ibz(1, ik_bz)
1580 0 : gwr%np_kibz(ik_ibz) = 1
1581 : end do
1582 :
1583 0 : gwr%my_nkibz = count(gwr%np_kibz > 0)
1584 0 : ABI_MALLOC(gwr%my_kibz_inds, (gwr%my_nkibz))
1585 0 : ii = 0
1586 0 : do ik_ibz=1,gwr%nkibz
1587 0 : if (gwr%np_kibz(ik_ibz) > 0) then
1588 0 : ii = ii + 1; gwr%my_kibz_inds(ii) = ik_ibz
1589 : end if
1590 : end do
1591 :
1592 0 : call xmpi_sum(gwr%np_kibz, gwr%kpt_comm%value, ierr)
1593 :
1594 : ! Build table to distribute iterations over ik_ibz as kIBZ might be replicated across MPI procs.
1595 0 : ABI_ICALLOC(iwork, (gwr%kpt_comm%nproc, gwr%nkibz))
1596 0 : ABI_ICALLOC(got, (gwr%kpt_comm%nproc))
1597 0 : do my_iki=1,gwr%my_nkibz
1598 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
1599 0 : iwork(gwr%kpt_comm%me + 1, ik_ibz) = 1
1600 : end do
1601 0 : call xmpi_sum(iwork, gwr%kpt_comm%value, ierr)
1602 :
1603 0 : ABI_MALLOC(gwr%itreat_ikibz, (gwr%nkibz))
1604 0 : gwr%itreat_ikibz = .False.
1605 0 : do ik_ibz=1,gwr%nkibz
1606 0 : ii = imin_loc(got, mask=iwork(:, ik_ibz) /= 0); got(ii) = got(ii) + 1
1607 0 : if (ii == gwr%kpt_comm%me + 1) gwr%itreat_ikibz(ik_ibz) = .True.
1608 : end do
1609 0 : ABI_FREE(got)
1610 0 : ABI_FREE(iwork)
1611 :
1612 : ! Distribute q-points in full BZ, transfer symmetry tables.
1613 : ! Finally find the number of my IBZ q-points that should be stored in memory.
1614 0 : call xmpi_split_block(gwr%nqbz, gwr%kpt_comm%value, gwr%my_nqbz, gwr%my_qbz_inds)
1615 :
1616 : ! Compute np_qibz
1617 0 : ABI_ICALLOC(gwr%np_qibz, (gwr%nqibz))
1618 0 : do my_iqf=1,gwr%my_nqbz
1619 0 : iq_bz = gwr%my_qbz_inds(my_iqf); iq_ibz = gwr%qbz2ibz(1, iq_bz)
1620 0 : gwr%np_qibz(iq_ibz) = 1
1621 : end do
1622 :
1623 0 : gwr%my_nqibz = count(gwr%np_qibz > 0)
1624 0 : ABI_MALLOC(gwr%my_qibz_inds, (gwr%my_nqibz))
1625 0 : ii = 0
1626 0 : do iq_ibz=1,gwr%nqibz
1627 0 : if (gwr%np_qibz(iq_ibz) > 0) then
1628 0 : ii = ii + 1; gwr%my_qibz_inds(ii) = iq_ibz
1629 : end if
1630 : end do
1631 :
1632 0 : call xmpi_sum(gwr%np_qibz, gwr%kpt_comm%value, ierr)
1633 :
1634 : ! Build table to distribute iterations over iq_ibz as qIBZ might be replicated.
1635 0 : ABI_ICALLOC(iwork, (gwr%kpt_comm%nproc, gwr%nqibz))
1636 0 : ABI_ICALLOC(got, (gwr%kpt_comm%nproc))
1637 0 : do my_iqi=1,gwr%my_nqibz
1638 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
1639 0 : iwork(gwr%kpt_comm%me + 1, iq_ibz) = 1
1640 : end do
1641 0 : call xmpi_sum(iwork, gwr%kpt_comm%value, ierr)
1642 :
1643 0 : ABI_MALLOC(gwr%itreat_iqibz, (gwr%nqibz))
1644 0 : gwr%itreat_iqibz = .False.
1645 0 : do iq_ibz=1,gwr%nqibz
1646 0 : ii = imin_loc(got, mask=iwork(:, iq_ibz) /= 0); got(ii) = got(ii) + 1
1647 0 : if (ii == gwr%kpt_comm%me + 1) gwr%itreat_iqibz(iq_ibz) = .True.
1648 : end do
1649 0 : ABI_FREE(got)
1650 0 : ABI_FREE(iwork)
1651 :
1652 : ! Initialize Coulomb interaction.
1653 : ! Note: MC integration should not be used when computing epsilon, only when integrating in q-space.
1654 0 : vc_ecut = max(dtset%ecutsigx, dtset%ecuteps)
1655 0 : gw_icutcoul_ = dtset%gw_icutcoul
1656 :
1657 0 : gwr%has_vcgen_sigma = .False.
1658 0 : if (any(gw_icutcoul_ == [14, 15, 16])) then
1659 0 : gw_icutcoul_ = mod(gw_icutcoul_, 10); gwr%has_vcgen_sigma = .True.
1660 : end if
1661 :
1662 : call gwr%vcgen_eps%init(cryst, ks_ebands%kptrlatt, gwr%nkbz, gwr%nqibz, gwr%nqbz, gwr%qbz, &
1663 0 : dtset%gw_rcut, gw_icutcoul_, dtset%vcutgeo, vc_ecut, gwr%comm%value)
1664 :
1665 0 : if (gwr%has_vcgen_sigma) then
1666 : ! Note dtset%gw_icutcoul here.
1667 : call gwr%vcgen_sigma%init(cryst, ks_ebands%kptrlatt, gwr%nkbz, gwr%nqibz, gwr%nqbz, gwr%qbz, &
1668 0 : dtset%gw_rcut, dtset%gw_icutcoul, dtset%vcutgeo, vc_ecut, gwr%comm%value)
1669 : end if
1670 :
1671 : ! Now we know the value of g_ngfft. Setup tables for zero-padded FFTs.
1672 : ! Build descriptors for Green's functions and tchi and setup tables for zero-padded FFTs.
1673 0 : ABI_MALLOC(gwr%green_desc_kibz, (gwr%nkibz))
1674 :
1675 0 : do my_iki=1,gwr%my_nkibz
1676 0 : ik_ibz = gwr%my_kibz_inds(my_iki); kk_ibz = gwr%kibz(:, ik_ibz)
1677 0 : call gwr%green_desc_kibz(ik_ibz)%init(kk_ibz, istwfk1, dtset%ecutwfn, gwr, kin_sorted=.False.)
1678 : end do
1679 :
1680 0 : ABI_MALLOC(gwr%tchi_desc_qibz, (gwr%nqibz))
1681 0 : ABI_ICALLOC(gwr%chinpw_qibz, (gwr%nqibz))
1682 :
1683 0 : do my_iqi=1,gwr%my_nqibz
1684 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
1685 : ! Note ecuteps instead of ecut. Also, sort the g-vectors by |q+g|^2/2 when q is in the IBZ to facilitate
1686 : ! the extrapolation of the RPA energy as a function of ecut_chi
1687 0 : call gwr%tchi_desc_qibz(iq_ibz)%init(qq_ibz, istwfk1, dtset%ecuteps, gwr, kin_sorted=.True., rot=.True.)
1688 :
1689 : ! Compute sqrt(vc(q,G))
1690 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
1691 0 : if (gwr%itreat_iqibz(iq_ibz)) gwr%chinpw_qibz(iq_ibz) = desc_q%npw
1692 0 : q_is_gamma = (normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0)
1693 0 : call desc_q%get_vc_sqrt(qq_ibz, q_is_gamma, gwr, "epsilon", gwr%gtau_comm%value)
1694 0 : if (gwr%has_vcgen_sigma) then
1695 0 : call desc_q%get_vc_sqrt(qq_ibz, q_is_gamma, gwr, "sigma", gwr%gtau_comm%value)
1696 : end if
1697 : end associate
1698 : end do
1699 :
1700 : ! Collect npwq on all procs
1701 0 : call xmpi_sum(gwr%chinpw_qibz, gwr%comm%value, ierr)
1702 :
1703 : ! Init 1D PBLAS grid to block-distribute matrices along columns.
1704 0 : call gwr%g_slkproc%init(gwr%g_comm%value, grid_dims=[1, gwr%g_comm%nproc])
1705 0 : call gwr%gtau_slkproc%init(gwr%gtau_comm%value, grid_dims=[1, gwr%gtau_comm%nproc])
1706 :
1707 : ! ==================================
1708 : ! Allocate arrays of PBLAS matrices
1709 : ! ==================================
1710 0 : ABI_MALLOC(gwr%gt_kibz, (2, gwr%nkibz, gwr%ntau, gwr%nsppol, gwr%nsig_ab))
1711 0 : ABI_MALLOC(gwr%tchi_qibz, (gwr%nqibz, gwr%ntau, gwr%nsppol))
1712 0 : ABI_MALLOC(gwr%sigc_kibz, (2, gwr%nkibz, gwr%ntau, gwr%nsppol, gwr%nsig_ab))
1713 :
1714 : ! ====================================
1715 : ! Create netcdf file to store results
1716 : ! ====================================
1717 0 : gwr%gwrnc_write = .True.
1718 : !gwr%gwrnc_write = .False.
1719 0 : gwr%gwrnc_path = strcat(dtfil%filnam_ds(4), "_GWR.nc")
1720 :
1721 0 : if (my_rank == master .and. gwr%gwrnc_write) then
1722 0 : call gwr%print(units)
1723 0 : NCF_CHECK(nctk_open_create(ncid, gwr%gwrnc_path, xmpi_comm_self))
1724 : ! Write structure and ebands
1725 0 : NCF_CHECK(cryst%ncwrite(ncid))
1726 0 : NCF_CHECK(ks_ebands%ncwrite(ncid))
1727 :
1728 : ! Add GWR dimensions.
1729 0 : smat_bsize1 = gwr%b2gw - gwr%b1gw + 1
1730 0 : smat_bsize2 = merge(1, gwr%b2gw - gwr%b1gw + 1, gwr%sig_diago)
1731 : ncerr = nctk_def_dims(ncid, [ &
1732 : nctkdim_t("nsppol", gwr%nsppol), &
1733 : nctkdim_t("nspin_channel", gwr%nsppol*gwr%nsig_ab),&
1734 : nctkdim_t("nsig_ab", gwr%nsig_ab),&
1735 : nctkdim_t("ntau", gwr%ntau), &
1736 : nctkdim_t("nwr", gwr%nwr), &
1737 : nctkdim_t("chi_mpw", gwr%tchi_mpw), &
1738 : nctkdim_t("nqibz", gwr%nqibz), &
1739 : nctkdim_t("nqbz", gwr%nqbz), &
1740 : nctkdim_t("nkcalc", gwr%nkcalc), &
1741 : nctkdim_t("max_nbcalc", gwr%max_nbcalc), &
1742 : nctkdim_t("smat_bsize1", smat_bsize1), &
1743 : nctkdim_t("smat_bsize2", smat_bsize2) &
1744 0 : ], defmode=.True.)
1745 0 : NCF_CHECK(ncerr)
1746 :
1747 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
1748 : "gwr_completed", "sig_diago", "b1gw", "b2gw", "symsigma", "symchi", "scf_iteration" &
1749 0 : ])
1750 0 : NCF_CHECK(ncerr)
1751 :
1752 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
1753 : "wr_step", "ecuteps", "ecut", "ecutwfn", "ecutsigx", "gwr_boxcutmin", &
1754 : "gwr_max_hwtene", "min_transition_energy_eV", "max_transition_energy_eV", &
1755 : "eratio", "ft_max_err_t2w_cos", "ft_max_err_w2t_cos", "ft_max_err_t2w_sin", &
1756 : "cosft_duality_error", "regterm" &
1757 0 : ])
1758 0 : NCF_CHECK(ncerr)
1759 :
1760 : ! Define arrays with results.
1761 : ncerr = nctk_def_arrays(ncid, [ &
1762 : nctkarr_t("gwr_task", "char", "character_string_length"), &
1763 : nctkarr_t("tau_mesh", "dp", "ntau"), &
1764 : nctkarr_t("tau_wgs", "dp", "ntau"), &
1765 : nctkarr_t("iw_mesh", "dp", "ntau"), &
1766 : nctkarr_t("iw_wgs", "dp", "ntau"), &
1767 : nctkarr_t("cosft_wt", "dp", "ntau, ntau"), &
1768 : nctkarr_t("cosft_tw", "dp", "ntau, ntau"), &
1769 : nctkarr_t("sinft_wt", "dp", "ntau, ntau"), &
1770 : !nctkarr_t("ngqpt", "int", "three"), &
1771 : nctkarr_t("bstart_ks", "int", "nkcalc, nsppol"), &
1772 : nctkarr_t("bstop_ks", "int", "nkcalc, nsppol"), &
1773 : nctkarr_t("kcalc", "dp", "three, nkcalc"), &
1774 : nctkarr_t("kcalc2ibz", "int", "nkcalc, six") &
1775 0 : ])
1776 0 : NCF_CHECK(ncerr)
1777 :
1778 : ! ======================================================
1779 : ! Write data that do not depend on the (kpt, spin) loop.
1780 : ! ======================================================
1781 0 : NCF_CHECK(nctk_set_datamode(ncid))
1782 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
1783 : "gwr_completed", "sig_diago", "b1gw", "b2gw", "symsigma", "symchi", "scf_iteration"], &
1784 0 : [0, merge(1, 0, gwr%sig_diago), gwr%b1gw, gwr%b2gw, gwr%dtset%symsigma, dtset%symchi, gwr%scf_iteration])
1785 0 : NCF_CHECK(ncerr)
1786 :
1787 : ncerr = nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: &
1788 : "wr_step", "ecuteps", "ecut", "ecutwfn", "ecutsigx", "gwr_boxcutmin", &
1789 : "gwr_max_hwtene", "min_transition_energy_eV", "max_transition_energy_eV", &
1790 : "eratio", "ft_max_err_t2w_cos", "ft_max_err_w2t_cos", "ft_max_err_t2w_sin", &
1791 : "cosft_duality_error", "regterm"], &
1792 : [gwr%wr_step, dtset%ecuteps, dtset%ecut, dtset%ecutwfn, dtset%ecutsigx, dtset%gwr_boxcutmin, &
1793 : dtset%gwr_max_hwtene, gwr%te_min, gwr%te_max, gwr%te_max / gwr%te_min, &
1794 : gwr%ft_max_error(1), gwr%ft_max_error(2), gwr%ft_max_error(3), gwr%cosft_duality_error, regterm &
1795 0 : ])
1796 0 : NCF_CHECK(ncerr)
1797 :
1798 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_task"), trim(dtset%gwr_task)))
1799 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_mesh"), gwr%tau_mesh))
1800 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_wgs"), gwr%tau_wgs))
1801 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_mesh"), gwr%iw_mesh))
1802 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_wgs"), gwr%iw_wgs))
1803 0 : NCF_CHECK(nf90_put_var(ncid, vid("cosft_wt"), gwr%cosft_wt))
1804 0 : NCF_CHECK(nf90_put_var(ncid, vid("cosft_tw"), gwr%cosft_tw))
1805 0 : NCF_CHECK(nf90_put_var(ncid, vid("sinft_wt"), gwr%sinft_wt))
1806 0 : NCF_CHECK(nf90_put_var(ncid, vid("bstart_ks"), gwr%bstart_ks))
1807 0 : NCF_CHECK(nf90_put_var(ncid, vid("bstop_ks"), gwr%bstop_ks))
1808 0 : NCF_CHECK(nf90_put_var(ncid, vid("kcalc"), gwr%kcalc))
1809 0 : NCF_CHECK(nf90_put_var(ncid, vid("kcalc2ibz"), gwr%kcalc2ibz))
1810 0 : NCF_CHECK(nf90_close(ncid))
1811 : end if ! master
1812 :
1813 0 : call cwtime_report(" gwr_init:", cpu, wall, gflops)
1814 0 : call timab(1920, 2, tsec)
1815 :
1816 : contains
1817 0 : integer function vid(vname)
1818 : character(len=*),intent(in) :: vname
1819 0 : vid = nctk_idname(ncid, vname)
1820 : end function vid
1821 :
1822 : end subroutine gwr_init
1823 : !!***
1824 :
1825 : !----------------------------------------------------------------------
1826 :
1827 : !!****f* m_gwr/estimate
1828 : !! NAME
1829 : !! estimate
1830 : !!
1831 : !! FUNCTION
1832 : !! Estimate memory requirements and the parallel speedup of a given `np_kgts` configuration.
1833 : !!
1834 : !! SOURCE
1835 :
1836 0 : type(est_t) pure function estimate(gwr, np_kgts) result(est)
1837 :
1838 : !Arguments ------------------------------------
1839 : class(gwr_t),intent(in) :: gwr
1840 : integer,intent(in) :: np_kgts(4)
1841 :
1842 : !Local variables-------------------------------
1843 : real(dp) :: np_k, np_g, np_t, np_s, w_k, w_g, w_t, w_s, np_tot
1844 : ! *************************************************************************
1845 :
1846 : ! Use real quantities to avoid integer division
1847 0 : np_k = np_kgts(1); np_g = np_kgts(2); np_t = np_kgts(3); np_s = np_kgts(4)
1848 0 : np_tot = product(real(np_kgts))
1849 :
1850 : ! NB: array dimensioned with nkibz and nqibz do not scale as 1/np_k as we distribute the BZ, IBZ points might be replicated.
1851 :
1852 : !!! FIXME HT: Here we should recalculate with nsig_ab
1853 : ! Resident memory in Mb for G(g,g',+/-tau) and chi(g,g',tau)
1854 0 : est%mem_green_gg = two * two * (one*gwr%nspinor*gwr%green_mpw)**2 * two*gwr%ntau * gwr%nkibz * gwr%nsppol * gwp*b2Mb / np_tot
1855 0 : est%mem_chi_gg = two * (one*gwr%tchi_mpw)**2 * gwr%ntau * gwr%nqibz * gwp*b2Mb / (np_g * np_t * np_k)
1856 0 : est%mem_ugb = two * gwr%green_mpw * gwr%nspinor * gwr%dtset%nband(1) * gwr%nkibz * gwr%nsppol * gwp*b2Mb / np_tot
1857 :
1858 : ! Temporary memory allocated inside the tau loops.
1859 : ! This is the chunck we have to minimize by increasing np_g and/or np_k to avoid going OOM.
1860 0 : est%mem_green_rg = two * two * gwr%nspinor**2 * gwr%green_mpw * gwr%g_nfft * gwr%nkbz * gwr%nsppol * gwp*b2Mb / (np_g * np_k)
1861 0 : est%mem_chi_rg = two * gwr%tchi_mpw * gwr%g_nfft * gwr%nqbz * gwp*b2Mb / (np_g * np_k)
1862 :
1863 0 : est%mem_total = est%mem_green_gg + est%mem_chi_gg + est%mem_ugb + est%mem_green_rg + est%mem_chi_rg
1864 :
1865 : ! Estimate speedup and parallel efficiency using heuristic weights. Note g_nfft instead of green_mpw.
1866 0 : w_k = 0.799_dp; w_g = 0.899_dp; w_t = 1.1_dp; w_s = 1.2_dp
1867 :
1868 : ! Promote kpt parallelism under particular circumstances.
1869 0 : if (gwr%nkbz > 4**3) w_k = w_g + tol2 * merge(+1, -5, np_k < 5)
1870 :
1871 : est%speedup = speedup(gwr%nkbz, nint(np_k), w_k) * speedup(gwr%g_nfft, nint(np_g), w_g) * &
1872 0 : speedup(gwr%ntau, nint(np_t), w_t) * speedup(gwr%nsppol, nint(np_s), w_s)
1873 0 : est%efficiency = est%speedup / np_tot
1874 :
1875 : contains
1876 :
1877 0 : real(dp) pure function speedup(size, np, weight)
1878 : ! Expected speedup for a `size` problem and `np` processes
1879 : integer,intent(in) :: size, np
1880 : real(dp),intent(in) :: weight
1881 0 : if (np == 1) then
1882 : speedup = one
1883 : else
1884 0 : speedup = (weight*size) / (one* ((size / np) + merge(0, 1, mod(size, np) == 0)))
1885 : end if
1886 0 : end function speedup
1887 :
1888 : end function estimate
1889 : !!***
1890 :
1891 : !----------------------------------------------------------------------
1892 :
1893 : !!****f* m_gwr/est_print
1894 : !! NAME
1895 : !! est_print
1896 : !!
1897 : !! FUNCTION
1898 : !! Print memory estimate.
1899 : !!
1900 : !! SOURCE
1901 :
1902 0 : subroutine est_print(est, units)
1903 :
1904 : !Arguments ------------------------------------
1905 : class(est_t), intent(in) :: est
1906 : integer,intent(in) :: units(:)
1907 :
1908 : !Local variables-------------------------------
1909 : character(len=4),parameter :: fmt = "f8.1"
1910 : ! *************************************************************************
1911 :
1912 0 : call wrtout(units, "- Resident memory in Mb for G(g,g',+/-tau) and chi(g,g',tau):")
1913 0 : call wrtout(units, sjoin("- G_k(g,g,tau): ", ftoa(est%mem_green_gg, fmt=fmt)))
1914 0 : call wrtout(units, sjoin("- Chi_q(g,g,tau): ", ftoa(est%mem_chi_gg, fmt=fmt)))
1915 0 : call wrtout(units, sjoin("- u_k(g,b): ", ftoa(est%mem_ugb, fmt=fmt)))
1916 0 : call wrtout(units, "- Temporary memory allocated inside the tau loops:")
1917 0 : call wrtout(units, sjoin("- G_k(r,g): ", ftoa(est%mem_green_rg, fmt=fmt)))
1918 0 : call wrtout(units, sjoin("- chi_q(r,g): ", ftoa(est%mem_chi_rg, fmt=fmt)))
1919 :
1920 0 : end subroutine est_print
1921 : !!***
1922 :
1923 : !----------------------------------------------------------------------
1924 :
1925 : !!****f* m_gwr/gwr_malloc_free_mats
1926 : !! NAME
1927 : !! gwr_malloc_free_mats
1928 : !!
1929 : !! FUNCTION
1930 : !! Allocate/Free PBLAS matrices according to `what` for the set of k/q-points selected by `mask_ibz`.
1931 : !!
1932 : !! INPUTS
1933 : !! mask_ibz
1934 : !! what
1935 : !! action
1936 : !!
1937 : !! SOURCE
1938 :
1939 0 : subroutine gwr_malloc_free_mats(gwr, mask_ibz, what, action)
1940 :
1941 : !Arguments ------------------------------------
1942 : class(gwr_t), target, intent(inout) :: gwr
1943 : integer,intent(in) :: mask_ibz(:)
1944 : character(len=*),intent(in) :: what, action
1945 :
1946 : !Local variables-------------------------------
1947 : integer :: my_is, my_it, ipm, npw, col_bsize, itau, spin, ik_ibz, iq_ibz, iab
1948 : !integer :: ii, num_pm, ipm_list__(2)
1949 : type(__slkmat_t), pointer :: mat
1950 : character(len=500) :: msg !, gpu_action
1951 : ! *************************************************************************
1952 :
1953 0 : ABI_CHECK(string_in(action, "malloc, free"), sjoin("Invalid action:", action))
1954 :
1955 : !gpu_action = "None"; if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
1956 :
1957 : !num_pm = 2; ipm_list__ = [1, 2]
1958 : !if (present(ipm_list)) then
1959 : ! num_pm = size(ipm_list)
1960 : ! ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
1961 : ! ipm_list__(1:num_pm) = ipm_list(:)
1962 : !end if
1963 :
1964 0 : do my_is=1,gwr%my_nspins
1965 0 : spin = gwr%my_spins(my_is)
1966 0 : do my_it=1,gwr%my_ntau
1967 0 : itau = gwr%my_itaus(my_it)
1968 : ! NB: all the PBLAS matrices are MPI distributed over g' in blocks if action == "malloc"
1969 :
1970 0 : select case (what)
1971 : case ("green")
1972 : ! ========================
1973 : ! Allocate/free G_k(g,g', +-itau)
1974 : ! ========================
1975 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nkibz, "wrong mask size")
1976 :
1977 0 : do ik_ibz=1,gwr%nkibz
1978 0 : if (mask_ibz(ik_ibz) == 0) cycle
1979 0 : npw = gwr%green_desc_kibz(ik_ibz)%npw
1980 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
1981 0 : do iab=1,gwr%nsig_ab
1982 0 : associate (gt => gwr%gt_kibz(:, ik_ibz, itau, spin, iab))
1983 0 : do ipm=1,2
1984 0 : if (action == "malloc") call gt(ipm)%init(npw, npw, gwr%g_slkproc, istwfk1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
1985 0 : if (action == "free") call gt(ipm)%free()
1986 : end do
1987 : end associate
1988 : end do
1989 : end do
1990 :
1991 : case ("tchi", "wc")
1992 : ! ===========================
1993 : ! Allocate/free tchi_q(g,g', +itau)
1994 : ! ===========================
1995 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nqibz, "wrong mask size")
1996 :
1997 0 : do iq_ibz=1,gwr%nqibz
1998 0 : if (mask_ibz(iq_ibz) == 0) cycle
1999 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
2000 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
2001 0 : if (what == "tchi") mat => gwr%tchi_qibz(iq_ibz, itau, spin)
2002 0 : if (what == "wc") mat => gwr%wc_qibz(iq_ibz, itau, spin)
2003 0 : if (action == "malloc") call mat%init(npw, npw, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
2004 0 : if (action == "free") call mat%free()
2005 : end do
2006 :
2007 : case ("sigma")
2008 : ! ================================
2009 : ! Allocate/free sigmac_kibz(g,g', +- itau)
2010 : ! ================================
2011 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nkibz, "wrong mask size")
2012 0 : do ik_ibz=1,gwr%nkibz
2013 0 : if (mask_ibz(ik_ibz) == 0) cycle
2014 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
2015 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
2016 0 : do iab=1,gwr%nsig_ab
2017 0 : associate (sigc => gwr%sigc_kibz(:, ik_ibz, itau, spin, iab))
2018 0 : do ipm=1,2
2019 0 : if (action == "malloc") call sigc(ipm)%init(npw, npw, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
2020 0 : if (action == "free") call sigc(ipm)%free()
2021 : end do
2022 : end associate
2023 : end do
2024 : end do
2025 :
2026 : case default
2027 0 : ABI_ERROR(sjoin("Invalid what:", what))
2028 : end select
2029 :
2030 : end do ! my_it
2031 : end do ! my_is
2032 :
2033 0 : call wrtout(std_out, "")
2034 0 : call gwr%print_mem([std_out])
2035 :
2036 0 : end subroutine gwr_malloc_free_mats
2037 : !!***
2038 :
2039 : !----------------------------------------------------------------------
2040 :
2041 : !!****f* m_gwr/gwr_free
2042 : !! NAME
2043 : !! gwr_free
2044 : !!
2045 : !! FUNCTION
2046 : !! Free dynamic memory in gwr object.
2047 : !!
2048 : !! SOURCE
2049 :
2050 0 : subroutine gwr_free(gwr)
2051 :
2052 : !Arguments ------------------------------------
2053 : class(gwr_t), intent(inout) :: gwr
2054 : ! *************************************************************************
2055 :
2056 0 : ABI_SFREE(gwr%ks_vbik)
2057 0 : ABI_SFREE(gwr%kbz)
2058 0 : ABI_SFREE(gwr%kbz2ibz)
2059 0 : ABI_SFREE(gwr%kbz2ibz_symrel)
2060 0 : ABI_SFREE(gwr%qbz2ibz)
2061 0 : ABI_SFREE(gwr%my_kbz_inds)
2062 0 : ABI_SFREE(gwr%my_kibz_inds)
2063 0 : ABI_SFREE(gwr%my_qbz_inds)
2064 0 : ABI_SFREE(gwr%my_qibz_inds)
2065 0 : ABI_SFREE(gwr%qbz)
2066 0 : ABI_SFREE(gwr%qibz)
2067 0 : ABI_SFREE(gwr%wtq)
2068 0 : ABI_SFREE(gwr%chi0_head_myw)
2069 0 : ABI_SFREE(gwr%chi0_uwing_myw)
2070 0 : ABI_SFREE(gwr%chi0_lwing_myw)
2071 0 : ABI_SFREE(gwr%my_spins)
2072 0 : ABI_SFREE(gwr%my_itaus)
2073 0 : ABI_SFREE(gwr%tau_master)
2074 0 : ABI_SFREE(gwr%np_kibz)
2075 0 : ABI_SFREE(gwr%itreat_ikibz)
2076 0 : ABI_SFREE(gwr%np_qibz)
2077 0 : ABI_SFREE(gwr%itreat_iqibz)
2078 0 : ABI_SFREE_NOCOUNT(gwr%tau_mesh)
2079 0 : ABI_SFREE_NOCOUNT(gwr%tau_wgs)
2080 0 : ABI_SFREE_NOCOUNT(gwr%iw_mesh)
2081 0 : ABI_SFREE_NOCOUNT(gwr%iw_wgs)
2082 0 : ABI_SFREE_NOCOUNT(gwr%cosft_tw)
2083 0 : ABI_SFREE_NOCOUNT(gwr%cosft_wt)
2084 0 : ABI_SFREE_NOCOUNT(gwr%sinft_wt)
2085 0 : ABI_SFREE(gwr%kcalc)
2086 0 : ABI_SFREE(gwr%bstart_ks)
2087 0 : ABI_SFREE(gwr%bstop_ks)
2088 0 : ABI_SFREE(gwr%nbcalc_ks)
2089 0 : ABI_SFREE(gwr%kcalc2ibz)
2090 0 : ABI_SFREE(gwr%sigx_mat)
2091 0 : ABI_SFREE(gwr%sigc_iw_mat)
2092 0 : ABI_SFREE(gwr%chinpw_qibz)
2093 :
2094 0 : call gwr%ks_gaps%free()
2095 0 : call gwr%qp_ebands%free()
2096 0 : call gwr%qp_ebands_prev%free()
2097 0 : call gwr%kcalc_wfd%free()
2098 0 : call gwr%wfk_hdr%free()
2099 :
2100 : ! Free descriptors
2101 0 : if (allocated(gwr%green_desc_kibz)) then
2102 0 : call desc_array_free(gwr%green_desc_kibz)
2103 0 : ABI_FREE(gwr%green_desc_kibz)
2104 : end if
2105 0 : if (allocated(gwr%tchi_desc_qibz)) then
2106 0 : call desc_array_free(gwr%tchi_desc_qibz)
2107 0 : ABI_FREE(gwr%tchi_desc_qibz)
2108 : end if
2109 :
2110 : ! Free PBLAS matrices
2111 0 : if (allocated(gwr%gt_kibz)) then
2112 0 : call slk_array_free(gwr%gt_kibz)
2113 0 : ABI_FREE(gwr%gt_kibz)
2114 : end if
2115 0 : if (allocated(gwr%tchi_qibz)) then
2116 0 : call slk_array_free(gwr%tchi_qibz)
2117 0 : ABI_FREE(gwr%tchi_qibz)
2118 : end if
2119 0 : if (allocated(gwr%wc_qibz)) then
2120 0 : call slk_array_free(gwr%wc_qibz)
2121 0 : ABI_FREE(gwr%wc_qibz)
2122 : end if
2123 0 : if (allocated(gwr%sigc_kibz)) then
2124 0 : call slk_array_free(gwr%sigc_kibz)
2125 0 : ABI_FREE(gwr%sigc_kibz)
2126 : end if
2127 : ! Release the scalapack pressor.
2128 0 : call gwr%g_slkproc%free()
2129 :
2130 0 : if (allocated(gwr%ugb)) then
2131 0 : call slk_array_free(gwr%ugb)
2132 0 : ABI_FREE(gwr%ugb)
2133 : end if
2134 : !if (allocated(gwr%nato_ugb)) then
2135 : ! call slk_array_free(gwr%nato_ugb)
2136 : ! ABI_FREE(gwr%nato_ugb)
2137 : !end if
2138 0 : call gwr%gtau_slkproc%free()
2139 :
2140 : ! datatypes.
2141 0 : call gwr%ks_me%free()
2142 0 : call gwr%vcgen_eps%free()
2143 0 : if (gwr%has_vcgen_sigma) call gwr%vcgen_sigma%free()
2144 :
2145 0 : if (allocated(gwr%degtab)) then
2146 0 : call degtab_array_free(gwr%degtab)
2147 0 : ABI_FREE(gwr%degtab)
2148 : end if
2149 :
2150 : ! Free MPI communicators
2151 0 : call gwr%spin_comm%free(); call gwr%g_comm%free(); call gwr%tau_comm%free()
2152 0 : call gwr%kpt_comm%free(); call gwr%gtau_comm%free(); call gwr%kg_comm%free()
2153 0 : call gwr%kgt_comm%free(); call gwr%kts_comm%free(); call gwr%comm%free()
2154 :
2155 0 : end subroutine gwr_free
2156 : !!***
2157 :
2158 : ! Free array of desc_t objects.
2159 0 : subroutine desc_array1_free(desc_array1)
2160 : type(desc_t),intent(inout) :: desc_array1(:)
2161 : integer :: ii
2162 :
2163 0 : do ii=1,size(desc_array1, dim=1)
2164 0 : call desc_array1(ii)%free()
2165 : end do
2166 0 : end subroutine desc_array1_free
2167 :
2168 : !----------------------------------------------------------------------
2169 :
2170 : !!****f* m_gwr/gwr_load_kcalc_wfd
2171 : !! NAME
2172 : !! gwr_load_kcalc_wfd
2173 : !!
2174 : !! FUNCTION
2175 : !! Load the KS states to compute Sigma_nk from the WFK file
2176 : !!
2177 : !! INPUTS
2178 : !! wfk_path=Name of the WFK file.
2179 : !!
2180 : !! OUTPUT
2181 : !! tmp_kstab
2182 : !!
2183 : !! SOURCE
2184 :
2185 0 : subroutine gwr_load_kcalc_wfd(gwr, wfk_path, tmp_kstab)
2186 :
2187 : !Arguments ------------------------------------
2188 : class(gwr_t),intent(inout) :: gwr
2189 : character(len=*),intent(in) :: wfk_path
2190 : integer,allocatable,intent(out) :: tmp_kstab(:,:,:)
2191 :
2192 : !Local variables-------------------------------
2193 : !scalars
2194 : integer :: mband, nkibz, nsppol, spin, ik_ibz, ikcalc
2195 : real(dp) :: cpu, wall, gflops
2196 : !character(len=5000) :: msg
2197 : type(ebands_t) :: ks_ebands
2198 0 : type(hdr_type) :: wfk_hdr
2199 : !arrays
2200 0 : integer,allocatable :: nband(:,:), wfd_istwfk(:)
2201 0 : logical,allocatable :: bks_mask(:,:,:), keep_ur(:,:,:)
2202 : ! *************************************************************************
2203 :
2204 0 : call cwtime(cpu, wall, gflops, "start")
2205 :
2206 : associate (wfd => gwr%kcalc_wfd, dtset => gwr%dtset)
2207 :
2208 0 : ks_ebands = wfk_read_ebands(wfk_path, gwr%comm%value, out_hdr=wfk_hdr)
2209 0 : call wfk_hdr%vs_dtset(dtset)
2210 :
2211 : ! TODO: Add more consistency checks e.g. nkibz,...
2212 : !cryst = wfk_hdr%get_crystal()
2213 : !call cryst%print(header="crystal structure from WFK file")
2214 :
2215 0 : nkibz = ks_ebands%nkpt; nsppol = ks_ebands%nsppol
2216 :
2217 : ! Don't take mband from ks_ebands but compute it from gwr%bstop_ks
2218 0 : mband = maxval(gwr%bstop_ks) !; mband = ks_ebands%mband
2219 :
2220 : ! Initialize the wave function descriptor.
2221 : ! Only wavefunctions for the symmetrical imagine of the k wavevectors
2222 : ! treated by this MPI rank are stored.
2223 0 : ABI_MALLOC(nband, (nkibz, nsppol))
2224 0 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
2225 0 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
2226 0 : nband = mband; bks_mask = .False.; keep_ur = .False.
2227 :
2228 0 : ABI_ICALLOC(tmp_kstab, (2, nkibz, nsppol))
2229 :
2230 0 : do spin=1,gwr%nsppol
2231 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
2232 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
2233 0 : associate (b1 => gwr%bstart_ks(ikcalc, spin), b2 => gwr%bstop_ks(ikcalc, spin))
2234 0 : tmp_kstab(:, ik_ibz, spin) = [b1, b2]
2235 0 : bks_mask(b1:b2, ik_ibz, spin) = .True.
2236 : end associate
2237 : end do
2238 : end do
2239 :
2240 : ! Impose istwfk = 1 for all k-points.
2241 : ! wfd_read_wfk will handle a possible conversion if the WFK contains istwfk /= 1.
2242 0 : ABI_MALLOC(wfd_istwfk, (nkibz))
2243 0 : wfd_istwfk = 1
2244 :
2245 : call wfd%init(gwr%cryst, gwr%pawtab, gwr%psps, keep_ur, mband, nband, nkibz, dtset%nsppol, bks_mask, &
2246 : dtset%nspden, dtset%nspinor, dtset%ecutwfn, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ks_ebands%kptns, gwr%g_ngfft, &
2247 0 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, gwr%comm%value)
2248 :
2249 0 : call wfd%print([std_out], header="Wavefunctions for GWR calculation")
2250 :
2251 0 : ABI_FREE(nband)
2252 0 : ABI_FREE(keep_ur)
2253 0 : ABI_FREE(wfd_istwfk)
2254 0 : ABI_FREE(bks_mask)
2255 :
2256 0 : call ks_ebands%free(); call wfk_hdr%free()
2257 :
2258 : ! Read KS wavefunctions.
2259 0 : call wfd%read_wfk(wfk_path, iomode_from_fname(wfk_path))
2260 : end associate
2261 :
2262 0 : call cwtime_report(" gwr_load_kcalc_from_wfk:", cpu, wall, gflops)
2263 0 : call pstat_proc%print(_PSTAT_ARGS_)
2264 :
2265 0 : end subroutine gwr_load_kcalc_wfd
2266 : !!***
2267 :
2268 : !----------------------------------------------------------------------
2269 :
2270 : !!****f* m_gwr/gwr_read_ugb_from_wfk
2271 : !! NAME
2272 : !! gwr_read_ugb_from_wfk
2273 : !!
2274 : !! FUNCTION
2275 : !! Read wavefunctions from the WFK file `wfk_path` and store them in gwr%ugb (MPI distributed).
2276 : !!
2277 : !! SOURCE
2278 :
2279 0 : subroutine gwr_read_ugb_from_wfk(gwr, wfk_path)
2280 :
2281 : !Arguments ------------------------------------
2282 : class(gwr_t),target,intent(inout) :: gwr
2283 : character(len=*),intent(in) :: wfk_path
2284 :
2285 : !Local variables-------------------------------
2286 : !scalars
2287 : integer,parameter :: formeig0 = 0, master = 0
2288 : integer :: mband, min_nband, nkibz, nsppol, my_is, my_iki, spin, ik_ibz, ierr, bcast_comm, color
2289 : integer :: npw_k, mpw_disk, istwf_k, il_b, ib, band, iloc, cg_spad, gw_spad
2290 : integer :: nbsum, npwsp, npw_k_disk, npwsp_disk, bstart, bstop, band_step, nb, nmiss, ig, igw, spinor, icg
2291 : logical :: print_time
2292 : real(dp) :: cpu, wall, gflops, cpu_green, wall_green, gflops_green
2293 : complex(gwp) :: cdum
2294 : character(len=5000) :: msg
2295 : logical :: have_band, need_block_ks, io_in_kcomm, cut_ug
2296 : type(ebands_t) :: wfk_ebands
2297 0 : type(wfk_t) :: wfk
2298 : type(dataset_type),pointer :: dtset
2299 : type(xcomm_t), pointer :: io_comm
2300 : !arrays
2301 : integer :: units(2)
2302 0 : integer,allocatable :: kg_k_disk(:,:), gf2wfd(:)
2303 : !logical,allocatable :: bmask(:)
2304 : real(dp) :: kk_ibz(3), tsec(2)
2305 0 : real(dp),target,allocatable :: cg_work(:,:,:)
2306 0 : real(dp),contiguous, pointer :: cg_k(:,:)
2307 : ! *************************************************************************
2308 :
2309 0 : units = [std_out, ab_out]
2310 0 : call cwtime(cpu, wall, gflops, "start")
2311 0 : call timab(1921, 1, tsec)
2312 :
2313 0 : dtset => gwr%dtset
2314 0 : wfk_ebands = wfk_read_ebands(wfk_path, gwr%comm%value, out_hdr=gwr%wfk_hdr)
2315 0 : call gwr%wfk_hdr%vs_dtset(dtset)
2316 :
2317 : ! TODO: Add more consistency checks e.g. nkibz,...
2318 : !cryst = gwr%wfk_hdr%get_crystal()
2319 : !call cryst%print(header="crystal structure from WFK file")
2320 :
2321 : ! TODO: Could read the wavefunctions twice and use ecutwfc for sigma_c and ecut for sigma_x.
2322 0 : nkibz = wfk_ebands%nkpt; nsppol = wfk_ebands%nsppol; mband = wfk_ebands%mband; min_nband = minval(wfk_ebands%nband)
2323 :
2324 0 : nbsum = dtset%nband(1)
2325 0 : if (nbsum > min_nband) then
2326 0 : ABI_ERROR(sjoin("WFK file contains", itoa(min_nband), "states while you're asking for:", itoa(nbsum)))
2327 0 : nbsum = min_nband
2328 : end if
2329 0 : call wfk_ebands%free()
2330 :
2331 0 : cut_ug = (abs(gwr%dtset%ecut - gwr%dtset%ecutwfn) > tol3)
2332 0 : if (cut_ug) then
2333 0 : call wrtout(units, sjoin(" Cutting u(g) as ecutwfn:", ftoa(gwr%dtset%ecutwfn), " < ecut: ", ftoa(gwr%dtset%ecut)))
2334 : end if
2335 :
2336 : ! ==============================================
2337 : ! Build Green's functions in g-space for given k
2338 : ! ==============================================
2339 :
2340 : ! for tau > 0:
2341 : !
2342 : ! G_k(r,r',itau) = i \sum_b^{occ} psi_b(r) \psi_b^*(r') exp(e_b tau)
2343 : !
2344 : ! for tau < 0:
2345 : !
2346 : ! G_k(r,r',itau) = -i \sum_b^{empty} psi_b(r) \psi_b^*(r') exp(e_b tau)
2347 : !
2348 : ! NB: G_k is constructed for k in the IBZ, then we rotate the k-point to obtain G_k in the BZ.
2349 : !
2350 : ! TODO:
2351 : ! 1) Make sure that gvec in gwr and wfd agree with each other.
2352 : ! 2) May implement trick used in gwst to add empty states approximated with LC of PWs.
2353 :
2354 : ! Select occupied or empty G.
2355 : ! if (eig_nk < -tol6) then
2356 : ! !ipm = 1
2357 : ! !gt_cfact = j_dpc * exp(gwr%tau_mesh(itau) * eig_nk)
2358 : ! ! Vasp convention
2359 : ! ipm = 2
2360 : ! gt_cfact = exp(gwr%tau_mesh(itau) * eig_nk)
2361 : ! else if (eig_nk > tol6) then
2362 : ! !ipm = 2
2363 : ! !gt_cfact = -j_dpc * exp(-gwr%tau_mesh(itau) * eig_nk)
2364 : ! ! Vasp convention
2365 : ! ipm = 1
2366 : ! gt_cfact = -exp(-gwr%tau_mesh(itau) * eig_nk)
2367 : ! else
2368 : ! ABI_WARNING("Metallic system of semiconductor with Fermi level inside bands!!!!")
2369 : ! end if
2370 :
2371 0 : call wrtout(std_out, sjoin(" Reading KS states with nbsum:", itoa(nbsum), "..."), do_flush=.True.)
2372 :
2373 : ! Init set of (npwsp, nbsum) PBLAS matrix distributed within the g_comm communicator.
2374 : ! and distribute it over bands so that each proc reads a subset of bands in read_band_block
2375 : ! Note size_blocs below that corresponds to a round-robin distribution along the band axis.
2376 :
2377 0 : ABI_MALLOC(gwr%ugb, (gwr%nkibz, gwr%nsppol))
2378 0 : gwr%ugb_nband = nbsum
2379 :
2380 0 : do my_is=1,gwr%my_nspins
2381 0 : spin = gwr%my_spins(my_is)
2382 0 : do my_iki=1,gwr%my_nkibz
2383 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
2384 0 : npw_k = gwr%green_desc_kibz(ik_ibz)%npw; npwsp = npw_k * gwr%nspinor
2385 0 : call gwr%ugb(ik_ibz, spin)%init(npwsp, gwr%ugb_nband, gwr%g_slkproc, istwfk1, size_blocs=[-1, 1])
2386 : end do
2387 : end do
2388 0 : call gwr%print_mem([std_out])
2389 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
2390 :
2391 0 : mpw_disk = maxval(gwr%wfk_hdr%npwarr)
2392 0 : ABI_MALLOC(kg_k_disk, (3, mpw_disk))
2393 :
2394 : ! Master reads and broadcasts. Much faster on lumi
2395 0 : call wrtout(std_out, " Using IO version based on master reads and brodcasts ...")
2396 0 : io_comm => gwr%comm; io_in_kcomm = .False.
2397 0 : io_comm => gwr%kpt_comm; io_in_kcomm = .True.
2398 :
2399 0 : if (io_comm%me == master) then
2400 0 : call wfk%open_read(wfk_path, formeig0, iomode_from_fname(wfk_path), get_unit(), xmpi_comm_self)
2401 : end if
2402 :
2403 : ! TODO This to maximize the size of cg_work and decrease number of IO operations.
2404 : !min_mem_mb = pstat_proc%pstat_min_mem_mb_per_proc(gwr%comm)
2405 :
2406 0 : do spin=1,gwr%nsppol
2407 0 : if (io_in_kcomm .and. .not. any(gwr%my_spins == spin)) cycle
2408 :
2409 0 : do ik_ibz=1,gwr%nkibz
2410 0 : print_time = gwr%comm%me == 0 .and. (ik_ibz < LOG_MODK .or. mod(ik_ibz, LOG_MODK) == 0)
2411 0 : if (print_time) call cwtime(cpu_green, wall_green, gflops_green, "start")
2412 0 : kk_ibz = gwr%kibz(:, ik_ibz)
2413 0 : npw_k = gwr%green_desc_kibz(ik_ibz)%npw
2414 0 : npw_k_disk = gwr%wfk_hdr%npwarr(ik_ibz); istwf_k = gwr%wfk_hdr%istwfk(ik_ibz); npwsp_disk = npw_k_disk * gwr%nspinor
2415 :
2416 0 : ABI_CHECK_IEQ(istwf_k, 1, "istwfk_k should be 1")
2417 : ! See m_wfd for calls to convert to istwfk 1
2418 : !change_gsphere = istwfk_disk /= wfd%istwfk(ik_ibz)
2419 :
2420 : ! Create communicator with master and all procs requiring this (k,s) block (color == 1)
2421 0 : need_block_ks = any(gwr%my_spins == spin) .and. any(gwr%my_kibz_inds == ik_ibz)
2422 0 : color = merge(1, 0, (need_block_ks .or. io_comm%me == master))
2423 0 : call xmpi_comm_split(io_comm%value, color, io_comm%me, bcast_comm, ierr)
2424 :
2425 : ! TODO: Optimize this part
2426 : ! Find band_step that gives good compromise between memory and efficiency.
2427 : !band_step = memb_limited_step(1, nbsum, 2*npwsp_disk, xmpi_bsize_dp, min_mem_mb * 0.8_dp)
2428 0 : band_step = 200
2429 :
2430 0 : do bstart=1, nbsum, band_step
2431 0 : bstop = min(bstart + band_step - 1, nbsum); nb = bstop - bstart + 1
2432 :
2433 0 : ABI_MALLOC(cg_work, (2, npwsp_disk, nb)) ! This array is always in double precision.
2434 0 : if (io_comm%me == master) then
2435 0 : call c_f_pointer(c_loc(cg_work), cg_k, shape=[2, npwsp_disk * nb])
2436 0 : call wfk%read_band_block([bstart, bstop], ik_ibz, spin, xmpio_single, kg_k=kg_k_disk, cg_k=cg_k)
2437 : end if
2438 :
2439 0 : if (color == 1) then
2440 0 : call xmpi_bcast(kg_k_disk, master, bcast_comm, ierr)
2441 0 : call xmpi_bcast(cg_work, master, bcast_comm, ierr)
2442 : endif
2443 :
2444 : ! Copy my portion of cg_work to buffer_cplx (here we have dp --> sp conversion).
2445 0 : if (need_block_ks) then
2446 : associate (ugb => gwr%ugb(ik_ibz, spin), desc_k => gwr%green_desc_kibz(ik_ibz))
2447 :
2448 : ! Table with the correspondence btw the k-centered sphere of the WFK file
2449 : ! and the one used in wfd (possibly smaller due to ecutwfn).
2450 0 : if (cut_ug .and. bstart == 1) then
2451 0 : ABI_MALLOC(gf2wfd, (npw_k_disk))
2452 0 : call kg_map(npw_k, desc_k%gvec, npw_k_disk, kg_k_disk, gf2wfd, nmiss)
2453 : end if
2454 :
2455 0 : do band=bstart, bstop
2456 0 : ib = band - bstart + 1
2457 0 : call ugb%glob2loc(1, band, iloc, il_b, have_band); if (.not. have_band) cycle
2458 :
2459 0 : if (.not. cut_ug) then
2460 0 : if (band == bstart) then
2461 0 : ABI_CHECK(all(kg_k_disk(:,1:npw_k_disk) == desc_k%gvec), "kg_k_disk != desc_k%gvec")
2462 : end if
2463 0 : ugb%buffer_cplx(:, il_b) = cmplx(cg_work(1,:,ib), cg_work(2,:,ib), kind=gwp)
2464 :
2465 : else
2466 : !ugb%buffer_cplx(:, il_b) = zero
2467 0 : do spinor=1,gwr%nspinor
2468 0 : cg_spad = (spinor-1) * npw_k_disk
2469 0 : gw_spad = (spinor-1) * npw_k
2470 0 : do ig=1,npw_k_disk
2471 0 : icg = ig + cg_spad
2472 0 : igw = gf2wfd(ig) + gw_spad
2473 0 : if (gf2wfd(ig) /= 0) then
2474 0 : ugb%buffer_cplx(igw, il_b) = cmplx(cg_work(1,icg,ib), cg_work(2,icg,ib), kind=gwp)
2475 : end if
2476 : end do
2477 : end do ! spinor
2478 :
2479 : ! Re-normalize wavefunctions..
2480 0 : cdum = xdotc(npw_k*gwr%nspinor, ugb%buffer_cplx(:,il_b), 1, ugb%buffer_cplx(:,il_b), 1)
2481 0 : if (istwf_k > 1) then
2482 0 : cdum = two * DBLE(cdum)
2483 : associate (ug1 => ugb%buffer_cplx(1,il_b))
2484 0 : if (istwf_k == 2) cdum = cdum - conjg(ug1) * ug1
2485 : end associate
2486 : end if
2487 0 : cdum = one / sqrt(cdum)
2488 0 : call xscal(npw_k*gwr%nspinor, cdum, ugb%buffer_cplx(:,il_b), 1)
2489 : !print *, "new norm:", xdotc(npw_k*gwr%nspinor, ugb%buffer_cplx(:,il_b), 1, ugb%buffer_cplx(:,il_b), 1)
2490 : end if
2491 :
2492 : end do ! band
2493 : end associate
2494 : end if
2495 :
2496 0 : ABI_FREE(cg_work)
2497 : end do ! bstart
2498 :
2499 0 : ABI_SFREE(gf2wfd)
2500 0 : call xmpi_comm_free(bcast_comm)
2501 :
2502 0 : if (print_time) then
2503 0 : write(msg,'(4x,2(a,i0),a)')" Read ugb_k: ik_ibz [", ik_ibz, "/", gwr%nkibz, "]"
2504 0 : call cwtime_report(msg, cpu_green, wall_green, gflops_green); if (ik_ibz == LOG_MODK) call wrtout(std_out, " ...")
2505 : end if
2506 : end do ! ik_ibz
2507 : end do ! spin
2508 0 : if (io_comm%me == master) call wfk%close()
2509 :
2510 0 : ABI_FREE(kg_k_disk)
2511 0 : call gwr%print_mem([std_out])
2512 :
2513 0 : call cwtime_report(" gwr_read_ugb_from_wfk:", cpu, wall, gflops)
2514 0 : call timab(1921, 2, tsec)
2515 :
2516 0 : end subroutine gwr_read_ugb_from_wfk
2517 : !!***
2518 :
2519 : !----------------------------------------------------------------------
2520 :
2521 : !!****f* m_gwr/gwr_build_green
2522 : !! NAME
2523 : !! gwr_build_green
2524 : !!
2525 : !! FUNCTION
2526 : !! Build Green's functions in imaginary time from the gwr%ugb matrices stored in memory.
2527 : !! Store only G_k for the IBZ k-points treated by this MPI proc.
2528 : !!
2529 : !! INPUTS
2530 : !! free_ugb: True if the gwr%ugb wavefunctions should be deallocated before returning.
2531 : !!
2532 : !! SOURCE
2533 :
2534 0 : subroutine gwr_build_green(gwr, free_ugb)
2535 :
2536 : !Arguments ------------------------------------
2537 : class(gwr_t),target,intent(inout) :: gwr
2538 : logical,intent(in) :: free_ugb
2539 :
2540 : !Local variables-------------------------------
2541 : !scalars
2542 : integer :: my_is, my_iki, spin, ik_ibz, band, itau, ipm, il_b, npw, isgn, my_it, nbsum !, ig_glob, ig_loc, jg_loc, nb_occ
2543 : integer :: ii, icomp
2544 : real(dp), parameter :: eratio = 0.95_dp
2545 : real(dp) :: eig_nk, cpu, wall, gflops, cpu_k, wall_k, gflops_k !, f_nk
2546 : logical :: print_time, compute_svd
2547 : character(len=500) :: msg
2548 : real(dp) :: gt_rfact, s2_sum, s2_sum_all
2549 0 : type(__slkmat_t), target :: work_gb(gwr%nspinor), green, u_mat, vt_mat
2550 0 : real(gwp),allocatable :: s_vals(:)
2551 : !arrays
2552 0 : integer :: mask_kibz(gwr%nkibz), units(2) !, ija(2), ijb(2)
2553 : !integer :: occ_idx(gwr%ks_ebands%nkpt, gwr%ks_ebands%nsppol)
2554 : real(dp) :: tsec(2) , kk_ibz(3) !, kg(3)
2555 0 : real(dp),contiguous, pointer :: qp_eig(:,:,:), qp_occ(:,:,:)
2556 : integer :: iab, iiab, jiab, ispinor !,i, j
2557 : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
2558 : ! *************************************************************************
2559 :
2560 0 : call cwtime(cpu, wall, gflops, "start")
2561 0 : call timab(1922, 1, tsec)
2562 0 : units = [std_out, ab_out]
2563 0 : nbsum = gwr%dtset%nband(1)
2564 :
2565 : ! Use KS or QP energies depending on the iteration state.
2566 0 : if (gwr%scf_iteration == 1) then
2567 : call wrtout(units, " Building Green's functions from KS orbitals and KS energies...", &
2568 0 : pre_newlines=2, newlines=1, do_flush=.True.)
2569 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
2570 0 : msg = sjoin("Fermi energy is not set to zero! fermie:", ftoa(gwr%ks_ebands%fermie))
2571 0 : ABI_CHECK(abs(gwr%ks_ebands%fermie) < tol12, msg)
2572 :
2573 : !occ_idx = gwr%ks_ebands%get_occupied()
2574 :
2575 : ! Allocate my Green's functions in IBZ if this is the first iteration.
2576 0 : mask_kibz = 0; mask_kibz(gwr%my_kibz_inds(:)) = 1
2577 0 : call gwr%malloc_free_mats(mask_kibz, "green", "malloc")
2578 :
2579 : else
2580 : call wrtout(units, " Building Green's functions from KS orbitals and QP energies...", &
2581 0 : pre_newlines=2, newlines=1, do_flush=.True.)
2582 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
2583 0 : msg = sjoin("Fermi energy is not set to zero! fermie:", ftoa(gwr%qp_ebands%fermie))
2584 0 : ABI_CHECK(abs(gwr%qp_ebands%fermie) < tol12, msg)
2585 :
2586 : !occ_idx = gwr%qp_ebands%get_occupied()
2587 : end if
2588 :
2589 0 : ABI_CHECK(allocated(gwr%ugb), "gwr%ugb array should be allocated!")
2590 0 : compute_svd = .False.
2591 : !compute_svd = .True.
2592 :
2593 0 : do my_is=1,gwr%my_nspins
2594 0 : spin = gwr%my_spins(my_is)
2595 : ! Loop over my k-points in the IBZ
2596 0 : do my_iki=1,gwr%my_nkibz
2597 0 : print_time = gwr%comm%me == 0 .and. (my_iki < LOG_MODK .or. mod(my_iki, LOG_MODK) == 0)
2598 0 : if (print_time) call cwtime(cpu_k, wall_k, gflops_k, "start")
2599 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
2600 0 : kk_ibz = gwr%kibz(:, ik_ibz)
2601 0 : associate (ugb_ks => gwr%ugb(ik_ibz, spin), desc_k => gwr%green_desc_kibz(ik_ibz))
2602 0 : npw = desc_k%npw
2603 : ! Init output of pzgemm in g-communicator
2604 0 : call green%init(npw, npw, gwr%g_slkproc, istwfk1) ! size_blocs=[-1, col_bsize])
2605 :
2606 : ! Loop over my_ntau as pzgemm is MPI-parallelized inside g_comm.
2607 0 : do my_it=1,gwr%my_ntau
2608 0 : itau = gwr%my_itaus(my_it)
2609 0 : do ipm=1,2
2610 0 : do ispinor = 1, gwr%nspinor
2611 0 : call ugb_ks%cut(npw, ugb_ks%size_global(2), work_gb(ispinor), ija=[(ispinor - 1)*npw + 1, 1])
2612 :
2613 : !work_gb(my_is)%buffer_cplx = gwr %ugb(ik_ibz, spin)%buffer_cplx
2614 :
2615 : !call ugb_ks%change_size_blocs(work_gb, size_blocs=, processor=)
2616 : !call work_gb%copy(green, empty=.True.)
2617 :
2618 : ! Loop over my_ntau as pzgemm is MPI-parallelized inside g_comm.
2619 : ! do my_it=1,gwr%my_ntau
2620 : ! itau = gwr%my_itaus(my_it)
2621 : ! do ipm=1,2
2622 : ! Multiply my columns by exponentials in imaginary time.
2623 : ! work_gb%buffer_cplx = ugb_ks%buffer_cplx
2624 :
2625 : !!!$OMP PARALLEL DO PRIVATE(band, f_nk, eig_nk, gt_rfact)
2626 : !$OMP PARALLEL DO PRIVATE(band, eig_nk, gt_rfact)
2627 0 : do il_b = 1, work_gb(ispinor)%size_local(2)
2628 0 : band = work_gb(ispinor)%loc2gcol(il_b)
2629 : !f_nk = qp_occ(band, ik_ibz, spin)
2630 0 : eig_nk = qp_eig(band, ik_ibz, spin)
2631 0 : gt_rfact = zero
2632 0 : if (ipm == 2) then
2633 0 : if (eig_nk < -tol6) gt_rfact = exp(gwr%tau_mesh(itau) * eig_nk)
2634 : else
2635 0 : if (eig_nk > tol6) gt_rfact = exp(-gwr%tau_mesh(itau) * eig_nk)
2636 : end if
2637 :
2638 : !work_gb%buffer_cplx(:,il_b) = work_gb%buffer_cplx(:,il_b) * sqrt(gt_rfact)
2639 0 : call xscal(npw, real(sqrt(gt_rfact), kind=gwp), work_gb(ispinor)%buffer_cplx(:, il_b), 1)
2640 : end do ! il_b
2641 : end do !ispinor
2642 : ! end do ! ipm
2643 : ! end do ! itau
2644 :
2645 : ! Now build G(g,g',ipm) with PZGEMM.
2646 0 : isgn = merge(1, -1, ipm == 2)
2647 0 : do iab = 1, gwr%nsig_ab
2648 0 : iiab = spinor_idxs(1, iab)
2649 0 : jiab = spinor_idxs(2, iab)
2650 :
2651 : ! TODO: optimize this part
2652 : ! This wont' work for metals
2653 : !nb_occ = occ_idx(ik_ibz, spin)
2654 : ! nb_occ = -1
2655 : !if (ipm == 1) then
2656 : ! ija = [1, nb_occ]; ijb = ija
2657 : !else
2658 : ! ija = [nb_occ+1, gwr%ugb_nband]; ijb = ija
2659 : !end if
2660 0 : call slk_pgemm("N", "C", work_gb(iiab), isgn*cone_gw, work_gb(jiab), czero_gw, green)
2661 :
2662 : ! SVD. NB: green matrix in destroyed in output.
2663 : if (compute_svd) then
2664 : call green%svd("N", "N", u_mat, s_vals, vt_mat)
2665 : s2_sum_all = sum(s_vals**2)
2666 : icomp = -1
2667 : do ii=1,size(s_vals)
2668 : s2_sum = sum(s_vals(1:ii)**2)
2669 : if (icomp == -1 .and. s2_sum / s2_sum_all > eratio) icomp = ii
2670 : !write(std_out, *)ii, s_vals(ii), 100 * s2_sum / s2_sum_all
2671 : end do
2672 : write(std_out, "(a,i0,2a,3(a,1x,i0))") &
2673 : "SVD: For ik_ibz: ", ik_ibz, ", kpt: ", trim(ktoa(kk_ibz)), ", itau: ", itau, ", ipm: ", ipm, ", spin: ", spin
2674 : write(std_out, "(a,i0,2(a,f5.2),a,i0)") &
2675 : "SVD: Need ", icomp, " vectors with frac: ", (100.0_dp * icomp) / size(s_vals), &
2676 : "% to reach eratio: ", eratio, ", G matrix size: ", size(s_vals)
2677 : ABI_FREE(s_vals)
2678 : end if
2679 :
2680 : ! Redistribute data.
2681 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%take_from(green)
2682 : end do ! iab
2683 0 : call slk_array_free(work_gb)
2684 :
2685 : end do ! ipm
2686 : end do ! my_it
2687 :
2688 0 : call green%free()
2689 : ! Free wavefunctions if asked for.
2690 0 : if (free_ugb) call ugb_ks%free()
2691 :
2692 0 : if (print_time) then
2693 0 : write(msg,'(4x,3(a,i0),a)')"G_ikbz [", my_iki, "/", gwr%my_nkibz, "] (tot: ", gwr%nkibz, ")"
2694 0 : call cwtime_report(msg, cpu_k, wall_k, gflops_k); if (my_iki == LOG_MODK) call wrtout(std_out, " ...")
2695 : end if
2696 : end associate
2697 : end do ! my_iki
2698 : end do ! my_is
2699 :
2700 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "gt_kibz")
2701 0 : call gwr%print_mem([std_out])
2702 :
2703 0 : call cwtime_report(" gwr_build_green:", cpu, wall, gflops)
2704 0 : call timab(1922, 2, tsec)
2705 :
2706 : !if (compute_svd) stop "compute_svd"
2707 :
2708 0 : end subroutine gwr_build_green
2709 : !!***
2710 :
2711 : !----------------------------------------------------------------------
2712 :
2713 : !!****f* m_gwr/gwr_gk_to_scbox
2714 : !! NAME
2715 : !! gwr_gk_to_scbox
2716 : !!
2717 : !! FUNCTION
2718 : !! Insert G_k(g',r) in the FFT box of the supercell: k+g' index.
2719 : !!
2720 : !! INPUTS
2721 : !! select_my_kbz: Mask used to select a subset of gwr%my_nkbz k-points.
2722 : !!
2723 : !! OUTPUT
2724 : !!
2725 : !! SOURCE
2726 :
2727 0 : subroutine gwr_gk_to_scbox(gwr, sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr, gt_scbox, gt_scbox_win)
2728 :
2729 : !Arguments ------------------------------------
2730 : class(gwr_t),target,intent(in) :: gwr
2731 : integer,intent(in) :: sc_ngfft(18)
2732 : logical,intent(in) :: select_my_kbz(gwr%my_nkbz)
2733 : integer,intent(out) :: green_scgvec(3, gwr%green_mpw)
2734 : type(desc_t),intent(inout) :: desc_mykbz(gwr%my_nkbz)
2735 : type(__slkmat_t),intent(in) :: gt_gpr(2, gwr%my_nkbz)
2736 : integer,intent(in) :: my_ir, ndat
2737 : complex(gwp), intent(out) :: gt_scbox(product(sc_ngfft(4:6)), gwr%sc_batch_size, 2)
2738 : integer,optional,intent(inout) :: gt_scbox_win
2739 :
2740 : !Local variables-------------------------------
2741 0 : integer :: my_ikf, ik_bz, ipm, gg(3), idat, iepoch, ii, idat_list(gwr%kpt_comm%nproc), ierr ! ig,
2742 : !real(dp) :: tsec(2) !, cpu, wall, gflops
2743 : ! *************************************************************************
2744 :
2745 : !call cwtime(cpu, wall, gflops, "start")
2746 : !call timab(1929, 1, tsec)
2747 :
2748 : ! Take the union of (k,g') for k in the BZ.
2749 : ! Note gwr%ngkpt instead of gwr%ngqpt.
2750 0 : if (.not. present(gt_scbox_win)) then
2751 : ! Zero output array.
2752 0 : gt_scbox = czero_gw
2753 :
2754 0 : do my_ikf=1,gwr%my_nkbz
2755 : if (.not. select_my_kbz(my_ikf)) continue
2756 0 : ik_bz = gwr%my_kbz_inds(my_ikf); gg = nint(gwr%kbz(:,ik_bz) * gwr%ngkpt)
2757 0 : do ipm=1,2
2758 : call desc_mykbz(my_ikf)%to_scbox(gwr%kbz(:, ik_bz), gwr%ngkpt, sc_ngfft, ndat, &
2759 0 : gt_gpr(ipm, my_ikf)%buffer_cplx(1,my_ir), gt_scbox(:,:,ipm))
2760 : end do
2761 : end do ! my_ikf
2762 :
2763 : else
2764 : ! Each MPI proc operates on a different idat vector at each epoch
2765 0 : idat_list = cshift([(ii, ii=1,gwr%kpt_comm%nproc)], shift=-gwr%kpt_comm%me)
2766 :
2767 0 : do iepoch=1,gwr%kpt_comm%nproc
2768 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! Start the RMA epoch
2769 0 : idat = idat_list(iepoch)
2770 0 : if (idat > ndat) goto 10
2771 0 : if (iepoch == 1) then
2772 : ! Zero output array.
2773 0 : do ipm=1,2
2774 0 : gt_scbox(:,idat,ipm) = czero_gw
2775 : end do
2776 : end if
2777 :
2778 0 : do my_ikf=1,gwr%my_nkbz
2779 : if (.not. select_my_kbz(my_ikf)) continue
2780 0 : ik_bz = gwr%my_kbz_inds(my_ikf); gg = nint(gwr%kbz(:, ik_bz) * gwr%ngkpt)
2781 0 : do ipm=1,2
2782 : call desc_mykbz(my_ikf)%to_scbox(gwr%kbz(:, ik_bz), gwr%ngkpt, sc_ngfft, ndat1, &
2783 0 : gt_gpr(ipm, my_ikf)%buffer_cplx(1,my_ir+idat-1), gt_scbox(:,idat,ipm))
2784 : end do
2785 : end do ! my_ikf
2786 : 10 continue
2787 : !call xmpi_barrier(gwr%kpt_comm%value)
2788 : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
2789 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! End the RMA epoch
2790 : end do ! iepoch
2791 : end if
2792 :
2793 : !call cwtime_report(" gwr_gk_to_scbox:", cpu, wall, gflops)
2794 : !call timab(1929, 2, tsec)
2795 :
2796 0 : end subroutine gwr_gk_to_scbox
2797 : !!***
2798 :
2799 : !----------------------------------------------------------------------
2800 :
2801 : !!****f* m_gwr/gwr_wcq_to_scbox
2802 : !! NAME
2803 : !! gwr_wcq_to_scbox
2804 : !!
2805 : !! FUNCTION
2806 : !! Insert W_q(g',r) in the FFT box of the supercell: q+g' index.
2807 : !!
2808 : !! INPUTS
2809 : !! select_my_qbz: Mask used to select a subset of gwr%my_qkbz q-points.
2810 : !!
2811 : !! OUTPUT
2812 : !!
2813 : !! SOURCE
2814 :
2815 0 : subroutine gwr_wcq_to_scbox(gwr, sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, &
2816 0 : wc_gpr, wct_scbox, wct_scbox_win)
2817 :
2818 : !Arguments ------------------------------------
2819 : class(gwr_t),target,intent(in) :: gwr
2820 : integer,intent(in) :: sc_ngfft(18)
2821 : logical,intent(in) :: select_my_qbz(gwr%my_nqbz)
2822 : integer,intent(out) :: wc_scgvec(3, gwr%tchi_mpw)
2823 : type(desc_t),intent(inout) :: desc_myqbz(gwr%my_nqbz)
2824 : type(__slkmat_t),intent(in) :: wc_gpr(gwr%my_nqbz)
2825 : integer,intent(in) :: my_ir, ndat
2826 : complex(gwp),intent(out) :: wct_scbox(product(sc_ngfft(4:6)), gwr%sc_batch_size)
2827 : !complex(gwp),intent(out) :: wct_scbox(:,:)
2828 : integer,optional,intent(inout) :: wct_scbox_win
2829 :
2830 : !Local variables-------------------------------
2831 0 : integer :: my_iqf, iq_bz, idat, iepoch, ii, idat_list(gwr%kpt_comm%nproc), ierr ! gg(3), ig,
2832 : !real(dp) :: tsec(2) !, cpu, wall, gflops
2833 : ! *************************************************************************
2834 :
2835 : !call timab(1930, 1, tsec)
2836 :
2837 : ! Take the union of (q,g') for q in the BZ. Note gwr%ngqpt instead of gwr%ngkpt.
2838 :
2839 0 : if (.not. present(wct_scbox_win)) then
2840 0 : wct_scbox = czero_gw
2841 0 : do my_iqf=1,gwr%my_nqbz
2842 : if (.not. select_my_qbz(my_iqf)) continue
2843 0 : iq_bz = gwr%my_qbz_inds(my_iqf)
2844 :
2845 : call desc_myqbz(my_iqf)%to_scbox(gwr%qbz(:,iq_bz), gwr%ngqpt, sc_ngfft, ndat, &
2846 0 : wc_gpr(my_iqf)%buffer_cplx(1,my_ir), wct_scbox)
2847 : end do ! my_iqf
2848 :
2849 : else
2850 : ! Each MPI proc operates on a different idat vector at each epoch
2851 0 : idat_list = cshift([(ii, ii=1,gwr%kpt_comm%nproc)], shift=-gwr%kpt_comm%me)
2852 :
2853 0 : do iepoch=1,gwr%kpt_comm%nproc
2854 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, wct_scbox_win, ierr) ! Start the RMA epoch
2855 0 : idat = idat_list(iepoch)
2856 0 : if (idat > ndat) goto 10
2857 0 : if (iepoch == 1) wct_scbox(:,idat) = czero_gw
2858 :
2859 0 : do my_iqf=1,gwr%my_nkbz
2860 : if (.not. select_my_qbz(my_iqf)) continue
2861 0 : iq_bz = gwr%my_qbz_inds(my_iqf)
2862 : call desc_myqbz(my_iqf)%to_scbox(gwr%qbz(:,iq_bz), gwr%ngqpt, sc_ngfft, ndat1, &
2863 0 : wc_gpr(my_iqf)%buffer_cplx(1,my_ir+idat-1), wct_scbox(:,idat))
2864 : end do ! my_iqf
2865 : 10 continue
2866 : !call xmpi_barrier(gwr%kpt_comm%value)
2867 : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(wct_scbox)
2868 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, wct_scbox_win, ierr) ! End the RMA epoch
2869 : end do ! iepoch
2870 : end if
2871 :
2872 : !call timab(1930, 2, tsec)
2873 :
2874 0 : end subroutine gwr_wcq_to_scbox
2875 : !!***
2876 :
2877 : !----------------------------------------------------------------------
2878 :
2879 : !!****f* m_gwr/gwr_rotate_gpm
2880 : !! NAME
2881 : !! gwr_rotate_gpm
2882 : !!
2883 : !! FUNCTION
2884 : !! Reconstruct the Green's functions in the BZ from the IBZ.
2885 : !!
2886 : !! INPUTS
2887 : !! ik_bz = Index of the k-point in the BZ
2888 : !! itau = tau index (global index)
2889 : !! spin = spin index (global index)
2890 : !! [ipm_list]=Optional list of ipm indices to be considered, e.g. ipm_list=[2] to compute the -tau component.
2891 : !!
2892 : !! OUTPUT
2893 : !! desc_kbz = Descriptor in the BZ
2894 : !! gt_pm(2) = Gk(+/-tau)
2895 : !!
2896 : !! NOTES
2897 : !!
2898 : !! * Remember the symmetry properties of \tilde\espilon^{-1}
2899 : !!
2900 : !! If q_bz = S q_ibz + G0:
2901 : !!
2902 : !! $\epsilon^{-1}_{SG1-G0, SG2-G0}(q_bz) = e^{+iS(G2-G1).\tau} \epsilon^{-1}_{G1, G2)}(q)
2903 : !!
2904 : !! If time-reversal symmetry can be used then:
2905 : !!
2906 : !! $\epsilon^{-1}_{G1,G2}(-q_bz) = e^{+i(G1-G2).\tau} \epsilon^{-1}_{-S^{-1}(G1+Go), -S^{-1}(G2+G0)}^*(q)
2907 : !!
2908 : !! In the present implementation we are not considering a possible umklapp vector G0 in the
2909 : !! expression Sq = q+G0. Treating this case would require some changes in the G-sphere
2910 : !! since we have to consider G - G0. The code however stops in sigma if a nonzero G0 is required
2911 : !! to reconstruct the BZ.
2912 : !!
2913 : !! SOURCE
2914 :
2915 0 : subroutine gwr_rotate_gpm(gwr, ik_bz, itau, spin, desc_kbz, gt_pm, ipm_list)
2916 :
2917 : !Arguments ------------------------------------
2918 : class(gwr_t),intent(in) :: gwr
2919 : integer,intent(in) :: ik_bz, spin, itau
2920 : type(desc_t),intent(out) :: desc_kbz
2921 : type(__slkmat_t),intent(out) :: gt_pm(2, gwr%nsig_ab)
2922 : integer,optional,intent(in) :: ipm_list(:)
2923 :
2924 : !Local variables-------------------------------
2925 : !scalars
2926 : integer :: ig1, ig2, il_g1, il_g2, ipm, ik_ibz, isym_k, trev_k, g0_k(3), tsign_k, ii, num_pm, ipm_list__(2)
2927 : integer :: iab, iiab, jiab
2928 : logical :: isirr_k
2929 : !arrays
2930 : integer :: g1(3), g2(3)
2931 : real(dp) :: tnon(3), spinrot_k(4) !, cpu, wall, gflops
2932 : complex(dp) :: ph2, ph1, spinrot_cmat1(2,2), spinrot_cmat2(2,2), tmp_mat(2,2)
2933 : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
2934 : ! *************************************************************************
2935 :
2936 : !call cwtime(cpu, wall, gflops, "start")
2937 0 : num_pm = 2; ipm_list__ = [1, 2]
2938 0 : if (present(ipm_list)) then
2939 0 : num_pm = size(ipm_list)
2940 0 : ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
2941 0 : ipm_list__(1:num_pm) = ipm_list(:)
2942 : end if
2943 :
2944 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
2945 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
2946 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2947 0 : tsign_k = merge(1, -1, trev_k == 0)
2948 : !ABI_CHECK(all(g0_k == 0), sjoin("For kbz:", ktoa(gwr%kbz(:, ik_bz)), "g0_k:", ltoa(g0_k), " != 0"))
2949 :
2950 : ! Copy descriptor from IBZ
2951 : associate (desc_kibz => gwr%green_desc_kibz(ik_ibz))
2952 0 : call desc_kibz%copy(desc_kbz)
2953 :
2954 0 : if (isirr_k) then
2955 : ! Copy the PBLAS matrices with the two Green's functions and we are done.
2956 0 : do ii=1,num_pm
2957 0 : ipm = ipm_list__(ii)
2958 0 : do iab=1,gwr%nsig_ab
2959 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%copy(gt_pm(ipm, iab))
2960 : end do
2961 : end do
2962 : goto 10
2963 : end if
2964 :
2965 : ! From:
2966 : !
2967 : ! u_{Sk}(Sg) = e^{-i(Sk+Sg).tnon} u_k(g)
2968 : !
2969 : ! and
2970 : !
2971 : ! u_{k+g0}(g-g0) = u_k(g)
2972 : !
2973 : ! one obtains:
2974 : !
2975 : ! G_{Sk+g0}(Sg-g0,Sg'-g0) = e^{-i tnon.S(g-g')} G_k{g,g'}
2976 : !
2977 : ! For time-reversal, we have u_{-k}(g) = u_{k}{-g}^*
2978 : !
2979 : ! G_{-k}(-g,-g') = [G_k(g,g')]*
2980 :
2981 : !ABI_WARNING_IF(trev_k == 0, "green: trev_k /= 0 should be tested")
2982 :
2983 : ! Rotate gvec, recompute gbound and rotate vc_sqrt_eps
2984 : ! TODO: 1) Handle TR and routine to rotate tchi/W including vc_sqrt_eps
2985 : ! 2) Make sure that the FFT box is large enough to accommodate umklapps
2986 :
2987 0 : desc_kbz%ig0 = -1
2988 : !$OMP PARALLEL DO
2989 0 : do ig1=1,desc_kbz%npw
2990 0 : desc_kbz%gvec(:,ig1) = tsign_k * matmul(gwr%cryst%symrec(:,:,isym_k), desc_kibz%gvec(:,ig1)) - g0_k
2991 0 : if (all(desc_kbz%gvec(:,ig1) == 0)) desc_kbz%ig0 = ig1
2992 : end do
2993 0 : desc_kbz%kin_sorted = .False.
2994 0 : ABI_CHECK(desc_kbz%ig0 /= -1, "Cannot find g=0 after rotation!")
2995 :
2996 0 : call sphereboundary(desc_kbz%gbound, desc_kbz%istwfk, desc_kbz%gvec, gwr%g_mgfft, desc_kbz%npw)
2997 :
2998 : ! Get G_k with k in the BZ.
2999 0 : tnon = gwr%cryst%tnons(:, isym_k)
3000 0 : do ii=1,num_pm
3001 0 : ipm = ipm_list__(ii)
3002 0 : do iab=1,gwr%nsig_ab
3003 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%copy(gt_pm(ipm, iab))
3004 : end do
3005 : ! associate (gk_i => gwr%gt_kibz(ipm, ik_ibz, itau, spin, :), gk_f => gt_pm(ipm, :))
3006 : !!$OMP PARALLEL DO PRIVATE(ig1, g2, ph2, ig1, g2, ph1)
3007 0 : do il_g2=1, gt_pm(ipm, 1)%size_local(2)
3008 0 : ig2 = mod(gt_pm(ipm, 1)%loc2gcol(il_g2) - 1, desc_kbz%npw) + 1
3009 0 : g2 = desc_kbz%gvec(:,ig2)
3010 0 : ph2 = exp(+j_dpc * two_pi * dot_product(g2, tnon))
3011 0 : do il_g1=1, gt_pm(ipm, 1)%size_local(1)
3012 0 : ig1 = mod(gt_pm(ipm, 1)%loc2grow(il_g1) - 1, desc_kbz%npw) + 1
3013 0 : g1 = desc_kbz%gvec(:,ig1)
3014 0 : ph1 = exp(-j_dpc * two_pi * dot_product(g1, tnon))
3015 0 : if (gwr%nspinor == 1) then
3016 0 : gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2) = gwr%gt_kibz(ipm, ik_ibz, itau, spin, 1)%buffer_cplx(il_g1, il_g2) * ph1 * ph2
3017 : else
3018 0 : spinrot_k = gwr%cryst%spinrot(:, isym_k)
3019 :
3020 0 : spinrot_cmat1(1,1) = spinrot_k(1) - j_dpc*spinrot_k(4)
3021 0 : spinrot_cmat1(1,2) =-spinrot_k(3) - j_dpc*spinrot_k(2)
3022 0 : spinrot_cmat1(2,1) = spinrot_k(3) - j_dpc*spinrot_k(2)
3023 0 : spinrot_cmat1(2,2) = spinrot_k(1) + j_dpc*spinrot_k(4)
3024 :
3025 0 : spinrot_cmat2(1,1) = spinrot_k(1) + j_dpc*spinrot_k(4)
3026 0 : spinrot_cmat2(1,2) = spinrot_k(3) + j_dpc*spinrot_k(2)
3027 0 : spinrot_cmat2(2,1) =-spinrot_k(3) + j_dpc*spinrot_k(2)
3028 0 : spinrot_cmat2(2,2) = spinrot_k(1) - j_dpc*spinrot_k(4)
3029 :
3030 0 : do iab=1,gwr%nsig_ab
3031 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
3032 0 : tmp_mat(iiab, jiab) = gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%buffer_cplx(il_g1, il_g2)
3033 : end do
3034 0 : tmp_mat = matmul(spinrot_cmat1, matmul(tmp_mat, spinrot_cmat2)) * ph1 * ph2
3035 0 : do iab=1,gwr%nsig_ab
3036 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
3037 0 : gt_pm(ipm, iab)%buffer_cplx(il_g1, il_g2) = tmp_mat(iiab, jiab)
3038 : end do
3039 : end if
3040 0 : if (trev_k == 1) then
3041 0 : if (gwr%nspinor == 1) then
3042 0 : gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2) = conjg(gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2))
3043 : else
3044 0 : gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2) = conjg(tmp_mat(2, 2))
3045 0 : gt_pm(ipm, 2)%buffer_cplx(il_g1, il_g2) = conjg(tmp_mat(1, 1))
3046 0 : gt_pm(ipm, 3)%buffer_cplx(il_g1, il_g2) = - conjg(tmp_mat(2, 1))
3047 0 : gt_pm(ipm, 4)%buffer_cplx(il_g1, il_g2) = - conjg(tmp_mat(1, 2))
3048 : end if
3049 : end if
3050 : end do
3051 : end do
3052 : ! end associate
3053 : end do ! ii
3054 : end associate
3055 :
3056 : 10 continue
3057 : !call cwtime_report(" gwr_rotate_gpm:", cpu, wall, gflops)
3058 :
3059 0 : end subroutine gwr_rotate_gpm
3060 : !!***
3061 :
3062 : !----------------------------------------------------------------------
3063 :
3064 : !!****f* m_gwr/gwr_get_myk_green_gpr
3065 : !! NAME
3066 : !! gwr_get_myk_green_gpr
3067 : !!
3068 : !! FUNCTION
3069 : !! Use FFTs to compute G_k(g,g') --> G_k(g',r) for each k in the BZ treated by this MPI proc for given spin and tau.
3070 : !!
3071 : !! 1) FFT Transform the first index and multiply by e^{ik.r}:
3072 : !!
3073 : !! G_k(g,g') --> G_k(r,g') = e^{ik.r} \sum_g e^{ig.r} G_k(g,g')
3074 : !!
3075 : !! NB: This is a local operation.
3076 : !!
3077 : !! 2) MPI transpose the matrix to go from (r,g') to (g',r) distribution.
3078 : !!
3079 : !! INPUTS
3080 : !! select_my_kbz: Mask used to select a subset of gwr%my_nkbz k-points.
3081 : !!
3082 : !! OUTPUT
3083 : !!
3084 : !! SOURCE
3085 :
3086 0 : subroutine gwr_get_myk_green_gpr(gwr, itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
3087 :
3088 : !Arguments ------------------------------------
3089 : class(gwr_t),intent(in) :: gwr
3090 : integer,intent(in) :: itau, spin
3091 : logical,intent(in) :: select_my_kbz(gwr%my_nkbz)
3092 : type(desc_t),intent(out) :: desc_mykbz(gwr%my_nkbz)
3093 : type(__slkmat_t),intent(inout) :: gt_gpr(2, gwr%my_nkbz, gwr%nsig_ab)
3094 :
3095 : !Local variables-------------------------------
3096 : !scalars
3097 : integer :: my_ikf, ik_bz, ig2, ipm, npw, col_bsize, ndat, gpu_option, gpu_mode, iab
3098 : logical :: k_is_gamma
3099 : real(dp) :: kk_bz(3), cpu, wall, gflops, mem_mb
3100 0 : complex(gwp),allocatable :: ceikr(:)
3101 : character(len=500) :: msg, gpu_action
3102 0 : type(__slkmat_t) :: rgp, gt_pm(2, gwr%nsig_ab)
3103 0 : type(uplan_t) :: uplan_k
3104 : ! *************************************************************************
3105 :
3106 0 : call cwtime(cpu, wall, gflops, "start")
3107 0 : gpu_option = gwr%dtset%gpu_option
3108 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3109 :
3110 0 : mem_mb = two * gwr%my_nkbz * two * gwp * gwr%g_nfft * gwr%green_mpw * b2Mb / gwr%g_slkproc%grid%nprocs
3111 0 : call wrtout(std_out, sjoin(" Estimated local memory for Green's functions: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
3112 :
3113 0 : ABI_MALLOC(ceikr, (gwr%g_nfft))
3114 : #ifdef HAVE_OPENMP_OFFLOAD
3115 : !$OMP TARGET ENTER DATA MAP(alloc:ceikr) IF (gpu_option == ABI_GPU_OPENMP)
3116 : #endif
3117 :
3118 0 : do my_ikf=1,gwr%my_nkbz
3119 : if (.not. select_my_kbz(my_ikf)) continue
3120 0 : ik_bz = gwr%my_kbz_inds(my_ikf)
3121 0 : kk_bz = gwr%kbz(:, ik_bz)
3122 0 : k_is_gamma = normv(kk_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3123 0 : if (.not. k_is_gamma) then
3124 0 : call calc_ceikr(kk_bz, gwr%g_ngfft, gwr%g_nfft, 1, ceikr)
3125 : #ifdef HAVE_OPENMP_OFFLOAD
3126 : !$omp target update to(ceikr) if (gpu_option == ABI_GPU_OPENMP)
3127 : #endif
3128 : end if
3129 :
3130 : ! Get G_kbz(+/- itau) in the BZ.
3131 0 : call gwr%rotate_gpm(ik_bz, itau, spin, desc_mykbz(my_ikf), gt_pm)
3132 :
3133 0 : associate (desc_k => desc_mykbz(my_ikf))
3134 : call uplan_k%init(desc_k%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_k%istwfk, &
3135 0 : desc_k%gvec, gwp, gpu_option)
3136 :
3137 0 : do ipm=1,2
3138 0 : do iab=1,gwr%nsig_ab
3139 : ! Allocate rgp PBLAS matrix to store G_kbz(r,g')
3140 : ! Here we're gonna have a lot of memory allocated due to loop over the full BZ!.
3141 0 : associate (g_gp => gt_pm(ipm, iab))
3142 0 : npw = desc_k%npw
3143 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3144 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_k%istwfk, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
3145 :
3146 : ! Perform FFT G_k(g,g') -> G_k(r,g') and store results in rgp.
3147 0 : gpu_mode = 1
3148 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
3149 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3150 0 : if (k_is_gamma) then
3151 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), gpu_mode=gpu_mode)
3152 : else
3153 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), phase_r=ceikr, gpu_mode=gpu_mode)
3154 : end if
3155 : end do ! ig2
3156 :
3157 : ! MPI transpose: G_k(r,g') -> G_k(g',r)
3158 0 : call rgp%ptrans("N", gt_gpr(ipm, my_ikf, iab), free=.True.)
3159 : end associate
3160 : end do ! iab
3161 : end do ! ipm
3162 :
3163 0 : call uplan_k%free(); call slk_array_free(gt_pm)
3164 : end associate
3165 : end do ! my_ikf
3166 :
3167 0 : mem_mb = sum(slk_array_locmem_mb(gt_gpr))
3168 0 : call wrtout(std_out, sjoin(" Local memory for G_kbz(g',r,itau): ", ftoa(mem_mb, fmt="f8.1"), "[Mb] <<< MEM"))
3169 :
3170 : #ifdef HAVE_OPENMP_OFFLOAD
3171 : !$OMP TARGET EXIT DATA MAP(delete: ceikr) if (gpu_option == ABI_GPU_OPENMP)
3172 : #endif
3173 0 : ABI_FREE(ceikr)
3174 :
3175 0 : call cwtime_report(" gwr_get_myk_green_gpr:", cpu, wall, gflops)
3176 :
3177 0 : end subroutine gwr_get_myk_green_gpr
3178 : !!***
3179 :
3180 : !----------------------------------------------------------------------
3181 :
3182 : !!****f* m_gwr/gwr_get_gkbz_rpr_pm
3183 : !! NAME
3184 : !! gwr_get_gkbz_rpr_pm
3185 : !!
3186 : !! FUNCTION
3187 : !! Compute G_k(r',r) from G_k(g,g') for k in the BZ and given spin and tau.
3188 : !! Note that the output matrix `gk_rpr_pm` is transposed i.e. (r',r) instead of (r,r').
3189 : !!
3190 : !! INPUTS
3191 : !!
3192 : !! OUTPUT
3193 : !!
3194 : !! SOURCE
3195 :
3196 0 : subroutine gwr_get_gkbz_rpr_pm(gwr, ik_bz, itau, spin, gk_rpr_pm, &
3197 0 : g0, ipm_list) ! optional
3198 :
3199 : !Arguments ------------------------------------
3200 : class(gwr_t),intent(in) :: gwr
3201 : integer,intent(in) :: ik_bz, itau, spin
3202 : type(__slkmat_t),intent(inout) :: gk_rpr_pm(2, gwr%nsig_ab)
3203 : integer,optional,intent(in) :: g0(3), ipm_list(:)
3204 :
3205 : !Local variables-------------------------------
3206 : !scalars
3207 : integer :: ig2, ipm, npw, col_bsize, ir1, ndat, ii, num_pm, ipm_list__(2), gpu_option, gpu_mode, iab
3208 : logical :: have_g0
3209 : !real(dp) :: cpu, wall, gflops
3210 0 : type(__slkmat_t) :: rgp, gt_pm(2, gwr%nsig_ab), gpr
3211 0 : type(desc_t) :: desc_kbz
3212 0 : type(uplan_t) :: uplan_k
3213 0 : complex(gwp),allocatable :: ceig0r(:), conjg_ceig0r(:)
3214 : character(len=500) :: msg, gpu_action
3215 : ! *************************************************************************
3216 :
3217 : !call cwtime(cpu, wall, gflops, "start")
3218 : ABI_NVTX_START_RANGE(NVTX_GWR_GKBZ_RPR_PM)
3219 :
3220 0 : gpu_option = gwr%dtset%gpu_option
3221 :
3222 0 : num_pm = 2; ipm_list__ = [1, 2]
3223 0 : if (present(ipm_list)) then
3224 0 : num_pm = size(ipm_list)
3225 0 : ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
3226 0 : ipm_list__(1:num_pm) = ipm_list
3227 : end if
3228 :
3229 0 : have_g0 = .False.
3230 0 : if (present(g0)) then
3231 : ! NB: Non-zero g0, requires the application of the phase.
3232 0 : if (any(g0 /= 0)) then
3233 0 : have_g0 = .True.
3234 0 : ABI_MALLOC(ceig0r, (gwr%g_nfft))
3235 0 : call calc_ceigr(-g0, gwr%g_nfft, 1, gwr%g_ngfft, ceig0r)
3236 0 : ABI_MALLOC(conjg_ceig0r, (gwr%g_nfft))
3237 0 : conjg_ceig0r = conjg(ceig0r)
3238 : #ifdef HAVE_OPENMP_OFFLOAD
3239 : !$OMP TARGET ENTER DATA MAP(alloc:ceig0r, conjg_ceig0r) IF (gpu_option == ABI_GPU_OPENMP)
3240 : !$omp target update to(ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3241 : #endif
3242 : end if
3243 : end if
3244 :
3245 : ! Get G_k(g,g', +/- itau) in the BZ.
3246 0 : call gwr%rotate_gpm(ik_bz, itau, spin, desc_kbz, gt_pm, ipm_list=ipm_list__(1:num_pm))
3247 :
3248 : call uplan_k%init(desc_kbz%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_kbz%istwfk, &
3249 0 : desc_kbz%gvec, gwp, gpu_option)
3250 :
3251 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3252 :
3253 : ! For each tau in imp_list__
3254 0 : do ii=1,num_pm
3255 0 : ipm = ipm_list__(ii)
3256 : ! Allocate temporary rgp PBLAS matrix to store G(r,g')
3257 0 : npw = desc_kbz%npw
3258 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3259 0 : do iab=1,gwr%nsig_ab
3260 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_kbz%istwfk, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
3261 : associate (g_gp => gt_pm(ipm, iab))
3262 0 : gpu_mode = 1
3263 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
3264 : ! G_k(g,g') -> G_k(r,g') and store results in rgp.
3265 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3266 0 : if (have_g0) then
3267 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), phase_r=ceig0r, gpu_mode=gpu_mode)
3268 : else
3269 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), gpu_mode=gpu_mode)
3270 : end if
3271 : end do ! ig2
3272 : end associate
3273 :
3274 : ! MPI transpose: G_k(r,g') -> G_k(g',r) and transform g' index.
3275 0 : call rgp%ptrans("N", gpr, free=.True.)
3276 :
3277 : gpu_mode = 1
3278 0 : do ir1=1, gpr%size_local(2), gwr%uc_batch_size
3279 : ! G_k(g',r) -> G_k(r',r) and store results in rgp.
3280 0 : ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3281 0 : if (have_g0) then
3282 : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), gk_rpr_pm(ipm, iab)%buffer_cplx(:,ir1), &
3283 0 : isign=-1, iscale=0, phase_r=conjg_ceig0r, gpu_mode=gpu_mode)
3284 : else
3285 : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), gk_rpr_pm(ipm, iab)%buffer_cplx(:,ir1), &
3286 0 : isign=-1, iscale=0, gpu_mode=gpu_mode)
3287 : end if
3288 : end do ! ir1
3289 0 : call gpr%free()
3290 : end do
3291 : end do ! ii
3292 :
3293 0 : call slk_array_free(gt_pm); call desc_kbz%free(); call uplan_k%free()
3294 :
3295 0 : if (have_g0) then
3296 : #ifdef HAVE_OPENMP_OFFLOAD
3297 : !$OMP TARGET EXIT DATA MAP(delete: ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3298 : #endif
3299 0 : ABI_FREE(ceig0r)
3300 0 : ABI_FREE(conjg_ceig0r)
3301 : end if
3302 :
3303 : ! FIXME: Transfer data from CPU to GPU.
3304 0 : if (gpu_option == ABI_GPU_OPENMP) then
3305 0 : do ii=1,num_pm
3306 0 : ipm = ipm_list__(ii)
3307 0 : do iab=1,gwr%nsig_ab
3308 0 : call gk_rpr_pm(ipm, iab)%gpu_map("update_to")
3309 : end do
3310 : end do
3311 : end if
3312 :
3313 : ABI_NVTX_END_RANGE()
3314 : !call cwtime_report(" gwr_get_gkbz_rpr_pm:", cpu, wall, gflops)
3315 :
3316 0 : end subroutine gwr_get_gkbz_rpr_pm
3317 : !!***
3318 :
3319 : !----------------------------------------------------------------------
3320 :
3321 : !! !!****f* m_gwr/gwr_ggp_to_rpr
3322 : !! !! NAME
3323 : !! !! gwr_ggp_to_rpr
3324 : !! !!
3325 : !! !! FUNCTION
3326 : !! !! Helper function to FFT transform a two-point function: F_{g,g'} --> F_{r',r}
3327 : !! !!
3328 : !! !! INPUTS
3329 : !! !!
3330 : !! !! OUTPUT
3331 : !! !!
3332 : !! !! SOURCE
3333 : !!
3334 : !! !subroutine gwr_ggp_to_rpr(gwr, desc, g_gp, rp_r)
3335 : !! !
3336 : !! !!Arguments ------------------------------------
3337 : !! ! class(gwr_t),intent(in) :: gwr
3338 : !! ! type(desc_t),intent(in) :: desc
3339 : !! ! type(__slkmat_t),intent(in) :: g_gp
3340 : !! ! type(__slkmat_t),intent(inout) :: rp_r
3341 : !! !
3342 : !! !!Local variables-------------------------------
3343 : !! ! integer :: ig2, npw, nrsp, col_bsize, ir1, ndat
3344 : !! ! type(__slkmat_t) :: rgp, gpr
3345 : !! ! character(len=500) :: msg
3346 : !! ! type(uplan_t) :: uplan_k
3347 : !! !! *************************************************************************
3348 : !! !
3349 : !! ! ABI_ERROR("Not Implemented Error")
3350 : !! !
3351 : !! ! ! Allocate intermediate rgp PBLAS matrix to store F(r,g')
3352 : !! ! npw = desc%npw
3353 : !! ! nrsp = gwr%g_nfft * gwr%nspinor
3354 : !! ! ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3355 : !! ! call rgp%init(nrsp, npw, gwr%g_slkproc, desc%istwfk, size_blocs=[-1, col_bsize])
3356 : !! !
3357 : !! ! call uplan_k%init(desc%npw, gwr%nspinor, gwr%uc_batch_size, gwr%g_ngfft, desc%istwfk, &
3358 : !! ! desc%gvec, gwp, gwr%dtset%gpu_option)
3359 : !! !
3360 : !! ! ! F(g,g') --> F(r,g') and store results in rgp.
3361 : !! ! do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
3362 : !! ! ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3363 : !! ! call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2))
3364 : !! ! end do
3365 : !! !
3366 : !! ! ! F(r,g') --> F(g',r)
3367 : !! ! call rgp%ptrans("N", gpr, free=.True.)
3368 : !! !
3369 : !! ! ! F(g',r) --> F(r',r) and store results in rp_r.
3370 : !! ! do ir1=1, gpr%size_local(2), gwr%uc_batch_size
3371 : !! ! ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3372 : !! ! call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), rp_r%buffer_cplx(:,ir1), isign=-1, iscale=0)
3373 : !! ! end do
3374 : !! !
3375 : !! ! call uplan_k%free()
3376 : !! ! call gpr%free()
3377 : !! !
3378 : !! !end subroutine gwr_ggp_to_rpr
3379 : !! !!!***
3380 :
3381 : !----------------------------------------------------------------------
3382 :
3383 : !!****f* m_gwr/gwr_rpr_to_ggp
3384 : !! NAME
3385 : !! gwr_rpr_to_ggp
3386 : !!
3387 : !! FUNCTION
3388 : !! Helper function to FFT a two-point function: F_{r',r} --> F_{g,g'}
3389 : !! Note that rp_r is destroyed in output.
3390 : !!
3391 : !! INPUTS
3392 : !!
3393 : !! OUTPUT
3394 : !!
3395 : !! SOURCE
3396 :
3397 0 : subroutine gwr_rpr_to_ggp(gwr, desc, rp_r, rfact, g_gp)
3398 :
3399 : !Arguments ------------------------------------
3400 : class(gwr_t),intent(in) :: gwr
3401 : type(desc_t),intent(in) :: desc
3402 : real(dp),intent(in) :: rfact
3403 : class(__slkmat_t),intent(inout) :: rp_r, g_gp
3404 :
3405 : !Local variables-------------------------------
3406 : integer :: ig2, npw, nr, col_bsize, ir2, ndat, isign, gpu_option, gpu_mode
3407 0 : type(__slkmat_t) :: r_gp, gp_r
3408 : character(len=500) :: msg, gpu_action
3409 0 : type(uplan_t) :: uplan_k
3410 : ! *************************************************************************
3411 :
3412 : ABI_NVTX_START_RANGE(NVTX_GWR_RPR_TO_GGP)
3413 :
3414 : ! Allocate intermediate gp_r PBLAS matrix to store F(g',r)
3415 0 : npw = desc%npw; nr = gwr%g_nfft
3416 0 : ABI_CHECK(block_dist_1d(nr, gwr%g_comm%nproc, col_bsize, msg), msg)
3417 :
3418 0 : gpu_option = gwr%dtset%gpu_option
3419 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3420 0 : call gp_r%init(npw, nr, gwr%g_slkproc, desc%istwfk, size_blocs=[-1, col_bsize])
3421 :
3422 : call uplan_k%init(desc%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc%istwfk, desc%gvec, gwp, &
3423 0 : 0)
3424 : !gwr%dtset%gpu_option) ! FIXME GPU option
3425 :
3426 0 : isign = +1 ! This should be ok
3427 : !isign = -1
3428 :
3429 0 : if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) call rp_r%gpu_map("update_from") ! FIXME
3430 :
3431 : ! F(r',r) --> F(g',r) and store results in gp_r.
3432 0 : gpu_mode = 1
3433 0 : do ir2=1, rp_r%size_local(2), gwr%uc_batch_size
3434 0 : ndat = blocked_loop(ir2, rp_r%size_local(2), gwr%uc_batch_size)
3435 : call uplan_k%execute_rg(ndat, rp_r%buffer_cplx(:,ir2), gp_r%buffer_cplx(:,ir2), &
3436 0 : isign=isign, iscale=0, gpu_mode=gpu_mode)
3437 : end do
3438 :
3439 : ! F(g',r) --> F(r,g')
3440 : !call gp_r%ptrans("N", r_gp, free=.True.)
3441 : ! FIXME: I don't know why but C is needed here.
3442 0 : call gp_r%ptrans("C", r_gp, free=.True.)
3443 :
3444 : ! F(r,g') --> F(g,g') and store results in g_gp.
3445 : gpu_mode = 1
3446 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
3447 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3448 : call uplan_k%execute_rg(ndat, r_gp%buffer_cplx(:,ig2), g_gp%buffer_cplx(:,ig2), &
3449 0 : isign=-isign, iscale=0, gpu_mode=gpu_mode)
3450 : end do
3451 :
3452 : ! Scale output.
3453 0 : g_gp%buffer_cplx = g_gp%buffer_cplx * rfact
3454 :
3455 0 : if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) call g_gp%gpu_map("update_to") ! FIXME
3456 :
3457 0 : call uplan_k%free(); call r_gp%free()
3458 : ABI_NVTX_END_RANGE()
3459 :
3460 0 : end subroutine gwr_rpr_to_ggp
3461 : !!***
3462 :
3463 : !----------------------------------------------------------------------
3464 :
3465 : !!****f* m_gwr/gwr_rotate_wc
3466 : !! NAME
3467 : !! gwr_rotate_wc
3468 : !!
3469 : !! FUNCTION
3470 : !! Reconstruct Wc(q,g,g') in the BZ from the IBZ.
3471 : !!
3472 : !! INPUTS
3473 : !!
3474 : !! OUTPUT
3475 : !!
3476 : !! SOURCE
3477 :
3478 0 : subroutine gwr_rotate_wc(gwr, iq_bz, itau, spin, desc_qbz, wc_qbz)
3479 :
3480 : !Arguments ------------------------------------
3481 : class(gwr_t),intent(inout) :: gwr
3482 : integer,intent(in) :: iq_bz, itau, spin
3483 : type(desc_t),intent(out) :: desc_qbz
3484 : type(__slkmat_t),intent(inout) :: wc_qbz
3485 :
3486 : !Local variables-------------------------------
3487 : !scalars
3488 : integer :: ig1, ig2, il_g1, il_g2, iq_ibz, isym_q, trev_q, tsign_q
3489 : logical :: isirr_q, q_is_gamma
3490 : !arrays
3491 : integer :: g1(3), g2(3), g0_q(3)
3492 : real(dp) :: tnon(3), qq_bz(3)
3493 : complex(dp) :: ph2, ph1
3494 : ! *************************************************************************
3495 :
3496 : ABI_NVTX_START_RANGE(NVTX_GWR_ROTATE_WC)
3497 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("wc_space:", gwr%wc_space, " != itau"))
3498 :
3499 0 : qq_bz = gwr%qbz(:, iq_bz)
3500 0 : q_is_gamma = normv(qq_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3501 :
3502 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz); isym_q = gwr%qbz2ibz(2, iq_bz)
3503 0 : trev_q = gwr%qbz2ibz(6, iq_bz); g0_q = gwr%qbz2ibz(3:5, iq_bz)
3504 0 : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3505 0 : tsign_q = merge(1, -1, trev_q == 0)
3506 : ! TODO: Understand why legacy GW does not need umklapp
3507 : !ABI_CHECK(all(g0_q == 0), sjoin("For qbz:", ktoa(gwr%qbz(:, iq_bz)), "g0_q:", ltoa(g0_q), " != 0"))
3508 :
3509 : ! Copy descriptor from IBZ
3510 : associate (desc_qibz => gwr%tchi_desc_qibz(iq_ibz))
3511 0 : call desc_qibz%copy(desc_qbz)
3512 :
3513 0 : if (isirr_q) then
3514 : ! Copy the PBLAS matrix in wc_qbz and we are done.
3515 0 : call gwr%wc_qibz(iq_ibz, itau, spin)%copy(wc_qbz); goto 10
3516 : end if
3517 :
3518 : !ABI_WARNING_IF(trev_q == 0, "trev_q should be tested")
3519 : ! rotate gvec, recompute gbound and rotate vc_sqrt_eps.
3520 : ! TODO: 1) Handle TR and routine to rotate tchi/W including vc_sqrt_eps
3521 : ! 2) Make sure that FFT box is large enough to accomodate umklapps
3522 0 : desc_qbz%ig0 = -1
3523 0 : do ig1=1,desc_qbz%npw
3524 0 : desc_qbz%gvec(:,ig1) = tsign_q * matmul(gwr%cryst%symrec(:,:,isym_q), desc_qibz%gvec(:,ig1)) - g0_q
3525 0 : if (all(desc_qbz%gvec(:,ig1) == 0)) desc_qbz%ig0 = ig1
3526 : end do
3527 0 : desc_qbz%kin_sorted = .False.
3528 0 : ABI_CHECK(desc_qbz%ig0 /= -1, "Cannot find g = 0 after g-vector rotation!")
3529 :
3530 0 : call sphereboundary(desc_qbz%gbound, desc_qbz%istwfk, desc_qbz%gvec, gwr%g_mgfft, desc_qbz%npw)
3531 :
3532 : ! Compute sqrt(vc(q,G))
3533 : ! TODO: rotate vc_sqrt_eps
3534 : ! vc(Sq, Sg) = vc(q, g)
3535 : ! vc(-q, -g) = vc(q, g)
3536 0 : call desc_qbz%get_vc_sqrt(qq_bz, q_is_gamma, gwr, "sigma", gwr%gtau_comm%value)
3537 :
3538 : ! Get Wc_q with q in the BZ.
3539 0 : tnon = gwr%cryst%tnons(:, isym_q)
3540 0 : associate (wq_i => gwr%wc_qibz(iq_ibz, itau, spin), wq_f => wc_qbz)
3541 0 : call wq_i%copy(wc_qbz)
3542 :
3543 : !!!$OMP PARALLEL DO PRIVATE(ig2, g2, ph2, ig1, g2, ph1)
3544 0 : do il_g2=1, wq_f%size_local(2)
3545 0 : ig2 = mod(wq_f%loc2gcol(il_g2) - 1, desc_qbz%npw) + 1
3546 0 : g2 = desc_qbz%gvec(:,ig2)
3547 0 : ph2 = exp(+j_dpc * two_pi * dot_product(g2, tnon))
3548 0 : do il_g1=1, wq_f%size_local(1)
3549 0 : ig1 = mod(wq_f%loc2grow(il_g1) - 1, desc_qbz%npw) + 1
3550 0 : g1 = desc_qbz%gvec(:,ig1)
3551 0 : ph1 = exp(-j_dpc * two_pi * dot_product(g1, tnon))
3552 0 : wq_f%buffer_cplx(il_g1, il_g2) = wq_i%buffer_cplx(il_g1, il_g2) * ph1 * ph2
3553 0 : if (trev_q == 1) wq_f%buffer_cplx(il_g1, il_g2) = conjg(wq_f%buffer_cplx(il_g1, il_g2))
3554 : end do
3555 : end do
3556 : end associate
3557 : end associate
3558 :
3559 : 10 continue
3560 : ABI_NVTX_END_RANGE()
3561 :
3562 0 : end subroutine gwr_rotate_wc
3563 : !!***
3564 :
3565 : !----------------------------------------------------------------------
3566 :
3567 : !!****f* m_gwr/gwr_get_myq_wc_gpr
3568 : !! NAME
3569 : !! gwr_get_myq_wc_gpr
3570 : !!
3571 : !! FUNCTION
3572 : !! Use FFTs to compute: Wc_q(g,g') --> Wc_q(g',r)
3573 : !! for each q in the BZ treated by this MPI proc for given `spin` and `itau` index:
3574 : !!
3575 : !! 1) FFT Transform the first index: Wc(g,g',it) --> Wc(r,g',it) (local operation)
3576 : !! 2) MPI transposition: Wc(r,g',it) --> Wc(g',r,it)
3577 : !!
3578 : !! INPUTS
3579 : !! select_my_qbz: Mask used to select a subset of gwr%my_qkbz q-points.
3580 : !!
3581 : !! OUTPUT
3582 : !!
3583 : !! SOURCE
3584 :
3585 0 : subroutine gwr_get_myq_wc_gpr(gwr, itau, spin, select_my_qbz, desc_myqbz, wc_gpr)
3586 :
3587 : !Arguments ------------------------------------
3588 : class(gwr_t),intent(inout) :: gwr
3589 : integer,intent(in) :: itau, spin
3590 : logical,intent(in) :: select_my_qbz(gwr%my_nqbz)
3591 : type(desc_t),target,intent(out) :: desc_myqbz(gwr%my_nqbz)
3592 : type(__slkmat_t),intent(inout) :: wc_gpr(gwr%my_nqbz)
3593 :
3594 : !Local variables-------------------------------
3595 : !scalars
3596 : integer :: my_iqf, iq_bz, ig2, npw, col_bsize, ndat, gpu_option, gpu_mode
3597 : real(dp) :: cpu, wall, gflops, mem_mb, qq_bz(3)
3598 : logical :: q_is_gamma
3599 : character(len=500) :: msg, gpu_action
3600 0 : type(__slkmat_t) :: rgp, wc_qbz
3601 0 : type(uplan_t) :: uplan_q
3602 0 : complex(gwp),allocatable :: ceiqr(:)
3603 : ! *************************************************************************
3604 :
3605 0 : call cwtime(cpu, wall, gflops, "start")
3606 : ABI_NVTX_START_RANGE(NVTX_GWR_MYQ_WW_GPR)
3607 :
3608 0 : gpu_option = gwr%dtset%gpu_option
3609 :
3610 0 : ABI_MALLOC(ceiqr, (gwr%g_nfft))
3611 : #ifdef HAVE_OPENMP_OFFLOAD
3612 : !$OMP TARGET ENTER DATA MAP(alloc:ceiqr) IF (gpu_option == ABI_GPU_OPENMP)
3613 : #endif
3614 :
3615 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3616 :
3617 0 : do my_iqf=1,gwr%my_nqbz
3618 : if (.not. select_my_qbz(my_iqf)) continue
3619 0 : iq_bz = gwr%my_qbz_inds(my_iqf); qq_bz = gwr%qbz(:, iq_bz)
3620 0 : q_is_gamma = normv(qq_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3621 0 : if (.not. q_is_gamma) then
3622 0 : call calc_ceikr(qq_bz, gwr%g_ngfft, gwr%g_nfft, 1, ceiqr)
3623 : #ifdef HAVE_OPENMP_OFFLOAD
3624 : !$omp target update to(ceiqr) if (gpu_option == ABI_GPU_OPENMP)
3625 : #endif
3626 : end if
3627 :
3628 : ! Get Wc_q in the BZ.
3629 0 : call gwr%rotate_wc(iq_bz, itau, spin, desc_myqbz(my_iqf), wc_qbz)
3630 : associate (desc_q => desc_myqbz(my_iqf))
3631 :
3632 : ! Allocate rgp PBLAS matrix to store Wc_q(r, g')
3633 0 : npw = desc_q%npw
3634 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3635 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_q%istwfk, size_blocs=[-1, col_bsize])
3636 :
3637 : call uplan_q%init(desc_q%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_q%istwfk, &
3638 0 : desc_q%gvec, gwp, gpu_option)
3639 :
3640 : ! FFT and store results in rgp
3641 0 : gpu_mode = 1
3642 0 : do ig2=1,wc_qbz%size_local(2), gwr%uc_batch_size
3643 0 : ndat = blocked_loop(ig2, wc_qbz%size_local(2), gwr%uc_batch_size)
3644 :
3645 0 : if (q_is_gamma) then
3646 0 : call uplan_q%execute_gr(ndat, wc_qbz%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), gpu_mode=gpu_mode)
3647 : else
3648 0 : call uplan_q%execute_gr(ndat, wc_qbz%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), phase_r=ceiqr, gpu_mode=gpu_mode)
3649 : end if
3650 : end do ! ig2
3651 :
3652 0 : call uplan_q%free()
3653 :
3654 : ! MPI transposition: Wc(r,g') -> Wc(g',r)
3655 0 : call rgp%ptrans("N", wc_gpr(my_iqf), free=.True.)
3656 : end associate
3657 0 : call wc_qbz%free()
3658 :
3659 : !if (gpu_option == ABI_GPU_OPENMP) call wc_gpr(my_iqf)%gpu_map("update_to")
3660 : end do ! my_iqf
3661 :
3662 : #ifdef HAVE_OPENMP_OFFLOAD
3663 : !$OMP TARGET EXIT DATA MAP(delete: ceiqr) if (gpu_option == ABI_GPU_OPENMP)
3664 : #endif
3665 0 : ABI_FREE(ceiqr)
3666 :
3667 0 : mem_mb = sum(slk_array_locmem_mb(wc_gpr))
3668 0 : call wrtout(std_out, sjoin(" Local memory for Wc(g',r):", ftoa(mem_mb, fmt="f8.1"), "[Mb] <<< MEM"))
3669 0 : call cwtime_report(" gwr_get_myq_wc_gpr:", cpu, wall, gflops)
3670 :
3671 : ABI_NVTX_END_RANGE()
3672 :
3673 0 : end subroutine gwr_get_myq_wc_gpr
3674 : !!***
3675 :
3676 : !----------------------------------------------------------------------
3677 :
3678 : !!****f* m_gwr/gwr_get_wc_rpr_qbz
3679 : !! NAME
3680 : !! gwr_get_wc_rpr_qbz
3681 : !!
3682 : !! FUNCTION
3683 : !! Compute Wc_q(r',r') for q in the BZ
3684 : !!
3685 : !! INPUTS
3686 : !!
3687 : !! OUTPUT
3688 : !!
3689 : !! SOURCE
3690 :
3691 0 : subroutine gwr_get_wc_rpr_qbz(gwr, g0_q, iq_bz, itau, spin, wc_rpr)
3692 :
3693 : !Arguments ------------------------------------
3694 : class(gwr_t),intent(inout) :: gwr
3695 : integer,intent(in) :: g0_q(3)
3696 : integer,intent(in) :: iq_bz, itau, spin
3697 : type(__slkmat_t),intent(inout) :: wc_rpr
3698 :
3699 : !Local variables-------------------------------
3700 : !scalars
3701 : integer :: ig2, npw, nr, col_bsize, ir1, ndat, gpu_option, gpu_mode
3702 : character(len=500) :: msg, gpu_action
3703 0 : type(desc_t) :: desc_qbz
3704 0 : type(__slkmat_t) :: wc_ggp, rgp, gpr
3705 0 : type(uplan_t) :: uplan_k
3706 0 : complex(gwp),allocatable :: ceig0r(:), conjg_ceig0r(:)
3707 : ! *************************************************************************
3708 :
3709 : ABI_NVTX_START_RANGE(NVTX_GWR_WC_RPR_QBZ)
3710 :
3711 0 : gpu_option = gwr%dtset%gpu_option
3712 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3713 :
3714 : ! NB: Non-zero g0, requires the application of the phase.
3715 0 : if (any(g0_q /= 0)) then
3716 0 : ABI_MALLOC(ceig0r, (gwr%g_nfft))
3717 0 : ABI_MALLOC(conjg_ceig0r, (gwr%g_nfft))
3718 0 : call calc_ceigr(-g0_q, gwr%g_nfft, 1, gwr%g_ngfft, ceig0r)
3719 0 : conjg_ceig0r = conjg(ceig0r)
3720 : #ifdef HAVE_OPENMP_OFFLOAD
3721 : !$OMP TARGET ENTER DATA MAP(alloc:ceig0r, conjg_ceig0r) IF (gpu_option == ABI_GPU_OPENMP)
3722 : !$omp target update to(ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3723 : #endif
3724 : end if
3725 :
3726 : ! Get W_q(g,g') in the BZ.
3727 0 : call gwr%rotate_wc(iq_bz, itau, spin, desc_qbz, wc_ggp)
3728 :
3729 : ! Allocate rgp PBLAS matrix to store Wc(r,g')
3730 0 : nr = gwr%g_nfft
3731 0 : npw = desc_qbz%npw
3732 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3733 0 : call rgp%init(nr, npw, gwr%g_slkproc, desc_qbz%istwfk, size_blocs=[-1, col_bsize]) ! , gpu_action=gpu_action)
3734 :
3735 : call uplan_k%init(desc_qbz%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_qbz%istwfk, &
3736 0 : desc_qbz%gvec, gwp, gpu_option)
3737 :
3738 : ! FFT Wc(g,g') -> Wc(r,g') and store results in rgp
3739 0 : gpu_mode = 1
3740 0 : do ig2=1,wc_ggp%size_local(2), gwr%uc_batch_size
3741 0 : ndat = blocked_loop(ig2, wc_ggp%size_local(2), gwr%uc_batch_size)
3742 :
3743 0 : if (any(g0_q /= 0)) then
3744 : call uplan_k%execute_gr(ndat, wc_ggp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), &
3745 0 : phase_r=ceig0r, gpu_mode=gpu_mode)
3746 : else
3747 : call uplan_k%execute_gr(ndat, wc_ggp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), &
3748 0 : gpu_mode=gpu_mode)
3749 : end if
3750 : end do ! ig2
3751 :
3752 : ! MPI transpose: Wc(r,g') -> Wc(g',r)
3753 0 : call rgp%ptrans("N", gpr, free=.True.)
3754 :
3755 : ! Wc_q(g',r) -> Wc_q(r',r) and store results in wc_rgp.
3756 : gpu_mode = 1
3757 0 : do ir1=1,gpr%size_local(2), gwr%uc_batch_size
3758 0 : ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3759 0 : if (any(g0_q /= 0)) then
3760 : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:, ir1), wc_rpr%buffer_cplx(:, ir1), &
3761 0 : isign=-1, iscale=0, phase_r=conjg_ceig0r, gpu_mode=gpu_mode)
3762 : else
3763 : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:, ir1), wc_rpr%buffer_cplx(:, ir1), &
3764 0 : isign=-1, iscale=0, gpu_mode=gpu_mode)
3765 : end if
3766 : end do ! ir1
3767 :
3768 0 : call uplan_k%free(); call gpr%free(); call desc_qbz%free(); call wc_ggp%free()
3769 :
3770 0 : if (any(g0_q /= 0)) then
3771 : #ifdef HAVE_OPENMP_OFFLOAD
3772 : !$OMP TARGET EXIT DATA MAP(delete: ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3773 : #endif
3774 0 : ABI_SFREE(ceig0r)
3775 0 : ABI_SFREE(conjg_ceig0r)
3776 : end if
3777 :
3778 0 : if (gpu_option == ABI_GPU_OPENMP) call wc_rpr%gpu_map("update_to")
3779 : ABI_NVTX_END_RANGE()
3780 :
3781 0 : end subroutine gwr_get_wc_rpr_qbz
3782 : !!***
3783 :
3784 : !----------------------------------------------------------------------
3785 :
3786 : !!****f* m_gwr/gwr_cos_transform
3787 : !! NAME
3788 : !! gwr_cos_transform
3789 : !!
3790 : !! FUNCTION
3791 : !! Perform cosine transform.
3792 : !!
3793 : !! INPUTS
3794 : !! what: "tchi" or "wc"
3795 : !! mode: "iw2t" for omega to tau or "it2w" for tau to omega.
3796 : !! [sum_spins]: True to sum the two spin-channgels when what == "tchi". Default: False.
3797 : !!
3798 : !! SOURCE
3799 :
3800 0 : subroutine gwr_cos_transform(gwr, what, mode, sum_spins)
3801 :
3802 : !Arguments ------------------------------------
3803 : class(gwr_t),target,intent(inout) :: gwr
3804 : character(len=*),intent(in) :: what, mode
3805 : logical,optional,intent(in) :: sum_spins
3806 :
3807 : !Local variables-------------------------------
3808 : !scalars
3809 : integer, parameter :: TAU_SPACE = 0, W_SPACE = 1
3810 : integer :: my_iqi, my_is, ig1, ig2, my_it, ierr, iq_ibz, itau, spin, it0, iw, cnt
3811 : integer :: ndat, idat, loc1_size, loc2_size, batch_size, from_space, units(2)
3812 : real(dp) :: cpu, wall, gflops !, min_abs_err, max_abs_err
3813 : complex(dp) :: cval
3814 : logical :: sum_spins_, do_chi_fit
3815 : !arrays
3816 0 : integer :: mask_qibz(gwr%nqibz)
3817 0 : real(dp), contiguous, pointer :: weights_ptr(:,:)
3818 0 : real(dp),allocatable :: beta_r(:,:)
3819 0 : complex(dp) :: wgt_globmy(gwr%ntau, gwr%my_ntau) ! Complex instead of real to be able to call ZGEMM.
3820 0 : complex(dp),allocatable :: cwork_myit(:,:,:), glob_cwork(:,:,:), alpha_c(:,:)
3821 0 : type(__slkmat_t), pointer :: mats(:)
3822 : ! *************************************************************************
3823 :
3824 0 : units = [std_out, ab_out]
3825 :
3826 : ABI_NVTX_START_RANGE(NVTX_GWR_COS_TRANSFORM)
3827 0 : call cwtime(cpu, wall, gflops, "start")
3828 :
3829 0 : sum_spins_ = .False.; if (present(sum_spins)) sum_spins_ = sum_spins
3830 :
3831 0 : call wrtout(std_out, sjoin(" Performing cosine transform. what:", what, ", mode:", mode))
3832 0 : mask_qibz = 0; mask_qibz(gwr%my_qibz_inds(:)) = 1
3833 :
3834 : ! Target weights depending on mode.
3835 0 : select case(mode)
3836 : case ("iw2t")
3837 : ! From omega to tau
3838 0 : from_space = W_SPACE
3839 0 : if (what == "tchi") then
3840 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("mode:", mode, "with what:", what, "and tchi_space:", gwr%tchi_space))
3841 0 : gwr%tchi_space = "itau"
3842 : end if
3843 0 : if (what == "wc") then
3844 0 : ABI_CHECK(gwr%wc_space == "iomega", sjoin("mode:", mode, "with what:", what, "and wc_space:", gwr%wc_space))
3845 0 : gwr%wc_space = "itau"
3846 : end if
3847 0 : weights_ptr => gwr%cosft_tw
3848 :
3849 : case ("it2w")
3850 : ! From tau to omega
3851 0 : from_space = TAU_SPACE
3852 0 : if (what == "tchi") then
3853 0 : ABI_CHECK(gwr%tchi_space == "itau", sjoin("mode:", mode, " with what:", what, "and tchi_space:", gwr%tchi_space))
3854 0 : gwr%tchi_space = "iomega"
3855 : end if
3856 0 : if (what == "wc") then
3857 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("mode:", mode, " with what:", what, "and wc_space:", gwr%wc_space))
3858 0 : gwr%wc_space = "iomega"
3859 : end if
3860 0 : weights_ptr => gwr%cosft_wt
3861 :
3862 : case default
3863 0 : ABI_ERROR(sjoin("Wrong mode:", mode))
3864 : end select
3865 :
3866 : ! Extract my weights from global array.
3867 0 : do my_it=1,gwr%my_ntau
3868 0 : itau = gwr%my_itaus(my_it)
3869 0 : do iw=1,gwr%ntau
3870 0 : wgt_globmy(iw, my_it) = weights_ptr(iw, itau)
3871 : end do
3872 : end do
3873 :
3874 0 : do_chi_fit = (iand(gwr%dtset%gwr_fit, CHI_FIT) /= 0)
3875 0 : if (do_chi_fit) then
3876 0 : call wrtout(units, " Activating fit of matrix elements in tau/iw space")
3877 : end if
3878 :
3879 : ! Perform inhomogeneous FT in parallel.
3880 0 : do my_is=1,gwr%my_nspins
3881 0 : spin = gwr%my_spins(my_is)
3882 0 : do my_iqi=1,gwr%my_nqibz
3883 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
3884 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
3885 :
3886 0 : mats => null()
3887 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz, :, spin)
3888 0 : if (what =="wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
3889 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
3890 :
3891 : ! Use the first itau index to get the size of the local buffer.
3892 : ! Block over ig2 to reduce the number of MPI calls and take advantage of ZGEMM.
3893 0 : it0 = gwr%my_itaus(1)
3894 0 : loc1_size = mats(it0)%size_local(1)
3895 0 : loc2_size = mats(it0)%size_local(2)
3896 :
3897 : ! batch_size in terms of columns
3898 : ! TODO: Determine batch_size automatically to avoid going OOM
3899 0 : batch_size = 48
3900 : !batch_size = loc2_size
3901 :
3902 0 : ABI_MALLOC(cwork_myit, (gwr%my_ntau, loc1_size, batch_size))
3903 0 : ABI_MALLOC(glob_cwork, (gwr%ntau, loc1_size, batch_size))
3904 :
3905 0 : if (do_chi_fit) then
3906 : ! Allocate coefficients for the fit.
3907 0 : ABI_MALLOC(beta_r, (loc1_size, batch_size))
3908 0 : ABI_MALLOC(alpha_c, (loc1_size, batch_size))
3909 : end if
3910 :
3911 0 : do ig2=1,mats(it0)%size_local(2), batch_size
3912 0 : ndat = blocked_loop(ig2, mats(it0)%size_local(2), batch_size)
3913 :
3914 : ! TODO
3915 : ! When fit mode is activated, collect all tau/omega points for this set of (g1, g2) inside tau_comm
3916 : ! Each MPI rank performs the fit locally using the first point and all the points treated by the rank.
3917 : ! compute loss functions of all the fits and find the one leading to the minimum loss.
3918 0 : if (do_chi_fit) then
3919 0 : glob_cwork = zero
3920 0 : do idat=1,ndat
3921 0 : do my_it=1,gwr%my_ntau
3922 0 : itau = gwr%my_itaus(my_it)
3923 0 : do ig1=1,mats(it0)%size_local(1)
3924 0 : glob_cwork(itau, ig1, idat) = mats(itau)%buffer_cplx(ig1, ig2+idat-1)
3925 : end do
3926 : end do
3927 : end do
3928 0 : call xmpi_sum(glob_cwork, gwr%tau_comm%value, ierr)
3929 :
3930 : ! Start the fit
3931 0 : cnt = 0; beta_r = zero; alpha_c = zero
3932 0 : do idat=1,ndat
3933 0 : do ig1=1,mats(it0)%size_local(1)
3934 0 : cnt = cnt + 1; if (gwr%tau_comm%skip(cnt)) cycle ! MPI parallelism inside tau_comm
3935 0 : if (from_space == TAU_SPACE) then
3936 : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, glob_cwork(:,ig1,idat), &
3937 0 : alpha_c(ig1,idat), beta_r(ig1,idat), ierr)
3938 0 : else if (from_space == W_SPACE) then
3939 : call fit_iomega(gwr%ntau, gwr%iw_mesh, gwr%iw_wgs, glob_cwork(:,ig1,idat), &
3940 0 : alpha_c(ig1,idat), beta_r(ig1,idat), ierr)
3941 : else
3942 0 : ABI_ERROR(sjoin("Invalid from_space:", itoa(from_space)))
3943 : end if
3944 : !if (from_space == W_SPACE) print *, "my_it, alpha, beta", alpha_c(ig1,idat), beta_r(ig1,idat)
3945 : end do ! ig1
3946 : end do ! idat
3947 0 : call xmpi_sum(alpha_c, gwr%tau_comm%value, ierr)
3948 0 : call xmpi_sum(beta_r, gwr%tau_comm%value, ierr)
3949 : end if ! do_chi_fit
3950 :
3951 : ! Extract (g1, g2) matrix elements as a function of tau/omega
3952 : !!$OMP PARALLEL DO PRIVATE(itau, cval) COLLAPSE(2)
3953 0 : do idat=1,ndat
3954 0 : do my_it=1,gwr%my_ntau
3955 0 : itau = gwr%my_itaus(my_it)
3956 0 : cval = zero
3957 0 : do ig1=1,mats(it0)%size_local(1)
3958 0 : if (do_chi_fit) then
3959 : ! Evaluate the fit and remove it from the signal.
3960 0 : if (from_space == TAU_SPACE) then
3961 0 : cval = fit_tau_exp_eval("func", gwr%tau_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3962 0 : else if (from_space == W_SPACE) then
3963 0 : cval = fit_iomega_eval("func", gwr%iw_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3964 : end if
3965 : if (from_space == W_SPACE .and. any(my_it == [1, gwr%my_ntau])) then
3966 : !if (from_space == TAU_SPACE .and. any(my_it == [1, gwr%my_ntau])) then
3967 : !print * "beta_r, alpha:", beta_r(ig1,idat), alpha_c(ig1,idat)
3968 : !write(*, "(a,i3,1x, *(es12.5,2x))") "my_it abs_diff_1", my_it, abs(cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)), &
3969 : ! cval, mats(itau)%buffer_cplx(ig1, ig2+idat-1)
3970 : end if
3971 : end if
3972 0 : cwork_myit(my_it, ig1, idat) = mats(itau)%buffer_cplx(ig1, ig2+idat-1) - cval
3973 : end do
3974 : end do
3975 : end do
3976 :
3977 : ! Compute contribution to itau matrix,
3978 : call ZGEMM("N", "N", gwr%ntau, loc1_size*ndat, gwr%my_ntau, cone, &
3979 0 : wgt_globmy, gwr%ntau, cwork_myit, gwr%my_ntau, czero, glob_cwork, gwr%ntau)
3980 :
3981 0 : call xmpi_sum(glob_cwork, gwr%tau_comm%value, ierr)
3982 :
3983 : ! Update my local (g1, g2) entry to have it in imaginary-frequency.
3984 : !!$OMP PARALLEL DO PRIVATE(itau, cval) COLLAPSE(2)
3985 0 : do idat=1,ndat
3986 0 : do my_it=1,gwr%my_ntau
3987 0 : itau = gwr%my_itaus(my_it)
3988 0 : cval = zero
3989 0 : do ig1=1,mats(it0)%size_local(1)
3990 :
3991 0 : if (do_chi_fit) then
3992 : ! Add Fourier transform of the fitted model.
3993 0 : if (from_space == TAU_SPACE) then
3994 0 : cval = fit_tau_exp_eval("ft", gwr%iw_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3995 0 : else if (from_space == W_SPACE) then
3996 0 : cval = fit_iomega_eval("ft", gwr%tau_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3997 : end if
3998 : !if (from_space == W_SPACE .and. my_it == 1) then
3999 : !if (from_space == TAU_SPACE .and. my_it == 1) then
4000 : ! !print *, "beta_r, alpha:", beta_r(ig1,idat), alpha_c(ig1,idat)
4001 : ! print *, "my_it, abs_diff_2", my_it, abs(cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)), &
4002 : ! cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)
4003 : !end if
4004 : end if
4005 : !if (from_space == TAU_SPACE) then
4006 : !if (from_space == W_SPACE) then
4007 : !write(200, *)"mats:", mats(itau)%buffer_cplx(ig1, ig2+idat-1)
4008 : !write(300, *)"cval", cval
4009 : !end if
4010 :
4011 0 : mats(itau)%buffer_cplx(ig1, ig2+idat-1) = glob_cwork(itau, ig1, idat) + cval
4012 : end do ! ig1
4013 : end do ! my_it
4014 : end do ! idat
4015 :
4016 : end do ! ig2
4017 :
4018 0 : ABI_FREE(cwork_myit)
4019 0 : ABI_FREE(glob_cwork)
4020 0 : ABI_SFREE(alpha_c)
4021 0 : ABI_SFREE(beta_r)
4022 : end associate
4023 : end do ! my_iqi
4024 : end do ! my_is
4025 : !stop
4026 :
4027 0 : if (sum_spins_) then ! gwr%nsppol == 2 .and.
4028 : ! Sum over spin channels.
4029 0 : do my_iqi=1,gwr%my_nqibz
4030 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
4031 0 : do my_is=1,gwr%my_nspins
4032 0 : spin = gwr%my_spins(my_is)
4033 0 : mats => null()
4034 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz,:,spin)
4035 : !if (what =="wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
4036 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
4037 :
4038 0 : do my_it=1,gwr%my_ntau
4039 0 : itau = gwr%my_itaus(my_it)
4040 :
4041 0 : if (gwr%nsppol == 1 .and. gwr%nspinor == 1) then
4042 0 : mats(itau)%buffer_cplx = two * mats(itau)%buffer_cplx
4043 :
4044 0 : else if (gwr%nsppol == 2) then
4045 0 : if (gwr%spin_comm%nproc > 1) then
4046 : ! Spins are distributed thus we have to sum them.
4047 0 : call xmpi_sum(mats(itau)%buffer_cplx, gwr%spin_comm%value, ierr)
4048 : else
4049 : ! Spins are not distributed. This should happen only in sequential.
4050 0 : if (spin == 1) then
4051 0 : mats(itau)%buffer_cplx = mats(itau)%buffer_cplx + gwr%tchi_qibz(iq_ibz,itau,spin+1)%buffer_cplx
4052 0 : gwr%tchi_qibz(iq_ibz,itau,spin+1)%buffer_cplx = mats(itau)%buffer_cplx
4053 : end if
4054 : end if
4055 : end if
4056 :
4057 : end do ! my_it
4058 : end do ! my_is
4059 : end do ! my_iqi
4060 : end if
4061 :
4062 : ABI_NVTX_END_RANGE()
4063 0 : call cwtime_report(" gwr_cos_transform:", cpu, wall, gflops)
4064 :
4065 0 : end subroutine gwr_cos_transform
4066 : !!***
4067 :
4068 : !!****f* m_gwr/fit_tau_exp
4069 : !! NAME
4070 : !!
4071 : !! FUNCTION
4072 : !! Fit values in imaginary time using A exp^{-b t} with A complex and b real and > 0.
4073 : !! The fit passes through the first tau point, the second point is selected by
4074 : !! minimizing the "distance" between the fit and the ab-initio results cvals.
4075 : !!
4076 : !! b = -\frac{\ln(y_n / y_0)}{\tau_n - \tau_0},
4077 : !! A = y_0 e^{b \tau_0}
4078 : !!
4079 : !! SOURCE
4080 :
4081 0 : subroutine fit_tau_exp(ntau, tau_mesh, tau_wgs, cvals, alpha_c, beta_r, ierr)
4082 :
4083 : !Arguments ------------------------------------
4084 : integer,intent(in) :: ntau
4085 : real(dp),intent(in) :: tau_mesh(ntau), tau_wgs(ntau)
4086 : complex(dp),intent(in) :: cvals(ntau)
4087 : complex(dp),intent(out) :: alpha_c
4088 : real(dp),intent(out) :: beta_r
4089 : integer,intent(out) :: ierr
4090 :
4091 : !Local variables-------------------------------
4092 : integer :: ii
4093 : real(dp) :: loss, min_loss, my_beta_r
4094 0 : complex(dp) :: cfit(ntau), zz, my_alpha_c
4095 : ! *************************************************************************
4096 :
4097 0 : min_loss = huge(one); alpha_c = zero; beta_r = zero
4098 0 : do ii=2,ntau
4099 : ! Find my_beta_r. Note that we take the real part of the log to avoid oscillatory behaviour in the exp.
4100 0 : zz = -log(cvals(ii) / cvals(1)) / (tau_mesh(ii) - tau_mesh(1))
4101 0 : my_beta_r = real(zz)
4102 0 : my_alpha_c = cvals(1) * exp(+my_beta_r * tau_mesh(1))
4103 : ! Compute loss function.
4104 0 : cfit(:) = my_alpha_c * exp(-my_beta_r * tau_mesh)
4105 0 : loss = sum(tau_wgs * abs(cvals - cfit)**2)
4106 0 : if (loss < min_loss) then
4107 0 : min_loss = loss; alpha_c = my_alpha_c; beta_r = my_beta_r
4108 : end if
4109 : end do
4110 :
4111 : ! If something goes wrong, disable the fit.
4112 0 : ierr = 0
4113 0 : if (beta_r <= tol12) then
4114 0 : alpha_c = zero; beta_r = tol6; ierr = 1
4115 : end if
4116 :
4117 0 : end subroutine fit_tau_exp
4118 : !!***
4119 :
4120 : !!****f* m_gwr/fit_tau_exp_eval
4121 : !! NAME
4122 : !!
4123 : !! FUNCTION
4124 : !! Exalute tau fit or it's Fourier transform.
4125 : !!
4126 : !! SOURCE
4127 :
4128 0 : pure complex(dp) function fit_tau_exp_eval(what, xx, alpha_c, beta_r) result(cval)
4129 :
4130 : !Arguments ------------------------------------
4131 : character(len=*),intent(in) :: what
4132 : real(dp),intent(in) :: xx, beta_r
4133 : complex(dp),intent(in) :: alpha_c
4134 : ! *************************************************************************
4135 :
4136 0 : select case (what)
4137 : case ("func")
4138 0 : cval = alpha_c * exp(-beta_r * xx)
4139 : case ("ft")
4140 : ! \mathcal{F}\{A e^{-b |t|} \}(\omega) = \frac{2A b}{b^2 + \omega^2}
4141 : !cval = (two * alpha_c * beta_r) / (beta_r**2 + xx**2)
4142 : ! Cosine-transform.
4143 0 : cval = (alpha_c * two * beta_r) / (beta_r**2 + xx**2)
4144 : case default
4145 0 : cval = huge(one)
4146 : end select
4147 :
4148 0 : end function fit_tau_exp_eval
4149 : !!***
4150 :
4151 : !!****f* m_gwr/fit_iomega
4152 : !! NAME
4153 : !!
4154 : !! FUNCTION
4155 : !! To fit the function
4156 : !!
4157 : !! f(\omega) = \frac{A}{b^2 + \omega^2}
4158 : !!
4159 : !! to pass through two given points (\omega_1, y_1) and (\omega_2, y_2), follow these steps.
4160 : !!
4161 : !! A = \frac{y_1 y_2 (\omega_2^2 - \omega_1^2)}{y_1 - y_2}.
4162 : !! b^2 = \frac{y_2 \omega_2^2 - y_1 \omega_1^2}{y_1 - y_2},
4163 : !!
4164 : !! SOURCE
4165 :
4166 0 : subroutine fit_iomega(ntau, iw_mesh, iw_wgs, cvals, alpha_c, beta_r, ierr)
4167 :
4168 : !Arguments ------------------------------------
4169 : integer,intent(in) :: ntau
4170 : real(dp),intent(in) :: iw_mesh(ntau), iw_wgs(ntau)
4171 : complex(dp),intent(in) :: cvals(ntau)
4172 : complex(dp),intent(out) :: alpha_c
4173 : real(dp),intent(out) :: beta_r
4174 : integer,intent(out) :: ierr
4175 :
4176 : !Local variables-------------------------------
4177 : integer :: ii
4178 : real(dp) :: loss, min_loss, w0, wn, b2 ! my_beta_r,
4179 0 : complex(dp) :: my_alpha_c, cfit(ntau), f0, fn ! zz, b2_cplx,
4180 : ! *************************************************************************
4181 :
4182 0 : min_loss = huge(one); w0 = iw_mesh(1); f0 = cvals(1); alpha_c = czero; beta_r = zero
4183 :
4184 0 : do ii=2,ntau
4185 : ! Find alpha_c and beta_r
4186 0 : wn = iw_mesh(ii); fn = cvals(ii)
4187 : !b2_cplx = (f0*w0**2 - fn*wn**2) / (fn - f0)
4188 : !b2 = real(b2)
4189 0 : b2 = (real(f0) * w0**2 - real(fn) * wn**2) / (real(fn) - real(f0))
4190 : !print *, "b2:", b2
4191 :
4192 0 : if (b2 <= tol12) then
4193 : b2 = tol12; my_alpha_c = zero
4194 : else
4195 : !my_alpha_c = f0*fn * (wn**2 - w0**2) / (f0 - fn)
4196 : !print *, "b2:", b2
4197 : !my_alpha_c = f0 *((fn*wn**2 - f0*w0**2)/(f0 - fn) + w0**2)
4198 0 : my_alpha_c = f0 * (b2 + w0**2)
4199 : end if
4200 :
4201 : ! Compute loss function.
4202 0 : cfit(:) = my_alpha_c / (b2 + iw_mesh**2)
4203 0 : loss = sum(iw_wgs * abs(cvals - cfit)**2)
4204 0 : if (loss < min_loss) then
4205 0 : min_loss = loss; alpha_c = my_alpha_c; beta_r = sqrt(b2)
4206 : end if
4207 : end do
4208 :
4209 : ! DEBUG: disable the fit
4210 : !beta_r = zero; alpha_c = zero
4211 :
4212 0 : ierr = 0; if (b2 <= tol12) ierr = 1
4213 :
4214 : !if (alpha_c /= zero) then
4215 : ! print *, "beta_r, alpha_c", beta_r, alpha_c, min_loss
4216 : !end if
4217 :
4218 : ! If something goes wrong, disable the fit.
4219 : !beta_r = zero; alpha_c = zero
4220 : !if ((my_beta_r) > zero) then
4221 : ! beta_r = my_beta_r
4222 : ! alpha_c = my_alpha_c
4223 : !end if
4224 :
4225 0 : end subroutine fit_iomega
4226 : !!***
4227 :
4228 : !!****f* m_gwr/fit_iomega_eval
4229 : !! NAME
4230 : !!
4231 : !! FUNCTION
4232 : !!
4233 : !! SOURCE
4234 :
4235 0 : pure complex(dp) function fit_iomega_eval(what, xx, alpha_c, beta_r) result(cval)
4236 :
4237 : !Arguments ------------------------------------
4238 : character(len=*),intent(in) :: what
4239 : real(dp),intent(in) :: xx, beta_r
4240 : complex(dp),intent(in) :: alpha_c
4241 : ! *************************************************************************
4242 :
4243 0 : select case (what)
4244 : case ("func")
4245 0 : cval = alpha_c / (beta_r**2 + xx**2)
4246 : case ("ft")
4247 0 : cval = zero
4248 0 : if (alpha_c /= zero) then
4249 : !cval = alpha_c * exp(-beta_r * abs(xx))
4250 : ! TODO: check sign in prefactor
4251 : !cval = (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4252 : !cval = - (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4253 : ! Cosine-transform
4254 0 : cval = (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4255 : end if
4256 :
4257 : case default
4258 0 : cval = huge(one)
4259 : end select
4260 :
4261 0 : end function fit_iomega_eval
4262 : !!***
4263 :
4264 : !----------------------------------------------------------------------
4265 :
4266 : !!****f* m_gwr/desc_init
4267 : !! NAME
4268 : !! desc_init
4269 : !!
4270 : !! FUNCTION
4271 : !! Initialize the descriptor.
4272 : !!
4273 : !! INPUTS
4274 : !!
4275 : !! OUTPUT
4276 : !!
4277 : !! SOURCE
4278 :
4279 0 : subroutine desc_init(desc, kk, istwfk, ecut, gwr, kin_sorted, rot)
4280 :
4281 : !Arguments ------------------------------------
4282 : class(desc_t),intent(inout) :: desc
4283 : real(dp),intent(in) :: kk(3)
4284 : integer,intent(in) :: istwfk
4285 : real(dp),intent(in) :: ecut
4286 : class(gwr_t),intent(in) :: gwr
4287 : logical,optional,intent(in) :: kin_sorted, rot
4288 :
4289 : !Local variables-------------------------------
4290 : integer :: ig, ig1, ig2, itim, isym, istep_forward, istep_backward, grot(3)
4291 : ! character(len=256) :: msg
4292 : logical :: found, rot__
4293 0 : real(dp),allocatable :: gnorm(:)
4294 0 : integer,allocatable :: igvec(:)
4295 : ! *************************************************************************
4296 :
4297 0 : desc%kin_sorted = .False.; if (present(kin_sorted)) desc%kin_sorted = kin_sorted
4298 0 : rot__ = .False.; if (present(rot)) rot__ = rot
4299 0 : desc%istwfk = istwfk
4300 0 : call get_kg(kk, desc%istwfk, ecut, gwr%cryst%gmet, desc%npw, desc%gvec, kin_sorted=desc%kin_sorted)
4301 :
4302 0 : ABI_MALLOC(desc%gbound, (2 * gwr%g_mgfft + 8, 2))
4303 0 : call sphereboundary(desc%gbound, desc%istwfk, desc%gvec, gwr%g_mgfft, desc%npw)
4304 :
4305 : ! Find the index of g = 0.
4306 0 : desc%ig0 = -1
4307 0 : do ig=1,desc%npw
4308 0 : if (all(desc%gvec(:,ig) == 0)) then
4309 0 : desc%ig0 = ig; exit
4310 : end if
4311 : end do
4312 :
4313 0 : if (rot__) then
4314 0 : ABI_ICALLOC(desc%rottb, (desc%npw, gwr%cryst%timrev, gwr%cryst%nsym))
4315 0 : ABI_ICALLOC(desc%rottbm1, (desc%npw, gwr%cryst%timrev, gwr%cryst%nsym))
4316 0 : ABI_CALLOC(desc%phmGt, (desc%npw, gwr%cryst%nsym))
4317 0 : ABI_CALLOC(desc%phmSGt, (desc%npw, gwr%cryst%nsym))
4318 : ! Fast sort for norm(desc%gvec) and store indices in igvec.
4319 0 : ABI_MALLOC(gnorm, (desc%npw))
4320 0 : ABI_MALLOC(igvec, (desc%npw))
4321 :
4322 0 : do ig=1,desc%npw
4323 0 : igvec(ig) = ig
4324 0 : gnorm(ig) = normv(desc%gvec(:,ig), gwr%cryst%gmet, "G") ** 2
4325 : end do
4326 :
4327 0 : call sort_dp(desc%npw, gnorm, igvec, tol14)
4328 :
4329 0 : ABI_FREE(gnorm)
4330 :
4331 0 : do ig1=1,desc%npw
4332 0 : do itim=1,gwr%cryst%timrev
4333 0 : do isym=1,gwr%cryst%nsym
4334 0 : grot=(3-2*itim)*MATMUL(gwr%cryst%symrec(:,:,isym),desc%gvec(:,ig1))
4335 0 : found=.FALSE.
4336 : ! * Loop on the shell of ig1 to speed up the search.
4337 : istep_forward = ig1; istep_backward = ig1
4338 0 : do while (istep_forward <= desc%npw .or. istep_backward >= 1)
4339 0 : if (istep_forward <= desc%npw) then
4340 0 : ig2 = igvec(istep_forward)
4341 0 : if (ALL(ABS(grot(:)-desc%gvec(:,ig2))==0)) then
4342 0 : found=.TRUE.
4343 0 : desc%rottb(ig1,itim,isym)=ig2
4344 0 : desc%rottbm1(ig2,itim,isym)=ig1
4345 0 : desc%phmGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(desc%gvec(:,ig1), gwr%cryst%tnons(:,isym)))
4346 0 : desc%phmSGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(grot(:), gwr%cryst%tnons(:,isym)))
4347 0 : exit
4348 : end if
4349 : end if
4350 0 : if (istep_backward >= 1) then
4351 0 : ig2 = igvec(istep_backward)
4352 0 : if (ALL(ABS(grot(:)-desc%gvec(:,ig2))==0)) then
4353 0 : found=.TRUE.
4354 0 : desc%rottb(ig1,itim,isym)=ig2
4355 0 : desc%rottbm1(ig2,itim,isym)=ig1
4356 0 : desc%phmGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(desc%gvec(:,ig1), gwr%cryst%tnons(:,isym)))
4357 0 : desc%phmSGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(grot(:), gwr%cryst%tnons(:,isym)))
4358 0 : exit
4359 : end if
4360 : end if
4361 0 : istep_forward = istep_forward + 1
4362 0 : istep_backward = istep_backward - 1
4363 : end do
4364 : ! if (.not.found) then
4365 : ! write(msg,'(3a,i5,a,i5,1x,2(3i10,a),a,i3,a,i3)')&
4366 : ! 'G-shell not closed',ch10,&
4367 : ! ' Initial G vector ',ig1,'/',desc%npw,desc%gvec(:,ig1),' Rotated G vector ',grot(:),ch10,&
4368 : ! ' Through sym ',isym,' and itim ',itim
4369 : ! ABI_ERROR(msg)
4370 : ! end if
4371 : end do ! itim
4372 : end do ! isym
4373 : end do ! ig1
4374 :
4375 0 : ABI_FREE(igvec)
4376 :
4377 : end if ! rot__
4378 :
4379 0 : end subroutine desc_init
4380 : !!***
4381 :
4382 : !----------------------------------------------------------------------
4383 :
4384 : !!****f* m_gwr/desc_get_vc_sqrt
4385 : !! NAME
4386 : !! desc_get_vc_sqrt
4387 : !!
4388 : !! FUNCTION
4389 : !! Compute square root of the Coulomb interaction vc(q,g).
4390 : !!
4391 : !! SOURCE
4392 :
4393 0 : subroutine desc_get_vc_sqrt(desc, qpt, q_is_gamma, gwr, mode, comm)
4394 :
4395 : !Arguments ------------------------------------
4396 : class(desc_t),intent(inout) :: desc
4397 : real(dp),intent(in) :: qpt(3)
4398 : logical, intent(in) :: q_is_gamma
4399 : class(gwr_t),intent(in) :: gwr
4400 : character(len=*),intent(in) :: mode
4401 : integer,intent(in) :: comm
4402 : ! *************************************************************************
4403 :
4404 : ABI_UNUSED([q_is_gamma])
4405 :
4406 0 : if (mode == "epsilon" .or. .not. gwr%has_vcgen_sigma) then
4407 0 : if (allocated(desc%vc_sqrt_eps)) return
4408 0 : ABI_MALLOC(desc%vc_sqrt_eps, (desc%npw))
4409 0 : call gwr%vcgen_eps%get_vc_sqrt(qpt, desc%npw, desc%gvec, gwr%q0, gwr%cryst, desc%vc_sqrt_eps, comm)
4410 :
4411 0 : else if (mode == "sigma") then
4412 0 : if (allocated(desc%vc_sqrt_sigma)) return
4413 0 : ABI_MALLOC(desc%vc_sqrt_sigma, (desc%npw))
4414 0 : call gwr%vcgen_sigma%get_vc_sqrt(qpt, desc%npw, desc%gvec, gwr%q0, gwr%cryst, desc%vc_sqrt_sigma, comm)
4415 :
4416 : else
4417 0 : ABI_ERROR(sjoin("Invalid mode:", mode))
4418 : end if
4419 :
4420 : end subroutine desc_get_vc_sqrt
4421 : !!***
4422 :
4423 : !----------------------------------------------------------------------
4424 :
4425 : !!****f* m_gwr/desc_copy
4426 : !! NAME
4427 : !! desc_copy
4428 : !!
4429 : !! FUNCTION
4430 : !! Copy object
4431 : !! NB: cannot use obj1 = obj2 syntax because ABINIT memory-leak detector
4432 : !! won't see the allocation automatically performed by the compiler.
4433 : !!
4434 : !! SOURCE
4435 :
4436 0 : subroutine desc_copy(in_desc, new_desc)
4437 :
4438 : !Arguments ------------------------------------
4439 : class(desc_t),intent(in) :: in_desc
4440 : class(desc_t),intent(out) :: new_desc
4441 : ! *************************************************************************
4442 :
4443 0 : call new_desc%free()
4444 :
4445 0 : new_desc%istwfk = in_desc%istwfk
4446 0 : new_desc%npw = in_desc%npw
4447 0 : new_desc%ig0 = in_desc%ig0
4448 0 : new_desc%kin_sorted = in_desc%kin_sorted
4449 :
4450 0 : call alloc_copy(in_desc%gvec, new_desc%gvec)
4451 0 : call alloc_copy(in_desc%gbound, new_desc%gbound)
4452 0 : if (allocated(in_desc%vc_sqrt_eps)) call alloc_copy(in_desc%vc_sqrt_eps, new_desc%vc_sqrt_eps)
4453 0 : if (allocated(in_desc%vc_sqrt_sigma)) call alloc_copy(in_desc%vc_sqrt_sigma, new_desc%vc_sqrt_sigma)
4454 :
4455 0 : if (allocated(in_desc%g2box)) then
4456 0 : call alloc_copy(in_desc%g2box, new_desc%g2box)
4457 0 : new_desc%cached_sc_ngfft = in_desc%cached_sc_ngfft
4458 : end if
4459 :
4460 0 : end subroutine desc_copy
4461 : !!***
4462 :
4463 : !----------------------------------------------------------------------
4464 :
4465 : !!****f* m_gwr/desc_to_scbox
4466 : !! NAME
4467 : !! desc_to_scbox
4468 : !!
4469 : !! FUNCTION
4470 : !! Insert cg_k array defined on the k-centered g-sphere with npw vectors inside the FFT box.
4471 : !! The main difference wrt to sphere is that cfft is not initialized to zero. See notes below.
4472 : !!
4473 : !! INPUTS
4474 : !! sc_ngfft:
4475 : !! n1,n2,n3=physical dimension of the FFT box
4476 : !! n4,n5,n6=memory dimension of cfft
4477 : !! npw=number of G vectors in basis at this k point
4478 : !! ndat=number of items to process
4479 : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere
4480 : !!
4481 : !! OUTPUT
4482 : !! cfft(n4,n5,n6*ndat) = array on FFT box filled with cg data
4483 : !! Note that cfft is intent(inout) so that we can add contributions from different k-points.
4484 : !!
4485 : !! SOURCE
4486 :
4487 0 : subroutine desc_to_scbox(desc, kk, ngkpt, sc_ngfft, ndat, cg, cfft)
4488 :
4489 : !Arguments ------------------------------------
4490 : !scalars
4491 : class(desc_t),intent(inout) :: desc
4492 : real(dp),intent(in) :: kk(3)
4493 : integer,intent(in) :: ngkpt(3)
4494 : integer,intent(in) :: sc_ngfft(6), ndat
4495 : !arrays
4496 : complex(gwp),intent(in) :: cg(desc%npw, ndat)
4497 : complex(gwp),intent(inout) :: cfft(sc_ngfft(4)*sc_ngfft(5)*sc_ngfft(6),ndat)
4498 :
4499 : !Local variables-------------------------------
4500 : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw, kg(3), gg(3), ifft, npw
4501 : logical :: compute_mapping
4502 : !real(dp) :: tsec(2)
4503 : ! *************************************************************************
4504 :
4505 : ! TODO: Add op_type
4506 : !call timab(1931, 1, tsec)
4507 :
4508 0 : npw = desc%npw
4509 0 : n1 = sc_ngfft(1); n2 = sc_ngfft(2); n3 = sc_ngfft(3)
4510 0 : n4 = sc_ngfft(4); n5 = sc_ngfft(5); n6 = sc_ngfft(6)
4511 0 : gg = nint(kk * ngkpt)
4512 :
4513 0 : compute_mapping = .not. allocated(desc%g2box) .or. any(desc%cached_sc_ngfft /= sc_ngfft(1:6))
4514 :
4515 : ! FIXME This is not thread safe
4516 : if (compute_mapping) then
4517 0 : ABI_REMALLOC(desc%g2box, (npw))
4518 0 : desc%cached_sc_ngfft = sc_ngfft(1:6)
4519 0 : do ipw=1,npw
4520 0 : kg = gg + ngkpt * desc%gvec(:,ipw) ! k+g
4521 0 : i1 = modulo(kg(1), n1)
4522 0 : i2 = modulo(kg(2), n2)
4523 0 : i3 = modulo(kg(3), n3)
4524 0 : desc%g2box(ipw) = 1 + i1 + n4*(i2+i3*n5)
4525 : end do
4526 : end if
4527 :
4528 : !do ipw=1,npw
4529 : ! if (any(desc%gvec(:,ipw) > sc_ngfft(1:3)/2) .or. any(desc%gvec(:,ipw) < -(sc_ngfft(1:3)-1)/2) ) then
4530 : ! ABI_ERROR(sjoin(" The G-vector: ",ltoa(desc%gvec(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
4531 : ! end if
4532 : !end do
4533 :
4534 : ! Insert cg into cfft
4535 : !$OMP PARALLEL DO PRIVATE(ifft) IF (ndat > 1)
4536 0 : do idat=1,ndat
4537 0 : do ipw=1,npw
4538 0 : ifft = desc%g2box(ipw)
4539 0 : cfft(ifft,idat) = cg(ipw,idat)
4540 : end do
4541 : end do
4542 :
4543 : !call timab(1931, 2, tsec)
4544 :
4545 0 : end subroutine desc_to_scbox
4546 : !!***
4547 :
4548 : !----------------------------------------------------------------------
4549 :
4550 : !!****f* m_gwr/desc_free
4551 : !! NAME
4552 : !! desc_free
4553 : !!
4554 : !! FUNCTION
4555 : !! Free memory
4556 : !!
4557 : !! SOURCE
4558 :
4559 0 : subroutine desc_free(desc)
4560 :
4561 : !Arguments ------------------------------------
4562 : class(desc_t),intent(inout) :: desc
4563 : ! *************************************************************************
4564 :
4565 0 : ABI_SFREE(desc%gvec)
4566 0 : ABI_SFREE(desc%gbound)
4567 0 : ABI_SFREE(desc%vc_sqrt_eps)
4568 0 : ABI_SFREE(desc%vc_sqrt_sigma)
4569 0 : ABI_SFREE(desc%g2box)
4570 0 : ABI_SFREE(desc%rottb)
4571 0 : ABI_SFREE(desc%rottbm1)
4572 0 : ABI_SFREE(desc%phmGt)
4573 0 : ABI_SFREE(desc%phmSGt)
4574 0 : desc%cached_sc_ngfft = -1
4575 :
4576 0 : end subroutine desc_free
4577 : !!***
4578 :
4579 : !----------------------------------------------------------------------
4580 :
4581 : !!****f* m_gwr/gwr_print
4582 : !! NAME
4583 : !! gwr_print
4584 : !!
4585 : !! FUNCTION
4586 : !! Print info on the gwr object.
4587 : !!
4588 : !! INPUTS
4589 : !!
4590 : !! SOURCE
4591 :
4592 0 : subroutine gwr_print(gwr, units, header)
4593 :
4594 : !Arguments ------------------------------------
4595 : class(gwr_t),intent(in) :: gwr
4596 : integer,intent(in) :: units(:)
4597 : character(len=*),optional,intent(in) :: header
4598 :
4599 : !Local variables-------------------------------
4600 : integer :: ii
4601 : character(len=500) :: msg
4602 : type(yamldoc_t) :: ydoc
4603 : ! *********************************************************************
4604 :
4605 0 : msg = ' ==== Info on the gwr_t object ==== '; if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
4606 0 : call wrtout(units, msg)
4607 :
4608 0 : ydoc = yamldoc_open('GWR_params') !, width=11, real_fmt='(3f8.3)')
4609 0 : call ydoc%add_string("gwr_task", gwr%dtset%gwr_task)
4610 0 : call ydoc%add_int("nband", gwr%dtset%nband(1))
4611 0 : call ydoc%add_int("ntau", gwr%ntau)
4612 0 : call ydoc%add_int1d("ngkpt", gwr%ngkpt)
4613 0 : call ydoc%add_int1d("ngqpt", gwr%ngqpt)
4614 0 : msg = "supercell"; if (.not. gwr%use_supercell_for_tchi) msg = "BZ-convolutions"
4615 0 : call ydoc%add_string("chi_algo", msg)
4616 0 : msg = "supercell"; if (.not. gwr%use_supercell_for_sigma) msg = "BZ-convolutions"
4617 0 : call ydoc%add_string("sigma_algo", msg)
4618 0 : call ydoc%add_int("nkibz", gwr%nkibz)
4619 0 : call ydoc%add_int("nqibz", gwr%nqibz)
4620 0 : call ydoc%add_int("inclvkb", gwr%dtset%inclvkb)
4621 0 : call ydoc%add_real1d("q0", gwr%q0) ! "for long-wavelenght limit"))
4622 0 : call ydoc%add_int("gw_icutcoul", gwr%dtset%gw_icutcoul)
4623 0 : call ydoc%add_int("green_mpw", gwr%green_mpw)
4624 0 : call ydoc%add_int("tchi_mpw", gwr%tchi_mpw)
4625 0 : call ydoc%add_int1d("g_ngfft", gwr%g_ngfft(1:6))
4626 0 : call ydoc%add_real("gwr_boxcutmin", gwr%dtset%gwr_boxcutmin)
4627 0 : call ydoc%add_int1d("P gwr_np_kgts", gwr%dtset%gwr_np_kgts)
4628 0 : call ydoc%add_int1d("P np_kibz", gwr%np_kibz)
4629 0 : call ydoc%add_int1d("P np_qibz", gwr%np_qibz)
4630 : ! Print Max error due to the inhomogeneous FT.
4631 0 : call ydoc%add_real("min_transition_energy_eV", gwr%te_min * Ha_eV)
4632 0 : call ydoc%add_real("max_transition_energy_eV", gwr%te_max * Ha_eV)
4633 0 : call ydoc%add_real("eratio", gwr%te_max / gwr%te_min)
4634 0 : call ydoc%add_real("ft_max_err_t2w_cos", gwr%ft_max_error(1))
4635 0 : call ydoc%add_real("ft_max_err_w2t_cos", gwr%ft_max_error(2))
4636 0 : call ydoc%add_real("ft_max_err_t2w_sin", gwr%ft_max_error(3))
4637 0 : call ydoc%add_real("cosft_duality_error", gwr%cosft_duality_error)
4638 : ! Print imaginary time/frequency mesh with weights.
4639 0 : call ydoc%open_tabular("Minimax imaginary tau/omega mesh in a.u.", comment="tau, weight(tau), omega, weight(omega)")
4640 0 : do ii=1,gwr%ntau
4641 0 : write(msg, "(i0, 4(es12.5,2x))")ii, gwr%tau_mesh(ii), gwr%tau_wgs(ii), gwr%iw_mesh(ii), gwr%iw_wgs(ii)
4642 0 : call ydoc%add_tabular_line(msg)
4643 : end do
4644 :
4645 0 : call ydoc%write_units_and_free(units)
4646 :
4647 0 : end subroutine gwr_print
4648 : !!***
4649 :
4650 : !!****f* m_gwr/gwr_print_mem
4651 : !! NAME
4652 : !! gwr_print_mem
4653 : !!
4654 : !! FUNCTION
4655 : !! Print memory allocated for matrices.
4656 : !!
4657 : !! SOURCE
4658 :
4659 0 : subroutine gwr_print_mem(gwr, units)
4660 :
4661 : !Arguments ------------------------------------
4662 : class(gwr_t),intent(in) :: gwr
4663 : integer,intent(in) :: units(:)
4664 :
4665 : !Local variables-------------------------------
4666 : !scalars
4667 : real(dp) :: mem_mb
4668 : !character(len=500) :: msg
4669 : ! *********************************************************************
4670 :
4671 0 : if (allocated(gwr%gt_kibz)) then
4672 0 : mem_mb = sum(slk_array_locmem_mb(gwr%gt_kibz))
4673 0 : if (mem_mb > zero) then
4674 0 : call wrtout(units, sjoin("- Local memory for G(g,g',kibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4675 : end if
4676 : end if
4677 0 : if (allocated(gwr%tchi_qibz)) then
4678 0 : mem_mb = sum(slk_array_locmem_mb(gwr%tchi_qibz))
4679 0 : if (mem_mb > zero) then
4680 0 : call wrtout(units, sjoin("- Local memory for Chi(g,g',qibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4681 : end if
4682 : end if
4683 0 : if (allocated(gwr%wc_qibz)) then
4684 0 : mem_mb = sum(slk_array_locmem_mb(gwr%wc_qibz))
4685 0 : if (mem_mb > zero) then
4686 0 : call wrtout(units, sjoin("- Local memory for Wc(g,g,qibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4687 : end if
4688 : end if
4689 0 : if (allocated(gwr%sigc_kibz)) then
4690 0 : mem_mb = sum(slk_array_locmem_mb(gwr%sigc_kibz))
4691 0 : if (mem_mb > zero) then
4692 0 : call wrtout(units, sjoin("- Local memory for Sigma_c(g,g',kibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4693 : end if
4694 : end if
4695 0 : if (allocated(gwr%ugb)) then
4696 0 : mem_mb = sum(slk_array_locmem_mb(gwr%ugb))
4697 0 : if (mem_mb > zero) then
4698 0 : call wrtout(units, sjoin('- Local memory for u_gb wavefunctions: ', ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4699 : end if
4700 : end if
4701 0 : call wrtout(units, " ")
4702 :
4703 0 : end subroutine gwr_print_mem
4704 : !!***
4705 :
4706 : !----------------------------------------------------------------------
4707 :
4708 : !!****f* m_gwr/gwr_build_tchi
4709 : !! NAME
4710 : !! gwr_build_tchi
4711 : !!
4712 : !! FUNCTION
4713 : !! High-level routine to compute the irreducible polarizability.
4714 : !!
4715 : !! SOURCE
4716 :
4717 0 : subroutine gwr_build_tchi(gwr)
4718 :
4719 : !Arguments ------------------------------------
4720 : class(gwr_t),target,intent(inout) :: gwr
4721 :
4722 : !Local variables-------------------------------
4723 : !scalars
4724 : integer :: my_is, my_it, my_ikf, ig, my_ir, my_nr, nr, npw, ncol_glob, col_bsize, my_iqi, gt_scbox_win, gpu_option, iab
4725 : integer :: idat, ndat, max_ndat, sc_nfft, sc_nfftsp, spin, ik_bz, iq_ibz, ikq_ibz, ikq_bz, ierr, ipm, itau, ig2, ifft !, ii
4726 : integer :: use_umklp, gpu_mode ! ik_ibz, isym_k, trev_k, tsign_k, ! g0_k(3),
4727 : !integer :: my_ikf_start, my_ikf_stop !, nkf_batch_size, nkf_now, op_type
4728 : integer :: itim, isym
4729 : integer(kind=XMPI_ADDRESS_KIND) :: buf_count
4730 : real(dp) :: cpu_tau, wall_tau, gflops_tau, cpu_all, wall_all, gflops_all, cpu_ir, wall_ir, gflops_ir
4731 : real(dp) :: cpu_ikf, wall_ikf, gflops_ikf
4732 : real(dp) :: tchi_rfact, mem_mb, local_max, max_abs_imag_chit
4733 : real(gwp) :: wtqp, wtqm
4734 : complex(gwp) :: head_q
4735 : complex(dp) :: chq(3), wng(3)
4736 : logical :: q_is_gamma, use_shmem_for_k, use_mpi_for_k, print_time, keep_tchim !, doit ! isirr_k,
4737 : character(len=5000) :: msg
4738 : character(len=50) :: gpu_action
4739 : type(desc_t),pointer :: desc_q ! desc_k,
4740 0 : type(__slkmat_t) :: chi_rgp
4741 : type(c_ptr) :: void_ptr
4742 : !arrays
4743 0 : integer :: sc_ngfft(18), gg(3), g0_kq(3), mask_qibz(gwr%nqibz), need_kibz(gwr%nkibz), got_kibz(gwr%nkibz), units(2)
4744 0 : integer,allocatable :: green_scgvec(:,:), chi_scgvec(:,:)
4745 0 : logical :: select_my_kbz(gwr%my_nkbz)
4746 : real(dp) :: kk_bz(3), kpq_bz(3), qq_ibz(3), tsec(2)
4747 0 : complex(gwp) ABI_ASYNC, contiguous, pointer :: gt_scbox(:,:,:)
4748 0 : complex(gwp),allocatable :: low_wing_q(:), up_wing_q(:), cemiqr(:)
4749 : !complex(gwp),contiguous, pointer :: buf_cplx(:,:)
4750 0 : type(__slkmat_t) :: gkq_rpr_pm(2, gwr%nsig_ab), gk_rpr_pm(2, gwr%nsig_ab), work2, work1, chiq_ggp
4751 0 : type(__slkmat_t),target,allocatable :: gt_gpr(:,:,:), chiq_gpr(:), chiq_rpr(:)
4752 0 : type(desc_t),target,allocatable :: desc_mykbz(:)
4753 0 : type(littlegroup_t),allocatable :: ltg_qibz(:)
4754 : type(fftbox_plan3_t) :: green_plan
4755 0 : type(uplan_t) :: uplan_q
4756 : ! *************************************************************************
4757 :
4758 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
4759 0 : call timab(1923, 1, tsec)
4760 :
4761 0 : units = [std_out, ab_out]
4762 0 : gpu_option = gwr%dtset%gpu_option
4763 :
4764 0 : ABI_CHECK(gwr%tchi_space == "none", sjoin("tchi_space: ", gwr%tchi_space, " != none"))
4765 0 : gwr%tchi_space = "itau"
4766 :
4767 : ! Allocate tchi_q(g,g') matrices
4768 0 : mask_qibz = 0; mask_qibz(gwr%my_qibz_inds(:)) = 1
4769 0 : call gwr%print_mem([std_out])
4770 :
4771 0 : call gwr%malloc_free_mats(mask_qibz, "tchi", "malloc")
4772 0 : max_abs_imag_chit = zero
4773 :
4774 : ! Setup FFT mesh in the supercell.
4775 0 : sc_ngfft = gwr%g_ngfft
4776 0 : sc_ngfft(1:3) = gwr%ngkpt * gwr%g_ngfft(1:3); sc_ngfft(4:6) = sc_ngfft(1:3)
4777 0 : sc_nfft = product(sc_ngfft(1:3)); sc_nfftsp = sc_nfft !* gwr%nspinor
4778 :
4779 0 : if (gwr%use_supercell_for_tchi) then
4780 : ! ============================
4781 : ! Chi algorithm with supercell
4782 : ! ============================
4783 0 : call print_chi_header()
4784 :
4785 : ! Be careful when using the FFT plan with ndat as ndat can change inside the loop if we start to block.
4786 : ! Perhaps the safest approach would be to generate the plan on the fly.
4787 0 : max_ndat = gwr%sc_batch_size
4788 0 : use_mpi_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
4789 : !use_mpi_for_k = .False.
4790 :
4791 0 : use_shmem_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
4792 0 : use_shmem_for_k = use_shmem_for_k .and. gwr%kpt_comm%can_use_shmem()
4793 0 : if (gwr%dtset%userie == 234) use_shmem_for_k = .False.
4794 : #ifndef HAVE_MPI_ALLOCATE_SHARED_CPTR
4795 : use_shmem_for_k = .False.
4796 : #endif
4797 :
4798 0 : if (use_shmem_for_k) then
4799 0 : buf_count = 2 * (sc_nfftsp * max_ndat * 2)
4800 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, gt_scbox_win)
4801 0 : call c_f_pointer(void_ptr, gt_scbox, shape=[sc_nfftsp, max_ndat, 2])
4802 : end if
4803 :
4804 0 : call wrtout(std_out, sjoin(" use_mpi_for_k:", yesno(use_mpi_for_k)))
4805 0 : call wrtout(std_out, sjoin(" use_shmem_for_k:", yesno(use_shmem_for_k)))
4806 0 : mem_mb = (sc_nfftsp * max_ndat * 2 * gwp) * b2Mb
4807 0 : call wrtout(std_out, sjoin(" Memory for gt_scbox array:", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4808 :
4809 0 : if (.not. use_shmem_for_k) then
4810 0 : ABI_MALLOC(gt_scbox, (sc_nfftsp, max_ndat, 2))
4811 : #ifdef HAVE_OPENMP_OFFLOAD
4812 : !$OMP TARGET ENTER DATA MAP(alloc:gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) IF (gpu_option == ABI_GPU_OPENMP)
4813 : #endif
4814 : end if
4815 :
4816 : ! Build plan for dense FFTs.
4817 0 : call green_plan%from_ngfft(sc_ngfft, max_ndat*2, gpu_option)
4818 :
4819 : ! The g-vectors in the supercell for G and tchi.
4820 0 : ABI_MALLOC(green_scgvec, (3, gwr%green_mpw))
4821 0 : ABI_MALLOC(chi_scgvec, (3, gwr%tchi_mpw))
4822 0 : ABI_MALLOC(gt_gpr, (2, gwr%my_nkbz, gwr%nsig_ab))
4823 0 : ABI_MALLOC(chiq_gpr, (gwr%my_nqibz))
4824 0 : ABI_MALLOC(desc_mykbz, (gwr%my_nkbz))
4825 :
4826 0 : ABI_MALLOC(cemiqr, (gwr%g_nfft)) ! The phase e^{-iq.r} in the unit cell.
4827 : #ifdef HAVE_OPENMP_OFFLOAD
4828 : !$OMP TARGET ENTER DATA MAP(alloc:cemiqr) IF (gpu_option == ABI_GPU_OPENMP)
4829 : #endif
4830 :
4831 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4832 0 : call wrtout(std_out, " Allocating PBLAS arrays for tchi_q(g',r) for all q in the IBZ treated by this MPI rank.")
4833 0 : call wrtout(std_out, " Here we're gonna have a big allocation peak...")
4834 : ! TODO: To reduce memory one could use a diagonal approximation for chi at large G so that we can use a smaller ecuteps.
4835 :
4836 0 : do my_iqi=1,gwr%my_nqibz
4837 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
4838 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
4839 0 : ncol_glob = gwr%g_nfft
4840 0 : ABI_CHECK(block_dist_1d(ncol_glob, gwr%g_comm%nproc, col_bsize, msg), msg)
4841 0 : call chiq_gpr(my_iqi)%init(npw, gwr%g_nfft, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
4842 0 : if (gwr%comm%me == 0 .and. mod(my_iqi, 2) == 0) call pstat_proc%print(_PSTAT_ARGS_)
4843 : end do
4844 :
4845 0 : mem_mb = sum(slk_array_locmem_mb(chiq_gpr))
4846 0 : call wrtout(std_out, sjoin(" Local memory for Chi_q(g',r) matrices: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4847 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4848 :
4849 0 : select_my_kbz = .True.
4850 : !nkf_batch_size = gwr%my_nkbz
4851 :
4852 : ! Loop over my spins and my taus.
4853 0 : do my_is=1,gwr%my_nspins
4854 0 : spin = gwr%my_spins(my_is)
4855 0 : do my_it=1,gwr%my_ntau
4856 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
4857 0 : itau = gwr%my_itaus(my_it)
4858 :
4859 : ! TODO: To reduce memory one could allocate and then accumulate chi only for a subset of k-points in the BZ
4860 : ! inside an extra loop over k-groups. This increase the number of FFTs by ngroups but memory decreases
4861 : ! get_myk_green_gpr should receive a mask and box2gsph should accumulate for ik_group > 1.
4862 : ! First of all, I need to undestand if get_myk_green_gpr is responsible for the OOM (very likely)
4863 :
4864 : ! This trick cannot be used for chi as we have GG but it might be implemented for GW
4865 : ! where Sigma = G1_k W + G2_k W + G3_k W ...
4866 :
4867 : !do my_ikf_start=1, gwr%my_nkbz, nkf_batch_size
4868 : ! nkf_now = blocked_loop(my_ikf_start, gwr%my_nkbz, nkf_batch_size)
4869 : ! my_ikf_stop = min(my_ikf_start + nkf_now, gwr%my_nkbz)
4870 : ! !select_my_kbz = .False.; select_my_kbz(my_ifk_start:my_ifk_stop) = .True.
4871 : ! !op_type = OP_COPY; if (my_ifk_start /= 0) op_type = OP_SUM
4872 : !end do ! my_ifk_start
4873 :
4874 : ! G_k(g,g') --> G_k(g',r) e^{ik.r} for each k in the BZ treated by me.
4875 0 : call gwr%get_myk_green_gpr(itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
4876 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4877 :
4878 : ! Loop over r in the unit cell that is now MPI-distributed inside g_comm.
4879 : ! This is a bottleneck but perhaps one can take advantage of localization.
4880 : ! Also, one can save all the FFTs in a matrix G(mnfft * ndat, my_nkbz) multiply by the e^{-ikr} phase
4881 : ! and then use zgemm to compute Out(r,L) = [e^{-ikr}G_k(r)] e^{-ikL} with precomputed e^{-iLk} phases.
4882 0 : my_nr = gt_gpr(1,1,1)%size_local(2)
4883 0 : do my_ir=1, my_nr, gwr%sc_batch_size
4884 0 : ndat = blocked_loop(my_ir, my_nr, gwr%sc_batch_size)
4885 0 : print_time = (gwr%comm%me == 0 .and. (my_ir <= 6 * gwr%sc_batch_size .or. mod(my_ir, LOG_MODR) == 0))
4886 0 : if (print_time) call cwtime(cpu_ir, wall_ir, gflops_ir, "start")
4887 0 : do iab=1, gwr%nsig_ab
4888 :
4889 : ! TODO: GPU version
4890 0 : if (.not. use_shmem_for_k) then
4891 :
4892 : ! Insert G_k(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir).
4893 0 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox)
4894 : #ifdef HAVE_OPENMP_OFFLOAD
4895 : !$omp target update to(gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
4896 : #endif
4897 :
4898 0 : if (.not. use_mpi_for_k) then
4899 : ! G(G',r) --> G(R',r) = sum_{k,g'} e^{-i(k+g').R'} G_k(g',r)
4900 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_sum(gt_scbox, gwr%kpt_comm%value, ierr)
4901 0 : call green_plan%execute(gt_scbox(:,1,1), -1, max_ndat*2, iscale=0)
4902 :
4903 : ! Compute tchi(R',r) for this r and store it in (:,:,1). Note that results are real so one might use r2c FFT.
4904 : ! Then back to tchi(G'=q+g',r) immediately with isign + 1.
4905 : !gt_scbox(:,:,1) = gt_scbox(:,:,1) * conjg(gt_scbox(:,:,2))
4906 : #ifdef HAVE_OPENMP_OFFLOAD
4907 : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(2) MAP(to:gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) IF (gpu_option == ABI_GPU_OPENMP)
4908 : #endif
4909 0 : do idat=1,max_ndat
4910 0 : do ifft=1,sc_nfftsp
4911 0 : gt_scbox(ifft,idat,1) = gt_scbox(ifft,idat,1) * conjg(gt_scbox(ifft,idat,2))
4912 : end do
4913 : end do
4914 : !max_abs_imag_chit = max(max_abs_imag_chit, maxval(abs(aimag(gt_scbox(:,:,1)))))
4915 :
4916 0 : call green_plan%execute(gt_scbox(:,1,1), +1, max_ndat*2)
4917 : #ifdef HAVE_OPENMP_OFFLOAD
4918 : !$omp target update from(gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
4919 : #endif
4920 :
4921 : else
4922 : ! Reduce one G_k(tau) on the idat-1 proc and perform ndat FFTs in parallel.
4923 : ! Finally, broadcast from the (idat-1) proc inside gwr%kpt_comm.
4924 0 : do ipm=1,2
4925 0 : do idat=1,ndat
4926 0 : call xmpi_sum_master(gt_scbox(:,idat,ipm), idat-1, gwr%kpt_comm%value, ierr)
4927 : end do
4928 : end do
4929 0 : idat = gwr%kpt_comm%me + 1
4930 0 : do ipm=1,2
4931 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
4932 : end do
4933 0 : gt_scbox(:,idat,1) = gt_scbox(:,idat,1) * conjg(gt_scbox(:,idat,2))
4934 0 : call green_plan%execute(gt_scbox(:,idat,1), +1, ndat=1)
4935 0 : do idat=1,ndat
4936 0 : call xmpi_bcast(gt_scbox(:,idat,1), idat-1, gwr%kpt_comm%value, ierr)
4937 : end do
4938 : end if
4939 :
4940 : else
4941 : ! use_shmem_for_k --> MPI shared window version. Only gt_scbox is shared.
4942 :
4943 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox, &
4944 0 : gt_scbox_win=gt_scbox_win)
4945 :
4946 : ! Now each MPI proc operates on different idat entries.
4947 : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
4948 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! Start the RMA epoch
4949 0 : idat = gwr%kpt_comm%me + 1
4950 0 : if (idat <= ndat) then
4951 0 : do ipm=1,2
4952 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
4953 : end do
4954 0 : gt_scbox(:,idat,1) = gt_scbox(:,idat,1) * conjg(gt_scbox(:,idat,2))
4955 0 : call green_plan%execute(gt_scbox(:,idat,1), +1, ndat=1)
4956 : end if
4957 : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
4958 : !call xmpi_barrier(gwr%kpt_comm%value)
4959 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! End the RMA epoch
4960 : end if
4961 :
4962 : ! Now extract tchi_q(g',r) on the ecuteps (q+g)-sphere from the FFT box in the supercell
4963 : ! and save data in chiq_gpr PBLAS matrix. Only my q-points in the IBZ are considered.
4964 : ! Alternatively, one can avoid the above FFT, use zero-padded to go from the supercell
4965 : ! to the ecuteps g-sphere inside the my_iqi loop. This approach should play well with k-point parallelism.
4966 0 : do my_iqi=1,gwr%my_nqibz
4967 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz); desc_q => gwr%tchi_desc_qibz(iq_ibz)
4968 0 : gg = nint(qq_ibz * gwr%ngqpt)
4969 0 : do ig=1,desc_q%npw
4970 0 : chi_scgvec(:,ig) = gg + gwr%ngqpt(:) * desc_q%gvec(:,ig) ! q+g
4971 : end do
4972 : call box2gsph(merge(OP_COPY, OP_ACC, iab == 1),&
4973 : sc_ngfft, desc_q%npw, ndat, chi_scgvec, &
4974 0 : gt_scbox(:,1,1), chiq_gpr(my_iqi)%buffer_cplx(:,my_ir))
4975 : ! TODO:
4976 : !call desc_q%box2gsph(qq_ibz, gwr%ngqpt, sc_ngfft, gwr%nspinor * ndat, &
4977 : ! gt_scbox(:,1,1), chiq_gpr(my_iqi)%buffer_cplx(:,my_ir))
4978 : end do ! my_iqi
4979 : end do ! iab
4980 :
4981 0 : if (print_time) then
4982 0 : write(msg,'(4x,3(a,i0),a)')"Chi my_ir [", my_ir, "/", my_nr, "] (tot: ", gwr%g_nfft, ")"
4983 0 : call cwtime_report(msg, cpu_ir, wall_ir, gflops_ir)
4984 : end if
4985 : end do ! my_ir (end cpu intensive loop)
4986 :
4987 : ! Free descriptors and PBLAS matrices in kBZ.
4988 0 : call desc_array_free(desc_mykbz); call slk_array_free(gt_gpr)
4989 :
4990 : ! Now we have tchi_q(g',r).
4991 : ! For each IBZ q-point treated by this MPI proc, do:
4992 : !
4993 : ! 1) MPI transpose to have tchi_q(r,g')
4994 : ! 2) FFT along the first dimension to get tchi_q(g,g') and store it in gwr%tchi_qibz
4995 : !
4996 0 : tchi_rfact = one / gwr%g_nfft / gwr%cryst%ucvol / (gwr%nkbz * gwr%nqbz)
4997 :
4998 0 : do my_iqi=1,gwr%my_nqibz
4999 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
5000 0 : q_is_gamma = normv(gwr%qibz(:,iq_ibz), gwr%cryst%gmet, "G") < GW_TOLQ0
5001 0 : desc_q => gwr%tchi_desc_qibz(iq_ibz)
5002 :
5003 : ! Note the minus sign in q.
5004 0 : call calc_ceikr(-gwr%qibz(:,iq_ibz), gwr%g_ngfft, gwr%g_nfft, 1, cemiqr)
5005 0 : cemiqr = cemiqr * tchi_rfact
5006 : #ifdef HAVE_OPENMP_OFFLOAD
5007 : !$omp target update to(cemiqr) if (gpu_option == ABI_GPU_OPENMP)
5008 : #endif
5009 :
5010 : ! MPI-transposition: tchi_q(g',r) => tchi_q(r,g')
5011 0 : call chiq_gpr(my_iqi)%ptrans("N", chi_rgp)
5012 :
5013 : ! FFT tchi_q(r,g') --> tchi_q(g,g'). Results stored in gwr%tchi_qibz.
5014 : call uplan_q%init(desc_q%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, istwfk1, &
5015 0 : desc_q%gvec, gwp, gpu_option)
5016 :
5017 0 : gpu_mode = 1
5018 0 : do ig2=1, chi_rgp%size_local(2), gwr%uc_batch_size
5019 0 : ndat = blocked_loop(ig2, chi_rgp%size_local(2), gwr%uc_batch_size)
5020 :
5021 : call uplan_q%execute_rg(ndat, chi_rgp%buffer_cplx(:, ig2), &
5022 0 : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:, ig2), phase_r=cemiqr, gpu_mode=gpu_mode)
5023 : end do ! ig2
5024 :
5025 0 : call uplan_q%free()
5026 0 : call chi_rgp%free()
5027 :
5028 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%set_imag_diago_to_zero(local_max)
5029 : end do ! my_iqi
5030 :
5031 0 : write(msg,'(3(a,i0),a)')" My itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
5032 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau, end_str=ch10)
5033 : end do ! my_it
5034 : end do ! my_is
5035 :
5036 0 : if (use_shmem_for_k) then
5037 0 : call xmpi_win_free(gt_scbox_win, ierr)
5038 : else
5039 : #ifdef HAVE_OPENMP_OFFLOAD
5040 : !$OMP TARGET EXIT DATA MAP(delete: gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
5041 : #endif
5042 0 : ABI_FREE(gt_scbox)
5043 : end if
5044 :
5045 0 : ABI_FREE(green_scgvec)
5046 0 : ABI_FREE(chi_scgvec)
5047 0 : ABI_FREE(gt_gpr)
5048 0 : ABI_FREE(desc_mykbz)
5049 0 : call slk_array_free(chiq_gpr)
5050 0 : ABI_FREE(chiq_gpr)
5051 0 : call green_plan%free()
5052 :
5053 : #ifdef HAVE_OPENMP_OFFLOAD
5054 : !$OMP TARGET EXIT DATA MAP(delete:cemiqr) IF (gpu_option == ABI_GPU_OPENMP)
5055 : #endif
5056 0 : ABI_FREE(cemiqr)
5057 :
5058 : else ! not gwr%use_supercell_for_tchi
5059 : ! ===================================================================
5060 : ! Mixed-space algorithm in the unit cell with convolutions in k-space
5061 : ! ===================================================================
5062 0 : call print_chi_header()
5063 :
5064 0 : call wrtout(std_out, " Allocating memory for G_k(r',r) and chi_q(r',r)...")
5065 0 : call wrtout(std_out, " Here we're gonna have a big allocation peak...")
5066 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5067 :
5068 : ! Need all nqibz matrices in chi_q here as the iq_ibz loop is the innermost one unlike in the legacy GW code.
5069 0 : nr = gwr%g_nfft
5070 0 : col_bsize = nr / gwr%g_comm%nproc; if (mod(nr, gwr%g_comm%nproc) /= 0) col_bsize = col_bsize + 1
5071 0 : tchi_rfact = one / gwr%cryst%ucvol
5072 :
5073 0 : gpu_action = "None";
5074 0 : if (gpu_option == ABI_GPU_OPENMP) then
5075 0 : gpu_action = "alloc"; call wrtout(std_out, " Allocating Chi_q(r,r', +tau) on the GPU...")
5076 : end if
5077 :
5078 0 : ABI_MALLOC(chiq_rpr, (gwr%nqibz))
5079 0 : do iq_ibz=1,gwr%nqibz
5080 0 : call chiq_rpr(iq_ibz)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize], gpu_action=gpu_action)
5081 : end do
5082 :
5083 0 : call pstat_proc%print(_PSTAT_ARGS_)
5084 :
5085 : ! Allocate G_k(r',r, +/- tau) and G_kq(r',r, +/- tau)
5086 : ! TODO: Can save memory here as we don't need +/- tau for each k+q.
5087 0 : do ipm=1,2
5088 0 : do iab=1,gwr%nsig_ab
5089 0 : call gk_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
5090 0 : call gkq_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
5091 : end do
5092 : end do
5093 :
5094 0 : mem_mb = sum(slk_array_locmem_mb(chiq_rpr)) + sum(slk_array_locmem_mb(gk_rpr_pm)) + sum(slk_array_locmem_mb(gkq_rpr_pm))
5095 0 : call wrtout(std_out, sjoin(" Local memory for Chi_q(r',r) (gt_gpr): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
5096 0 : call pstat_proc%print(_PSTAT_ARGS_)
5097 :
5098 : ! The little group is needed when symchi == 1 (default)
5099 : ! If use_umklp == 1 then symmetries requiring an umklapp to preserve qibz are included as well.
5100 : ! TODO: Note that TR is not yet supported so timrev is set to 1 even if TR has been used to generate the GS IBZ.
5101 0 : ABI_MALLOC(ltg_qibz, (gwr%nqibz))
5102 0 : use_umklp = 0
5103 : !gw_timrev = kpts_timrev_from_kptopt(gwr%ks_ebands%kptopt) + 1
5104 0 : do iq_ibz=1,gwr%nqibz
5105 : call ltg_qibz(iq_ibz)%init(gwr%qibz(:,iq_ibz), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, &
5106 0 : npwe=gwr%tchi_desc_qibz(iq_ibz)%npw, gvec=gwr%tchi_desc_qibz(iq_ibz)%gvec)
5107 : !call ltg_qibz(iq_ibz)%init(gwr%qibz(:,iq_ibz), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, npwe=0, timrev=1)
5108 0 : if (gwr%comm%me == 0) call ltg_qibz(iq_ibz)%print([std_out], prtvol=gwr%dtset%prtvol)
5109 : end do
5110 :
5111 : ! Compute mask with the k+q points in the IBZ required by this MPI proc.
5112 0 : need_kibz = 0
5113 0 : do my_ikf=1,gwr%my_nkbz
5114 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
5115 0 : do iq_ibz=1,gwr%nqibz
5116 0 : qq_ibz = gwr%qibz(:, iq_ibz); kpq_bz = kk_bz + qq_ibz
5117 0 : call findqg0(ikq_bz, g0_kq, kpq_bz, gwr%nkbz, gwr%kbz, gwr%mG0)
5118 : ! TODO: here I may need to take into account the umklapp
5119 : !ABI_CHECK(all(g0_kq == 0), sjoin("g0_kq != 0, kk_bz", ktoa(kpq_bz), "qq_ibz:", ktoa(qq_ibz)))
5120 0 : ikq_ibz = gwr%kbz2ibz(1, ikq_bz)
5121 0 : need_kibz(ikq_ibz) = 1
5122 : end do
5123 : end do
5124 :
5125 : ! Begin loop over spin and tau points.
5126 0 : do my_is=1,gwr%my_nspins
5127 0 : spin = gwr%my_spins(my_is)
5128 0 : do my_it=1,gwr%my_ntau
5129 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
5130 0 : itau = gwr%my_itaus(my_it)
5131 :
5132 : ! Redistribute G_k(g,g') with k in the IBZ so that each MPI proc
5133 : ! can reconstruct G_{k+q} in the BZ inside the MPI-distributed loops.
5134 : ! TODO: support for ipm_list else we have a memory leak.
5135 0 : call gwr%redistrib_gt_kibz(itau, spin, need_kibz, got_kibz, "communicate") !ipm_list=
5136 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5137 :
5138 : ! Sum over my k-points in the BZ.
5139 0 : if (gpu_option == ABI_GPU_OPENMP) then
5140 0 : call slk_array_gpu_set_zero(chiq_rpr)
5141 : else
5142 0 : call slk_array_set_zero(chiq_rpr)
5143 : end if
5144 :
5145 0 : do my_ikf=1,gwr%my_nkbz
5146 0 : print_time = gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0)
5147 0 : if (print_time) call cwtime(cpu_ikf, wall_ikf, gflops_ikf, "start")
5148 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
5149 :
5150 : ! Use symmetries to get G_kbz(g,g') from the IBZ, then G_kbz(g,g') -> G_kbz(r',r).
5151 : ! TODO: here I may need to take into account the umklapp
5152 0 : call gwr%get_gkbz_rpr_pm(ik_bz, itau, spin, gk_rpr_pm, ipm_list=[1]) ! g0=??
5153 :
5154 : ! Accumulate contribution to chi_q(r',r) with q in the IBZ.
5155 0 : do iq_ibz=1,gwr%nqibz
5156 0 : if (gwr%dtset%symchi /= 0 .and. ltg_qibz(iq_ibz)%ibzq(ik_bz) == 0) cycle
5157 0 : qq_ibz = gwr%qibz(:,iq_ibz); kpq_bz = kk_bz + qq_ibz
5158 :
5159 0 : call findqg0(ikq_bz, g0_kq, kpq_bz, gwr%nkbz, gwr%kbz, gwr%mG0)
5160 : ! TODO: here I may need to take into account the umklapp if k+q is outside the BZ.
5161 : !ABI_CHECK(all(g0_kq == 0), sjoin("g0_kq != 0, kk_bz", ktoa(kpq_bz), "qq_ibz:", ktoa(qq_ibz)))
5162 :
5163 : ! Use symmetries to get G_kqbz(g,g') from the IBZ, then G_kqbz(g,g') -> G_kqbz(r',r).
5164 : ! Note that only G_kq(-itau) is needed.
5165 0 : call gwr%get_gkbz_rpr_pm(ikq_bz, itau, spin, gkq_rpr_pm, g0=g0_kq, ipm_list=[2])
5166 :
5167 : ! The weight depends on q_ibz and the symmetries of the little group of qq_ibz.
5168 0 : wtqp = one / gwr%nkbz; wtqm = zero
5169 0 : if (gwr%dtset%symchi /= 0) then
5170 0 : wtqp = (one * sum(ltg_qibz(iq_ibz)%wtksym(1,:,ik_bz))) / gwr%nkbz
5171 0 : wtqm = (one * sum(ltg_qibz(iq_ibz)%wtksym(2,:,ik_bz))) / gwr%nkbz
5172 : !ABI_CHECK(wtqm == zero, sjoin("TR is not yet implemented:, wqtm:", ftoa(wtqm)))
5173 : end if
5174 :
5175 : ! Accumulate.
5176 :
5177 : !chiq_rpr(iq_ibz)%buffer_cplx = chiq_rpr(iq_ibz)%buffer_cplx + &
5178 : ! wtqp * gk_rpr_pm(1)%buffer_cplx * conjg(gkq_rpr_pm(2)%buffer_cplx) ! RECHECK EQ. This one works but requires ptrans with C
5179 : ! !wtqp * gkq_rpr_pm(1)%buffer_cplx * conjg(gk_rpr_pm(2)%buffer_cplx) ! This should be OK
5180 0 : do iab=1,gwr%nsig_ab
5181 : call cplx_mat_plus_bc(chiq_rpr(iq_ibz)%bufsize, chiq_rpr(iq_ibz)%buffer_cplx(:,1), &
5182 0 : wtqp+wtqm, "C", gkq_rpr_pm(2, iab)%buffer_cplx(:,1), gk_rpr_pm(1, iab)%buffer_cplx(:,1), gpu_option)
5183 : end do ! iab
5184 :
5185 : end do ! iq_ibz
5186 :
5187 0 : if (print_time) then
5188 0 : write(msg,'(4x,3(a,i0),a)')"Chi my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
5189 0 : call cwtime_report(msg, cpu_ikf, wall_ikf, gflops_ikf)
5190 : end if
5191 : end do ! my_ikf
5192 :
5193 : ! Deallocate got_kibz Green's functions.
5194 0 : call gwr%redistrib_gt_kibz(itau, spin, need_kibz, got_kibz, "free")
5195 :
5196 : ! From chi_q(r',r) to chi_q(g,g') for each q in the IBZ.
5197 0 : do iq_ibz=1,gwr%nqibz
5198 0 : call xmpi_sum(chiq_rpr(iq_ibz)%buffer_cplx, gwr%kpt_comm%value, ierr)
5199 : end do
5200 :
5201 0 : tchi_rfact = one / gwr%cryst%ucvol
5202 0 : do iq_ibz=1,gwr%nqibz
5203 0 : if (.not. any(iq_ibz == gwr%my_qibz_inds)) cycle
5204 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%copy(chiq_ggp, empty=.True.)
5205 0 : call gwr%rpr_to_ggp(gwr%tchi_desc_qibz(iq_ibz), chiq_rpr(iq_ibz), tchi_rfact, chiq_ggp)
5206 0 : call chiq_ggp%copy(work1, empty=.True.)
5207 :
5208 : ! Here we symmetrize chi0 to get the integral in the BZ.
5209 : ! This section is needed only if symchi /= 0.
5210 : ! TODO: Timrev should be tested. At present is disabled.
5211 : associate(desc => gwr%tchi_desc_qibz(iq_ibz), ltg => ltg_qibz(iq_ibz))
5212 0 : call gwr%rpr_to_ggp(gwr%tchi_desc_qibz(iq_ibz), chiq_rpr(iq_ibz), tchi_rfact, chiq_ggp)
5213 0 : do itim=1, ltg%timrev
5214 0 : do isym=1, ltg%nsym_sg
5215 0 : if (ltg%preserve(itim,isym) /= 1) cycle
5216 : associate(sglist => desc%rottbm1(ltg%igmG0(1:desc%npw, itim, isym), itim, isym), &
5217 0 : phase => desc%phmGt(:, isym))
5218 0 : call slk_array_set_zero(work1)
5219 : ! (g,g') --> (Sg, g')
5220 0 : do ig2=1,work1%size_local(2)
5221 0 : if (itim == 1) then
5222 0 : work1%buffer_cplx(:,ig2) = chiq_ggp%buffer_cplx(sglist, ig2) * phase
5223 : else
5224 0 : work1%buffer_cplx(:,ig2) = GWPC_CONJG(chiq_ggp%buffer_cplx(sglist, ig2)) * phase
5225 : end if
5226 : end do
5227 : ! (Sg, g') --> (g', Sg)
5228 0 : call work1%ptrans("C", work2, free=.False.)
5229 : ! (g', Sg) --> (Sg', Sg)
5230 0 : do ig2=1,work2%size_local(2)
5231 0 : work2%buffer_cplx(:,ig2) = work2%buffer_cplx(sglist, ig2) * phase
5232 : end do
5233 : ! (Sg', Sg) --> (Sg, Sg')
5234 0 : call work2%ptrans("C", work1, free=.True.)
5235 0 : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) = gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:)+work1%buffer_cplx(:,:)
5236 : end associate
5237 : end do ! isym
5238 : end do ! itim
5239 :
5240 0 : call work1%free()
5241 : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) = gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) &
5242 0 : & / ltg%nsym_ltg
5243 :
5244 : end associate
5245 0 : call chiq_ggp%free()
5246 : end do ! iq_ibz
5247 :
5248 0 : write(msg,'(3(a,i0),a)')" My itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
5249 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau)
5250 : end do ! my_it
5251 : end do ! spin
5252 :
5253 : ! Free memory
5254 0 : call slk_array_free(gk_rpr_pm); call slk_array_free(gkq_rpr_pm); call slk_array_free(chiq_rpr)
5255 0 : ABI_FREE(chiq_rpr)
5256 :
5257 0 : do iq_ibz=1,gwr%nqibz
5258 0 : call ltg_qibz(iq_ibz)%free()
5259 : end do
5260 0 : ABI_FREE(ltg_qibz)
5261 0 : call wrtout(std_out, " Mixed space algorithm for chi completed.")
5262 :
5263 : end if ! super cell or mixed space algorithm.
5264 : !call wrtout(std_out, sjoin(" max_abs_imag_chit", ftoa(max_abs_imag_chit)))
5265 :
5266 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5267 :
5268 : ! Print trace of chi_q(i tau) matrices for testing purposes.
5269 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "tchi_qibz")
5270 :
5271 : ! Write tchi(i tau). NB: this option is not documented in the docs.
5272 0 : keep_tchim = .False.
5273 0 : if (gwr%dtset%prtsuscep == -1) then
5274 0 : call gwr%ncwrite_tchi_wc("tchi", "tau", keep_tchim, trim(gwr%dtfil%filnam_ds(4))//'_TCHIM.nc')
5275 0 : keep_tchim = .True.
5276 : end if
5277 :
5278 : ! Transform irreducible tchi from imaginary tau to imaginary omega.
5279 : ! Also, sum over spins to get total tchi if collinear spin.
5280 0 : call gwr%cos_transform("tchi", "it2w", sum_spins=.True.)
5281 :
5282 0 : if (gwr%kpt_comm%me == 0) then
5283 : ! ===================================================
5284 : ! ==== Construct head and wings from the tensor =====
5285 : ! ===================================================
5286 : associate (desc_q0 => gwr%tchi_desc_qibz(1), mat_ts => gwr%tchi_qibz(1,:,:))
5287 0 : ABI_CHECK_IEQ(desc_q0%ig0, 1, "ig0 should be 1")
5288 0 : ABI_MALLOC(up_wing_q, (desc_q0%npw))
5289 0 : ABI_MALLOC(low_wing_q, (desc_q0%npw))
5290 :
5291 0 : do my_is=1,gwr%my_nspins
5292 0 : spin = gwr%my_spins(my_is)
5293 0 : do my_it=1,gwr%my_ntau
5294 0 : itau = gwr%my_itaus(my_it)
5295 :
5296 0 : do ig=2,desc_q0%npw
5297 0 : wng = gwr%chi0_uwing_myw(:,ig, my_it)
5298 0 : up_wing_q(ig) = vdotw(gwr%q0, wng, gwr%cryst%gmet, "G")
5299 0 : wng = gwr%chi0_lwing_myw(:,ig,my_it)
5300 0 : low_wing_q(ig) = vdotw(gwr%q0, wng, gwr%cryst%gmet, "G")
5301 : end do
5302 0 : chq = matmul(gwr%chi0_head_myw(:,:,my_it), gwr%q0)
5303 0 : head_q = vdotw(gwr%q0, chq, gwr%cryst%gmet, "G")
5304 :
5305 0 : call mat_ts(itau, spin)%set_head_and_wings(head_q, low_wing_q, up_wing_q)
5306 : end do ! my_it
5307 : end do ! my_is
5308 : end associate
5309 0 : ABI_FREE(up_wing_q)
5310 0 : ABI_FREE(low_wing_q)
5311 : end if
5312 :
5313 : ! Print trace of chi_q(i omega) matrices for testing purposes.
5314 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "tchi_qibz")
5315 :
5316 : ! Write file with chi0(i omega).
5317 0 : if (abs(gwr%dtset%prtsuscep) == 1) then
5318 0 : call gwr%ncwrite_tchi_wc("tchi", "omega", keep_tchim, trim(gwr%dtfil%filnam_ds(4))//'_TCHIM.nc')
5319 : end if
5320 :
5321 0 : call cwtime_report(" gwr_build_tchi:", cpu_all, wall_all, gflops_all)
5322 0 : call timab(1923, 2, tsec)
5323 :
5324 : contains
5325 :
5326 0 : subroutine print_chi_header()
5327 0 : if (gwr%comm%me /= 0) return
5328 0 : if (gwr%use_supercell_for_tchi) then
5329 0 : call wrtout(std_out, " Building chi0(r,R, itau) in the supercell with FFTs ", pre_newlines=2)
5330 : else
5331 0 : call wrtout(std_out, " Building chi_q(r,r', itau) with convolutions in k-space:", pre_newlines=2)
5332 : end if
5333 0 : call wrtout(std_out, sjoin(" gwr_np_kgts:", ltoa(gwr%dtset%gwr_np_kgts)))
5334 0 : call wrtout(std_out, sjoin(" ngkpt:", ltoa(gwr%ngkpt), ", ngqpt:", ltoa(gwr%ngqpt)))
5335 0 : call wrtout(std_out, sjoin(" gwr_boxcutmin:", ftoa(gwr%dtset%gwr_boxcutmin)))
5336 0 : call wrtout(std_out, sjoin(" sc_ngfft:", ltoa(sc_ngfft(1:8))))
5337 0 : call wrtout(std_out, sjoin(" my_ntau:", itoa(gwr%my_ntau), ", ntau:", itoa(gwr%ntau)))
5338 0 : call wrtout(std_out, sjoin(" my_nkbz:", itoa(gwr%my_nkbz), ", nkbz:", itoa(gwr%nkbz)))
5339 0 : call wrtout(std_out, sjoin(" my_nkibz:", itoa(gwr%my_nkibz), ", nkibz:", itoa(gwr%nkibz)))
5340 0 : call wrtout(std_out, sjoin("- FFT uc_batch_size:", itoa(gwr%uc_batch_size)))
5341 0 : call wrtout(std_out, sjoin("- FFT sc_batch_size:", itoa(gwr%sc_batch_size)), do_flush=.True.)
5342 : end subroutine print_chi_header
5343 :
5344 : end subroutine gwr_build_tchi
5345 : !!***
5346 :
5347 : !----------------------------------------------------------------------
5348 :
5349 : !!****f* m_gwr/gwr_redistrib_gt_kibz
5350 : !! NAME
5351 : !! gwr_redistrib_gt_kibz
5352 : !!
5353 : !! FUNCTION
5354 : !! Redistribute/deallocate G_k
5355 : !!
5356 : !! If action == "communicate":
5357 : !! Redistribute G_k for fixed (itau, spin) according to `need_kibz` table.
5358 : !! Also, set got_kibz to 1 for each IBZ k-point that has been received.
5359 : !!
5360 : !! If action == "free":
5361 : !! Use input `got_kibz` array to deallocate matrices received in a previous call.
5362 : !!
5363 : !! INPUTS
5364 : !!
5365 : !! OUTPUT
5366 : !!
5367 : !! SOURCE
5368 :
5369 0 : subroutine gwr_redistrib_gt_kibz(gwr, itau, spin, need_kibz, got_kibz, action)
5370 :
5371 : !Arguments ------------------------------------
5372 : class(gwr_t),target,intent(inout) :: gwr
5373 : integer,intent(in) :: itau, spin, need_kibz(gwr%nkibz)
5374 : integer,intent(inout) :: got_kibz(gwr%nkibz)
5375 : character(len=*),intent(in) :: action
5376 : !integer,optional,intent(in) :: ipm_list(:)
5377 :
5378 : !Local variables-------------------------------
5379 0 : integer :: ik_ibz, ipm, ierr, do_mpi_kibz(gwr%nkibz), sender_kibz(gwr%nkibz)
5380 : integer :: bcast_comm, sender_in_bcast_comm, color, iab
5381 : logical :: im_sender
5382 : !integer :: num_pm, ipm_list__(2)
5383 : real(dp) :: kk_ibz(3), cpu, wall, gflops
5384 0 : complex(gwp),contiguous, pointer :: ck_ptr(:,:)
5385 : ! *************************************************************************
5386 :
5387 0 : call cwtime(cpu, wall, gflops, "start")
5388 :
5389 : !num_pm = 2; ipm_list__ = [1, 2]
5390 : !if (present(ipm_list)) then
5391 : ! num_pm = size(ipm_list)
5392 : ! ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
5393 : ! ipm_list__(1:num_pm) = ipm_list(:)
5394 : !end if
5395 :
5396 : select case (action)
5397 : case ("communicate")
5398 0 : do_mpi_kibz = need_kibz
5399 0 : do ik_ibz=1,gwr%nkibz
5400 0 : if (allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) do_mpi_kibz(ik_ibz) = 0
5401 : end do
5402 0 : call xmpi_sum(do_mpi_kibz, gwr%kpt_comm%value, ierr)
5403 : !do_mpi_kibz = 1
5404 :
5405 : ! All procs enter the loop. Sender_kibz stores the rank of the sender in gwr%kpt_comm
5406 0 : got_kibz = 0; sender_kibz(:) = huge(1)
5407 0 : do ik_ibz=1,gwr%nkibz
5408 0 : if (do_mpi_kibz(ik_ibz) == 0) cycle
5409 0 : kk_ibz = gwr%kibz(:, ik_ibz)
5410 0 : if (allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) sender_kibz(ik_ibz) = gwr%kpt_comm%me
5411 0 : if (need_kibz(ik_ibz) /= 0 .and. .not. allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) then
5412 : ! NB: Use same args as those used to init the descriptors in gwr_init
5413 : ! so that the ordering of gvec is consistent across MPI procs.
5414 0 : got_kibz(ik_ibz) = 1
5415 0 : call gwr%green_desc_kibz(ik_ibz)%init(kk_ibz, istwfk1, gwr%dtset%ecutwfn, gwr)
5416 : end if
5417 : end do
5418 :
5419 : ! Define the sender for each kibz in do_mpi_kibz.
5420 0 : call xmpi_min_ip(sender_kibz, gwr%kpt_comm%value, ierr)
5421 :
5422 : ! Allocate memory
5423 0 : call gwr%malloc_free_mats(got_kibz, "green", "malloc")
5424 :
5425 : ! MPI communication
5426 0 : do ik_ibz=1,gwr%nkibz
5427 0 : if (do_mpi_kibz(ik_ibz) == 0) cycle
5428 :
5429 : ! Create subcommunicators with color and bcast only inside subcomm.
5430 0 : im_sender = gwr%kpt_comm%me == sender_kibz(ik_ibz)
5431 0 : color = merge(1, 0, im_sender .or. need_kibz(ik_ibz) /= 0)
5432 0 : call xmpi_comm_split(gwr%kpt_comm%value, color, gwr%kpt_comm%me, bcast_comm, ierr)
5433 :
5434 0 : if (color == 1) then
5435 0 : sender_in_bcast_comm = xmpi_comm_translate_rank(gwr%kpt_comm%value, sender_kibz(ik_ibz), bcast_comm)
5436 0 : do ipm=1,2
5437 0 : do iab=1,gwr%nsig_ab
5438 0 : ck_ptr => gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%buffer_cplx
5439 0 : call xmpi_bcast(ck_ptr, sender_in_bcast_comm, bcast_comm, ierr)
5440 : end do
5441 : end do
5442 : end if
5443 0 : call xmpi_comm_free(bcast_comm)
5444 : end do
5445 :
5446 : case ("free")
5447 : ! Use got_kibz to free previously allocated memory.
5448 0 : do ik_ibz=1,gwr%nkibz
5449 0 : if (got_kibz(ik_ibz) == 1) call gwr%green_desc_kibz(ik_ibz)%free()
5450 : end do
5451 0 : call gwr%malloc_free_mats(got_kibz, "green", "free")
5452 :
5453 : case default
5454 0 : ABI_ERROR(sjoin("Invalid action:", action))
5455 : end select
5456 :
5457 0 : if (action == "communicate") call cwtime_report(" gwr_redistrib_gt_kibz:", cpu, wall, gflops)
5458 :
5459 0 : end subroutine gwr_redistrib_gt_kibz
5460 : !!***
5461 :
5462 : !!****f* m_gwr/gwr_redistrib_mats_qibz
5463 : !! NAME
5464 : !! gwr_redistrib_mats_qibz
5465 : !!
5466 : !! FUNCTION
5467 : !! If action == "communicate":
5468 : !! Redistribute chi_q (wc_q) for fixed (itau, spin) according to `need_qibz` table.
5469 : !! Also, set `got_qibz` to 1 for each IBZ q-point that has been received.
5470 : !! If action == "free":
5471 : !! Use `got_qibz` to deallocate matrices received in a previous call with "communicate".
5472 : !!
5473 : !! INPUTS
5474 : !!
5475 : !! OUTPUT
5476 : !!
5477 : !! SOURCE
5478 :
5479 0 : subroutine gwr_redistrib_mats_qibz(gwr, what, itau, spin, need_qibz, got_qibz, action)
5480 :
5481 : !Arguments ------------------------------------
5482 : class(gwr_t),target,intent(inout) :: gwr
5483 : character(len=*),intent(in) :: what
5484 : integer,intent(in) :: itau, spin, need_qibz(gwr%nqibz)
5485 : integer,intent(inout) :: got_qibz(gwr%nqibz)
5486 : character(len=*),intent(in) :: action
5487 :
5488 : !Local variables-------------------------------
5489 0 : integer :: iq_ibz, ierr, bcast_comm, color, do_mpi_qibz(gwr%nqibz), sender_qibz(gwr%nqibz), sender_in_bcast_comm
5490 : logical :: im_sender
5491 : logical, parameter :: timeit = .False.
5492 : real(dp) :: qq_ibz(3), cpu, wall, gflops
5493 0 : complex(gwp),contiguous, pointer :: cq_ptr(:,:)
5494 : ! *************************************************************************
5495 :
5496 0 : ABI_CHECK(what == "tchi" .or. what == "wc", sjoin("Invalid what:", what))
5497 : if (timeit) call cwtime(cpu, wall, gflops, "start")
5498 :
5499 : select case (action)
5500 : case ("communicate")
5501 0 : do_mpi_qibz = need_qibz
5502 0 : do iq_ibz=1,gwr%nqibz
5503 0 : select case (what)
5504 : case ("tchi")
5505 0 : if (allocated(gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx)) do_mpi_qibz(iq_ibz) = 0
5506 : case ("wc")
5507 0 : if (allocated(gwr%wc_qibz(iq_ibz, itau, spin)%buffer_cplx)) do_mpi_qibz(iq_ibz) = 0
5508 : case default
5509 0 : ABI_ERROR(sjoin("Invalid what:", what))
5510 : end select
5511 : end do
5512 :
5513 0 : call xmpi_sum(do_mpi_qibz, gwr%kpt_comm%value, ierr)
5514 : !do_mpi_qibz = 1
5515 :
5516 : ! All procs enter the loop. Sender_qibz stores the rank of the sender in gwr%kpt_comm
5517 0 : got_qibz = 0; sender_qibz(:) = huge(1)
5518 0 : do iq_ibz=1,gwr%nqibz
5519 0 : if (do_mpi_qibz(iq_ibz) == 0) cycle
5520 0 : qq_ibz = gwr%qibz(:, iq_ibz)
5521 0 : if (allocated(gwr%tchi_desc_qibz(iq_ibz)%gvec)) sender_qibz(iq_ibz) = gwr%kpt_comm%me
5522 0 : if (need_qibz(iq_ibz) /= 0 .and. .not. allocated(gwr%tchi_desc_qibz(iq_ibz)%gvec)) then
5523 : ! NB: Use same args as those used to init the descriptors in gwr_init
5524 : ! so that gvec ordering is consistent across MPI procs.
5525 0 : got_qibz(iq_ibz) = 1
5526 0 : call gwr%tchi_desc_qibz(iq_ibz)%init(qq_ibz, istwfk1, gwr%dtset%ecuteps, gwr, kin_sorted=.True.)
5527 : end if
5528 : end do
5529 :
5530 : ! Define the sender for each qibz in do_mpi_qibz
5531 0 : call xmpi_min_ip(sender_qibz, gwr%kpt_comm%value, ierr)
5532 :
5533 : ! Allocate memory
5534 0 : call gwr%malloc_free_mats(got_qibz, what, "malloc")
5535 :
5536 : ! MPI communication
5537 0 : do iq_ibz=1,gwr%nqibz
5538 0 : if (do_mpi_qibz(iq_ibz) == 0) cycle
5539 :
5540 : ! Create subcommunicators with color and bcast only inside subcomm.
5541 0 : im_sender = gwr%kpt_comm%me == sender_qibz(iq_ibz)
5542 0 : color = merge(1, 0, im_sender .or. need_qibz(iq_ibz) /= 0)
5543 0 : call xmpi_comm_split(gwr%kpt_comm%value, color, gwr%kpt_comm%me, bcast_comm, ierr)
5544 :
5545 0 : if (color == 1) then
5546 0 : if (what == "tchi") cq_ptr => gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx
5547 0 : if (what == "wc") cq_ptr => gwr%wc_qibz(iq_ibz, itau, spin)%buffer_cplx
5548 0 : sender_in_bcast_comm = xmpi_comm_translate_rank(gwr%kpt_comm%value, sender_qibz(iq_ibz), bcast_comm)
5549 0 : call xmpi_bcast(cq_ptr, sender_in_bcast_comm, bcast_comm, ierr)
5550 : end if
5551 0 : call xmpi_comm_free(bcast_comm)
5552 : end do ! iq_ibz
5553 :
5554 : case ("free")
5555 : ! Use got_qibz table to free previously allocated memory
5556 0 : do iq_ibz=1,gwr%nqibz
5557 0 : if (got_qibz(iq_ibz) /= 0) call gwr%tchi_desc_qibz(iq_ibz)%free()
5558 : end do
5559 0 : call gwr%malloc_free_mats(got_qibz, what, "free")
5560 :
5561 : case default
5562 0 : ABI_ERROR(sjoin("Invalid action:", action))
5563 : end select
5564 :
5565 : if (timeit) call cwtime_report(" gwr_redistrib_mats_qibz:", cpu, wall, gflops)
5566 :
5567 0 : end subroutine gwr_redistrib_mats_qibz
5568 : !!***
5569 :
5570 : !----------------------------------------------------------------------
5571 :
5572 : !!****f* m_gwr/gwr_print_trace
5573 : !! NAME
5574 : !! gwr_print_trace
5575 : !!
5576 : !! FUNCTION
5577 : !! Print traces of PBLAS matrices to units.
5578 : !! NB: This is a global routine that should be called by all procs inside gwr%comm.
5579 : !!
5580 : !! INPUTS
5581 : !!
5582 : !! OUTPUT
5583 : !!
5584 : !! SOURCE
5585 :
5586 0 : subroutine gwr_print_trace(gwr, units, what)
5587 :
5588 : !Arguments ------------------------------------
5589 : class(gwr_t),target,intent(inout) :: gwr
5590 : integer,intent(in) :: units(:)
5591 : character(len=*),intent(in) :: what
5592 :
5593 : !Local variables-------------------------------
5594 : integer,parameter :: master = 0
5595 : integer :: my_is, spin, my_it, itau, iq_ibz, ierr, my_iqi, my_iki, ik_ibz, ipm, iab
5596 : character(len=5000) :: comment
5597 0 : complex(dp),allocatable :: ctrace3(:,:,:), ctrace5(:,:,:,:,:) !, ctrace4(:,:,:,:)
5598 0 : type(__slkmat_t),contiguous, pointer :: mats(:,:,:)
5599 : ! *************************************************************************
5600 :
5601 : ! NB: The same q/k point in the IBZ might be available on different procs in kpt_comm
5602 : ! hence we have to rescale the trace before summing the results in gwr%comm.
5603 0 : comment = "Invalid space!"
5604 :
5605 0 : select case (what)
5606 : case ("tchi_qibz", "wc_qibz")
5607 : ! Trace of tchi or Wc
5608 0 : ABI_CALLOC(ctrace3, (gwr%nqibz, gwr%ntau, gwr%nsppol))
5609 :
5610 0 : if (what == "tchi_qibz") then
5611 0 : mats => gwr%tchi_qibz
5612 0 : if (gwr%tchi_space == "iomega") comment = " (iq_ibz, iomega) table"
5613 0 : if (gwr%tchi_space == "itau") comment = " (iq_ibz, itau) table"
5614 0 : else if (what == "wc_qibz") then
5615 0 : mats => gwr%wc_qibz
5616 0 : if (gwr%wc_space == "iomega") comment = " (iq_ibz, iomega) table"
5617 0 : if (gwr%wc_space == "itau") comment = " (iq_ibz, itau) table"
5618 : end if
5619 :
5620 0 : do my_is=1,gwr%my_nspins
5621 0 : spin = gwr%my_spins(my_is)
5622 0 : do my_it=1,gwr%my_ntau
5623 0 : itau = gwr%my_itaus(my_it)
5624 0 : do my_iqi=1,gwr%my_nqibz
5625 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
5626 0 : ctrace3(iq_ibz, itau, spin) = mats(iq_ibz, itau, spin)%get_trace() / gwr%np_qibz(iq_ibz)
5627 : end do
5628 : end do
5629 : end do
5630 :
5631 0 : call xmpi_sum_master(ctrace3, 0, gwr%kts_comm%value, ierr)
5632 :
5633 0 : if (gwr%comm%me == master) then
5634 0 : do spin=1,gwr%nsppol
5635 0 : call wrtout(units, sjoin(" Trace of:", what, "for spin:", itoa(spin), "for testing purposes:"))
5636 0 : call wrtout(units, comment, pre_newlines=2)
5637 0 : call print_arr(units, ctrace3(:,:,spin))
5638 : end do
5639 : end if
5640 0 : ABI_FREE(ctrace3)
5641 :
5642 : case ("gt_kibz")
5643 : ! Trace of Green's functions.
5644 0 : ABI_CALLOC(ctrace5, (gwr%nkibz, gwr%ntau, 2, gwr%nsppol, gwr%nsig_ab))
5645 :
5646 0 : do my_is=1,gwr%my_nspins
5647 0 : spin = gwr%my_spins(my_is)
5648 0 : do my_it=1,gwr%my_ntau
5649 0 : itau = gwr%my_itaus(my_it)
5650 0 : do my_iki=1,gwr%my_nkibz
5651 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
5652 0 : do ipm=1,2
5653 0 : do iab=1,gwr%nsig_ab
5654 0 : ctrace5(ik_ibz, itau, ipm, spin, iab) = gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%get_trace() / gwr%np_kibz(ik_ibz)
5655 : end do
5656 : end do
5657 : end do
5658 : end do
5659 : end do
5660 0 : comment = " (ik_ibz, itau) table"
5661 :
5662 0 : call xmpi_sum_master(ctrace5, master, gwr%kts_comm%value, ierr)
5663 :
5664 0 : if (gwr%comm%me == master) then
5665 0 : do spin=1,gwr%nsppol
5666 0 : do ipm=1,2
5667 0 : do iab=1,gwr%nsig_ab
5668 0 : if (gwr%nspinor == 2) then
5669 0 : call wrtout(units, sjoin(" Trace of:", what, "for ipm:", itoa(ipm), ", spin:", itoa(spin), ", iab:", itoa(iab), "for testing purposes:"))
5670 : else
5671 0 : call wrtout(units, sjoin(" Trace of:", what, "for ipm:", itoa(ipm), ", spin:", itoa(spin), "for testing purposes:"))
5672 : end if
5673 0 : call wrtout(units, comment, newlines=1)
5674 0 : call print_arr(units, ctrace5(:,:, ipm, spin, iab))
5675 : end do
5676 : end do
5677 : end do
5678 : end if
5679 0 : ABI_FREE(ctrace5)
5680 :
5681 : case default
5682 0 : ABI_ERROR(sjoin("Invalid value of what:", what))
5683 : end select
5684 :
5685 0 : end subroutine gwr_print_trace
5686 : !!***
5687 :
5688 : !----------------------------------------------------------------------
5689 :
5690 : !!****f* m_gwr/gwr_build_wc
5691 : !! NAME
5692 : !! gwr_build_wc
5693 : !!
5694 : !! FUNCTION
5695 : !! Compute Wc(i tau,g,g') from tchi(i omega,g,g')
5696 : !!
5697 : !! INPUTS
5698 : !!
5699 : !! OUTPUT
5700 : !!
5701 : !! SOURCE
5702 :
5703 0 : subroutine gwr_build_wc(gwr)
5704 :
5705 : !Arguments ------------------------------------
5706 : class(gwr_t),target,intent(inout) :: gwr
5707 :
5708 : !Local variables-------------------------------
5709 : !scalars
5710 : integer,parameter :: master = 0
5711 : integer :: my_iqi, my_it, my_is, iq_ibz, spin, itau, iw, ierr, npwe
5712 : integer :: il_g1, il_g2, ig1, ig2, iglob1, iglob2, ig0
5713 : real(dp) :: cpu_all, wall_all, gflops_all, cpu_q, wall_q, gflops_q, i_sz !, cpu_tmp, wall_tmp, gflops_tmp
5714 : logical :: q_is_gamma, free_tchi, print_time, keep_wcimw
5715 : character(len=5000) :: msg
5716 : complex(dp) :: vcs_g1, vcs_g2
5717 0 : type(__slkmat_t) :: em1
5718 : type(yamldoc_t) :: ydoc
5719 : !arrays
5720 : integer :: units(2)
5721 : real(dp) :: qq_ibz(3), tsec(2)
5722 0 : complex(dp) :: em1_wq(gwr%ntau, gwr%nqibz), eps_wq(gwr%ntau, gwr%nqibz)
5723 : ! *************************************************************************
5724 :
5725 : ABI_NVTX_START_RANGE(NVTX_GWR_BUILD_WC)
5726 0 : units = [std_out, ab_out]
5727 :
5728 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
5729 0 : call timab(1924, 1, tsec)
5730 0 : call wrtout(units, " Building correlated screening Wc(i omega) ...", pre_newlines=2)
5731 :
5732 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in epsilon and W", gwr%dtset%prtvol)
5733 :
5734 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("tchi_space: ", gwr%tchi_space, " != iomega"))
5735 :
5736 0 : if (allocated(gwr%wc_qibz)) then
5737 0 : call slk_array_free(gwr%wc_qibz)
5738 0 : ABI_FREE(gwr%wc_qibz)
5739 0 : gwr%wc_space = "none"
5740 : end if
5741 :
5742 0 : ABI_CHECK(gwr%wc_space == "none", sjoin("wc_space: ", gwr%wc_space, " != none"))
5743 0 : gwr%wc_space = "iomega"
5744 :
5745 : ! =======================================
5746 : ! Allocate PBLAS arrays for wc_qibz(g,g')
5747 : ! =======================================
5748 : ! Note that we have already summed tchi over spin.
5749 : ! Also, G=0 corresponds to iglob = 1 as only q-points in the IBZ are treated here.
5750 : ! This is not true for the other q-points in the full BZ as we may have a non-zero umklapp g0_q.
5751 0 : ABI_MALLOC(gwr%wc_qibz, (gwr%nqibz, gwr%ntau, gwr%nsppol))
5752 :
5753 0 : free_tchi = .True.; if (free_tchi) gwr%tchi_space = "none"
5754 0 : em1_wq = zero; eps_wq = zero
5755 :
5756 : ! If possible, use 2d rectangular grid of processors for diagonalization.
5757 : !call slkproc_4diag%init(gwr%g_comm%value)
5758 :
5759 0 : do my_iqi=1,gwr%my_nqibz
5760 0 : print_time = gwr%comm%me == 0 .and. (my_iqi <= LOG_MODK .or. mod(my_iqi, LOG_MODK) == 0)
5761 0 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
5762 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
5763 0 : q_is_gamma = normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0
5764 :
5765 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
5766 0 : ig0 = desc_q%ig0
5767 0 : npwe = desc_q%npw
5768 :
5769 : ! The spin loop is needed so that procs in different pools can operate
5770 : ! on their own matrix that has been already summed over (collinear) spins.
5771 0 : do my_is=1,gwr%my_nspins
5772 0 : spin = gwr%my_spins(my_is)
5773 0 : do my_it=1,gwr%my_ntau
5774 0 : itau = gwr%my_itaus(my_it)
5775 :
5776 : ! Build symmetrized RPA epsilon: 1 - Vc^{1/2} chi0 Vc^{1/2}
5777 : ! Note vc_sqrt_eps here.
5778 0 : associate (wc => gwr%wc_qibz(iq_ibz, itau, spin))
5779 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%copy(wc)
5780 0 : if (free_tchi) call gwr%tchi_qibz(iq_ibz, itau, spin)%free()
5781 :
5782 0 : do il_g2=1,wc%size_local(2)
5783 0 : iglob2 = wc%loc2gcol(il_g2)
5784 0 : ig2 = mod(iglob2 - 1, desc_q%npw) + 1
5785 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2)
5786 0 : do il_g1=1,wc%size_local(1)
5787 0 : iglob1 = wc%loc2grow(il_g1)
5788 0 : ig1 = mod(iglob1 - 1, desc_q%npw) + 1
5789 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1)
5790 0 : wc%buffer_cplx(il_g1, il_g2) = -wc%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2
5791 0 : if (iglob1 == iglob2) then
5792 0 : wc%buffer_cplx(il_g1, il_g2) = one + wc%buffer_cplx(il_g1, il_g2)
5793 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5794 : ! Store epsilon_{iw, iq_ibz}(0, 0). Rescale by np_qibz because we will MPI reduce this array.
5795 0 : eps_wq(itau, iq_ibz) = wc%buffer_cplx(il_g1, il_g2) / gwr%np_qibz(iq_ibz)
5796 : end if
5797 : end if
5798 : end do ! il_g1
5799 : end do ! il_g2
5800 :
5801 : ! Invert symmetrized epsilon.
5802 : ! NB: PZGETRF requires square block cyclic decomposition along the two axes
5803 : ! hence we have to redistribute the data before calling invert and then
5804 : ! go back to colum-distribution, that is: wc --> em1 --> wc
5805 :
5806 0 : call wc%change_size_blocs(em1) ! processor=slkproc_4diag
5807 : ! Use hpd_invert as eps along imag axis is always hermitian.
5808 : !call em1%invert()
5809 0 : call em1%hpd_invert("U")
5810 0 : call wc%take_from(em1, free=.True.) ! processor=wc%processor)
5811 :
5812 : !call wrtout(std_out, sjoin(" e-1 at q:", ktoa(qq_ibz), "i omega:", ftoa(gwr%iw_mesh(itau) * Ha_eV), "eV"))
5813 : !call print_arr(units, wc%buffer_cplx)
5814 :
5815 : ! Build Wc(q, iw) = e^{-1}_q(g,g',iw) - delta_{gg'} v_q(g,g') by removing bare vc.
5816 0 : do il_g2=1,wc%size_local(2)
5817 0 : iglob2 = wc%loc2gcol(il_g2)
5818 0 : ig2 = mod(iglob2 - 1, desc_q%npw) + 1
5819 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2)
5820 0 : if (gwr%has_vcgen_sigma) vcs_g2 = desc_q%vc_sqrt_sigma(ig2)
5821 0 : do il_g1=1,wc%size_local(1)
5822 0 : iglob1 = wc%loc2grow(il_g1)
5823 0 : ig1 = mod(iglob1 - 1, desc_q%npw) + 1
5824 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1)
5825 0 : if (gwr%has_vcgen_sigma) vcs_g1 = desc_q%vc_sqrt_sigma(ig1)
5826 :
5827 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5828 : ! Store epsilon^{-1}_{iw, iq_ibz}(0, 0). Rescale by np_qibz because we will MPI reduce this array.
5829 0 : em1_wq(itau, iq_ibz) = wc%buffer_cplx(il_g1, il_g2) / gwr%np_qibz(iq_ibz)
5830 : end if
5831 :
5832 : ! Subtract exchange part.
5833 0 : if (iglob1 == iglob2) wc%buffer_cplx(il_g1, il_g2) = wc%buffer_cplx(il_g1, il_g2) - one
5834 :
5835 : ! Handle divergence in Wc for q --> 0
5836 : ! Here we always use vcgen_eps
5837 0 : i_sz = gwr%vcgen_eps%i_sz
5838 0 : if (gwr%has_vcgen_sigma) i_sz = gwr%vcgen_sigma%i_sz
5839 :
5840 0 : if (q_is_gamma .and. (iglob1 == ig0 .or. iglob2 == ig0)) then
5841 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5842 0 : vcs_g1 = sqrt(i_sz); vcs_g2 = sqrt(i_sz)
5843 0 : else if (iglob1 == ig0) then
5844 0 : vcs_g1 = sqrt(i_sz)
5845 0 : else if (iglob2 == ig0) then
5846 0 : vcs_g2 = sqrt(i_sz)
5847 : end if
5848 : end if
5849 :
5850 0 : wc%buffer_cplx(il_g1, il_g2) = wc%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2 / gwr%cryst%ucvol
5851 : end do ! il_g1
5852 : end do ! il_g2
5853 : end associate
5854 :
5855 : end do ! my_it
5856 : end do ! my_is
5857 : end associate
5858 :
5859 0 : if (print_time) then
5860 0 : write(msg,'(4x,2(a,i0),a)')"My iq_ibz [", my_iqi, "/", gwr%my_nqibz, "]"
5861 0 : call cwtime_report(msg, cpu_q, wall_q, gflops_q)
5862 : end if
5863 : end do ! my_iqi
5864 :
5865 : !call slkproc_4diag%free()
5866 :
5867 0 : call xmpi_sum_master(em1_wq, master, gwr%kgt_comm%value, ierr)
5868 0 : call xmpi_sum_master(eps_wq, master, gwr%kgt_comm%value, ierr)
5869 :
5870 0 : if (gwr%comm%me == master) then
5871 : ! Print results to ab_out for testing purposes.
5872 0 : ydoc = yamldoc_open('EMACRO_WITHOUT_LOCAL_FIELDS') !, width=11, real_fmt='(3f8.3)')
5873 0 : call ydoc%open_tabular("epsilon_{iw, q -> Gamma}(0,0)") ! comment="(iomega, iq_ibz)")
5874 0 : do iw=1,gwr%ntau
5875 0 : write(msg, "(3(es16.8,2x))") gwr%iw_mesh(iw), real(eps_wq(iw, 1)), aimag(eps_wq(iw, 1))
5876 0 : call ydoc%add_tabular_line(msg)
5877 : end do
5878 0 : call ydoc%write_units_and_free(units)
5879 :
5880 0 : ydoc = yamldoc_open('EMACRO_WITH_LOCAL_FIELDS') !, width=11, real_fmt='(3f8.3)')
5881 0 : call ydoc%open_tabular("epsilon_{iw, q -> Gamma}(0,0)") !, comment="(iomega, iq_ibz)")
5882 0 : do iw=1,gwr%ntau
5883 0 : write(msg, "(3(es16.8,2x))") gwr%iw_mesh(iw), real(em1_wq(iw, 1)), aimag(em1_wq(iw, 1))
5884 0 : call ydoc%add_tabular_line(msg)
5885 : end do
5886 0 : call ydoc%write_units_and_free(units)
5887 : end if
5888 :
5889 : ! Print trace of wc_q(iomega) matrices for testing purposes.
5890 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5891 :
5892 : ! Write file with Wc(i omega)
5893 0 : keep_wcimw = .False.
5894 0 : if (gwr%dtset%prtsuscep == -1) then
5895 0 : call gwr%ncwrite_tchi_wc("wc", "omega", keep_wcimw, trim(gwr%dtfil%filnam_ds(4))//'_WCIM.nc')
5896 0 : keep_wcimw = .True.
5897 : end if
5898 :
5899 : ! Cosine transform from iomega to itau to get Wc(i tau)
5900 0 : call gwr%cos_transform("wc", "iw2t")
5901 :
5902 : ! Print trace of wc_q(itau) matrices for testing purposes.
5903 : ! if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5904 :
5905 : ! Write file with Wc(i tau)
5906 0 : if (abs(gwr%dtset%prtsuscep) == 1) then
5907 0 : call gwr%ncwrite_tchi_wc("wc", "tau", keep_wcimw, trim(gwr%dtfil%filnam_ds(4))//'_WCIM.nc')
5908 : end if
5909 :
5910 : ! Print trace of wc_q(iomega) matrices for testing purposes.
5911 : !if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5912 :
5913 0 : call cwtime_report(" gwr_build_wc:", cpu_all, wall_all, gflops_all)
5914 0 : call timab(1924, 2, tsec)
5915 : ABI_NVTX_END_RANGE()
5916 :
5917 0 : end subroutine gwr_build_wc
5918 : !!***
5919 :
5920 : !----------------------------------------------------------------------
5921 :
5922 : !!****f* m_gwr/gwr_build_sigmac
5923 : !! NAME
5924 : !! gwr_build_sigmac
5925 : !!
5926 : !! FUNCTION
5927 : !! Build Sigma_c(i tau) and compute matrix elements in the KS basis set.
5928 : !!
5929 : !! INPUTS
5930 : !!
5931 : !! OUTPUT
5932 : !!
5933 : !! SOURCE
5934 :
5935 0 : subroutine gwr_build_sigmac(gwr)
5936 :
5937 : !Arguments ------------------------------------
5938 : class(gwr_t),target,intent(inout) :: gwr
5939 :
5940 : !Local variables-------------------------------
5941 : !scalars
5942 : integer,parameter :: master = 0
5943 : integer :: my_is, my_it, spin, ikcalc_ibz, ik_ibz, sc_nfft, my_ir, my_nr, iw, idat, max_ndat, ndat, ii, jj, irow, iab, iiab, jiab, itim
5944 : integer :: iq_ibz, iq_bz, itau, ierr, ibc, ib1, ib2, bmin, bmax, band, band1, ifft, gpu_option
5945 : integer :: band2, band2_start, band2_stop, nbc
5946 : integer :: my_ikf, ipm, ik_bz, ikcalc, uc_ir, ir, ncid, col_bsize, nr, sc_nfftsp, iter_ncid
5947 : integer :: isym_k, trev_k, g0_k(3), tsign_k !, b1gw, b2gw, ! my_iqi, sc_ir, ig, my_iqf
5948 : integer :: gt_request, wct_request
5949 : integer :: band_val, ibv, unt_it, unt_iw, unt_rw ! ncerr,
5950 : integer(kind=XMPI_ADDRESS_KIND) :: buf_count
5951 : integer :: gt_scbox_win, wct_scbox_win, use_umklp, ideg, nstates, nb1, nb2, nspinor
5952 : integer(c_size_t) :: bufsize
5953 : !integer :: my_ikf_start, my_ikf_stop, nkf_batch_size, nkf_now, op_type
5954 : real(dp) :: e0, ks_gap, qp_gap, qp_pade_gap, sigx, vxc_val, vu, v_meanf, eshift, sigma_fact
5955 : real(dp) :: cpu_tau, wall_tau, gflops_tau, cpu_all, wall_all, gflops_all !, cpu, wall, gflops
5956 : real(dp) :: mem_mb, cpu_ir, wall_ir, gflops_ir, cpu_ikf, wall_ikf, gflops_ikf
5957 : real(dp) :: max_abs_imag_wct, max_abs_re_wct, sck_ucvol, scq_ucvol, beta_r
5958 : real(gwp) :: wtqm, wtqp
5959 : complex(dp) :: zz, zsc, sigc_e0__, dsigc_de0, z_e0, sig_xc, hhartree_bk, qp_ene, qp_ene_prev, alpha_c, sigc_zsc
5960 : logical :: k_is_gamma, use_shmem_for_k, use_mpi_for_k, isirr_k, do_sigma_fit
5961 : logical :: compute_this_kbz, print_time, sigc_is_herm, band_inversion ! define,
5962 : character(len=500) :: msg, gpu_action
5963 0 : type(gaps_t) :: new_gaps
5964 : type(yamldoc_t) :: ydoc
5965 : type(c_ptr) :: void_ptr
5966 0 : type(sigma_pade_t) :: spade
5967 : !arrays
5968 0 : integer :: sc_ngfft(18), need_qibz(gwr%nqibz), got_qibz(gwr%nqibz), units(2), dat_units(3), g0_q(3) ! gg(3),
5969 0 : integer,allocatable :: green_scgvec(:,:), wc_scgvec(:,:)
5970 0 : logical :: select_my_kbz(gwr%my_nkbz), select_my_qbz(gwr%my_nqbz)
5971 : real(dp) :: kk_bz(3), kcalc_bz(3), qq_bz(3), tsec(2) !, qq_ibz(3)
5972 0 : real(dp),allocatable :: betas_r(:,:,:), zcut_pm(:,:,:)
5973 : complex(gwp) :: cpsi_r, sigc_pm(2)
5974 0 : complex(dp) :: odd_t(gwr%ntau), even_t(gwr%ntau), avg_2ntau(2,gwr%ntau), cvals(gwr%ntau)
5975 0 : complex(dp),target,allocatable :: sigc_it_mat(:,:,:,:,:,:), alphas_c(:,:,:)
5976 0 : complex(gwp),allocatable :: loc_cwork(:)
5977 0 : complex(gwp) ABI_ASYNC, contiguous, pointer :: gt_scbox(:,:,:), wct_scbox(:,:)
5978 0 : complex(gwp),allocatable :: uc_psir_bk(:,:,:), scph1d_kcalc(:,:,:), uc_ceikr(:), ur(:), ucpsi_r(:)
5979 0 : type(__slkmat_t) :: gt_gpr(2, gwr%my_nkbz, gwr%nsig_ab), gk_rpr_pm(2, gwr%nsig_ab), wc_rpr, wc_gpr(gwr%my_nqbz)
5980 0 : type(__slkmat_t), target :: sigc_rpr(2,2,gwr%nkcalc, gwr%nsig_ab)
5981 0 : type(desc_t), target :: desc_mykbz(gwr%my_nkbz), desc_myqbz(gwr%my_nqbz)
5982 : type(fftbox_plan3_t) :: green_plan, wt_plan
5983 0 : type(littlegroup_t) :: ltg_kcalc(gwr%nkcalc)
5984 : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
5985 0 : integer,allocatable :: iperm(:)
5986 0 : real(dp),allocatable :: sorted_qpe(:)
5987 0 : real(dp) :: e0_kcalc(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol), rw_mesh(gwr%nwr)
5988 0 : real(dp) :: spfunc_diag(gwr%nwr, gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5989 0 : integer :: pade_solver_ierr(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5990 0 : real(dp) :: ks_gaps(gwr%nkcalc, gwr%nsppol), qpz_gaps(gwr%nkcalc, gwr%nsppol), qp_pade_gaps(gwr%nkcalc, gwr%nsppol)
5991 0 : complex(dp) :: ze0_kcalc(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5992 0 : complex(dp) :: sigc_e0(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5993 0 : complex(dp) :: qpz_ene(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol), imag_zmesh(gwr%ntau)
5994 0 : complex(dp) :: qp_pade(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5995 0 : complex(dp) :: sigxc_rw_diag(gwr%nwr, gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5996 : !complex(gwp),contiguous, pointer :: buf_cplx(:,:)
5997 0 : type(sigijtab_t),allocatable :: Sigxij_tab(:,:), Sigcij_tab(:,:)
5998 : ! *************************************************************************
5999 :
6000 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6001 0 : call timab(1925, 1, tsec)
6002 :
6003 0 : nspinor = gwr%nspinor
6004 0 : units = [std_out, ab_out]
6005 0 : gpu_option = gwr%dtset%gpu_option
6006 0 : if (gwr%sig_diago) then
6007 0 : call wrtout(units, " Computing diagonal matrix elements of Sigma_c", pre_newlines=1)
6008 : else
6009 0 : call wrtout(units, " Computing diagonal + off-diagonal matrix elements of Sigma_c", pre_newlines=1)
6010 : end if
6011 :
6012 0 : if (gwr%has_vcgen_sigma) then
6013 0 : call gwr%vcgen_sigma%print(units, " Info on Coulomb term used in Sigma_c", gwr%dtset%prtvol)
6014 : else
6015 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in Sigma_c", gwr%dtset%prtvol)
6016 : end if
6017 :
6018 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("wc_space: ", gwr%wc_space, " != itau"))
6019 :
6020 : !mask_kibz = 0; mask_kibz(gwr%my_kibz_inds(:)) = 1
6021 : !call gwr%malloc_free_mats(mask_kibz, "sigma" "malloc")
6022 :
6023 : !if (gwr%scf_iteration == 1) then
6024 : !else
6025 : !end if
6026 :
6027 : ! Set FFT mesh in the supercell.
6028 : ! Be careful when using the FFT plan as ndat can change inside the loop if we start to block.
6029 : ! Perhaps the safest approach would be to generate the plan on the fly.
6030 :
6031 0 : sc_ngfft = gwr%g_ngfft
6032 0 : sc_ngfft(1:3) = gwr%ngkpt * gwr%g_ngfft(1:3)
6033 0 : sc_ngfft(4:6) = sc_ngfft(1:3)
6034 0 : sc_nfft = product(sc_ngfft(1:3)); sc_nfftsp = sc_nfft !* gwr%nspinor
6035 : !sc_mgfft = maxval(sc_ngfft(1:3))
6036 0 : sck_ucvol = gwr%cryst%ucvol * product(gwr%ngkpt)
6037 0 : scq_ucvol = gwr%cryst%ucvol * product(gwr%ngqpt)
6038 :
6039 : ! Set FFT mesh used to compute u(r) in the unit cell.
6040 0 : call gwr%kcalc_wfd%change_ngfft(gwr%cryst, gwr%psps, gwr%g_ngfft)
6041 :
6042 : ! Table for \Sigmac_ij matrix elements.
6043 0 : sigc_is_herm = .False.
6044 : call sigtk_sigma_tables(gwr%nkcalc, gwr%nkibz, gwr%nsppol, gwr%bstart_ks, gwr%bstop_ks, gwr%kcalc2ibz(:,1), &
6045 0 : gwr%sig_diago, sigc_is_herm, sigxij_tab, sigcij_tab)
6046 :
6047 0 : call sigijtab_free(Sigxij_tab)
6048 0 : ABI_FREE(Sigxij_tab)
6049 :
6050 : ! Allocate matrix elements Sigmac_(itau) in the KS basis set.
6051 0 : ii = gwr%b1gw; jj = gwr%b2gw
6052 0 : if (gwr%sig_diago) then
6053 0 : ii = 1; jj = 1
6054 : end if
6055 0 : ABI_CALLOC(sigc_it_mat, (2, gwr%ntau, gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol))
6056 0 : ABI_RECALLOC(gwr%sigc_iw_mat, (gwr%ntau, gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol))
6057 :
6058 0 : do_sigma_fit = (iand(gwr%dtset%gwr_fit, SIGMA_FIT) /= 0)
6059 0 : ABI_CALLOC(alphas_c, (2, gwr%b1gw:gwr%b2gw, ii:jj))
6060 0 : ABI_CALLOC(betas_r, (2, gwr%b1gw:gwr%b2gw, ii:jj))
6061 0 : ABI_CALLOC(zcut_pm, (2, gwr%b1gw:gwr%b2gw, ii:jj))
6062 0 : zcut_pm = gwr%dtset%zcut
6063 :
6064 0 : if (do_sigma_fit) then
6065 0 : call wrtout(units, " Activating fit of sigma matrix elements in tau space")
6066 : end if
6067 :
6068 0 : max_abs_imag_wct = zero; max_abs_re_wct = zero
6069 0 : call gwr%print_mem([std_out])
6070 :
6071 0 : if (gwr%use_supercell_for_sigma) then
6072 :
6073 : ! NOTE:
6074 : ! There are two possibilities here:
6075 : !
6076 : ! 1) Compute the matrix elements of Sigma_c in the KS basis set by integrating over the real-space supercell.
6077 : !
6078 : ! 2) Compute and store Sigma_c^k(g,g',iomega) and then compute the matrix elements in g-space.
6079 : !
6080 : ! The first option requires less memory provided we are interested in a small set of KS states.
6081 : ! The second option is interesting if we need to compute several matrix elements, including off-diagonal terms.
6082 0 : call print_sigma_header()
6083 :
6084 0 : max_ndat = gwr%sc_batch_size
6085 : use_mpi_for_k = gwr%sc_batch_size > 1 .and. gwr%sc_batch_size == gwr%kpt_comm%nproc
6086 0 : use_mpi_for_k = .False.
6087 :
6088 0 : use_shmem_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
6089 0 : use_shmem_for_k = use_shmem_for_k .and. gwr%kpt_comm%can_use_shmem()
6090 : #ifndef HAVE_MPI_ALLOCATE_SHARED_CPTR
6091 : use_shmem_for_k = .False.
6092 : #endif
6093 :
6094 0 : if (use_shmem_for_k) then
6095 0 : buf_count = 2 * (sc_nfftsp * max_ndat * 2)
6096 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, gt_scbox_win)
6097 0 : call c_f_pointer(void_ptr, gt_scbox, shape=[sc_nfftsp, max_ndat, 2])
6098 0 : buf_count = 2 * (sc_nfftsp * max_ndat)
6099 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, wct_scbox_win)
6100 0 : call c_f_pointer(void_ptr, wct_scbox, shape=[sc_nfftsp, max_ndat])
6101 : end if
6102 :
6103 0 : call wrtout(std_out, sjoin(" use_mpi_for_k:", yesno(use_mpi_for_k)))
6104 0 : call wrtout(std_out, sjoin(" use_shmem_for_k:", yesno(use_shmem_for_k)))
6105 0 : mem_mb = 3 * (sc_nfftsp * max_ndat * gwp) * b2Mb
6106 0 : call wrtout(std_out, sjoin(" Memory for gt_scbox/wct_scbox arrays:", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
6107 :
6108 0 : if (.not. use_shmem_for_k) then
6109 0 : ABI_CALLOC(gt_scbox, (sc_nfft, max_ndat, 2))
6110 0 : ABI_CALLOC(wct_scbox, (sc_nfft, max_ndat))
6111 : #ifdef HAVE_OPENMP_OFFLOAD
6112 : !$OMP TARGET ENTER DATA MAP(to:gt_scbox(1:sc_nfft,1:max_ndat,1:2), wct_scbox(1:sc_nfft,1:max_ndat)) IF (gpu_option == ABI_GPU_OPENMP)
6113 : #endif
6114 : end if
6115 :
6116 : ! Build plans for dense FFTs.
6117 0 : call green_plan%from_ngfft(sc_ngfft, max_ndat*2, gpu_option)
6118 0 : call wt_plan%from_ngfft(sc_ngfft, max_ndat, gpu_option)
6119 :
6120 0 : sigma_fact = one / (sck_ucvol * scq_ucvol)
6121 :
6122 : ! The g-vectors in the supercell for G and tchi.
6123 0 : ABI_MALLOC(green_scgvec, (3, gwr%green_mpw))
6124 0 : ABI_MALLOC(wc_scgvec, (3, gwr%tchi_mpw))
6125 :
6126 0 : select_my_kbz = .True.; select_my_qbz = .True.
6127 :
6128 0 : do my_is=1,gwr%my_nspins
6129 0 : spin = gwr%my_spins(my_is)
6130 :
6131 : ! Load wavefunctions for GW corrections in the unit cell.
6132 : ! TODO: MPI distribute or use MPI shared memory
6133 0 : bmin = minval(gwr%bstart_ks(:, spin)); bmax = maxval(gwr%bstop_ks(:, spin))
6134 0 : ABI_MALLOC_OR_DIE(uc_psir_bk, (gwr%g_nfft * gwr%nspinor, bmin:bmax, gwr%nkcalc), ierr)
6135 0 : ABI_MALLOC(ur, (gwr%g_nfft * gwr%nspinor))
6136 0 : ABI_MALLOC(uc_ceikr, (gwr%g_nfft * gwr%nspinor))
6137 0 : ABI_MALLOC(ucpsi_r, (gwr%g_nfft))
6138 :
6139 0 : do ikcalc=1,gwr%nkcalc
6140 0 : kcalc_bz = gwr%kcalc(:, ikcalc); ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1) ! NB: Assuming wfs in the IBZ.
6141 : ! Compute e^{ik.r} phases in the unit cell.
6142 0 : call calc_ceikr(kcalc_bz, gwr%g_ngfft, gwr%g_nfft, gwr%nspinor, uc_ceikr)
6143 :
6144 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6145 0 : call gwr%kcalc_wfd%get_ur(band, ikcalc_ibz, spin, ur)
6146 0 : uc_psir_bk(:, band, ikcalc) = ur * uc_ceikr
6147 : end do
6148 : end do ! ikcalc
6149 :
6150 0 : ABI_FREE(ur)
6151 0 : ABI_FREE(uc_ceikr)
6152 :
6153 : ! Pre-compute one-dimensional factors to get 3d e^{ik.L}
6154 0 : call get_1d_sc_phases(gwr%ngkpt, gwr%nkcalc, gwr%kcalc, scph1d_kcalc)
6155 :
6156 : ! Construct Sigma(itau) in the supercell.
6157 0 : do my_it=1,gwr%my_ntau
6158 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
6159 0 : itau = gwr%my_itaus(my_it)
6160 :
6161 : ! G_k(g,g') --> G_k(g',r) e^{ik.r} for each k in the BZ treated by me.
6162 0 : call gwr%get_myk_green_gpr(itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
6163 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6164 :
6165 : ! Wc_q(g,g') --> Wc_q(g',r) e^{iq.r} for each q in the BZ treated by me.
6166 0 : call gwr%get_myq_wc_gpr(itau, spin, select_my_qbz, desc_myqbz, wc_gpr)
6167 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6168 :
6169 0 : my_nr = gt_gpr(1,1,1)%size_local(2)
6170 0 : ABI_CHECK(my_nr == wc_gpr(1)%size_local(2), "my_nr != wc_gpr(1)%size_local(2)")
6171 :
6172 : ! Loop over r in the unit cell that is now MPI-distributed inside g_comm.
6173 0 : do my_ir=1, my_nr, gwr%sc_batch_size
6174 0 : print_time = (gwr%comm%me == 0 .and. (my_ir <= 3 * gwr%sc_batch_size .or. mod(my_ir, LOG_MODR) == 0))
6175 0 : if (print_time) call cwtime(cpu_ir, wall_ir, gflops_ir, "start")
6176 0 : ndat = blocked_loop(my_ir, my_nr, gwr%sc_batch_size)
6177 0 : uc_ir = gt_gpr(1,1,1)%loc2gcol(my_ir) ! FIXME: This won't work if nspinor 2
6178 :
6179 0 : if (.not. use_shmem_for_k) then
6180 : ! Insert Wc_q(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir)
6181 0 : call gwr%wcq_to_scbox(sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, wc_gpr, wct_scbox)
6182 : #ifdef HAVE_OPENMP_OFFLOAD
6183 : !$omp target update to(wct_scbox(1:sc_nfft,1:max_ndat)) if (gpu_option == ABI_GPU_OPENMP)
6184 : #endif
6185 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_isum_ip(wct_scbox, gwr%kpt_comm%value, wct_request, ierr)
6186 :
6187 : ! Wc(G',r) --> Wc(R',r)
6188 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_wait(wct_request, ierr)
6189 0 : call wt_plan%execute(wct_scbox(:,1), -1, max_ndat, iscale=0)
6190 : else
6191 : call gwr%wcq_to_scbox(sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, wc_gpr, wct_scbox, &
6192 0 : wct_scbox_win=wct_scbox_win)
6193 : end if
6194 :
6195 : ! TODO: Should block using nproc in kpt_comm, scatter data and perform multiple FFTs in parallel.
6196 0 : do iab=1,gwr%nsig_ab
6197 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
6198 0 : if (.not. use_shmem_for_k) then
6199 :
6200 : ! Insert G_k(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir).
6201 0 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox)
6202 : #ifdef HAVE_OPENMP_OFFLOAD
6203 : !$omp target update to(gt_scbox(1:sc_nfft,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
6204 : #endif
6205 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_isum_ip(gt_scbox, gwr%kpt_comm%value, gt_request, ierr)
6206 :
6207 : ! G(G',r) --> G(R',r)
6208 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_wait(gt_request, ierr)
6209 0 : call green_plan%execute(gt_scbox(:,1,1), -1, max_ndat*2, iscale=0)
6210 :
6211 : ! Use gt_scbox to store GW (R',r, +/- i tau) for this set of ndat r-point
6212 : !gt_scbox(:,:,1) = gt_scbox(:,:,1) * wct_scbox(:,:) * sigma_fact
6213 : !gt_scbox(:,:,2) = gt_scbox(:,:,2) * wct_scbox(:,:) * sigma_fact
6214 : #ifdef HAVE_OPENMP_OFFLOAD
6215 : !$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO COLLAPSE(3) MAP(to:gt_scbox(1:sc_nfft,1:max_ndat,1:2), wct_scbox(1:sc_nfft,1:max_ndat)) if (gpu_option == ABI_GPU_OPENMP)
6216 : #endif
6217 0 : do ipm=1,2
6218 0 : do idat=1,max_ndat
6219 0 : do ifft=1,sc_nfft
6220 0 : gt_scbox(ifft,idat,ipm) = gt_scbox(ifft,idat,ipm) * wct_scbox(ifft,idat) * sigma_fact
6221 : end do
6222 : end do
6223 : end do
6224 : #ifdef HAVE_OPENMP_OFFLOAD
6225 : !$omp target update from(gt_scbox(1:sc_nfft,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
6226 : #endif
6227 : !print *, "Maxval abs imag G:", maxval(abs(aimag(gt_scbox)))
6228 :
6229 : else
6230 : ! use_shmem_for_k --> MPI shared window version. Only gt_scbox are wct_scbox are shared.
6231 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox, &
6232 0 : gt_scbox_win=gt_scbox_win)
6233 :
6234 : ! Now each MPI proc operates on different idat entries.
6235 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! Start the RMA epoch
6236 0 : idat = gwr%kpt_comm%me + 1
6237 0 : if (idat <= ndat) then
6238 0 : call wt_plan%execute(wct_scbox(:,idat), -1, ndat=1, iscale=0)
6239 0 : do ipm=1,2
6240 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
6241 0 : gt_scbox(:,idat,ipm) = gt_scbox(:,idat,ipm) * wct_scbox(:,idat) * sigma_fact
6242 : end do
6243 : end if
6244 : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
6245 : !call xmpi_barrier(gwr%kpt_comm%value)
6246 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! End the RMA epoch
6247 : end if
6248 :
6249 : ! Integrate Sigma matrix elements in the R-supercell for ndat r-points and accumulate.
6250 : ! possibly including off-diagonal terms.
6251 0 : do ikcalc=1,gwr%nkcalc
6252 0 : if (gwr%kpt_comm%skip(ikcalc)) cycle ! FIXME: Temporary hack till I find a better MPI algo for k-points.
6253 0 : k_is_gamma = normv(gwr%kcalc(:,ikcalc), gwr%cryst%gmet, "G") < GW_TOLQ0
6254 :
6255 0 : do band2=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6256 0 : do irow=1,Sigcij_tab(ikcalc, spin)%col(band2)%size1
6257 0 : band1 = Sigcij_tab(ikcalc, spin)%col(band2)%bidx(irow)
6258 0 : do idat=1,ndat
6259 : !if (use_shmem_for_k .and. idat /= gwr%kpt_comm + 1) cycle
6260 0 : ir = uc_ir + idat - 1
6261 0 : cpsi_r = conjg(uc_psir_bk((iiab-1)*gwr%g_nfft + ir, band1, ikcalc))
6262 0 : ucpsi_r = uc_psir_bk((jiab-1)*gwr%g_nfft+1:jiab*gwr%g_nfft, band2, ikcalc)
6263 0 : do ipm=1,2
6264 : call sc_sum(gwr%ngkpt, gwr%g_ngfft, scph1d_kcalc(:,:,ikcalc), k_is_gamma, &
6265 0 : cpsi_r, gt_scbox(:,idat,ipm), ucpsi_r, sigc_pm(ipm))
6266 : end do
6267 0 : if (gwr%sig_diago) then
6268 0 : sigc_it_mat(:, itau,band1,1,ikcalc,spin) = sigc_it_mat(:,itau,band1,1,ikcalc,spin) + sigc_pm(:)
6269 : else
6270 0 : sigc_it_mat(:,itau,band1,band2,ikcalc,spin) = sigc_it_mat(:,itau,band1,band2,ikcalc,spin) + sigc_pm(:)
6271 : end if
6272 : end do ! idat
6273 : end do
6274 : end do ! band2
6275 : end do ! ikcalc
6276 : end do ! iab
6277 :
6278 : !if (use_shmem_for_k) call xmpi_sum
6279 :
6280 0 : if (print_time) then
6281 0 : write(msg,'(4x,3(a,i0),a)')"Sigma_c my_ir [", my_ir, "/", my_nr, "] (tot: ", gwr%g_nfft, ")"
6282 0 : call cwtime_report(msg, cpu_ir, wall_ir, gflops_ir)
6283 : end if
6284 : end do ! my_ir
6285 :
6286 : ! Free descriptors and PBLAS matrices in kBZ and qBZ.
6287 0 : call desc_array_free(desc_mykbz); call desc_array_free(desc_myqbz)
6288 0 : call slk_array_free(gt_gpr); call slk_array_free(wc_gpr)
6289 :
6290 0 : write(msg,'(1x,3(a,i0),a)')"Sigma_c my_itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
6291 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau, end_str=ch10)
6292 : end do ! my_it
6293 :
6294 0 : ABI_FREE(scph1d_kcalc)
6295 0 : ABI_FREE(ucpsi_r)
6296 0 : ABI_FREE(uc_psir_bk)
6297 : end do ! my_is
6298 :
6299 0 : sigc_it_mat = -sigc_it_mat * (gwr%cryst%ucvol / gwr%g_nfft) ** 2
6300 :
6301 : !call wrtout(std_out, sjoin(" Maxval abs re W:", ftoa(max_abs_re_wct)))
6302 : !call wrtout(std_out, sjoin(" Maxval abs imag W:", ftoa(max_abs_imag_wct)))
6303 0 : if (.not. use_shmem_for_k) then
6304 : #ifdef HAVE_OPENMP_OFFLOAD
6305 : !$OMP TARGET EXIT DATA MAP(delete: gt_scbox(1:sc_nfft,1:max_ndat,1:2), wct_scbox(1:sc_nfft,1:max_ndat)) if (gpu_option == ABI_GPU_OPENMP)
6306 : #endif
6307 0 : ABI_FREE(gt_scbox)
6308 0 : ABI_FREE(wct_scbox)
6309 : else
6310 0 : call xmpi_win_free(gt_scbox_win, ierr)
6311 0 : call xmpi_win_free(wct_scbox_win, ierr)
6312 : end if
6313 :
6314 0 : call green_plan%free(); call wt_plan%free()
6315 :
6316 0 : ABI_FREE(green_scgvec)
6317 0 : ABI_FREE(wc_scgvec)
6318 :
6319 : else
6320 : ! ===================================================================
6321 : ! Mixed-space algorithm in the unit cell with convolutions in k-space
6322 : ! ===================================================================
6323 0 : call print_sigma_header()
6324 :
6325 : ! Define tables to account for symmetries:
6326 : ! - when looping over the BZ, we only need to include the union of IBZ_x for x in kcalc.
6327 : ! - when accumulating the self-energy, we have to use weights that depend on x.
6328 :
6329 : ! The little group is needed when symsigma == 1
6330 : ! If use_umklp == 1 then symmetries requiring an umklapp to preserve k_gw are included as well.
6331 : ! Note that TR is not yet supported so timrev is set to 1 even if TR has been used to generate the GS IBZ.
6332 0 : use_umklp = 1
6333 : !gw_timrev = kpts_timrev_from_kptopt(gwr%ks_ebands%kptopt) + 1
6334 0 : do ikcalc=1,gwr%nkcalc
6335 0 : call ltg_kcalc(ikcalc)%init(gwr%kcalc(:,ikcalc), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, npwe=0)
6336 0 : if (gwr%comm%me == 0 .and. gwr%dtset%symsigma /= 0) then
6337 0 : call ltg_kcalc(ikcalc)%print([std_out], prtvol=gwr%dtset%prtvol)
6338 : end if
6339 : end do
6340 :
6341 0 : call wrtout(std_out, " Allocating PBLAS matrices to store Wc_q(r',r,tau), and Sigma_kcalc(r',r,+/-tau) in the unit cell.")
6342 0 : nr = gwr%g_nfft
6343 0 : col_bsize = nr / gwr%g_comm%nproc; if (mod(nr, gwr%g_comm%nproc) /= 0) col_bsize = col_bsize + 1
6344 :
6345 0 : call wc_rpr%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
6346 :
6347 0 : gpu_action = "None"
6348 0 : if (gpu_option == ABI_GPU_OPENMP) then
6349 0 : gpu_action = "alloc"; call wrtout(std_out, " Allocating Sigma_k(r,r', +/-tau) on the GPU...")
6350 : end if
6351 :
6352 0 : do ipm=1,2
6353 0 : do iab=1,gwr%nsig_ab
6354 0 : call gk_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
6355 0 : do ikcalc=1,gwr%nkcalc
6356 0 : do itim=1,2
6357 0 : call sigc_rpr(itim,ipm,ikcalc, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize], gpu_action=gpu_action)
6358 : end do
6359 : end do
6360 : end do
6361 : end do
6362 :
6363 0 : mem_mb = slk_array_locmem_mb(wc_rpr) + sum(slk_array_locmem_mb(gk_rpr_pm)) + sum(slk_array_locmem_mb(sigc_rpr))
6364 0 : call wrtout(std_out, sjoin(" Local memory for PBLAS (r,r') matrices: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
6365 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6366 :
6367 0 : ii = sigc_rpr(1,1,1,1)%size_local(2)
6368 0 : ABI_MALLOC(loc_cwork, (ii))
6369 :
6370 0 : do my_is=1,gwr%my_nspins
6371 0 : spin = gwr%my_spins(my_is)
6372 :
6373 : ! Load wavefunctions for GW corrections in the real-space unit cell.
6374 : ! TODO: MPI distribute or use MPI shared memory
6375 0 : bmin = minval(gwr%bstart_ks(:, spin)); bmax = maxval(gwr%bstop_ks(:, spin))
6376 0 : ABI_MALLOC_OR_DIE(uc_psir_bk, (nr * gwr%nspinor, bmin:bmax, gwr%nkcalc), ierr)
6377 : #ifdef HAVE_OPENMP_OFFLOAD
6378 : !$OMP TARGET ENTER DATA MAP(alloc:uc_psir_bk) IF (gpu_option == ABI_GPU_OPENMP)
6379 : #endif
6380 :
6381 : !! !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(ikcalc_ibz)
6382 0 : do ikcalc=1,gwr%nkcalc
6383 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6384 0 : ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1) ! NB: Assuming wfs in IBZ
6385 0 : call gwr%kcalc_wfd%get_ur(band, ikcalc_ibz, spin, uc_psir_bk(:, band, ikcalc))
6386 : end do
6387 : end do
6388 : #ifdef HAVE_OPENMP_OFFLOAD
6389 : !$omp target update to(uc_psir_bk) if (gpu_option == ABI_GPU_OPENMP)
6390 : #endif
6391 :
6392 0 : need_qibz = 0
6393 0 : do my_ikf=1,gwr%my_nkbz
6394 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
6395 0 : do ikcalc=1,gwr%nkcalc
6396 0 : qq_bz = gwr%kcalc(:,ikcalc) - kk_bz !; qq_bz = -qq_bz
6397 : ! TODO: here I may need to take into account the umklapp
6398 0 : call findqg0(iq_bz, g0_q, qq_bz, gwr%nqbz, gwr%qbz, gwr%mG0)
6399 : !ABI_CHECK(all(g0_q == 0), sjoin("g0_q != 0, kcalc", ktoa(gwr%kcalc(:,ikcalc)), "kk_bz:", ktoa(kk_bz)))
6400 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz)
6401 0 : need_qibz(iq_ibz) = 1
6402 : end do
6403 : end do
6404 :
6405 : ! Construct Sigma(itau) using convolutions in k-space and real-space representation in the unit cell.
6406 0 : do my_it=1,gwr%my_ntau
6407 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
6408 0 : itau = gwr%my_itaus(my_it)
6409 :
6410 : ! Redistribute W_q(g,g') in the IBZ so that each MPI proc can reconstruct Wc_q in the BZ inside the loops
6411 0 : call gwr%redistrib_mats_qibz("wc", itau, spin, need_qibz, got_qibz, "communicate")
6412 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6413 :
6414 0 : if (gpu_option == ABI_GPU_OPENMP) then
6415 0 : call slk_array_gpu_set_zero(sigc_rpr)
6416 : end if
6417 : !else
6418 0 : call slk_array_set_zero(sigc_rpr)
6419 : !end if
6420 :
6421 : ! Sum over my k-points in the BZ.
6422 0 : do my_ikf=1,gwr%my_nkbz
6423 0 : print_time = (gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0))
6424 0 : if (print_time) call cwtime(cpu_ikf, wall_ikf, gflops_ikf, "start")
6425 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:,ik_bz)
6426 :
6427 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
6428 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
6429 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
6430 : tsign_k = merge(1, -1, trev_k == 0)
6431 : !if (.not. isirr_k) cycle
6432 :
6433 : ! Skip this BZ k-point if it is not in the IBZ(ikcalc) of some ikcalc.
6434 0 : compute_this_kbz = .True.
6435 0 : if (gwr%dtset%symsigma /= 0) then
6436 0 : compute_this_kbz = .False.
6437 0 : do ikcalc=1,gwr%nkcalc
6438 0 : if (ltg_kcalc(ikcalc)%ibzq(ik_bz) == 1) then
6439 : compute_this_kbz = .True.; exit
6440 : end if
6441 : end do
6442 : end if
6443 0 : if (.not. compute_this_kbz) cycle ! my_ikf loop
6444 :
6445 : ! Use symmetries to get G_kbz from the IBZ then G_k(g,g') --> G_k(r',r)
6446 0 : call gwr%get_gkbz_rpr_pm(ik_bz, itau, spin, gk_rpr_pm)
6447 :
6448 0 : do ikcalc=1,gwr%nkcalc
6449 0 : if (gwr%dtset%symsigma /= 0 .and. ltg_kcalc(ikcalc)%ibzq(ik_bz) == 0) cycle ! FIXME: iq_bz or ikq?
6450 0 : qq_bz = gwr%kcalc(:, ikcalc) - kk_bz !; qq_bz = -qq_bz
6451 : ! TODO: here I may need to take into account the umklapp
6452 0 : call findqg0(iq_bz, g0_q, qq_bz, gwr%nqbz, gwr%qbz, gwr%mG0)
6453 : !ABI_CHECK(all(g0_q == 0), sjoin("g0_q != 0", ktoa(gwr%kcalc(:,ikcalc)), "kk_bz", ktoa(kk_bz)))
6454 : !iq_ibz = gwr%qbz2ibz(1, iq_bz)
6455 0 : call gwr%get_wc_rpr_qbz(g0_q, iq_bz, itau, spin, wc_rpr)
6456 :
6457 : ! The integration weight depends on ikcalc.
6458 0 : wtqp = one / gwr%nkbz; wtqm = zero
6459 0 : if (gwr%dtset%symsigma /= 0) then
6460 : ! If symsigma, sum only q"s in IBZ_k, then symmetrize the matrix elements.
6461 : ! In this case elements are weighted according to wtqp and wtqm. wtqm is for time-reversal.
6462 : associate (ltg_k => ltg_kcalc(ikcalc))
6463 0 : wtqp = (one * sum(ltg_k%wtksym(1,:,ik_bz))) / gwr%nkbz ! FIXME: iq_bz or ik_bz?
6464 0 : wtqm = (one * sum(ltg_k%wtksym(2,:,ik_bz))) / gwr%nkbz
6465 : end associate
6466 : end if
6467 :
6468 0 : do ipm=1,2
6469 : !sigc_rpr(1,ipm,ikcalc)%buffer_cplx = sigc_rpr(1,ipm,ikcalc)%buffer_cplx + &
6470 : ! wtqp * gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx
6471 0 : do iab=1,gwr%nsig_ab
6472 0 : bufsize = sigc_rpr(1,ipm,ikcalc,iab)%bufsize
6473 : call cplx_mat_plus_bc(bufsize, sigc_rpr(1,ipm,ikcalc,iab)%buffer_cplx(:,1), &
6474 : wtqp, "N", gk_rpr_pm(ipm,iab)%buffer_cplx(:,1), wc_rpr%buffer_cplx(:,1), &
6475 0 : gpu_option)
6476 :
6477 : call cplx_mat_plus_bc(bufsize, sigc_rpr(2,ipm,ikcalc,iab)%buffer_cplx(:,1), &
6478 : wtqm, "N", gk_rpr_pm(ipm,iab)%buffer_cplx(:,1), wc_rpr%buffer_cplx(:,1), &
6479 0 : gpu_option)
6480 :
6481 : !sigc_rpr(1, ipm, ikcalc)%buffer_cplx = sigc_rpr(1, ipm, ikcalc)%buffer_cplx + &
6482 : ! (wtqp + wtqm) * real(gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx, kind=gwp) &
6483 : ! + (wtqp - wtqm) * j_gw * aimag(gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx)
6484 : end do ! iab
6485 : end do ! ipm
6486 :
6487 : end do ! ikcalc
6488 :
6489 0 : if (print_time) then
6490 0 : write(msg,'(4x,3(a,i0),a)')"Sigma_c my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
6491 0 : call cwtime_report(msg, cpu_ikf, wall_ikf, gflops_ikf)
6492 : end if
6493 : end do ! my_ikf
6494 :
6495 : ! Deallocate extra Wc matrices defined by got_qibz.
6496 0 : call gwr%redistrib_mats_qibz("wc", itau, spin, need_qibz, got_qibz, "free")
6497 :
6498 : ! Integrate self-energy matrix elements in the unit cell.
6499 : ! Remember that Sigma is stored as (r',r) and that the second dimension is MPI-distributed.
6500 : ! In case of k or g distribution, sigc_pm is a partial 6d integral that will be ALL_REDUCED in gwr%comm afterwards.
6501 : ! TODO: Off-diagonal terms although this is not the most efficient algorithm
6502 0 : do ikcalc=1,gwr%nkcalc
6503 0 : do iab=1,gwr%nsig_ab
6504 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
6505 0 : if (gpu_option == ABI_GPU_OPENMP) then
6506 0 : do ipm=1,2
6507 0 : do itim=1,2
6508 0 : call sigc_rpr(itim,ipm,ikcalc,iab)%gpu_map("update_from")
6509 : end do
6510 : end do
6511 : end if
6512 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6513 : call sig_braket_ur(sigc_rpr(:,:,ikcalc,iab), gwr%g_nfft, &
6514 : uc_psir_bk((jiab-1)*gwr%g_nfft+1:jiab*gwr%g_nfft, band, ikcalc), &
6515 : uc_psir_bk((iiab-1)*gwr%g_nfft+1:iiab*gwr%g_nfft, band, ikcalc), &
6516 0 : sigc_pm, loc_cwork)
6517 0 : if (gwr%sig_diago) sigc_it_mat(:, itau, band, 1, ikcalc, spin) = sigc_it_mat(:, itau, band, 1, ikcalc, spin) + sigc_pm(:)
6518 : end do ! band
6519 : end do ! iab
6520 : end do ! ikcalc
6521 :
6522 0 : write(msg,'(3(a,i0),a)')" Sigma_c my_itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
6523 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau)
6524 : end do ! my_it
6525 :
6526 : #ifdef HAVE_OPENMP_OFFLOAD
6527 : !$OMP TARGET EXIT DATA MAP(delete:uc_psir_bk) IF (gpu_option == ABI_GPU_OPENMP)
6528 : #endif
6529 0 : ABI_FREE(uc_psir_bk)
6530 : end do ! my_is
6531 :
6532 0 : sigc_it_mat = -sigc_it_mat * (one/gwr%g_nfft) ** 2
6533 :
6534 0 : ABI_FREE(loc_cwork)
6535 0 : call wc_rpr%free(); call slk_array_free(sigc_rpr); call slk_array_free(gk_rpr_pm)
6536 0 : do ikcalc=1,gwr%nkcalc
6537 0 : call ltg_kcalc(ikcalc)%free()
6538 : end do
6539 0 : call wrtout(std_out, " Mixed space algorithm for sigma completed")
6540 : end if
6541 :
6542 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6543 :
6544 0 : call sigijtab_free(Sigcij_tab)
6545 0 : ABI_FREE(Sigcij_tab)
6546 :
6547 : ! Collect results and average
6548 0 : call xmpi_sum(sigc_it_mat, gwr%comm%value, ierr)
6549 :
6550 : ! Average over degenerate states.
6551 : ! if (gwr%dtset%symsigma == +1 .and. .not. gwr%use_supercell_for_sigma) then
6552 0 : if (gwr%dtset%symsigma == +1) then
6553 0 : call wrtout(std_out, " Symsigma 1 --> Averaging Sig_c matrix elements within degenerate subspaces.")
6554 0 : ABI_CHECK(gwr%sig_diago, "symsigma = 1 requires diagonal Sigma_c")
6555 0 : do spin=1,gwr%nsppol
6556 0 : do ikcalc=1,gwr%nkcalc
6557 0 : do ideg=1,size(gwr%degtab(ikcalc, spin)%bids)
6558 0 : associate (bids => gwr%degtab(ikcalc, spin)%bids(ideg)%vals)
6559 0 : nstates = size(bids)
6560 0 : avg_2ntau = sum(sigc_it_mat(:,:,bids(:), 1,ikcalc, spin), dim=3) / nstates
6561 0 : do ii=1,nstates
6562 0 : sigc_it_mat(:,:,bids(ii), 1,ikcalc, spin) = avg_2ntau
6563 : end do
6564 : end associate
6565 : end do ! ideg
6566 : end do
6567 : end do
6568 : end if ! symsigma == +1
6569 :
6570 : ! Store matrix elements of Sigma_c(it), separate even and odd part
6571 : ! then use sine/cosine transform to get Sigma_c(i omega).
6572 : ! Finally, perform analytic continuation with Pade' to go to the real-frequency axis
6573 : ! for computing QP corrections and spectral functions. All procs execute this part as it's very cheap.
6574 :
6575 0 : imag_zmesh(:) = j_dpc * gwr%iw_mesh
6576 :
6577 : ! Save previous QP bands in qp_ebands_prev (needed for self-consistency)
6578 : ! In the loop below, we also update gwr%qp_ebands%eig with the QP results and recompute occ/fermie.
6579 0 : gwr%qp_ebands_prev%eig = gwr%qp_ebands%eig
6580 0 : gwr%qp_ebands_prev%occ = gwr%qp_ebands%occ
6581 :
6582 0 : e0_kcalc = zero; spfunc_diag = zero; pade_solver_ierr = 0; ze0_kcalc = zero; sigc_e0 = zero
6583 0 : qpz_ene = zero; qp_pade = zero; sigxc_rw_diag = zero
6584 0 : ks_gaps = -one; qpz_gaps = -one ; qp_pade_gaps = -one
6585 :
6586 0 : do spin=1,gwr%nsppol
6587 0 : do ikcalc=1,gwr%nkcalc
6588 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6589 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6590 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6591 0 : nb1 = gwr%bstop_ks(ikcalc, spin) - gwr%bstart_ks(ikcalc, spin) + 1
6592 :
6593 : ! FT Sigma(itau) --> Sigma(iw)
6594 0 : band2_start = 1; band2_stop = 1
6595 0 : if (.not. gwr%sig_diago) then
6596 0 : band2_start = gwr%bstart_ks(ikcalc, spin); band2_stop = gwr%bstop_ks(ikcalc, spin)
6597 : end if
6598 :
6599 0 : do band2=band2_start, band2_stop
6600 0 : associate (cvals_pmt => sigc_it_mat(:, :, band, band2, ikcalc, spin))
6601 0 : ib2 = band2 - band2_start + 1
6602 0 : nb2 = band2_stop - band2_start + 1
6603 :
6604 0 : if (do_sigma_fit) then
6605 0 : cvals = cvals_pmt(1,:)
6606 0 : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, cvals, alpha_c, beta_r, ierr)
6607 0 : alphas_c(1,band, band2) = alpha_c; betas_r(1,band,band2) = beta_r
6608 0 : zcut_pm(1, band, band2) = gwr%dtset%zcut
6609 : ! Remove the fit from the ab-initio data.
6610 0 : cvals_pmt(1,:) = cvals_pmt(1,:) - alpha_c * exp(-beta_r * gwr%tau_mesh)
6611 0 : if (gwr%comm%value == master) then
6612 0 : write(100, "(a,2(i0,1x))")"# +tau fit for band, band2: ", band, band2
6613 0 : write(100, *)"# alpha_c, beta_r: ", alpha_c, beta_r
6614 0 : do ii=1,gwr%ntau
6615 0 : zz = alpha_c * exp(-beta_r * gwr%tau_mesh(ii)); write(100, *) c2r(cvals_pmt(1,ii)), c2r(zz), abs(cvals_pmt(1,ii) - zz)
6616 : end do
6617 : end if
6618 : ! TODO: Recheck this part, in particular the order of -tau
6619 0 : cvals = cvals_pmt(2,:)
6620 0 : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, cvals, alpha_c, beta_r, ierr)
6621 0 : alphas_c(2, band, band2) = alpha_c; betas_r(2, band, band2) = beta_r
6622 0 : zcut_pm(2, band, band2) = gwr%dtset%zcut
6623 : ! Remove the fit from the ab-initio data.
6624 0 : cvals_pmt(2,:) = cvals_pmt(2,:) - alpha_c * exp(-beta_r * gwr%tau_mesh)
6625 0 : if (gwr%comm%value == master) then
6626 0 : write(101, "(a,2(i0,1x))")"# -tau fit for band, band2: ", band, band2
6627 0 : write(101, *)"# alpha_c, beta_r: ", alpha_c, beta_r
6628 0 : do ii=1,gwr%ntau
6629 0 : zz = alpha_c * exp(-beta_r * gwr%tau_mesh(ii)); write(101, *) c2r(cvals_pmt(2,ii)), c2r(zz), abs(cvals_pmt(2,ii) - zz)
6630 : end do
6631 : end if
6632 : end if ! do_sigma_fit
6633 :
6634 : ! f(t) = E(t) + O(t) = (f(t) + f(-t)) / 2 + (f(t) - f(-t)) / 2
6635 0 : even_t = (cvals_pmt(1,:) + cvals_pmt(2,:)) / two; odd_t = (cvals_pmt(1,:) - cvals_pmt(2,:)) / two
6636 0 : gwr%sigc_iw_mat(:, band, band2, ikcalc, spin) = matmul(gwr%cosft_wt, even_t) + j_dpc * matmul(gwr%sinft_wt, odd_t)
6637 : end associate
6638 : end do ! band2
6639 :
6640 : ! NB: e0 is always set to the KS energy even in case of self-consistency.
6641 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6642 0 : if ( gwr%sig_diago) sigx = gwr%sigx_mat(band, 1, ikcalc, spin)
6643 0 : if (.not. gwr%sig_diago) sigx = gwr%sigx_mat(band, band, ikcalc, spin)
6644 :
6645 : ! Note vxc[n_val] instead of vxc[n_val + n_nlcc] with the model core charge.
6646 0 : if (gwr%nspinor == 2) then
6647 0 : vxc_val = SUM(gwr%ks_me%vxcval(band, band, ik_ibz, :))
6648 : else
6649 0 : vxc_val = gwr%ks_me%vxcval(band, band, ik_ibz, spin)
6650 : end if
6651 0 : vu = zero; if (gwr%dtset%usepawu /= 0) vu = gwr%ks_me%vu(band, band, ik_ibz, spin)
6652 0 : v_meanf = vxc_val + vu
6653 :
6654 0 : band2 = merge(1, band, gwr%sig_diago)
6655 :
6656 : call spade%init(gwr%ntau, imag_zmesh, gwr%sigc_iw_mat(:, band, band2, ikcalc, spin), &
6657 0 : alphas_c(:, band, band2), betas_r(:, band, band2), zcut_pm(:, band, band2))
6658 0 : spade%do_sigma_fit = do_sigma_fit
6659 :
6660 : ! Solve the QP equation with Newton-Rapson starting from e0.
6661 0 : zz = cmplx(e0, zero)
6662 0 : call spade%qp_solve(e0, v_meanf, sigx, zz, zsc, sigc_zsc, msg, ierr)
6663 0 : qp_pade(band, ikcalc, spin) = zsc
6664 0 : pade_solver_ierr(band, ikcalc, spin) = ierr
6665 0 : ABI_WARNING_IF(ierr /= 0, msg)
6666 :
6667 0 : call spade%eval(zz, sigc_e0__, dvdz=dsigc_de0)
6668 :
6669 : ! Z = (1 - dSigma / domega(E0))^{-1}
6670 0 : z_e0 = one / (one - dsigc_de0)
6671 :
6672 : ! Compute linearized QP solution and store results
6673 0 : qp_ene = e0 + z_e0 * (sigc_e0__ + sigx - v_meanf)
6674 0 : qpz_ene(band, ikcalc, spin) = qp_ene
6675 0 : e0_kcalc(band, ikcalc, spin) = e0
6676 0 : sigc_e0(band, ikcalc, spin) = sigc_e0__
6677 0 : ze0_kcalc(band, ikcalc, spin) = z_e0
6678 :
6679 : ! IMPORTANT: Here we update qp_ebands%eig with the new ones obtained with the linearized QP equation.
6680 0 : gwr%qp_ebands%eig(band, ik_ibz, spin) = real(qp_ene)
6681 :
6682 : ! Compute Spectral function using linear mesh **centered** around KS e0.
6683 0 : rw_mesh = arth(e0 - gwr%wr_step * (gwr%nwr / 2), gwr%wr_step, gwr%nwr)
6684 0 : hhartree_bk = gwr%ks_ebands%eig(band, ik_ibz, spin) - v_meanf
6685 0 : do iw=1,gwr%nwr
6686 0 : zz = rw_mesh(iw)
6687 0 : call spade%eval(zz, sigc_e0__)
6688 0 : sig_xc = sigx + sigc_e0__
6689 0 : sigxc_rw_diag(iw, band, ikcalc, spin) = sig_xc
6690 :
6691 : spfunc_diag(iw, band, ikcalc, spin) = one / pi * abs(aimag(sigc_e0__)) &
6692 0 : / ( (real(rw_mesh(iw) - hhartree_bk - sig_xc)) ** 2 + (aimag(sigc_e0__)) ** 2) ! / Ha_eV
6693 :
6694 : !Sr%hhartree = hdft - KS_me%vxcval
6695 : !spfunc_diag(iw, band, ikcalc, spin) = &
6696 : ! one / pi * abs(aimag(sigc_e0__)) &
6697 : ! /( (real(rw_mesh(iw) - Sr%hhartree(ib, ib, ik_ibz, spin) - sigx_xc)) ** 2 &
6698 : ! +(aimag(sigc_e0__)) ** 2) / Ha_eV
6699 : end do ! iw
6700 0 : call spade%free()
6701 :
6702 : end do ! band
6703 : end do ! ikcalc
6704 : end do ! spin
6705 :
6706 0 : ABI_SFREE(alphas_c)
6707 0 : ABI_SFREE(betas_r)
6708 0 : ABI_SFREE(zcut_pm)
6709 :
6710 0 : if (gwr%nkcalc == gwr%nkibz) then
6711 : ! Shift the bands that are not explicitly included in the SCF calculation.
6712 : ! using the correction evaluated at bstop_ks/bstart_ks to accelerate self-consistent calculations.
6713 0 : do spin=1,gwr%nsppol
6714 0 : do ikcalc=1,gwr%nkcalc
6715 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6716 0 : band = gwr%bstop_ks(ikcalc, spin)
6717 0 : if (band + 1 <= size(gwr%qp_ebands%eig, dim=1)) then
6718 0 : eshift = gwr%qp_ebands%eig(band, ik_ibz, spin) - gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6719 0 : call wrtout(std_out, sjoin(" Correcting bands >= ", itoa(band+1), " with eshift:", ftoa(eshift * Ha_meV), "(meV)"))
6720 0 : gwr%qp_ebands%eig(band + 1:, ik_ibz, spin) = gwr%qp_ebands%eig(band + 1:, ik_ibz, spin) + eshift
6721 : end if
6722 0 : band = gwr%bstart_ks(ikcalc, spin)
6723 0 : if (band > 1) then ! unlikely
6724 0 : eshift = gwr%qp_ebands%eig(band, ik_ibz, spin) - gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6725 0 : call wrtout(std_out, sjoin(" Correcting bands < ", itoa(band), " with eshift:", ftoa(eshift * Ha_meV), "(meV)"))
6726 0 : gwr%qp_ebands%eig(:band - 1, ik_ibz, spin) = gwr%qp_ebands%eig(:band - 1, ik_ibz, spin) + eshift
6727 : end if
6728 : end do
6729 : end do
6730 :
6731 : ! Recompute occupancies and set fermie to zero.
6732 : ! FIXME: Possible problem here if the QP energies are not ordered!
6733 0 : call gwr%qp_ebands%update_occ(gwr%dtset%spinmagntarget, prtvol=gwr%dtset%prtvol, fermie_to_zero=.True.)
6734 : end if
6735 :
6736 0 : if (gwr%comm%me == 0) then
6737 : ! Master writes results to ab_out, std_out and GWR.nc
6738 0 : if (any(pade_solver_ierr /= 0)) then
6739 : ! Write warning if QP solver failed.
6740 0 : ierr = count(pade_solver_ierr /= 0)
6741 0 : call wrtout([ab_out, std_out], sjoin(" WARNING: QP solver failed for:", itoa(ierr), "states"))
6742 : end if
6743 :
6744 0 : call write_notations([std_out, ab_out])
6745 0 : do spin=1,gwr%nsppol
6746 0 : do ikcalc=1,gwr%nkcalc
6747 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6748 :
6749 0 : ydoc = yamldoc_open('GWR_SelfEnergy_ee', width=11, real_fmt='(3f8.3)')
6750 0 : call ydoc%add_real1d('kpoint', gwr%kcalc(:, ikcalc))
6751 0 : call ydoc%add_int('spin', spin, int_fmt="(i1)")
6752 0 : call ydoc%add_int('gwr_scf_iteration', gwr%scf_iteration)
6753 0 : call ydoc%add_string('gwr_task', gwr%dtset%gwr_task)
6754 :
6755 : ! Compute gaps assuming KS band indices.
6756 0 : band_val = gwr%ks_vbik(ik_ibz, spin)
6757 0 : nbc = gwr%bstop_ks(ikcalc, spin) - gwr%bstart_ks(ikcalc, spin) + 1
6758 0 : ib1 = gwr%bstart_ks(ikcalc, spin); ib2 = gwr%bstop_ks(ikcalc, spin)
6759 :
6760 0 : if (band_val >= gwr%bstart_ks(ikcalc, spin) .and. band_val + 1 <= gwr%bstop_ks(ikcalc, spin)) then
6761 0 : ibv = band_val - gwr%bstart_ks(ikcalc, spin) + 1
6762 0 : ks_gap = gwr%ks_ebands%eig(band_val+1, ik_ibz, spin) - gwr%ks_ebands%eig(band_val, ik_ibz, spin)
6763 :
6764 : ! This to detect a possible band inversion and compute qp_gaps accordingly.
6765 0 : band_inversion = .False.
6766 0 : call sort_rvals(nbc, real(qpz_ene(ib1:, ikcalc, spin)), iperm, sorted_qpe, tol=tol6)
6767 :
6768 0 : if (iperm(ibv) /= ibv .or. iperm(ibv + 1) /= ibv + 1) then
6769 0 : band_inversion = .True.
6770 0 : call ydoc%add_int('QP_VBM_band', iperm(ibv) + gwr%bstart_ks(ikcalc, spin) - 1)
6771 0 : call ydoc%add_int('QP_CBM_band', iperm(ibv+1) + gwr%bstart_ks(ikcalc, spin) - 1)
6772 0 : qp_gap = sorted_qpe(ibv+1) - sorted_qpe(ibv)
6773 0 : qp_pade_gap = qp_pade(band_val+1, ikcalc, spin) - qp_pade(band_val, ikcalc, spin)
6774 : else
6775 0 : call ydoc%add_int('QP_VBM_band', ibv + gwr%bstart_ks(ikcalc, spin) - 1)
6776 0 : call ydoc%add_int('QP_CBM_band', ibv+1 + gwr%bstart_ks(ikcalc, spin) - 1)
6777 0 : qp_gap = gwr%qp_ebands%eig(band_val+1, ik_ibz, spin) - gwr%qp_ebands%eig(band_val, ik_ibz, spin)
6778 0 : qp_pade_gap = qp_pade(band_val+1, ikcalc, spin) - qp_pade(band_val, ikcalc, spin)
6779 : end if
6780 0 : ABI_FREE(iperm)
6781 0 : ABI_FREE(sorted_qpe)
6782 :
6783 0 : call ydoc%add_real('KS_gap', ks_gap * Ha_eV)
6784 0 : call ydoc%add_real('QP_gap', qp_gap * Ha_eV)
6785 0 : call ydoc%add_real('Delta_QP_KS', (qp_gap - ks_gap) * Ha_eV)
6786 0 : ks_gaps(ikcalc, spin)= ks_gap
6787 0 : qpz_gaps(ikcalc, spin) = qp_gap
6788 0 : qp_pade_gaps(ikcalc, spin) = qp_pade_gap
6789 : end if
6790 :
6791 0 : call ydoc%open_tabular('data') !, tag='SigmaeeData')
6792 0 : write(msg, "(a5, *(a9))") "Band", "E0", "<VxcDFT>", "SigX", "SigC(E0)", "Z", "E-E0", "E-Eprev", "E", "Occ(E)"
6793 0 : call ydoc%add_tabular_line(msg)
6794 :
6795 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6796 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6797 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6798 0 : qp_ene = gwr%qp_ebands%eig(band, ik_ibz, spin)
6799 0 : qp_ene_prev = gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6800 0 : if ( gwr%sig_diago) sigx = gwr%sigx_mat(band, 1, ikcalc, spin)
6801 0 : if (.not. gwr%sig_diago) sigx = gwr%sigx_mat(band, band, ikcalc, spin)
6802 0 : if (gwr%nspinor == 2) then
6803 0 : vxc_val = SUM(gwr%ks_me%vxcval(band, band, ik_ibz, :))
6804 : else
6805 0 : vxc_val = gwr%ks_me%vxcval(band, band, ik_ibz, spin)
6806 : end if
6807 :
6808 : write(msg,'(i5, *(f9.3))') &
6809 0 : band, & ! Band
6810 0 : e0 * Ha_eV, & ! E0
6811 0 : real(vxc_val)*Ha_eV, & ! <VxcDFT>
6812 0 : real(sigx) * Ha_eV, & ! SigX
6813 0 : real(sigc_e0(band, ikcalc, spin)) * Ha_eV, & ! SigC(E0)
6814 0 : real(ze0_kcalc(band, ikcalc, spin)), & ! Z
6815 0 : (real(qp_ene - e0)) * Ha_eV, & ! E-E0
6816 0 : real(qp_ene - qp_ene_prev) * Ha_eV, & ! E-Eprev
6817 0 : real(qp_ene) * Ha_eV, & ! E
6818 0 : gwr%qp_ebands%occ(band, ik_ibz, spin) ! Occ(E)
6819 0 : call ydoc%add_tabular_line(msg)
6820 : end do
6821 :
6822 0 : call ydoc%write_units_and_free([std_out, ab_out])
6823 : end do ! ikcalc
6824 : end do ! spin
6825 :
6826 : ! Print KS and QP gaps
6827 0 : call gwr%ks_gaps%print(units, header="Kohn-Sham gaps and band edges from IBZ mesh")
6828 :
6829 0 : new_gaps = gwr%qp_ebands%get_gaps(ierr)
6830 0 : write(msg,"(a,i0,a)")" QP gaps and band edges taking into account Sigma_nk corrections for ",gwr%nkcalc," k-points"
6831 0 : call new_gaps%print(units, header=msg)
6832 0 : if (ierr /= 0) then
6833 0 : ABI_WARNING("Cannot compute QP fundamental and direct gap (likely metal)")
6834 : end if
6835 0 : call new_gaps%free()
6836 :
6837 : ! Write results to text files.
6838 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGC_IT'), msg, newunit=unt_it, action="write") /= 0) then
6839 0 : ABI_ERROR(msg)
6840 : end if
6841 0 : write(unt_it, "(a)")"# Diagonal elements of Sigma_c(i tau, +/-) in atomic units"
6842 0 : write(unt_it, "(a)")"# tau Re/Im Sigma_c(+itau) Re/Im Sigma_c(-itau)"
6843 :
6844 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGXC_IW'), msg, newunit=unt_iw, action="write") /= 0) then
6845 0 : ABI_ERROR(msg)
6846 : end if
6847 0 : write(unt_iw, "(a)")"# Diagonal elements of Sigma_xc(i omega) in eV units"
6848 0 : write(unt_iw, "(a)")"# omega Re/Im Sigma_c(i omega)"
6849 :
6850 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGXC_RW'), msg, newunit=unt_rw, action="write") /= 0) then
6851 0 : ABI_ERROR(msg)
6852 : end if
6853 0 : write(unt_rw, "(a)")"# Diagonal elements of Sigma_xc(omega) in eV units and spectral function A(omega)"
6854 0 : write(unt_rw, "(a)")"# omega Re/Im Sigma_xc(omega), A(omega)"
6855 :
6856 0 : dat_units = [unt_it, unt_iw, unt_rw]
6857 0 : call write_units(dat_units, "# Fermi energy set to zero. Energies in eV")
6858 0 : call write_units(dat_units, sjoin("# nkcalc:", itoa(gwr%nkcalc), ", nsppol:", itoa(gwr%nsppol)))
6859 :
6860 : ! TODO: Improve file format. Add compatibility with gnuplot format for datasets?
6861 0 : do spin=1,gwr%nsppol
6862 0 : do ikcalc=1,gwr%nkcalc
6863 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6864 0 : call write_units(dat_units, sjoin("# kpt:", ktoa(gwr%kcalc(:, ikcalc)), "spin:", itoa(spin)))
6865 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6866 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6867 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6868 0 : band2 = merge(1, band, gwr%sig_diago)
6869 0 : sigx = gwr%sigx_mat(band, band2, ikcalc, spin)
6870 :
6871 0 : call write_units(dat_units, sjoin("# band:", itoa(band), ", spin:", itoa(spin)))
6872 0 : call write_units(dat_units, sjoin("# sigx_ev:", ftoa(sigx * Ha_eV)))
6873 :
6874 0 : do itau=1,gwr%ntau
6875 : ! FIXME itau is not ordered
6876 : write(unt_it, "(*(es16.8))") &
6877 0 : gwr%tau_mesh(itau), &
6878 0 : c2r(sigc_it_mat(1, itau, band, band2, ikcalc, spin)), &
6879 0 : c2r(sigc_it_mat(2, itau, band, band2, ikcalc, spin))
6880 : write(unt_iw, "(*(es16.8))") &
6881 0 : gwr%iw_mesh(itau) * Ha_eV, &
6882 0 : (c2r(gwr%sigc_iw_mat(itau, band, band2, ikcalc, spin) + sigx)) * Ha_eV
6883 : end do
6884 :
6885 : ! Write Sigma_xc(omega) and A(omega)
6886 0 : rw_mesh = arth(e0 - gwr%wr_step * (gwr%nwr / 2), gwr%wr_step, gwr%nwr) * Ha_eV
6887 0 : do iw=1,gwr%nwr
6888 : write(unt_rw, "(*(es16.8))") &
6889 0 : rw_mesh(iw), &
6890 0 : c2r(sigxc_rw_diag(iw, band, ikcalc, spin)) * Ha_eV, &
6891 0 : spfunc_diag(iw, band, ikcalc, spin) / Ha_eV
6892 : end do
6893 : end do
6894 : end do
6895 : end do
6896 :
6897 0 : close(unt_it); close(unt_iw); close(unt_rw)
6898 :
6899 : ! ======================
6900 : ! Add results to GWR.nc
6901 : ! ======================
6902 0 : if (gwr%gwrnc_write) then
6903 0 : NCF_CHECK(nctk_open_modify(ncid, gwr%gwrnc_path, xmpi_comm_self))
6904 :
6905 : ! Define arrays with results.
6906 : ! TODO: Add matrix elements of vxc, have to trasfer data from vxcval to nkcalc packing
6907 0 : call ncwrite_sigmac(ncid)
6908 :
6909 : if (.true.) then
6910 0 : NCF_CHECK(nf90_def_grp(ncid, strcat("iter", itoa(gwr%scf_iteration)), iter_ncid))
6911 0 : call ncwrite_sigmac(iter_ncid)
6912 : end if
6913 :
6914 0 : NCF_CHECK(nf90_put_var(ncid, vid("scf_iteration"), gwr%scf_iteration))
6915 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_completed"), 1))
6916 0 : NCF_CHECK(nf90_close(ncid))
6917 : end if
6918 : end if ! master
6919 :
6920 0 : ABI_FREE(sigc_it_mat)
6921 : !ABI_FREE(sigc_iw_mat)
6922 :
6923 0 : call cwtime_report(" gwr_build_sigmac:", cpu_all, wall_all, gflops_all)
6924 0 : call timab(1925, 2, tsec)
6925 :
6926 : contains
6927 0 : integer function vid(vname)
6928 : character(len=*),intent(in) :: vname
6929 0 : vid = nctk_idname(ncid, vname)
6930 : end function vid
6931 :
6932 0 : subroutine print_sigma_header()
6933 :
6934 0 : if (gwr%comm%me /= 0) return
6935 0 : if (gwr%use_supercell_for_sigma) then
6936 0 : call wrtout(std_out, sjoin(" Building Sigma_c in the supercell with FFT mesh:", ltoa(sc_ngfft(1:3))), pre_newlines=2)
6937 : else
6938 0 : call wrtout([std_out,ab_out], " Building Sigma_c with convolutions in k-space:", pre_newlines=2)
6939 : end if
6940 0 : call wrtout(std_out, sjoin(" gwr_np_kgts:", ltoa(gwr%dtset%gwr_np_kgts)))
6941 0 : call wrtout(std_out, sjoin(" ngkpt:", ltoa(gwr%ngkpt), " ngqpt:", ltoa(gwr%ngqpt)))
6942 0 : call wrtout(std_out, sjoin(" gwr_boxcutmin:", ftoa(gwr%dtset%gwr_boxcutmin)))
6943 0 : call wrtout(std_out, sjoin(" my_ntau:", itoa(gwr%my_ntau), "ntau:", itoa(gwr%ntau)))
6944 0 : call wrtout(std_out, sjoin(" my_nkbz:", itoa(gwr%my_nkbz), "nkibz:", itoa(gwr%nkibz)))
6945 0 : call wrtout(std_out, sjoin("- FFT uc_batch_size:", itoa(gwr%uc_batch_size)))
6946 0 : call wrtout(std_out, sjoin("- FFT sc_batch_size:", itoa(gwr%sc_batch_size)), do_flush=.True.)
6947 :
6948 : end subroutine print_sigma_header
6949 :
6950 0 : subroutine ncwrite_sigmac(myncid)
6951 : integer,intent(in) :: myncid
6952 : !logical,intent(in), optional :: mydefine
6953 : integer :: myncerr
6954 :
6955 : ! Write Sigma_c to GWR.nc
6956 0 : NCF_CHECK(nctk_set_datamode(myncid))
6957 : ! if (.not. present(mydefine) .or. mydefine) then
6958 : if (.true.) then
6959 : myncerr = nctk_def_arrays(myncid, [ &
6960 : nctkarr_t("e0_kcalc", "dp", "smat_bsize1, nkcalc, nsppol"), &
6961 : nctkarr_t("ze0_kcalc", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6962 : !nctkarr_t("vxc_kcalc", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6963 : nctkarr_t("qpz_ene", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6964 : nctkarr_t("qp_pade", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6965 : nctkarr_t("pade_solver_ierr", "int", "smat_bsize1, nkcalc, nsppol"), &
6966 : nctkarr_t("ks_gaps", "dp", "nkcalc, nsppol"), &
6967 : nctkarr_t("qpz_gaps", "dp", "nkcalc, nsppol"), &
6968 : nctkarr_t("qp_pade_gaps", "dp", "nkcalc, nsppol"), &
6969 : nctkarr_t("sigx_mat", "dp", "two, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6970 : nctkarr_t("sigc_it_mat", "dp", "two, two, ntau, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6971 : nctkarr_t("sigc_iw_mat", "dp", "two, ntau, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6972 : nctkarr_t("sigxc_rw_diag", "dp", "two, nwr, smat_bsize1, nkcalc, nsppol"), &
6973 : nctkarr_t("spfunc_diag", "dp", "nwr, smat_bsize1, nkcalc, nsppol") &
6974 0 : ])
6975 0 : NCF_CHECK(myncerr)
6976 : end if
6977 : ! Write data.
6978 0 : NCF_CHECK(nctk_set_datamode(myncid))
6979 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "e0_kcalc"), e0_kcalc))
6980 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "ze0_kcalc"), c2r(ze0_kcalc)))
6981 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigx_mat"), c2r(gwr%sigx_mat(:,:,:,1:gwr%nsppol))))
6982 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qpz_ene"), c2r(qpz_ene)))
6983 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qp_pade"), c2r(qp_pade)))
6984 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "pade_solver_ierr"), pade_solver_ierr))
6985 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "ks_gaps"), ks_gaps))
6986 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qpz_gaps"), qpz_gaps))
6987 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qp_pade_gaps"), qp_pade_gaps))
6988 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigc_it_mat"), c2r(sigc_it_mat)))
6989 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigc_iw_mat"), c2r(gwr%sigc_iw_mat)))
6990 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigxc_rw_diag"), c2r(sigxc_rw_diag)))
6991 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "spfunc_diag"), spfunc_diag))
6992 :
6993 0 : end subroutine ncwrite_sigmac
6994 :
6995 : end subroutine gwr_build_sigmac
6996 : !!***
6997 :
6998 : !!****f* m_gwr/write_notations
6999 : !! NAME
7000 : !! write_notations
7001 : !!
7002 : !! FUNCTION
7003 : !! Write the meaning of the different columns.
7004 : !!
7005 : !! SOURCE
7006 :
7007 0 : subroutine write_notations(units)
7008 : integer,intent(in) :: units(:)
7009 : integer :: ii, unt
7010 :
7011 0 : do ii=1,size(units)
7012 0 : unt = units(ii)
7013 0 : write(unt,"(a)")repeat("=", 80)
7014 0 : write(unt,"(a)")" QP results (energies in eV)"
7015 0 : write(unt,"(a)")" Notations:"
7016 0 : write(unt,"(a)")" E0: Kohn-Sham energy"
7017 0 : write(unt,"(a)")" <VxcDFT>: Matrix elements of Vxc[n_val] without non-linear core correction (if any)"
7018 0 : write(unt,"(a)")" SigX: Matrix elements of Sigma_x"
7019 0 : write(unt,"(a)")" SigC(E0): Matrix elements of Sigma_c at E0"
7020 0 : write(unt,"(a)")" Z: Renormalization factor"
7021 0 : write(unt,"(a)")" E-E0: Difference between the QP and the KS energy."
7022 0 : write(unt,"(a)")" E-Eprev: Difference between QP energy at iteration i and i-1"
7023 0 : write(unt,"(a)")" E: Quasi-particle energy"
7024 0 : write(unt,"(a)")" Occ(E): Occupancy of QP state"
7025 : !write(unt,"(a)")" SE1(eKS): Real part of the self-energy computed at the KS energy, SE2 for imaginary part."
7026 0 : write(unt,"(a)")" "
7027 0 : write(unt,"(a)")" "
7028 : end do
7029 0 : end subroutine write_notations
7030 : !!***
7031 :
7032 : !----------------------------------------------------------------------
7033 :
7034 : !!****f* m_gwr/sig_braket_ur
7035 : !! NAME
7036 : !! sig_braket_ur
7037 : !!
7038 : !! FUNCTION
7039 : !! Integrate self-energy matrix elements in the unit cell.
7040 : !!
7041 : !! INPUTS
7042 : !!
7043 : !! OUTPUT
7044 : !!
7045 : !! SOURCE
7046 :
7047 0 : subroutine sig_braket_ur(sig_rpr, nfftsp, ur_bra_glob, ur_ket_glob, sigm_pm, loc_cwork)
7048 :
7049 : !Arguments ------------------------------------
7050 : type(__slkmat_t),intent(in) :: sig_rpr(2,2)
7051 : integer,intent(in) :: nfftsp
7052 : complex(gwp),intent(in) :: ur_bra_glob(nfftsp)
7053 : complex(gwp),intent(in) :: ur_ket_glob(nfftsp)
7054 :
7055 : complex(gwp),intent(out) :: sigm_pm(2)
7056 : complex(gwp),intent(inout) :: loc_cwork(sig_rpr(1,1)%size_local(2))
7057 :
7058 : !Local variables-------------------------------
7059 : integer :: ipm, ir1, il_r1, nrows, ncols, itim
7060 : !complex(gwp),allocatable :: loc_cwork(:)
7061 : ! *************************************************************************
7062 :
7063 : ABI_NVTX_START_RANGE(NVTX_GWR_BRAKET_UR)
7064 :
7065 : ! (r',r) with r' local and r-index PBLAS-distributed.
7066 0 : sigm_pm = czero_gw
7067 0 : do itim=1,2
7068 0 : do ipm=1,2
7069 0 : associate (rp_r => sig_rpr(itim,ipm))
7070 : ! Integrate over r'
7071 : !ABI_CHECK_IEQ(nfftsp, rp_r%size_local(1), "First dimension should be local to each MPI proc!")
7072 : !ABI_MALLOC(loc_cwork, (rp_r%size_local(2)))
7073 : !loc_cwork(:) = matmul(transpose(rp_r%buffer_cplx), ur_glob)
7074 :
7075 0 : nrows = rp_r%size_local(1); ncols = rp_r%size_local(2)
7076 0 : call xgemv('T', nrows, ncols, cone_gw, rp_r%buffer_cplx, nrows, ur_ket_glob, 1, czero_gw, loc_cwork, 1)
7077 :
7078 : ! Integrate over r. Note complex conjugate.
7079 0 : do il_r1=1,rp_r%size_local(2)
7080 0 : ir1 = rp_r%loc2gcol(il_r1)
7081 0 : if (itim == 1) then
7082 0 : sigm_pm(ipm) = sigm_pm(ipm) + conjg(ur_bra_glob(ir1)) * loc_cwork(il_r1)
7083 : else
7084 0 : sigm_pm(ipm) = sigm_pm(ipm) + ur_bra_glob(ir1) * conjg(loc_cwork(il_r1))
7085 : end if
7086 : end do
7087 : !ABI_FREE(loc_cwork)
7088 : end associate
7089 : end do
7090 : end do
7091 :
7092 : ABI_NVTX_END_RANGE()
7093 :
7094 0 : end subroutine sig_braket_ur
7095 : !!***
7096 :
7097 : !----------------------------------------------------------------------
7098 :
7099 : !!****f* m_gwr/gwr_rpa_energy
7100 : !! NAME
7101 : !! gwr_rpa_energy
7102 : !!
7103 : !! FUNCTION
7104 : !! Compute the correlated part of the total energy within ACFDT.
7105 : !!
7106 : !! INPUTS
7107 : !!
7108 : !! OUTPUT
7109 : !!
7110 : !! SOURCE
7111 :
7112 0 : subroutine gwr_rpa_energy(gwr)
7113 :
7114 : !Arguments ------------------------------------
7115 : class(gwr_t),target,intent(inout) :: gwr
7116 :
7117 : !Local variables-------------------------------
7118 : !scalars
7119 : integer,parameter :: master = 0
7120 : integer :: my_is, my_iqi, my_it, itau, spin, iq_ibz, ii, ierr, ig, ncut, icut, mat_size
7121 : integer :: il_g1, il_g2, ig1, ig2, npw_q, ig0, ncid, ncerr
7122 : logical :: q_is_gamma, print_time
7123 : real(dp) :: weight, qq_ibz(3), estep, aa, bb, rmsq, ecut_soft, damp, tsec(2)
7124 : real(dp) :: cpu_all, wall_all, gflops_all, cpu_q, wall_q, gflops_q, cpu_cut, wall_cut, gflops_cut
7125 : complex(dp) :: vcs_g1, vcs_g2
7126 : type(desc_t),pointer :: desc_q
7127 : character(len=500) :: msg
7128 : !arrays
7129 0 : type(__slkmat_t) :: chi_tmp, dummy_vec, chi_4diag
7130 : type(slk_processor_t) :: proc_4diag
7131 0 : real(gwp),allocatable :: eig(:)
7132 0 : real(dp),allocatable :: kin_qg(:), ec_rpa(:), ec_mp2(:), ecut_chi(:)
7133 : ! *************************************************************************
7134 :
7135 0 : call gwr%build_chi0_head_and_wings()
7136 0 : call gwr%build_green(free_ugb=.True.)
7137 0 : call gwr%build_tchi()
7138 :
7139 : ! Compute RPA energy for ncut cutoff energies in order to extrapolate for ecuteps --> oo
7140 : ! See also calc_rpa_functional in m_screening_driver
7141 0 : ncut = max(1, gwr%dtset%gwr_rpa_ncut) ! Usually 5
7142 0 : estep = -gwr%dtset%ecuteps * 0.05_dp
7143 :
7144 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
7145 0 : call timab(1928, 1, tsec)
7146 0 : call wrtout(std_out, sjoin(" Begin computation of RPA energy with gwr_rpa_ncut:", itoa(ncut), " ..."))
7147 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("tchi_space:", gwr%tchi_space, "!= iomega"))
7148 :
7149 0 : ABI_CALLOC(ec_rpa, (ncut))
7150 0 : ABI_CALLOC(ec_mp2, (ncut))
7151 0 : ABI_MALLOC(ecut_chi, (ncut))
7152 0 : ecut_chi = arth(gwr%dtset%ecuteps + tol12, estep, ncut)
7153 :
7154 : ! Polarizability has been summed over spins inside build_tchi.
7155 : ! The loop over spins is needed to parallelize the loop over my_iqi if nsppol == 2.
7156 0 : do my_is=1,gwr%my_nspins
7157 0 : spin = gwr%my_spins(my_is)
7158 0 : if (gwr%spin_comm%nproc == 1 .and. spin == 2) cycle
7159 :
7160 0 : do my_iqi=1,gwr%my_nqibz
7161 0 : if (gwr%spin_comm%skip(my_iqi)) cycle
7162 0 : print_time = gwr%comm%me == 0 .and. (my_iqi < LOG_MODK .or. mod(my_iqi, LOG_MODK) == 0)
7163 0 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
7164 :
7165 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
7166 0 : q_is_gamma = normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0
7167 : !if (q_is_gamma) then
7168 : ! call wrtout([std_out, ab_out], "RPA: Ignoring q==0"); cycle
7169 : !end if
7170 :
7171 : ! iq_ibz might be replicated inside gwr%kpt_comm.
7172 0 : if (.not. gwr%itreat_iqibz(iq_ibz)) cycle
7173 :
7174 0 : desc_q => gwr%tchi_desc_qibz(iq_ibz)
7175 0 : ABI_CHECK(desc_q%kin_sorted, "g-vectors are not sorted by |q+g|^2/2 !")
7176 0 : npw_q = desc_q%npw; ig0 = desc_q%ig0
7177 :
7178 0 : ABI_MALLOC(kin_qg, (npw_q))
7179 0 : do ig=1,npw_q
7180 0 : kin_qg(ig) = half * normv(qq_ibz + desc_q%gvec(:,ig), gwr%cryst%gmet, "G") ** 2
7181 : end do
7182 :
7183 0 : do my_it=1,gwr%my_ntau
7184 0 : itau = gwr%my_itaus(my_it)
7185 0 : associate (tchi => gwr%tchi_qibz(iq_ibz, itau, spin))
7186 0 : if (my_it == 1) then
7187 : ! Allocate workspace. NB: npw_q is the total number of PWs for this q.
7188 0 : call tchi%copy(chi_tmp)
7189 : !ABI_CHECK_IEQ(npw_q, tchi%sizeb_global(1), "npw_q")
7190 0 : ABI_MALLOC(eig, (npw_q))
7191 : end if
7192 :
7193 0 : do icut=1,ncut
7194 0 : call cwtime(cpu_cut, wall_cut, gflops_cut, "start")
7195 :
7196 : ! Damp Coulomb kernel in order to have smooth E(V).
7197 : ! See also https://www.vasp.at/wiki/index.php/ENCUTGWSOFT
7198 : ! and Harl's PhD thesis available at: https://utheses.univie.ac.at/detail/2259
7199 0 : ecut_soft = 0.8_dp * ecut_chi(icut)
7200 :
7201 : ! TODO: Contribution due to the head for q --> 0 is ignored.
7202 : ! This is not optimal but consistent with calc_rpa_functional
7203 0 : do il_g2=1,tchi%size_local(2)
7204 : !ig2 = mod(tchi%loc2gcol(il_g2) - 1, desc_q%npw) + 1
7205 0 : ig2 = tchi%loc2gcol(il_g2)
7206 0 : damp = one
7207 : !if (kin_qg(ig2) > ecut_soft) then
7208 : ! damp = sqrt(half * (one + cos(pi * (kin_qg(ig2) - ecut_soft) / (ecut_chi(icut) - ecut_soft))))
7209 : !end if
7210 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2) * damp
7211 0 : if (q_is_gamma .and. ig2 == ig0) vcs_g2 = zero
7212 :
7213 0 : do il_g1=1,tchi%size_local(1)
7214 : !ig1 = mod(tchi%loc2grow(il_g1) - 1, desc_q%npw) + 1
7215 0 : ig1 = tchi%loc2grow(il_g1)
7216 0 : damp = one
7217 : !if (kin_qg(ig1) > ecut_soft) then
7218 : ! damp = sqrt(half * (one + cos(pi * (kin_qg(ig1) - ecut_soft) / (ecut_chi(icut) - ecut_soft))))
7219 : !end if
7220 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1) * damp
7221 0 : if (q_is_gamma .and. ig1 == ig0) vcs_g1 = zero
7222 :
7223 0 : chi_tmp%buffer_cplx(il_g1, il_g2) = tchi%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2
7224 : end do
7225 : end do
7226 :
7227 : ! Diagonalize sub-matrix and perform integration in imaginary frequency.
7228 : ! Eq (6) in 10.1103/PhysRevB.81.115126
7229 : ! NB: have to build chi_tmp inside loop over icut as matrix is destroyed by pzheev.
7230 0 : mat_size = bisect(kin_qg, ecut_chi(icut))
7231 :
7232 : ! Change size block and, if possible, use 2D rectangular grid of processors for diagonalization
7233 0 : call proc_4diag%init(chi_tmp%processor%comm)
7234 0 : call chi_tmp%change_size_blocs(chi_4diag, processor=proc_4diag)
7235 : !call chi_4diag%copy(dummy_vec)
7236 0 : call chi_4diag%heev("N", "U", dummy_vec, eig, mat_size=mat_size)
7237 0 : call chi_4diag%free()
7238 : !call dummy_vec%free()
7239 0 : call proc_4diag%free()
7240 :
7241 : ! TODO: ELPA
7242 : !call compute_eigen_problem(processor, matrix, results, eigen, comm, istwf_k, nev)
7243 :
7244 0 : if (xmpi_comm_rank(chi_tmp%processor%comm) == 0) then
7245 0 : weight = gwr%wtq(iq_ibz) * gwr%iw_wgs(itau) / two_pi
7246 0 : do ii=1,mat_size
7247 0 : ec_rpa(icut) = ec_rpa(icut) + weight * (log(one - eig(ii)) + eig(ii))
7248 : ! second order Moeller Plesset.
7249 0 : ec_mp2(icut) = ec_mp2(icut) - weight * eig(ii) ** 2 / two
7250 : !if (eig(ii) > zero) then
7251 : ! write(msg, "(a, es16.8)")"Positive eigenvalue:", eig(ii)
7252 : ! ABI_ERROR(msg)
7253 : !end if
7254 : end do
7255 : end if
7256 :
7257 0 : write(msg,'(4x,2(a,i0),a)')"icut [", icut, "/", ncut, "]"
7258 0 : call cwtime_report(msg, cpu_cut, wall_cut, gflops_cut)
7259 : end do ! icut
7260 :
7261 0 : if (my_it == gwr%my_ntau) then
7262 : ! Free workspace
7263 0 : call chi_tmp%free()
7264 0 : ABI_FREE(eig)
7265 : end if
7266 : end associate
7267 : end do ! my_it
7268 :
7269 0 : ABI_FREE(kin_qg)
7270 0 : if (print_time) then
7271 0 : write(msg,'(4x,2(a,i0),a)')"My iqi [", my_iqi, "/", gwr%my_nqibz, "]"
7272 0 : call cwtime_report(msg, cpu_q, wall_q, gflops_q)
7273 : end if
7274 : end do ! my_iqi
7275 : end do ! my_is
7276 :
7277 : ! Collect results on the master node.
7278 0 : call xmpi_sum_master(ec_rpa, master, gwr%comm%value, ierr)
7279 0 : call xmpi_sum_master(ec_mp2, master, gwr%comm%value, ierr)
7280 :
7281 0 : if (gwr%comm%me == master) then
7282 : ! Print results to ab_out.
7283 : ! TODO: Add metadata: nband, nqbz...
7284 0 : write(ab_out, "(4a16)")"ecut_chi", "ecut_chi^(-3/2)", "RPA Ec (eV)", "RPA Ec (Ha)"
7285 0 : do icut=ncut,1,-1
7286 0 : write(ab_out, "(*(es16.8))") ecut_chi(icut), ecut_chi(icut) ** (-three/two), ec_rpa(icut) * Ha_eV, ec_rpa(icut)
7287 : end do
7288 0 : if (ncut > 1) then
7289 : ! Add last line with extrapolated value.
7290 0 : rmsq = linfit(ncut, ecut_chi(:) ** (-three/two), ec_rpa, aa, bb)
7291 0 : write(ab_out, "(2a16,*(es16.8))") "oo", "0", bb * Ha_eV, bb
7292 : end if
7293 :
7294 : ! ======================
7295 : ! Add results to GWR.nc
7296 : ! ======================
7297 0 : if (gwr%gwrnc_write) then
7298 0 : NCF_CHECK(nctk_open_modify(ncid, gwr%gwrnc_path, xmpi_comm_self))
7299 0 : ncerr = nctk_def_dims(ncid, [nctkdim_t("ncut", ncut)], defmode=.True.)
7300 0 : NCF_CHECK(ncerr)
7301 :
7302 : ncerr = nctk_def_arrays(ncid, [ &
7303 : nctkarr_t("ecut_chi", "dp", "ncut"), &
7304 : nctkarr_t("ec_rpa_ecut", "dp", "ncut"), &
7305 : nctkarr_t("ec_mp2_ecut", "dp", "ncut") &
7306 0 : ])
7307 0 : NCF_CHECK(ncerr)
7308 :
7309 : ! Write data.
7310 0 : NCF_CHECK(nctk_set_datamode(ncid))
7311 0 : NCF_CHECK(nf90_put_var(ncid, vid("ecut_chi"), ecut_chi))
7312 0 : NCF_CHECK(nf90_put_var(ncid, vid("ec_rpa_ecut"), ec_rpa))
7313 0 : NCF_CHECK(nf90_put_var(ncid, vid("ec_mp2_ecut"), ec_mp2))
7314 : end if
7315 : end if ! master
7316 :
7317 0 : ABI_FREE(ec_rpa)
7318 0 : ABI_FREE(ec_mp2)
7319 0 : ABI_FREE(ecut_chi)
7320 :
7321 0 : call cwtime_report(" gwr_rpa_energy:", cpu_all, wall_all, gflops_all)
7322 0 : call timab(1928, 2, tsec)
7323 :
7324 : contains
7325 0 : integer function vid(vname)
7326 : character(len=*),intent(in) :: vname
7327 0 : vid = nctk_idname(ncid, vname)
7328 : end function vid
7329 :
7330 : end subroutine gwr_rpa_energy
7331 : !!***
7332 :
7333 : !----------------------------------------------------------------------
7334 :
7335 : !!****f* m_gwr/gwr_run_g0w0
7336 : !! NAME
7337 : !! gwr_run_g0w0
7338 : !!
7339 : !! FUNCTION
7340 : !! Driver to compute QP energies within the G0W0 approximation and minimax meshes along the imaginary axis.
7341 : !!
7342 : !! INPUTS
7343 : !! [free_ugb]: True if array with empty KS states should be freed as soon as possibile. Default: True
7344 : !!
7345 : !! OUTPUT
7346 : !!
7347 : !! SOURCE
7348 :
7349 0 : subroutine gwr_run_g0w0(gwr, free_ugb)
7350 :
7351 : !Arguments ------------------------------------
7352 : class(gwr_t),intent(inout) :: gwr
7353 : logical,optional,intent(in) :: free_ugb
7354 :
7355 : !Local variables-------------------------------
7356 : logical :: free_ugb__
7357 : ! *************************************************************************
7358 :
7359 : ! Use ugb wavefunctions and the Lehmann representation to compute head/wings and Sigma_x matrix elements.
7360 0 : call gwr%build_chi0_head_and_wings()
7361 0 : call gwr%build_sigxme()
7362 :
7363 : ! Now compute G(itau) from ugb and start the GWR algorithm.
7364 0 : free_ugb__ = .True.; if (present(free_ugb)) free_ugb__ = free_ugb
7365 0 : call gwr%build_green(free_ugb=free_ugb__)
7366 0 : call gwr%build_tchi()
7367 0 : call gwr%build_wc()
7368 0 : call gwr%build_sigmac()
7369 :
7370 0 : end subroutine gwr_run_g0w0
7371 : !!***
7372 :
7373 : !!****f* m_gwr/gwr_run_chi0
7374 : !! NAME
7375 : !! gwr_run_chi0
7376 : !!
7377 : !! FUNCTION
7378 : !! Driver to compute CHI0 along the imaginary axis.
7379 : !!
7380 : !! INPUTS
7381 : !! [free_ugb]: True if array with empty KS states should freed as soon as possibile. Default: True
7382 : !!
7383 : !! OUTPUT
7384 : !!
7385 : !! SOURCE
7386 :
7387 0 : subroutine gwr_run_chi0(gwr, free_ugb)
7388 :
7389 : !Arguments ------------------------------------
7390 : class(gwr_t),intent(inout) :: gwr
7391 : logical,optional,intent(in) :: free_ugb
7392 :
7393 : !Local variables-------------------------------
7394 : logical :: free_ugb__
7395 : ! *************************************************************************
7396 :
7397 : ! Use ugb wavefunctions and the Lehmann representation to compute head/wings.
7398 0 : call gwr%build_chi0_head_and_wings()
7399 :
7400 : ! Now compute G(itau) from ugb and start the GWR algorithm for chi.
7401 0 : free_ugb__ = .True.; if (present(free_ugb)) free_ugb__ = free_ugb
7402 0 : call gwr%build_green(free_ugb=free_ugb__)
7403 0 : call gwr%build_tchi()
7404 :
7405 0 : end subroutine gwr_run_chi0
7406 : !!***
7407 :
7408 : !----------------------------------------------------------------------
7409 :
7410 : !!****f* m_gwr/gwr_run_energy_scf
7411 : !! NAME
7412 : !! gwr_run_energy_scf
7413 : !!
7414 : !! FUNCTION
7415 : !! Compute QP energies within energy-only self-consistent GW approximation
7416 : !! and minimax meshes along the imaginary axis.
7417 : !!
7418 : !! INPUTS
7419 : !!
7420 : !! OUTPUT
7421 : !!
7422 : !! SOURCE
7423 :
7424 0 : subroutine gwr_run_energy_scf(gwr)
7425 :
7426 : !Arguments ------------------------------------
7427 : class(gwr_t),intent(inout) :: gwr
7428 :
7429 : !Local variables-------------------------------
7430 : integer,parameter :: master = 0
7431 : integer :: units(2)
7432 : logical :: converged
7433 : character(len=500) :: msg
7434 : ! *************************************************************************
7435 :
7436 : ! TODO:
7437 : ! To implement restart capabilities we need to read scf_iteration, qp_ebands and gwr_task from GWR.nc
7438 : ! build_sigmac should be responsible for writing checkpoint data with qp_ebands at each iteration.
7439 0 : units = [std_out, ab_out]
7440 :
7441 0 : ABI_CHECK_IEQ(gwr%nkcalc, gwr%nkibz, "For energy-only GW, one should include all k-points in the IBZ")
7442 :
7443 0 : select case (gwr%dtset%gwr_task)
7444 : case ("EGEW")
7445 0 : converged = .False.
7446 0 : call wrtout(units, " Begin energy-only self-consistency in both G and W (EGEW)")
7447 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7448 0 : call gwr%run_g0w0(free_ugb=.False.)
7449 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7450 0 : call gwr%check_scf_cycle(converged)
7451 : end do
7452 :
7453 : case ("EGW0")
7454 0 : call wrtout(units, " Begin energy-only self-consistency in G (EGW0)")
7455 0 : call gwr%run_g0w0(free_ugb=.False.)
7456 0 : converged = .False.
7457 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7458 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7459 0 : call gwr%build_green(free_ugb=.False.)
7460 0 : call gwr%build_sigxme() ! NB: This should not change in semiconductors
7461 0 : call gwr%build_sigmac()
7462 0 : call gwr%check_scf_cycle(converged)
7463 : end do
7464 :
7465 : case ("G0EW")
7466 : ! This is more difficult to implement as we need to store G0 and eG
7467 : ! and then use G only for chi and not in Sigma
7468 0 : call wrtout(units, " Begin energy-only self-consistency in W (G0EW)")
7469 0 : ABI_ERROR("G0EW is not yet implemented")
7470 0 : call gwr%run_g0w0(free_ugb=.False.)
7471 0 : converged = .False.
7472 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7473 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7474 : !call gwr%build_green(free_ugb=.False.)
7475 0 : call gwr%build_chi0_head_and_wings()
7476 0 : call gwr%build_tchi()
7477 0 : call gwr%build_wc()
7478 0 : call gwr%build_sigmac()
7479 0 : call gwr%check_scf_cycle(converged)
7480 : end do
7481 :
7482 : case default
7483 0 : ABI_ERROR(sjoin("Invalid gwr_task:", gwr%dtset%gwr_task))
7484 : end select
7485 :
7486 0 : if (gwr%comm%me == master) then
7487 0 : if (converged) then
7488 : write(msg, "(1x,4a,i0,a,f8.3,a)") &
7489 0 : trim(gwr%dtset%gwr_task), " self-consistent loop:", ch10, &
7490 0 : " Convergence achieved at iteration: ", gwr%scf_iteration, &
7491 0 : " with gwr_tolqpe: ",gwr%dtset%gwr_tolqpe * Ha_meV, " (meV)"
7492 0 : call wrtout(units, msg)
7493 : else
7494 : write(msg, "(1x,4a,f8.3,3a,i0,a)") &
7495 0 : trim(gwr%dtset%gwr_task), " self-consistent loop:", ch10, &
7496 0 : " WARNING: Could not converge with gwr_tolqpe: ",gwr%dtset%gwr_tolqpe * Ha_meV, " (meV)", ch10, &
7497 0 : " after: ", gwr%dtset%gwr_nstep, " steps"
7498 0 : call wrtout(units, msg)
7499 : end if
7500 : end if
7501 :
7502 0 : end subroutine gwr_run_energy_scf
7503 : !!***
7504 :
7505 : !----------------------------------------------------------------------
7506 :
7507 : !!****f* m_gwr/check_scf_cyle
7508 : !! NAME
7509 : !! check_scf_cycle
7510 : !!
7511 : !! FUNCTION
7512 : !!
7513 : !! INPUTS
7514 : !!
7515 : !! OUTPUT
7516 : !!
7517 : !! SOURCE
7518 :
7519 0 : subroutine gwr_check_scf_cycle(gwr, converged)
7520 :
7521 : !Arguments ------------------------------------
7522 : class(gwr_t),intent(in) :: gwr
7523 : logical,intent(out) :: converged
7524 :
7525 : !Local variables-------------------------------
7526 : integer,parameter :: master = 0
7527 : integer :: spin, ikcalc, ik_ibz, band, ib, jb
7528 : character(len=500) :: msg
7529 0 : real(dp) :: max_adiff, adiff(gwr%qp_ebands%mband)
7530 : integer :: units(2)
7531 : ! *************************************************************************
7532 :
7533 0 : max_adiff = -one; converged = .True.; units = [std_out, ab_out]
7534 :
7535 0 : if (gwr%comm%me == master) then
7536 0 : call wrtout(units, sjoin(" Checking for convergence at iteration:", itoa(gwr%scf_iteration)))
7537 : end if
7538 :
7539 : associate (now => gwr%qp_ebands, prev => gwr%qp_ebands_prev)
7540 0 : do spin=1,gwr%nsppol
7541 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
7542 : ! Compute max abs difference between QP at iteration i and i-1.
7543 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
7544 0 : ib = gwr%bstart_ks(ikcalc, spin); jb = gwr%bstop_ks(ikcalc, spin)
7545 0 : adiff = zero; adiff(ib:jb) = abs(now%eig(ib:jb, ik_ibz, spin) - prev%eig(ib:jb, ik_ibz, spin))
7546 0 : band = maxloc(adiff, dim=1)
7547 0 : max_adiff = max(max_adiff, adiff(band))
7548 0 : if (adiff(band) > gwr%dtset%gwr_tolqpe) converged = .False.
7549 0 : if (gwr%comm%me == master) then
7550 : ! Write info
7551 0 : write(msg, "(a,i0,1x,2a,i0)") " For k-point: ", ik_ibz, trim(ktoa(now%kptns(:,ik_ibz))),", spin: ", spin
7552 0 : call wrtout(units, msg)
7553 0 : write(msg, "(4x,a,es12.5,a,i0)")"max(abs(E_i - E_{i-1})): ", adiff(band) * Ha_meV, " (meV) for band: ", band
7554 0 : call wrtout(units, msg)
7555 : end if
7556 : end do
7557 : end do
7558 : end associate
7559 :
7560 : ! Make sure that all MPI procs agree on this!
7561 0 : call xmpi_land(converged, gwr%comm%value)
7562 :
7563 0 : if (gwr%comm%me == master) then
7564 0 : write(msg, "(a,i0,a)") "QP gaps at iteration: ",gwr%scf_iteration," (Fermi energy set to zero)"
7565 0 : call gwr%qp_ebands%print_gaps(units, header=msg)
7566 0 : if (.not. converged) then
7567 0 : call wrtout(units," Not converged --> start new iteration ...")
7568 : !else
7569 : ! call wrtout(units, sjoin(" Convergence achieved at iteration", itoa(gwr%scf_iteration)))
7570 : end if
7571 : ! TODO: Increment scf_iteration in GWR.nc
7572 : end if
7573 :
7574 0 : end subroutine gwr_check_scf_cycle
7575 : !!***
7576 :
7577 : !----------------------------------------------------------------------
7578 :
7579 : !!****f* m_gwr/gwr_ncwrite_tchi_wc
7580 : !! NAME
7581 : !! gwr_ncwrite_tchi_wc
7582 : !!
7583 : !! FUNCTION
7584 : !! Write tchi or wc to netcdf file
7585 : !!
7586 : !! INPUTS
7587 : !! what: "tchi" or "wc"
7588 : !! wt_space: "omega" or "tau"
7589 : !!
7590 : !! OUTPUT
7591 : !!
7592 : !! SOURCE
7593 :
7594 0 : subroutine gwr_ncwrite_tchi_wc(gwr, what, wt_space, keep_file, filepath)
7595 :
7596 : !Arguments ------------------------------------
7597 : class(gwr_t),target,intent(in) :: gwr
7598 : logical,intent(in) :: keep_file
7599 : character(len=*),intent(in) :: what, wt_space, filepath
7600 :
7601 : !Local variables-------------------------------
7602 : !scalars
7603 : integer,parameter :: master = 0
7604 : integer :: my_is, my_iqi, my_it, spin, iq_ibz, itau, npwtot_q, my_ncols, my_gcol_start, ncid, ncerr, var_id !, ierr
7605 : real(dp) :: cpu, wall, gflops
7606 : !arrays
7607 0 : real(dp), contiguous, pointer :: fptr(:,:,:)
7608 0 : type(__slkmat_t), pointer :: mats(:)
7609 : ! *************************************************************************
7610 :
7611 : ! Cannot reuse SCR.nc/SUSC.nc fileformat as:
7612 : ! - hscr_new requires ep% instance
7613 : ! - old file formats assume Gamma-centered G vectors.
7614 :
7615 0 : call cwtime(cpu, wall, gflops, "start")
7616 :
7617 0 : if (gwr%comm%me == master) then
7618 0 : call wrtout(std_out, sjoin(" Writing", what, "with wt_space:", wt_space, "to:", filepath))
7619 0 : if (keep_file) then
7620 0 : NCF_CHECK(nctk_open_modify(ncid, filepath, xmpi_comm_self))
7621 : else
7622 0 : NCF_CHECK(nctk_open_create(ncid, filepath, xmpi_comm_self))
7623 : end if
7624 :
7625 : ! Write structure and qp_ebands
7626 0 : NCF_CHECK(gwr%cryst%ncwrite(ncid))
7627 0 : NCF_CHECK(gwr%qp_ebands%ncwrite(ncid))
7628 :
7629 : ! Add dimensions.
7630 : ncerr = nctk_def_dims(ncid, [ &
7631 : nctkdim_t("nsppol", gwr%nsppol), nctkdim_t("ntau", gwr%ntau), nctkdim_t("mpw", gwr%tchi_mpw), &
7632 : nctkdim_t("nqibz", gwr%nqibz), nctkdim_t("nqbz", gwr%nqbz)], &
7633 0 : defmode=.True.)
7634 0 : NCF_CHECK(ncerr)
7635 :
7636 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
7637 : "gwr_completed" &
7638 0 : ])
7639 :
7640 : ! Define arrays with results.
7641 : ! TODO: Add metadata for mats: spin sum, vc cutoff, t/w mesh, handle nspinor 2
7642 : ncerr = nctk_def_arrays(ncid, [ &
7643 : nctkarr_t("ngkpt", "int", "three"), &
7644 : nctkarr_t("ngqpt", "int", "three"), &
7645 : nctkarr_t("qibz", "dp", "three, nqibz"), &
7646 : nctkarr_t("wtq", "dp", "nqibz"), &
7647 : nctkarr_t("tau_mesh", "dp", "ntau"), &
7648 : nctkarr_t("tau_wgs", "dp", "ntau"), &
7649 : nctkarr_t("iw_mesh", "dp", "ntau"), &
7650 : nctkarr_t("iw_wgs", "dp", "ntau"), &
7651 : nctkarr_t("gvecs", "int", "three, mpw, nqibz"), &
7652 : nctkarr_t("chinpw_qibz", "int", "nqibz") &
7653 0 : ])
7654 0 : NCF_CHECK(ncerr)
7655 :
7656 0 : if (wt_space == "omega") then
7657 0 : NCF_CHECK(nctk_def_arrays(ncid, [nctkarr_t("mats_w", "dp", "two, mpw, mpw, ntau, nqibz, nsppol")]))
7658 0 : else if (wt_space == "tau") then
7659 0 : NCF_CHECK(nctk_def_arrays(ncid, [nctkarr_t("mats_tau", "dp", "two, mpw, mpw, ntau, nqibz, nsppol")]))
7660 : end if
7661 :
7662 : ! Write global arrays.
7663 0 : NCF_CHECK(nctk_set_datamode(ncid))
7664 :
7665 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
7666 : "gwr_completed"], &
7667 0 : [0])
7668 0 : NCF_CHECK(ncerr)
7669 :
7670 0 : NCF_CHECK(nf90_put_var(ncid, vid("ngkpt"), gwr%ngkpt))
7671 0 : NCF_CHECK(nf90_put_var(ncid, vid("ngqpt"), gwr%ngqpt))
7672 0 : NCF_CHECK(nf90_put_var(ncid, vid("qibz"), gwr%qibz))
7673 0 : NCF_CHECK(nf90_put_var(ncid, vid("wtq"), gwr%wtq))
7674 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_mesh"), gwr%tau_mesh))
7675 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_wgs"), gwr%tau_wgs))
7676 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_mesh"), gwr%iw_mesh))
7677 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_wgs"), gwr%iw_wgs))
7678 0 : NCF_CHECK(nf90_put_var(ncid, vid("chinpw_qibz"), gwr%chinpw_qibz))
7679 0 : NCF_CHECK(nf90_close(ncid))
7680 : end if
7681 :
7682 0 : call xmpi_barrier(gwr%comm%value)
7683 :
7684 : ! Reopen the file in gwr%comm.
7685 0 : NCF_CHECK(nctk_open_modify(ncid, filepath, gwr%comm%value))
7686 :
7687 0 : if (wt_space == "omega") then
7688 0 : NCF_CHECK(nctk_prepare_mpiio(ncid, "mats_w"))
7689 0 : else if (wt_space == "tau") then
7690 0 : NCF_CHECK(nctk_prepare_mpiio(ncid, "mats_tau"))
7691 : end if
7692 :
7693 0 : do my_is=1,gwr%my_nspins
7694 0 : spin = gwr%my_spins(my_is)
7695 0 : do my_iqi=1,gwr%my_nqibz
7696 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
7697 :
7698 : ! The same q-point in the IBZ might be stored on different pools.
7699 : ! To avoid writing the same array multiple times, we use itreat_qibz
7700 : ! to select the procs inside gwr%kpt_comm who are gonna write this iq_ibz q-point.
7701 0 : if (.not. gwr%itreat_iqibz(iq_ibz)) cycle
7702 :
7703 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
7704 0 : npwtot_q = desc_q%npw
7705 :
7706 0 : if (spin == 1 .and. gwr%gtau_comm%me == 0) then
7707 : ! Write all G-vectors for this q
7708 0 : NCF_CHECK(nf90_put_var(ncid, vid("gvecs"), desc_q%gvec, start=[1,1,iq_ibz], count=[3,npwtot_q,1]))
7709 : end if
7710 :
7711 0 : mats => null()
7712 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz, :, spin)
7713 0 : if (what == "wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
7714 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
7715 :
7716 0 : do my_it=1,gwr%my_ntau
7717 0 : itau = gwr%my_itaus(my_it)
7718 :
7719 : ! FIXME: Assuming PBLAS matrix distributed in contiguous blocks along the column index.
7720 : ! This part must be changed if we use round robin distribution.
7721 0 : my_ncols = mats(itau)%size_local(2)
7722 0 : my_gcol_start = mats(itau)%loc2gcol(1)
7723 :
7724 : ! FIXME: This is wrong if spc
7725 : !call c_f_pointer(c_loc(mats(itau)%buffer_cplx), fptr, shape=[2, npwtot_q, my_ncols])
7726 0 : ABI_MALLOC(fptr, (2, npwtot_q, my_ncols))
7727 0 : fptr(1,:,:) = dble(mats(itau)%buffer_cplx)
7728 0 : fptr(2,:,:) = aimag(mats(itau)%buffer_cplx)
7729 :
7730 0 : if (wt_space == "omega") then
7731 0 : var_id = vid("mats_w")
7732 0 : else if (wt_space == "tau") then
7733 0 : var_id = vid("mats_tau")
7734 : else
7735 0 : ABI_ERROR(sjoin("Invalid wt_space:", wt_space))
7736 : end if
7737 :
7738 : ncerr = nf90_put_var(ncid, var_id, fptr, &
7739 : start=[1, 1, my_gcol_start, itau, iq_ibz, spin], &
7740 0 : count=[2, npwtot_q, my_ncols, 1, 1, 1])
7741 : !stride=[1, gwr%g_comm%nproc, 1, 1, 1])
7742 0 : ABI_FREE(fptr)
7743 0 : NCF_CHECK(ncerr)
7744 : end do
7745 : end associate
7746 : end do ! my_iqi
7747 : end do ! my_is
7748 :
7749 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_completed"), 1))
7750 0 : NCF_CHECK(nf90_close(ncid))
7751 0 : call cwtime_report(" gwr_ncwrite_tchi_wc:", cpu, wall, gflops)
7752 :
7753 : contains
7754 0 : integer function vid(vname)
7755 : character(len=*),intent(in) :: vname
7756 0 : vid = nctk_idname(ncid, vname)
7757 : end function vid
7758 :
7759 : end subroutine gwr_ncwrite_tchi_wc
7760 : !!***
7761 :
7762 : !----------------------------------------------------------------------
7763 :
7764 : !!****f* m_gwr/gsph2box
7765 : !! NAME
7766 : !! gsph2box
7767 : !!
7768 : !! FUNCTION
7769 : !! Insert cg_k array defined on the k-centered g-sphere with npw vectors inside the FFT box.
7770 : !! The main difference wrt to sphere is that cfft is not initialized to zero. See notes below.
7771 : !!
7772 : !! INPUTS
7773 : !! ngfft:
7774 : !! n1,n2,n3=physical dimension of the FFT box
7775 : !! n4,n5,n6=memory dimension of cfft
7776 : !! npw=number of G vectors in basis at this k point
7777 : !! ndat=number of items to process
7778 : !! kg_k(3,npw)=integer coordinates of G vectors in basis sphere
7779 : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere
7780 : !!
7781 : !! OUTPUT
7782 : !! cfft(n4,n5,n6*ndat) = array on FFT box filled with cg data
7783 : !! Note that cfft is intent(inout) so that we can add contributions from different k-points.
7784 : !!
7785 : !! SOURCE
7786 :
7787 : subroutine gsph2box(ngfft, npw, ndat, kg_k, cg, cfft)
7788 :
7789 : !Arguments ------------------------------------
7790 : !scalars
7791 : integer,intent(in) :: ngfft(6), npw, ndat
7792 : !arrays
7793 : integer,intent(in) :: kg_k(3, npw)
7794 : complex(gwp),intent(in) :: cg(npw * ndat)
7795 : complex(gwp),target,intent(inout) :: cfft(ngfft(4)*ngfft(5)*ngfft(6)*ndat)
7796 :
7797 : !Local variables-------------------------------
7798 : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw
7799 : complex(gwp),contiguous,pointer :: cfft_ptr(:,:,:,:)
7800 : ! *************************************************************************
7801 :
7802 : !call timab(1931, 1, tsec)
7803 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
7804 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
7805 : call c_f_pointer(c_loc(cfft), cfft_ptr, shape=[n4, n5, n6, ndat])
7806 :
7807 : ! Insert cg into cfft
7808 : !$OMP PARALLEL DO PRIVATE(i1, i2, i3) IF (ndat > 1)
7809 : do idat=1,ndat
7810 : do ipw=1,npw
7811 : i1 = modulo(kg_k(1, ipw), n1) + 1
7812 : i2 = modulo(kg_k(2, ipw), n2) + 1
7813 : i3 = modulo(kg_k(3, ipw), n3) + 1
7814 : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7815 : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7816 : !end if
7817 : cfft_ptr(i1,i2,i3,idat) = cg(ipw+npw*(idat-1))
7818 : end do
7819 : end do
7820 : !call timab(1931, 2, tsec)
7821 :
7822 : end subroutine gsph2box
7823 : !!***
7824 :
7825 : !----------------------------------------------------------------------
7826 :
7827 : !!****f* m_gwr/box2gsph
7828 : !! NAME
7829 : !! box2gsph
7830 : !!
7831 : !! FUNCTION
7832 : !! Extract cg_k array defined on the k-centered g-sphere with npw vectors from the FFT box.
7833 : !!
7834 : !! INPUTS
7835 : !! op_type: OP_COPY to transfer data, OP_ACC to transfer and accumulate
7836 : !! ngfft:
7837 : !! n1,n2,n3=physical dimension of the FFT box
7838 : !! n4,n5,n6=memory dimension of cfft
7839 : !! npw=number of G vectors in basis at this k point
7840 : !! ndat=number of items to process
7841 : !! kg_k(3,npw)=integer coordinates of G vectors in basis sphere
7842 : !! cfft(n4,n5,n6, ndat) = array on FFT box
7843 : !!
7844 : !! SIZE
7845 : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere. See also op_type
7846 : !!
7847 : !! SOURCE
7848 :
7849 0 : subroutine box2gsph(op_type, ngfft, npw, ndat, kg_k, cfft, cg)
7850 :
7851 : !Arguments ------------------------------------
7852 : !scalars
7853 : integer,intent(in) :: op_type, ngfft(6), npw, ndat
7854 : !arrays
7855 : integer,intent(in) :: kg_k(3, npw)
7856 : complex(gwp),target,intent(in) :: cfft(ngfft(4)*ngfft(5)*ngfft(6)*ndat)
7857 : complex(gwp),intent(inout) :: cg(npw*ndat)
7858 :
7859 : !Local variables-------------------------------
7860 : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw, icg
7861 0 : complex(gwp),contiguous,pointer :: cfft_ptr(:,:,:,:)
7862 : ! *************************************************************************
7863 :
7864 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
7865 0 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
7866 0 : call c_f_pointer(c_loc(cfft), cfft_ptr, shape=[n4, n5, n6, ndat])
7867 :
7868 0 : select case (op_type)
7869 :
7870 : case (OP_COPY)
7871 : ! Extract cg from cfft, ignoring components outside range of cg sphere
7872 : !$OMP PARALLEL DO PRIVATE(i1, i2, i3, icg) IF (ndat > 1)
7873 0 : do idat=1,ndat
7874 0 : do ipw=1,npw
7875 0 : i1 = modulo(kg_k(1, ipw), n1) + 1
7876 0 : i2 = modulo(kg_k(2, ipw), n2) + 1
7877 0 : i3 = modulo(kg_k(3, ipw), n3) + 1
7878 : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7879 : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7880 : !end if
7881 0 : icg = ipw + (idat - 1) * npw
7882 0 : cg(icg) = cfft_ptr(i1, i2, i3, idat)
7883 : end do
7884 : end do
7885 :
7886 : case (OP_ACC)
7887 : ! Extract cg from cfft, ignoring components outside range of cg sphere and accumulate
7888 : !$OMP PARALLEL DO PRIVATE(i1, i2, i3, icg) IF (ndat > 1)
7889 0 : do idat=1,ndat
7890 0 : do ipw=1,npw
7891 0 : i1 = modulo(kg_k(1, ipw), n1) + 1
7892 0 : i2 = modulo(kg_k(2, ipw), n2) + 1
7893 0 : i3 = modulo(kg_k(3, ipw), n3) + 1
7894 : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7895 : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7896 : !end if
7897 0 : icg = ipw + (idat - 1) * npw
7898 0 : cg(icg) = cg(icg) + cfft_ptr(i1, i2, i3, idat)
7899 : end do
7900 : end do
7901 :
7902 : case default
7903 0 : ABI_BUG(sjoin("Invalid op_type:" ,itoa(op_type)))
7904 : end select
7905 :
7906 0 : end subroutine box2gsph
7907 : !!***
7908 :
7909 : !----------------------------------------------------------------------
7910 :
7911 : !!****f* m_gwr/gwr_build_chi0_head_and_wings
7912 : !! NAME
7913 : !! gwr_build_chi0_head_and_wings
7914 : !!
7915 : !! FUNCTION
7916 : !! Compute head and wings of chi0 on the minimax frequency grid.
7917 : !!
7918 : !! SOURCE
7919 :
7920 0 : subroutine gwr_build_chi0_head_and_wings(gwr)
7921 :
7922 : !Arguments ------------------------------------
7923 : class(gwr_t),target,intent(inout) :: gwr
7924 :
7925 : !Local variables-------------------------------
7926 : !scalars
7927 : integer,parameter :: two_poles = 2, one_pole = 1, gwcomp0 = 0, spmeth0 = 0
7928 : integer :: nsppol, nspinor, ierr, my_is, spin, my_ikf, itau, my_it
7929 : integer :: ik_bz, ik_ibz, isym_k, trev_k, g0_k(3)
7930 : !integer :: iq_bz, iq_ibz, isym_q, trev_q, g0_q(3)
7931 : integer :: nkpt_summed, use_umklp, band1, band2, band1_start, band1_stop, band1_max
7932 : integer :: ib, il_b2, nb, block_size, ii, mband, block_counter !,idir !, iab
7933 : integer :: istwf_ki, npw_ki, istwf_kf, nI, nJ, nomega, io, iq, nq, dim_rtwg !ig,
7934 : integer :: npwe, u_nfft, u_mgfft, u_mpw
7935 : logical :: isirr_k, use_tr, is_metallic, print_time, use_ddk
7936 : real(dp) :: spin_fact, weight, deltaf_b1b2, deltaeGW_b1b2, gwr_boxcutmin_c, zcut, qlen, eig_nk, eig_mk, e0
7937 : real(dp) :: cpu_all, wall_all, gflops_all, cpu_k, wall_k, gflops_k
7938 : complex(dp) :: deltaeKS_b1b2
7939 : type(__slkmat_t),pointer :: ugb_kibz
7940 : character(len=5000) :: msg
7941 : type(crystal_t),pointer :: cryst
7942 : type(dataset_type),pointer :: dtset
7943 : type(ebands_t),pointer :: now_ebands
7944 0 : type(littlegroup_t) :: ltg_q
7945 : type(desc_t),pointer :: desc_ki
7946 : !arrays
7947 : integer :: gmax(3), u_ngfft(18), work_ngfft(18), units(2) !, spinor_pad(2,4), spad1, spad2 !, ! g0(3),
7948 0 : integer,contiguous, pointer :: kg_ki(:,:)
7949 0 : integer,allocatable :: gvec_q0(:,:), gbound_q0(:,:), u_gbound(:,:)
7950 : real(dp) :: kk_ibz(3), kk_bz(3), tsec(2) !, rtmp(2)
7951 0 : real(dp),contiguous, pointer :: qp_eig(:,:,:), qp_occ(:,:,:), ks_eig(:,:,:)
7952 0 : real(dp),allocatable :: work(:,:,:,:), qdirs(:,:)
7953 0 : logical :: gradk_not_done(gwr%nkibz)
7954 0 : logical,allocatable :: bbp_mask(:,:)
7955 : complex(dp) :: chq(3)
7956 0 : complex(gwp) :: rhotwx(3, gwr%nspinor**2)
7957 0 : complex(gwp),allocatable :: ug2(:), ur1_kibz(:), ur2_kibz(:), ur_prod(:), rhotwg(:), ug1_block(:,:), ug1(:)
7958 0 : complex(dp) :: green_w(gwr%ntau), omega(gwr%ntau)
7959 0 : complex(dp),allocatable :: chi0_lwing(:,:,:), chi0_uwing(:,:,:), chi0_head(:,:,:), head_qvals(:)
7960 0 : real(dp), allocatable :: ddk_ug1(:,:,:), cg2_dp(:,:)
7961 0 : type(vkbr_t),allocatable :: vkbr(:)
7962 0 : type(gsphere_t) :: gsph
7963 0 : type(ddkop_t) :: ddkop
7964 0 : type(pawcprj_type),allocatable :: cwaveprj(:,:)
7965 : ! *************************************************************************
7966 :
7967 0 : units = [std_out, ab_out]
7968 0 : call timab(1927, 1, tsec)
7969 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
7970 0 : call wrtout(units, sjoin(" Computing chi0 head and wings with inclvkb:", itoa(gwr%dtset%inclvkb)), pre_newlines=1)
7971 :
7972 0 : nspinor = gwr%nspinor; nsppol = gwr%nsppol; dtset => gwr%dtset; cryst => gwr%cryst
7973 0 : use_tr = gwr%dtset%awtr == 1; zcut = gwr%dtset%zcut ! well, it's not used in g0w0 when omega is complex.
7974 :
7975 : ! Use KS or QP energies depending on the iteration state.
7976 0 : if (gwr%scf_iteration == 1) then
7977 0 : call wrtout(units, " Using KS orbitals and KS energies...", newlines=1, do_flush=.True.)
7978 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
7979 0 : now_ebands => gwr%ks_ebands
7980 : else
7981 0 : call wrtout(units, " Using KS orbitals and QP energies...", newlines=1, do_flush=.True.)
7982 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
7983 0 : now_ebands => gwr%qp_ebands
7984 : end if
7985 :
7986 0 : ks_eig => gwr%ks_ebands%eig
7987 0 : mband = gwr%ks_ebands%mband
7988 :
7989 0 : is_metallic = now_ebands%has_metal_scheme()
7990 :
7991 : ! Setup weight (2 for spin unpolarized systems, 1 for polarized).
7992 : ! spin_fact is used to normalize the occupation factors to one.
7993 : ! Consider also the AFM case.
7994 0 : select case (nsppol)
7995 : case (1)
7996 0 : weight = two / gwr%nkbz; spin_fact = half
7997 0 : if (gwr%nspden == 2) then
7998 0 : weight = one / gwr%nkbz; spin_fact = half
7999 : end if
8000 0 : if (nspinor == 2) then
8001 0 : weight = one / gwr%nkbz; spin_fact = one
8002 : end if
8003 : case (2)
8004 0 : weight = one / gwr%nkbz; spin_fact = one
8005 : case default
8006 0 : ABI_BUG(sjoin("Wrong nsppol:", itoa(nsppol)))
8007 : end select
8008 :
8009 : ! TODO: Replace vkbr with ddk and factorize calls to DDK |bra>
8010 0 : ABI_MALLOC(vkbr, (gwr%nkibz))
8011 0 : gradk_not_done = .TRUE.
8012 :
8013 : ! TODO: Big allocation. Might become 1b
8014 0 : ABI_MALLOC(bbp_mask, (mband, mband))
8015 :
8016 : ! =========================================
8017 : ! Find FFT mesh and max number of g-vectors
8018 : ! =========================================
8019 : ! TODO: Can be decreased. Consider also fftgw
8020 0 : gwr_boxcutmin_c = two
8021 : !gwr_boxcutmin_c = one
8022 0 : call gwr%get_u_ngfft(gwr_boxcutmin_c, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8023 :
8024 : ! Init work_ngfft
8025 0 : gmax = gmax + 4 ! FIXME: this is to account for umklapp, should also consider Gamma-only and istwfk
8026 0 : gmax = 2 * gmax + 1
8027 0 : call ngfft_seq(work_ngfft, gmax)
8028 : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
8029 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
8030 :
8031 0 : if (gwr%comm%me == 0) call print_ngfft([std_out], u_ngfft, header="FFT mesh for chi0 head/wings computation")
8032 :
8033 : ! Need to broadcast G-vectors at q = 0 if k/q-point parallelism is activated.
8034 0 : if (gwr%kpt_comm%me == 0) then
8035 0 : npwe = gwr%tchi_desc_qibz(1)%npw
8036 0 : ABI_CHECK(gwr%tchi_desc_qibz(1)%kin_sorted, "g-vectors are not sorted by |q+g|^2/2 !")
8037 : end if
8038 0 : call xmpi_bcast(npwe, 0, gwr%kpt_comm%value, ierr)
8039 0 : ABI_MALLOC(gvec_q0, (3, npwe))
8040 0 : if (gwr%kpt_comm%me == 0) gvec_q0 = gwr%tchi_desc_qibz(1)%gvec
8041 0 : call xmpi_bcast(gvec_q0, 0, gwr%kpt_comm%value, ierr)
8042 :
8043 : ! This is needed to call accumulate_head_wings_imagw
8044 0 : call gsph%init(cryst, npwe, gvec_q0)
8045 :
8046 0 : ABI_MALLOC(gbound_q0, (2 * u_mgfft + 8, 2))
8047 0 : call sphereboundary(gbound_q0, istwfk1, gvec_q0, u_mgfft, npwe)
8048 :
8049 : ! Init little group to find IBZ_q
8050 0 : use_umklp = 0
8051 0 : call ltg_q%init([zero, zero, zero], gwr%nkbz, gwr%kbz, cryst, use_umklp, npwe) !, gvec=gvec_kss)
8052 :
8053 0 : nkpt_summed = gwr%nkbz
8054 0 : if (dtset%symchi /= 0) then
8055 0 : nkpt_summed = ltg_q%nibz_ltg
8056 0 : call ltg_q%print([std_out], prtvol=dtset%prtvol)
8057 : end if
8058 0 : call wrtout(std_out, sjoin(' Calculation status: ', itoa(nkpt_summed), ' k-points to be completed'))
8059 :
8060 : ! ============================================
8061 : ! === Begin big fat loop over transitions ====
8062 : ! ============================================
8063 :
8064 : ! NB: One might reduce the number of bands as head and wings converge fast wrt nband and slow wrt k-mesh.
8065 : ! Should introduce a tolerance on the frequency part computed at the first minimax frequency and
8066 : ! compute max_nband from this.
8067 :
8068 : ! Find band1_max from gwr_max_hwtene
8069 0 : band1_max = gwr%ugb_nband
8070 0 : if (gwr%dtset%gwr_max_hwtene > zero) then
8071 : ! Set e0 to top of valence band if semiconductor else Fermi level
8072 0 : e0 = now_ebands%fermie
8073 0 : if (all(gwr%ks_gaps%ierr == 0)) e0 = minval(gwr%ks_gaps%vb_max)
8074 0 : do band1_start=1, gwr%ugb_nband
8075 0 : if (all(qp_eig(band1_start,:,:) - e0 > gwr%dtset%gwr_max_hwtene)) then
8076 0 : band1_max = band1_start; exit
8077 : end if
8078 : end do
8079 : !else if (gwr%dtset%gwr_max_hwtene < zero) then
8080 : ! band1_max = min(nint(-gwr%dtset%gwr_max_hwtene) gwr%ugb_nband)
8081 : end if
8082 :
8083 0 : call wrtout(std_out, sjoin(" gwr_max_hwtene:", ftoa(gwr%dtset%gwr_max_hwtene * Ha_eV), " (eV)"))
8084 0 : call wrtout(std_out, sjoin(" Using: ", itoa(band1_max), "/", itoa(gwr%ugb_nband), "bands for chi0 head and wings."))
8085 :
8086 : ! Loop on spin to calculate $\chi_{\up,\up} + \chi_{\down,\down}$
8087 : ! TODO: nspinor 2
8088 0 : nI = 1; nJ = 1; nomega = gwr%ntau
8089 0 : omega(:) = j_dpc * gwr%iw_mesh(:)
8090 0 : ABI_CALLOC(chi0_lwing, (npwe*nI, nomega, 3))
8091 0 : ABI_CALLOC(chi0_uwing, (npwe*nJ, nomega, 3))
8092 0 : ABI_CALLOC(chi0_head, (3, 3, nomega))
8093 :
8094 0 : ABI_MALLOC(u_gbound, (2 * u_mgfft + 8, 2))
8095 0 : ABI_MALLOC(ur1_kibz, (u_nfft * nspinor))
8096 0 : ABI_MALLOC(ur2_kibz, (u_nfft * nspinor))
8097 0 : ABI_MALLOC(ur_prod, (u_nfft * nspinor))
8098 0 : dim_rtwg = 1; if (nspinor == 2) dim_rtwg = 2 ! Can reduce size depending on Ep%nI and Ep%nj
8099 0 : ABI_MALLOC(rhotwg, (npwe * dim_rtwg))
8100 :
8101 : ! TODO: use ddkop instead of commutator so that we can handle SOC terms.
8102 : use_ddk = .False.
8103 0 : use_ddk = gwr%dtset%userie == 432
8104 0 : use_ddk = .True.
8105 : if (use_ddk) then
8106 0 : call wrtout(std_out, " Using DDK to compute the commutator matrix elements.")
8107 0 : call ddkop%init(dtset, gwr%cryst, gwr%pawtab, gwr%psps, gwr%mpi_enreg, u_mpw, u_ngfft)
8108 : end if
8109 :
8110 0 : ABI_CHECK_IEQ(dtset%symchi, 1, "symchi 0 not implemented")
8111 : if (dtset%nspinor == 2 .and. .not. use_ddk) then
8112 : ABI_CHECK_IEQ(dtset%inclvkb, 0, "inclvkb must be 0 when nspinor == 2 as SOC term is not coded.")
8113 : end if
8114 :
8115 : ! Loop over collinear spins.
8116 0 : do my_is=1,gwr%my_nspins
8117 0 : spin = gwr%my_spins(my_is)
8118 :
8119 : ! Loop over my k-points in the BZ.
8120 0 : do my_ikf=1,gwr%my_nkbz
8121 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
8122 0 : istwf_kf = 1
8123 : !istwf_kf = gwt% ???
8124 :
8125 0 : if (dtset%symchi == 1 .and. ltg_q%ibzq(ik_bz) /= 1) CYCLE ! Only IBZ_q
8126 0 : print_time = gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0)
8127 0 : if (print_time) call cwtime(cpu_k, wall_k, gflops_k, "start")
8128 : !write(*, *)" For kpoint:", trim(ktoa(kk_bz))
8129 :
8130 : ! FIXME: Be careful with the symmetry conventions here! and the interplay between umklapp in q and FFT
8131 : ! Also, the assembly_chi0 routines assume symrec and trev_k in [1, 2]
8132 0 : ik_ibz = gwr%kbz2ibz_symrel(1, ik_bz); isym_k = gwr%kbz2ibz_symrel(2, ik_bz)
8133 0 : trev_k = gwr%kbz2ibz_symrel(6, ik_bz); g0_k = gwr%kbz2ibz_symrel(3:5, ik_bz)
8134 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
8135 0 : kk_ibz = gwr%kibz(:, ik_ibz)
8136 :
8137 0 : ugb_kibz => gwr%ugb(ik_ibz, spin)
8138 0 : desc_ki => gwr%green_desc_kibz(ik_ibz)
8139 0 : npw_ki = desc_ki%npw
8140 0 : istwf_ki = desc_ki%istwfk
8141 0 : kg_ki => desc_ki%gvec
8142 :
8143 0 : ABI_MALLOC(ug1, (npw_ki * nspinor))
8144 0 : ABI_MALLOC(ug2, (npw_ki * nspinor))
8145 0 : ABI_MALLOC(cg2_dp, (2, npw_ki * nspinor))
8146 :
8147 0 : call sphereboundary(u_gbound, istwf_ki, kg_ki, u_mgfft, npw_ki)
8148 :
8149 0 : if (gwr%usepaw == 0 .and. dtset%inclvkb /= 0 .and. gradk_not_done(ik_ibz)) then
8150 : ! Include term <n,k|[Vnl,iqr]|n"k>' for q -> 0.
8151 0 : call vkbr_init(vkbr(ik_ibz), cryst, gwr%psps, dtset%inclvkb, istwf_ki, npw_ki, kk_ibz, kg_ki)
8152 0 : gradk_not_done(ik_ibz) = .FALSE.
8153 : end if
8154 :
8155 : if (use_ddk) then
8156 0 : call ddkop%setup_spin_kpoint(gwr%dtset, gwr%cryst, gwr%psps, spin, kk_ibz, istwf_ki, npw_ki, kg_ki)
8157 : end if
8158 :
8159 : call chi0_bbp_mask(ik_ibz, ik_ibz, spin, spin_fact, use_tr, &
8160 0 : gwcomp0, spmeth0, gwr%ugb_nband, mband, now_ebands, bbp_mask)
8161 : !bbp_mask = .True.
8162 :
8163 : ! FIXME: This part should be tested with tau/g-para
8164 : ! TODO:
8165 : ! 1) Logic to determine block_size from memory.
8166 : ! 2) Add support for symchi = 0
8167 : ! 3) Invert the loops
8168 :
8169 0 : block_size = min(48, gwr%ugb_nband)
8170 :
8171 0 : block_counter = 0
8172 0 : do band1_start=1, gwr%ugb_nband, block_size
8173 0 : block_counter = block_counter + 1
8174 : ! Distribute blocks inside tau_comm as wavefunctions are replicated.
8175 0 : if (gwr%tau_comm%skip(block_counter)) cycle
8176 :
8177 0 : if (all(.not. bbp_mask(band1_start:, :))) then
8178 : !print *, "exiting band1_start loop"
8179 : exit
8180 : end if
8181 :
8182 : !print *, "band1_start, gwr%ugb_nband, block_size", band1_start, gwr%ugb_nband, block_size
8183 0 : nb = blocked_loop(band1_start, gwr%ugb_nband, block_size)
8184 0 : band1_stop = band1_start + nb - 1
8185 0 : if (band1_stop > band1_max) exit
8186 :
8187 : ! Collect nb bands starting from band1_start on each proc.
8188 0 : call ugb_kibz%collect_cplx(npw_ki * nspinor, nb, [1, band1_start], ug1_block)
8189 :
8190 : ! Precompute DH_DK |psi_b1>.
8191 0 : ABI_MALLOC(ddk_ug1, (2, npw_ki * nspinor, 3))
8192 :
8193 : ! Loop over "conduction" states.
8194 : !do band1=band1_start, band1_stop
8195 0 : do ib=1,nb
8196 0 : band1 = band1_start + ib - 1
8197 0 : eig_nk = gwr%ks_ebands%eig(band1, ik_ibz, spin)
8198 :
8199 : ! FFT band1 from g to r
8200 0 : ug1 = ug1_block(:, ib)
8201 0 : call fft_ug(npw_ki, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_ki, kg_ki, u_gbound, ug1, ur1_kibz)
8202 :
8203 : if (use_ddk) then
8204 : ! Compute DH_DK |psi_k,bi>, store results in ddk_ug1
8205 0 : ddk_ug1(1,:,1) = real(ug1)
8206 0 : ddk_ug1(2,:,1) = aimag(ug1)
8207 0 : call ddkop%apply(eig_nk, npw_ki, nspinor, ddk_ug1(:,:,1), cwaveprj)
8208 : end if
8209 :
8210 : ! Loop over "valence" states.
8211 : !do band2=1,gwr%ugb_nband
8212 0 : do il_b2=1, ugb_kibz%size_local(2)
8213 0 : band2 = ugb_kibz%loc2gcol(il_b2)
8214 :
8215 0 : eig_mk = gwr%ks_ebands%eig(band2, ik_ibz, spin)
8216 :
8217 0 : deltaeKS_b1b2 = ks_eig(band1, ik_ibz, spin) - ks_eig(band2, ik_ibz, spin)
8218 0 : deltaf_b1b2 = spin_fact * (qp_occ(band1, ik_ibz, spin) - qp_occ(band2, ik_ibz, spin))
8219 0 : deltaeGW_b1b2 = qp_eig(band1, ik_ibz, spin) - qp_eig(band2, ik_ibz, spin)
8220 :
8221 : ! Skip negligible transitions.
8222 0 : if (abs(deltaf_b1b2) < GW_TOL_DOCC) CYCLE
8223 : ! Adler-Wiser expression.
8224 : ! Add small imaginary of the Time-Ordered response function but only for non-zero real omega
8225 : ! FIXME What about metals?
8226 0 : if (.not. use_tr) then
8227 : ! Adler-Wiser without time-reversal.
8228 0 : do io=1,nomega
8229 0 : green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, one_pole)
8230 : end do
8231 :
8232 : else
8233 0 : if (band1 < band2) CYCLE ! Here we GAIN a factor ~2
8234 :
8235 0 : do io=1,nomega
8236 : ! Rangel: In metals, the intra-band transitions term does not contain the antiresonant part
8237 : ! if(abs(deltaeGW_b1b2)>GW_TOL_W0) green_w(io) = g0g0w(omega(io),deltaf_b1b2,deltaeGW_b1b2,zcut,GW_TOL_W0)
8238 0 : if (band1 == band2) green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, one_pole)
8239 0 : if (band1 /= band2) green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, two_poles)
8240 : end do
8241 : end if
8242 :
8243 : ! FFT band2 from g to r
8244 0 : ug2 = ugb_kibz%buffer_cplx(:, il_b2)
8245 0 : call fft_ug(npw_ki, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_ki, kg_ki, u_gbound, ug2, ur2_kibz)
8246 :
8247 0 : ur_prod(:) = conjg(ur1_kibz(:)) * ur2_kibz
8248 0 : call fft_ur(npwe, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwfk1, gvec_q0, gbound_q0, ur_prod, rhotwg)
8249 : ! if nspinor == 2, sum 11, 22 terms in spin space
8250 0 : if (nspinor == 2) rhotwg(1:npwe) = rhotwg(1:npwe) + rhotwg(npwe+1:2*npwe)
8251 :
8252 : if (.not. use_ddk) then
8253 : if (gwr%usepaw == 0 ) then
8254 : ! Matrix elements of i[H,r] for NC pseudopotentials.
8255 : ! NB ug1 and ug2 are kind=gwp
8256 : rhotwx = nc_ihr_comm(vkbr(ik_ibz), cryst, gwr%psps, npw_ki, nspinor, istwf_ki, gwr%dtset%inclvkb, &
8257 : kk_ibz, ug1, ug2, kg_ki)
8258 : end if
8259 : else
8260 0 : cg2_dp(1,:) = real(ug2)
8261 0 : cg2_dp(2,:) = aimag(ug2)
8262 :
8263 : ! DH_DK operator is Hermitian.
8264 0 : call ddkop%get_ihr_comm(cryst, eig_mk, istwf_ki, npw_ki, nspinor, cg2_dp, rhotwx)
8265 0 : rhotwx = conjg(rhotwx)
8266 :
8267 : ! debug section
8268 : !do idir=1,3
8269 : ! write(std_out, "(a, *(es12.5,2x))")"rhotwx: ", rhotwx(:, 1)
8270 : ! write(std_out, "(a, *(es12.5,2x))")"new_rhotwx:", new_rhotwx(:, 1)
8271 : ! !write(std_out, "(a, *(es12.5,2x))")"ratio old/new:", rhotwx(:, 1) / new_rhotwx(:, 1)
8272 : ! do iab=1,gwr%nspinor**2
8273 : ! if (abs(rhotwx(iab,1) - new_rhotwx(iab,1)) > tol6 .and. &
8274 : ! (abs(rhotwx(iab,1)) > tol6 .or. abs(new_rhotwx(iab,1)) > tol6)) then
8275 : ! write(std_out, "(a, *(es12.5,2x))")"rhotwx: ", rhotwx(iab, 1)
8276 : ! write(std_out, "(a, *(es12.5,2x))")"new_rhotwx:", new_rhotwx(iab, 1)
8277 : ! ABI_ERROR("Too large diff")
8278 : ! end if
8279 : ! end do
8280 : !end do
8281 : end if ! use_ddk
8282 :
8283 : ! Treat a possible degeneracy between v and c.
8284 : ! Adler-Wiser expression, to be consistent here we use the KS eigenvalues (?)
8285 0 : if (abs(deltaeKS_b1b2) > GW_TOL_W0) then
8286 0 : rhotwx = -rhotwx / deltaeKS_b1b2
8287 : else
8288 0 : rhotwx = czero_gw
8289 : end if
8290 :
8291 : ! NB: Using symrec conventions here
8292 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
8293 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
8294 0 : trev_k = trev_k + 1 ! NB: GW routines assume trev in [1, 2]
8295 :
8296 : ! TODO: Metals
8297 : ! Note: if nspinor == 2, only rhotgw(1:npwe) with the 11 + 22 sum is used.
8298 : call accumulate_head_wings_imagw( &
8299 : npwe, nomega, nI, nJ, dtset%symchi, &
8300 : is_metallic, ik_bz, isym_k, trev_k, nspinor, cryst, ltg_q, gsph, &
8301 0 : rhotwx, rhotwg, green_w, chi0_head, chi0_lwing, chi0_uwing)
8302 : end do ! band2
8303 : end do ! band1
8304 :
8305 0 : ABI_FREE(ug1_block)
8306 0 : ABI_SFREE(ddk_ug1)
8307 : end do ! band1_start
8308 :
8309 0 : ABI_FREE(ug1)
8310 0 : ABI_FREE(ug2)
8311 0 : ABI_FREE(cg2_dp)
8312 :
8313 0 : if (print_time) then
8314 0 : write(msg,'(4x,3(a,i0),a)')"my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
8315 0 : call cwtime_report(msg, cpu_k, wall_k, gflops_k); if (my_ikf == LOG_MODK) call wrtout(std_out, " ...")
8316 : end if
8317 : end do ! my_ikf
8318 : end do ! my_is
8319 :
8320 0 : ABI_FREE(bbp_mask)
8321 0 : ABI_FREE(gvec_q0)
8322 0 : ABI_FREE(gbound_q0)
8323 0 : ABI_FREE(work)
8324 0 : ABI_FREE(ur1_kibz)
8325 0 : ABI_FREE(ur2_kibz)
8326 0 : ABI_FREE(ur_prod)
8327 0 : ABI_FREE(rhotwg)
8328 0 : ABI_FREE(u_gbound)
8329 :
8330 0 : if (use_ddk) call ddkop%free()
8331 0 : call vkbr_free(vkbr)
8332 0 : ABI_FREE(vkbr)
8333 :
8334 : ! Collect head and wings.
8335 0 : call xmpi_sum(chi0_head, gwr%comm%value, ierr)
8336 0 : call xmpi_sum(chi0_lwing, gwr%comm%value, ierr)
8337 0 : call xmpi_sum(chi0_uwing, gwr%comm%value, ierr)
8338 :
8339 0 : chi0_head = chi0_head * weight / cryst%ucvol
8340 : ! Tensor in terms of reciprocal lattice vectors.
8341 0 : do io=1,nomega
8342 0 : chi0_head(:,:,io) = matmul(chi0_head(:,:,io), cryst%gmet) * (two_pi**2)
8343 : end do
8344 0 : chi0_lwing = chi0_lwing * weight / cryst%ucvol
8345 0 : chi0_uwing = chi0_uwing * weight / cryst%ucvol
8346 :
8347 : ! ===============================================
8348 : ! ==== Symmetrize chi0 in case of AFM system ====
8349 : ! ===============================================
8350 : ! Reconstruct $chi0{\down,\down}$ from $chi0{\up,\up}$.
8351 : ! Works only in the case of magnetic group Shubnikov type IV.
8352 0 : if (cryst%use_antiferro) then
8353 : call symmetrize_afm_chi0(Cryst, gsph, ltg_q, npwe, nomega, &
8354 0 : chi0_head=chi0_head, chi0_lwing=chi0_lwing, chi0_uwing=chi0_uwing)
8355 : end if
8356 :
8357 0 : if (gwr%comm%me == 0 .and. gwr%dtset%prtvol >= 1) then
8358 : ! Construct head and wings from the tensor and output results.
8359 0 : qlen = tol3
8360 0 : call cryst%get_redcart_qdirs(nq, qdirs, qlen=qlen)
8361 0 : ABI_MALLOC(head_qvals, (nq))
8362 0 : call wrtout(units, " Head of the irreducible polarizability for q --> 0", pre_newlines=1)
8363 0 : call wrtout(units, sjoin(" q0_len:", ftoa(qlen), "(Bohr^-1)"))
8364 0 : write(msg, "(*(a14))") "iomega (eV)", "[100]", "[010]", "[001]", "x", "y", "z"
8365 0 : call wrtout(units, msg)
8366 0 : do io=1,nomega
8367 0 : do iq=1,nq
8368 0 : chq = matmul(chi0_head(:,:,io), qdirs(:,iq))
8369 0 : head_qvals(iq) = vdotw(qdirs(:, iq), chq, cryst%gmet, "G")
8370 : end do
8371 0 : write(msg, "(*(es12.5,2x))") gwr%iw_mesh(io) * Ha_eV, real(head_qvals(:))
8372 0 : call wrtout(units, msg)
8373 : ! Write imag part to std_out only
8374 0 : write(msg, "(*(es12.5,2x))") gwr%iw_mesh(io) * Ha_eV, aimag(head_qvals(:))
8375 0 : call wrtout(std_out, msg)
8376 : end do
8377 0 : call wrtout(units, " ")
8378 0 : ABI_FREE(qdirs)
8379 0 : ABI_FREE(head_qvals)
8380 : end if
8381 :
8382 : ! Save quantities for later use as this routine must be called before build_tchi.
8383 0 : if (gwr%kpt_comm%me == 0) then
8384 0 : ABI_REMALLOC(gwr%chi0_head_myw, (3, 3, gwr%my_ntau) )
8385 0 : ABI_REMALLOC(gwr%chi0_uwing_myw, (3, npwe, gwr%my_ntau) )
8386 0 : ABI_REMALLOC(gwr%chi0_lwing_myw, (3, npwe, gwr%my_ntau) )
8387 :
8388 0 : do my_it=1,gwr%my_ntau
8389 0 : itau = gwr%my_itaus(my_it)
8390 0 : gwr%chi0_head_myw(:,:,my_it) = chi0_head(:,:,itau)
8391 0 : do ii=1,3
8392 0 : gwr%chi0_uwing_myw(ii,:,my_it) = chi0_uwing(:,itau,ii)
8393 0 : gwr%chi0_lwing_myw(ii,:,my_it) = chi0_lwing(:,itau,ii)
8394 : end do
8395 : end do
8396 : end if
8397 :
8398 0 : ABI_FREE(chi0_lwing)
8399 0 : ABI_FREE(chi0_uwing)
8400 0 : ABI_FREE(chi0_head)
8401 0 : call ltg_q%free()
8402 0 : call gsph%free()
8403 :
8404 0 : call cwtime_report(" gwr_build_chi0_head_and_wings:", cpu_all, wall_all, gflops_all)
8405 0 : call timab(1927, 2, tsec)
8406 :
8407 : !if (use_ddk) stop "gwr_build_chi0_head_and_wings"
8408 :
8409 0 : end subroutine gwr_build_chi0_head_and_wings
8410 : !!***
8411 :
8412 : !----------------------------------------------------------------------
8413 :
8414 : !!****f* m_gwr/gwr_build_sigxme
8415 : !! NAME
8416 : !! gwr_build_sigxme
8417 : !!
8418 : !! FUNCTION
8419 : !! Compute matrix elements of the exchange part.
8420 : !!
8421 : !! INPUTS
8422 : !!
8423 : !! OUTPUT
8424 : !!
8425 : !! SOURCE
8426 :
8427 0 : subroutine gwr_build_sigxme(gwr, compute_qp)
8428 :
8429 : !Arguments ------------------------------------
8430 : class(gwr_t),target,intent(inout) :: gwr
8431 : logical,optional,intent(in) :: compute_qp
8432 :
8433 : !Local variables-------------------------------
8434 : !scalars
8435 : integer :: nsppol, nspinor, ierr, my_ikf, band_sum, ii, jj, kb, il_b, iab !ig_start, ig,
8436 : integer :: my_is, ikcalc, ikcalc_ibz, bmin, bmax, band, istwf_k, npw_k
8437 : integer :: spin, jb, is_idx, use_umklp, spad, wtqm, wtqp, irow, spadx1, spadx2, npwx, u_nfft, u_mgfft, u_mpw
8438 : integer :: ik_bz, ik_ibz, isym_k, trev_k, g0_k(3)
8439 : integer :: iq_bz, iq_ibz, isym_q, trev_q, g0_q(3)
8440 : logical :: isirr_k, isirr_q, sigc_is_herm, compute_qp__
8441 : real(dp) :: fact_spin, theta_mu_minus_esum, theta_mu_minus_esum2, tol_empty, tol_empty_in, gwr_boxcutmin_x, i_sz
8442 : real(dp) :: cpu_k, wall_k, gflops_k, cpu_all, wall_all, gflops_all
8443 : complex(gwp) :: gwpc_sigxme, gwpc_sigxme2, xdot_tmp, ctmp
8444 : character(len=5000) :: msg
8445 : logical :: q_is_gamma
8446 : type(__slkmat_t),pointer :: ugb_kibz
8447 : type(crystal_t),pointer :: cryst
8448 : type(dataset_type),pointer :: dtset
8449 0 : type(littlegroup_t) :: ltg_k
8450 : type(desc_t),pointer :: desc_ki
8451 : !arrays
8452 : integer :: g0(3), gmax(3), spinor_padx(2,4), u_ngfft(18), work_ngfft(18), units(2)
8453 0 : integer,allocatable :: gbound_kcalc(:,:), gvec_x(:,:), gbound_x(:,:), kg_k(:,:), gbound_ksum(:,:)
8454 : real(dp) :: ksum(3), kk_ibz(3), kgw(3), kgw_m_ksum(3), qq_bz(3), tsec(2) !, kk_bz(3), q0(3) !, spinrot_kbz(4), spinrot_kgw(4)
8455 0 : real(dp),contiguous, pointer :: ks_eig(:,:,:), qp_eig(:,:,:), qp_occ(:,:,:), cg2_ptr(:,:) ! cg1_ptr(:,:),
8456 0 : real(dp),allocatable :: work(:,:,:,:), cg1_ibz(:,:) !, cg2_bz(:,:)
8457 0 : complex(gwp),allocatable :: vc_sqrt_qbz(:), ur_bdgw(:,:)
8458 0 : complex(gwp),allocatable :: rhotwg(:), rhotwgp(:), rhotwg_ki(:,:), ur_ksum(:), ur_prod(:), eig0r(:)!, ugb_kcalcibz(:)
8459 0 : complex(gwp),allocatable :: ug_ksum(:)
8460 0 : complex(dp),target,allocatable :: ug_ksum_dp(:)
8461 0 : complex(dp),allocatable :: sigxme_tmp(:,:,:), sigx(:,:,:,:)
8462 0 : type(sigijtab_t),allocatable :: Sigxij_tab(:,:), Sigcij_tab(:,:)
8463 : type(yamldoc_t) :: ydoc
8464 : ! *************************************************************************
8465 :
8466 0 : call timab(1920, 1, tsec)
8467 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
8468 :
8469 0 : units = [std_out, ab_out]
8470 0 : if (gwr%sig_diago) then
8471 0 : call wrtout(units, " Computing diagonal matrix elements of Sigma_x", pre_newlines=1)
8472 : else
8473 0 : call wrtout(units, " Computing diagonal + off-diagonal matrix elements of Sigma_x", pre_newlines=1)
8474 : end if
8475 :
8476 0 : if (gwr%scf_iteration /= 1) then
8477 : associate (now => gwr%qp_ebands, prev => gwr%qp_ebands_prev)
8478 0 : if (all(now%occ == prev%occ)) then
8479 0 : call wrtout(units, " Occupations have not changed since last iteration, skipping Sigma_x matrix elements computation...", pre_newlines=1)
8480 : else
8481 0 : call wrtout(units, " Occupations have changed since last iteration, recomputing Sigma_x matrix elements...", pre_newlines=1)
8482 : end if
8483 : end associate
8484 : goto 10
8485 : end if
8486 :
8487 0 : if (gwr%has_vcgen_sigma) then
8488 0 : call gwr%vcgen_sigma%print(units, " Info on Coulomb term used in Sigma_x", gwr%dtset%prtvol)
8489 : else
8490 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in Sigma_x", dtset%prtvol)
8491 : end if
8492 :
8493 0 : nsppol = gwr%nsppol; nspinor = gwr%nspinor; cryst => gwr%cryst; dtset => gwr%dtset
8494 :
8495 : ! Table for \Sigmax_ij matrix elements.
8496 0 : sigc_is_herm = .False.
8497 : call sigtk_sigma_tables(gwr%nkcalc, gwr%nkibz, gwr%nsppol, gwr%bstart_ks, gwr%bstop_ks, gwr%kcalc2ibz(:,1), &
8498 0 : gwr%sig_diago, sigc_is_herm, sigxij_tab, sigcij_tab)
8499 :
8500 0 : call sigijtab_free(Sigcij_tab)
8501 0 : ABI_FREE(Sigcij_tab)
8502 :
8503 : ! Allocate array with Sigma_x matrix elements depending on sig_diago
8504 0 : ii = gwr%b1gw; jj = gwr%b2gw
8505 0 : if (gwr%sig_diago) then
8506 0 : ii = 1; jj = 1
8507 : end if
8508 0 : ABI_RECALLOC(gwr%sigx_mat, (gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol*gwr%nsig_ab))
8509 :
8510 0 : ks_eig => gwr%ks_ebands%eig
8511 0 : if (gwr%scf_iteration == 1) then
8512 0 : call wrtout(units, " Using KS orbitals and KS energies...", newlines=1, do_flush=.True.)
8513 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
8514 : else
8515 0 : call wrtout(units, " Using KS orbitals and QP energies...", newlines=1, do_flush=.True.)
8516 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
8517 : end if
8518 :
8519 : ! Set tolerance used to decide if a band is empty
8520 0 : tol_empty_in = 0.01
8521 0 : call get_fact_spin_tol_empty(nsppol, nspinor, tol_empty_in, fact_spin, tol_empty)
8522 :
8523 : ! =========================================
8524 : ! Find FFT mesh and max number of g-vectors
8525 : ! =========================================
8526 0 : gwr_boxcutmin_x = two
8527 0 : call gwr%get_u_ngfft(gwr_boxcutmin_x, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8528 :
8529 0 : if (gwr%comm%me == 0) call print_ngfft([std_out], u_ngfft, header="FFT mesh for Sigma_x")
8530 :
8531 : ! Init work_ngfft
8532 0 : gmax = gmax + 4 ! FIXME: this is to account for umklapp, should also consider Gamma-only and istwfk
8533 0 : gmax = 2 * gmax + 1
8534 0 : call ngfft_seq(work_ngfft, gmax)
8535 : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
8536 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
8537 :
8538 0 : do my_is=1,gwr%my_nspins
8539 0 : spin = gwr%my_spins(my_is)
8540 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
8541 0 : call cwtime(cpu_k, wall_k, gflops_k, "start")
8542 0 : ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1)
8543 0 : kgw = gwr%kcalc(:, ikcalc)
8544 0 : bmin = gwr%bstart_ks(ikcalc, spin); bmax = gwr%bstop_ks(ikcalc, spin)
8545 :
8546 : ! ==============================================================
8547 : ! ==== Find little group of the k-points for GW corrections ====
8548 : ! ==============================================================
8549 : ! * The little group is used only if symsigma == 1
8550 : ! * If use_umklp == 1 then symmetries requiring an umklapp to preserve k_gw are included as well.
8551 0 : use_umklp = 1
8552 0 : call ltg_k%init(kgw, gwr%nqbz, gwr%qbz, cryst, use_umklp, npwe=0)
8553 : !if (gwr%comm%me == 0) call ltg_k%print([std_out], prtvol=gwr%dtset%prtvol)
8554 :
8555 0 : write(msg,'(5a)') ch10, &
8556 0 : ' Calculating <nk|Sigma_x|nk> at k: ',trim(ktoa(kgw)), ", for band range: ", trim(ltoa([bmin, bmax]))
8557 0 : call wrtout(std_out, msg)
8558 :
8559 : ! ===============================================
8560 : ! Load wavefunctions for Sigma_x matrix elements
8561 : ! ===============================================
8562 : ! All procs need ur_bdgw but the IBZ is distributed and, possibly, replicated in gwr%kpt_comm.
8563 : ! Here we select the right procs, fill the buffer with the FFT results and then use
8564 : ! a dumb xmpi_sum + rescaling to gather the results.
8565 : ! FIXME: g-vectors from Green's descriptor or use another array to be able to deal with istwfk == 2?
8566 :
8567 0 : ABI_MALLOC_OR_DIE(ur_bdgw, (u_nfft * nspinor, bmin:bmax), ierr)
8568 0 : ur_bdgw = czero_gw
8569 :
8570 0 : if (any(ikcalc_ibz == gwr%my_kibz_inds)) then
8571 : associate (desc_kcalc => gwr%green_desc_kibz(ikcalc_ibz), ugb_kcalc => gwr%ugb(ikcalc_ibz, spin))
8572 0 : ABI_MALLOC(gbound_kcalc, (2 * u_mgfft + 8, 2))
8573 0 : call sphereboundary(gbound_kcalc, desc_kcalc%istwfk, desc_kcalc%gvec, u_mgfft, desc_kcalc%npw)
8574 :
8575 0 : do il_b=1,ugb_kcalc%size_local(2)
8576 0 : band = ugb_kcalc%loc2gcol(il_b); if (band < bmin .or. band > bmax) CYCLE
8577 : call fft_ug(desc_kcalc%npw, u_nfft, nspinor, ndat1, &
8578 : u_mgfft, u_ngfft, desc_kcalc%istwfk, desc_kcalc%gvec, gbound_kcalc, &
8579 : gwr%ugb(ikcalc_ibz, spin)%buffer_cplx(:, il_b), & ! in
8580 0 : ur_bdgw(:, band)) ! out
8581 : end do
8582 0 : ABI_FREE(gbound_kcalc)
8583 : end associate
8584 : end if
8585 :
8586 : ! Collect and rescale
8587 : !call xmpi_sum(ur_bdgw, gwr%kgt_comm%value, ierr)
8588 0 : call xmpi_sum(ur_bdgw, gwr%kg_comm%value, ierr)
8589 0 : ur_bdgw = ur_bdgw / gwr%np_kibz(ikcalc_ibz)
8590 :
8591 0 : ABI_MALLOC(ur_prod, (u_nfft * nspinor))
8592 0 : ABI_MALLOC(ur_ksum, (u_nfft * nspinor))
8593 0 : ABI_MALLOC(eig0r, (u_nfft * nspinor))
8594 :
8595 0 : ABI_CALLOC(sigxme_tmp, (bmin:bmax, bmin:bmax, nsppol * gwr%nsig_ab))
8596 0 : ABI_CALLOC(sigx, (2, bmin:bmax, bmin:bmax, nsppol * gwr%nsig_ab))
8597 :
8598 : ! ========================================
8599 : ! ==== Sum over my k-points in the BZ ====
8600 : ! ========================================
8601 :
8602 0 : do my_ikf=1,gwr%my_nkbz
8603 0 : ik_bz = gwr%my_kbz_inds(my_ikf)
8604 0 : ksum = gwr%kbz(:, ik_bz)
8605 :
8606 : ! Find the symmetrical image of ksum in the IBZ
8607 : ! FIXME: Be careful with the symmetry conventions here and the interplay between umklapp in q and FFT
8608 0 : ik_ibz = gwr%kbz2ibz_symrel(1, ik_bz); isym_k = gwr%kbz2ibz_symrel(2, ik_bz)
8609 0 : trev_k = gwr%kbz2ibz_symrel(6, ik_bz); g0_k = gwr%kbz2ibz_symrel(3:5, ik_bz)
8610 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
8611 0 : kk_ibz = gwr%kibz(:, ik_ibz)
8612 :
8613 : ! Identify q and G0 where q + G0 = k_GW - ksum
8614 0 : kgw_m_ksum = kgw - ksum
8615 0 : call findqg0(iq_bz, g0, kgw_m_ksum, gwr%nqbz, gwr%qbz, gwr%mG0)
8616 : !ABI_CHECK(all(g0 == 0), sjoin("g0 = ", ltoa(g0)))
8617 :
8618 0 : call calc_ceigr(g0, u_nfft, nspinor, u_ngfft, eig0r)
8619 :
8620 : ! If symmetries are exploited, only q-points in the IBZ_k are computed.
8621 : ! In this case elements are weighted according to wtqp and wtqm. wtqm is for time-reversal.
8622 0 : wtqp = 1; wtqm = 0
8623 : !if (can_symmetrize(spin)) then
8624 0 : if (gwr%dtset%symsigma == 1) then
8625 0 : if (ltg_k%ibzq(iq_bz) /= 1) CYCLE
8626 0 : wtqp = sum(ltg_k%wtksym(1,:,iq_bz))
8627 0 : wtqm = sum(ltg_k%wtksym(2,:,iq_bz))
8628 : end if
8629 :
8630 0 : qq_bz = gwr%qbz(:, iq_bz)
8631 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz); isym_q = gwr%qbz2ibz(2, iq_bz)
8632 0 : trev_q = gwr%qbz2ibz(6, iq_bz); g0_q = gwr%qbz2ibz(3:5, iq_bz)
8633 : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
8634 :
8635 : ! Find the corresponding irreducible q-point.
8636 : ! NB: non-zero umklapp G_o is not allowed. There's a check in setup_sigma
8637 : !call qmesh%get_BZ_item(iq_bz, qbz, iq_ibz, isym_q, itim_q)
8638 0 : q_is_gamma = normv(qq_bz, cryst%gmet, "G") < GW_TOLQ0
8639 0 : call get_kg(qq_bz, istwfk1, dtset%ecutsigx, cryst%gmet, npwx, gvec_x)
8640 :
8641 0 : ABI_MALLOC(gbound_x, (2*u_mgfft + 8, 2))
8642 0 : call sphereboundary(gbound_x, istwfk1, gvec_x, u_mgfft, npwx)
8643 :
8644 0 : ABI_MALLOC(rhotwg_ki, (npwx * nspinor, bmin:bmax))
8645 0 : ABI_MALLOC(rhotwg, (npwx * nspinor))
8646 0 : ABI_MALLOC(rhotwgp, (npwx * nspinor))
8647 0 : ABI_MALLOC(vc_sqrt_qbz, (npwx))
8648 0 : spinor_padx = reshape([0, 0, npwx, npwx, 0, npwx, npwx, 0], [2, 4])
8649 :
8650 : ! Get Fourier components of the Coulomb interaction in the BZ
8651 : ! In 3D systems, neglecting umklapp, vc(Sq,sG)=vc(q,G)=4pi/|q+G|
8652 : ! The same relation holds for 0-D systems, but not in 1-D or 2D systems. It depends on S.
8653 0 : if (gwr%has_vcgen_sigma) then
8654 0 : call gwr%vcgen_sigma%get_vc_sqrt(qq_bz, npwx, gvec_x, gwr%q0, gwr%cryst, vc_sqrt_qbz, gwr%gtau_comm%value)
8655 : else
8656 0 : call gwr%vcgen_eps%get_vc_sqrt(qq_bz, npwx, gvec_x, gwr%q0, gwr%cryst, vc_sqrt_qbz, gwr%gtau_comm%value)
8657 : end if
8658 :
8659 0 : desc_ki => gwr%green_desc_kibz(ik_ibz)
8660 :
8661 : ! Get npw_k and kg_k for this k.
8662 0 : if (isirr_k) then
8663 0 : istwf_k = desc_ki%istwfk; npw_k = desc_ki%npw
8664 0 : ABI_MALLOC(kg_k, (3, npw_k))
8665 0 : kg_k(:,:) = desc_ki%gvec
8666 : else
8667 0 : istwf_k = 1
8668 0 : call get_kg(ksum, istwf_k, dtset%ecutwfn, cryst%gmet, npw_k, kg_k)
8669 : end if
8670 :
8671 0 : ABI_MALLOC(ug_ksum, (npw_k * nspinor))
8672 0 : ABI_MALLOC(ug_ksum_dp, (npw_k * nspinor))
8673 : !ABI_MALLOC(ugb_kcalcibz, (npw_k * nspinor))
8674 0 : ABI_MALLOC(cg1_ibz, (2, desc_ki%npw * nspinor))
8675 : !ABI_MALLOC(cg2_bz, (2, npw_k * nspinor))
8676 :
8677 0 : ABI_MALLOC(gbound_ksum, (2*u_mgfft+8, 2))
8678 0 : call sphereboundary(gbound_ksum, istwf_k, kg_k, u_mgfft, npw_k)
8679 :
8680 : ! ==========================
8681 : ! Sum over (occupied) bands
8682 : ! ==========================
8683 0 : ugb_kibz => gwr%ugb(ik_ibz, spin)
8684 :
8685 0 : do il_b=1,ugb_kibz%size_local(2)
8686 : ! Distribute bands inside tau_comm as wavefunctions are replicated
8687 0 : if (gwr%tau_comm%skip(il_b)) cycle
8688 0 : band_sum = ugb_kibz%loc2gcol(il_b)
8689 :
8690 : ! Skip empty states. MRM: allow negative occ numbers.
8691 0 : if (abs(qp_occ(band_sum, ik_ibz, spin)) < tol_empty) CYCLE
8692 :
8693 : ! Compute ur_ksum(r) from the symmetrical image.
8694 : ! I should rotate the g-vectors outside the loop and rotate ug here
8695 : ! but at present I cannot use cgtk_rotate due to the symrel^T convention.
8696 :
8697 0 : if (isirr_k) then
8698 : !call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, bra_kq)
8699 0 : ug_ksum(:) = ugb_kibz%buffer_cplx(:, il_b)
8700 : else
8701 : ! Reconstruct u_kq(G) from the IBZ image.
8702 :
8703 : ! FIXME: This is wrong if spc
8704 0 : call c_f_pointer(c_loc(ug_ksum_dp), cg2_ptr, shape=[2, npw_k * nspinor])
8705 :
8706 : !call c_f_pointer(c_loc(ugb_kibz%buffer_cplx(:, il_b)), cg1_ptr, shape=[2, desc_ki%npw * nspinor])
8707 : !call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, nspinor, ndat1, &
8708 : ! desc_ki%npw, desc_ki%gvec, &
8709 : ! npw_k, kg_k, desc_ki%istwfk, istwf_k, cg1_ptr, cg2_ptr, work_ngfft, work)
8710 :
8711 0 : cg1_ibz(1,:) = real(ugb_kibz%buffer_cplx(:, il_b), kind=dp)
8712 0 : cg1_ibz(2,:) = real(aimag(ugb_kibz%buffer_cplx(:, il_b)), kind=dp)
8713 : call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, nspinor, ndat1, &
8714 : desc_ki%npw, desc_ki%gvec, &
8715 0 : npw_k, kg_k, desc_ki%istwfk, istwf_k, cg1_ibz, cg2_ptr, work_ngfft, work)
8716 0 : ug_ksum(:) = ug_ksum_dp(:)
8717 : end if
8718 :
8719 0 : call fft_ug(npw_k, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_k, kg_k, gbound_ksum, ug_ksum, ur_ksum)
8720 :
8721 0 : if (any(g0 /= 0)) ur_ksum = ur_ksum * conjg(eig0r)
8722 :
8723 : ! Get all <k-q,band_sum,s|e^{-i(q+G).r}|s,jb,k>
8724 0 : do jb=bmin,bmax
8725 :
8726 : ! FIXME: nspinor 2 is wrong as we have a 2x2 matrix
8727 0 : ur_prod(:) = conjg(ur_ksum(:)) * ur_bdgw(:,jb)
8728 0 : call fft_ur(npwx, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwfk1, gvec_x, gbound_x, ur_prod, rhotwg_ki(:,jb))
8729 :
8730 : ! Multiply by the square root of the Coulomb term
8731 : ! In 3-D systems, the factor sqrt(4pi) is included
8732 0 : do ii=1,nspinor
8733 0 : spad = (ii-1) * npwx
8734 0 : rhotwg_ki(spad+1:spad+npwx,jb) = rhotwg_ki(spad+1:spad + npwx,jb) * vc_sqrt_qbz(1:npwx)
8735 : end do
8736 :
8737 0 : if (q_is_gamma) then
8738 : !if (ik_bz == jk_bz) then
8739 : ! Treat analytically the case q --> 0:
8740 : !
8741 : ! * The oscillator is evaluated at q = 0 as it is considered constant in the small cube around Gamma
8742 : ! while the Colulomb term is integrated out.
8743 : ! * If nspinor == 1, we have nonzero contribution only if band_sum == jb
8744 : ! * If nspinor == 2, we evaluate <band_sum,up|jb,up> and <band_sum,dwn|jb,dwn>,
8745 : ! and impose orthonormalization since npwwfn might be < npwvec.
8746 : ! * Note the use of i_sz_resid and not i_sz, to account for the possibility
8747 : ! to have generalized KS basis set from hybrid
8748 :
8749 0 : i_sz = gwr%vcgen_eps%i_sz
8750 0 : if (gwr%has_vcgen_sigma) i_sz = gwr%vcgen_sigma%i_sz
8751 :
8752 0 : if (nspinor == 1) then
8753 0 : rhotwg_ki(1, jb) = czero_gw
8754 0 : if (band_sum == jb) rhotwg_ki(1,jb) = cmplx(sqrt(i_sz), 0.0_gwp)
8755 : !rhotwg_ki(1,jb) = czero_gw ! DEBUG
8756 :
8757 : else
8758 0 : rhotwg_ki(1, jb) = zero; rhotwg_ki(npwx+1, jb) = zero
8759 0 : if (band_sum == jb) then
8760 : associate(ugb_kcalcibz => gwr%ugb(ikcalc_ibz, spin)%buffer_cplx(:,il_b))
8761 0 : ABI_CHECK(size(ug_ksum) == size(ugb_kcalcibz), "Size mismatch in Sigma_x")
8762 0 : ctmp = xdotc(npw_k, ug_ksum(1:), 1, ugb_kcalcibz(1:), 1)
8763 0 : rhotwg_ki(1, jb) = cmplx(sqrt(i_sz), 0.0_gwp) * real(ctmp)
8764 0 : ctmp = xdotc(npw_k, ug_ksum(npw_k+1:), 1, ugb_kcalcibz(npw_k+1:), 1)
8765 0 : rhotwg_ki(npwx+1, jb) = cmplx(sqrt(i_sz), 0.0_gwp) * real(ctmp)
8766 : end associate
8767 : end if
8768 : !!!rhotwg_ki(1, jb) = zero; rhotwg_ki(npwx+1, jb) = zero
8769 : !!! PAW is missing
8770 : end if
8771 : end if
8772 :
8773 : end do ! jb Got all matrix elements from bmin up to bmax.
8774 :
8775 0 : theta_mu_minus_esum = fact_spin * qp_occ(band_sum, ik_ibz, spin)
8776 : theta_mu_minus_esum2 = sqrt(abs(fact_spin * qp_occ(band_sum, ik_ibz, spin))) ! MBB Nat. orb. funct. approx. sqrt(occ)
8777 :
8778 0 : if (abs(theta_mu_minus_esum / fact_spin) >= tol_empty) then ! MRM: allow negative occ numbers
8779 0 : do kb=bmin,bmax
8780 :
8781 : ! Copy the ket Sigma_x |phi_{k,kb}>.
8782 0 : rhotwgp(:) = rhotwg_ki(:, kb)
8783 :
8784 : ! Loop over the non-zero row elements of this column.
8785 : ! If gwcalctyp < 20: only diagonal elements since QP == KS.
8786 : ! If gwcalctyp >= 20:
8787 : ! * Only off-diagonal elements connecting states with same character.
8788 : ! * Only the upper triangle if HF, SEX, or COHSEX.
8789 :
8790 0 : do irow=1,Sigxij_tab(ikcalc, spin)%col(kb)%size1
8791 0 : jb = Sigxij_tab(ikcalc, spin)%col(kb)%bidx(irow)
8792 0 : rhotwg(:) = rhotwg_ki(:,jb)
8793 :
8794 : ! Calculate bare exchange <phi_jb|Sigma_x|phi_kb>.
8795 : ! Do the scalar product only if band_sum is occupied.
8796 0 : do iab=1,gwr%nsig_ab
8797 0 : spadx1 = spinor_padx(1, iab); spadx2 = spinor_padx(2, iab)
8798 0 : xdot_tmp = -XDOTC(npwx, rhotwg(spadx1+1:), 1, rhotwgp(spadx2+1:), 1)
8799 0 : gwpc_sigxme = xdot_tmp * theta_mu_minus_esum
8800 0 : gwpc_sigxme2 = xdot_tmp * theta_mu_minus_esum2
8801 :
8802 : ! Accumulate and symmetrize Sigma_x matrix elements.
8803 : ! -wtqm comes from time-reversal (exchange of band indices)
8804 0 : is_idx = spin; if (nspinor == 2) is_idx = iab
8805 : sigxme_tmp(jb, kb, is_idx) = sigxme_tmp(jb, kb, is_idx) + &
8806 0 : (wtqp + wtqm) * DBLE(gwpc_sigxme) + (wtqp - wtqm) * j_dpc * AIMAG(gwpc_sigxme)
8807 :
8808 0 : sigx(1, jb, kb, is_idx) = sigx(1, jb, kb, is_idx) + wtqp * gwpc_sigxme
8809 0 : sigx(2, jb, kb, is_idx) = sigx(2, jb, kb, is_idx) + wtqm *CONJG(gwpc_sigxme)
8810 : end do
8811 : end do ! irow
8812 :
8813 : end do ! kb
8814 : end if
8815 : end do ! band_sum
8816 :
8817 0 : ABI_FREE(gbound_x)
8818 0 : ABI_FREE(kg_k)
8819 0 : ABI_FREE(ug_ksum)
8820 0 : ABI_FREE(ug_ksum_dp)
8821 : !ABI_FREE(ugb_kcalcibz)
8822 0 : ABI_FREE(cg1_ibz)
8823 : !ABI_FREE(cg2_bz)
8824 0 : ABI_FREE(gbound_ksum)
8825 0 : ABI_FREE(gvec_x)
8826 0 : ABI_FREE(rhotwg_ki)
8827 0 : ABI_FREE(rhotwg)
8828 0 : ABI_FREE(rhotwgp)
8829 0 : ABI_FREE(vc_sqrt_qbz)
8830 : end do ! my_ikf Got all diagonal (off-diagonal) matrix elements.
8831 :
8832 : ! Gather contributions from all the CPUs.
8833 0 : call xmpi_sum(sigxme_tmp, gwr%kgt_comm%value, ierr)
8834 0 : call xmpi_sum(sigx, gwr%kgt_comm%value, ierr)
8835 :
8836 : ! Multiply by constants. For 3D systems sqrt(4pi) is included in vc_sqrt_qbz.
8837 0 : sigxme_tmp = (one / (cryst%ucvol * gwr%nkbz)) * sigxme_tmp ! * Sigp%sigma_mixing
8838 0 : sigx = (one / (cryst%ucvol * gwr%nkbz)) * sigx ! * Sigp%sigma_mixing
8839 :
8840 : ! If we have summed over the IBZ_q, we have to average over degenerate states.
8841 : ! Presently only diagonal terms are considered
8842 : ! Note that here we pass ks_eig to sigx_symmetrize instead of qp_eig.
8843 : ! The reason is that we use the eigenvalues to detect degeneracies before averaging
8844 : ! and qp_eig may break degeneracies while ks_eig are much more accurate.
8845 : ! Most of the breaking comes from the correlated part, likey due to the treatment of q --> 0.
8846 :
8847 : ! TODO QP-SCGW required a more involved approach, there is a check in sigma
8848 : ! TODO it does not work if nspinor == 2.
8849 :
8850 0 : if (gwr%dtset%symsigma == 1) then
8851 0 : call sigx_symmetrize(ikcalc_ibz, spin, bmin, bmax, nsppol, nspinor, gwr%nsig_ab, gwr%dtset%symsigma_de, ks_eig, sigx, sigxme_tmp)
8852 : !do ii=bmin, bmax; print *, "qp_eig:", ii, qp_eig(ii, ikcalc_ibz, spin) * Ha_eV; end do
8853 : !call sigx_symmetrize(ikcalc_ibz, spin, bmin, bmax, nsppol, nspinor, gwr%nsig_ab, gwr%dtset%symsigma_de, qp_eig, sigx, sigxme_tmp)
8854 : end if
8855 :
8856 : ! Reconstruct the full sigma_x matrix from the upper triangle.
8857 0 : if (gwr%nsig_ab == 1) then
8858 0 : call hermitianize(sigxme_tmp(:,:,spin), "Upper")
8859 : else
8860 0 : ABI_WARNING("Should hermitianize non-collinear sigma!")
8861 : end if
8862 :
8863 : ! Save exchange matrix in gwr%sigx_mat taking into account sig_diago.
8864 0 : if (gwr%nsig_ab == 1) then
8865 0 : if (gwr%sig_diago) then
8866 0 : do jb=bmin,bmax
8867 0 : gwr%sigx_mat(jb, 1, ikcalc, spin) = sigxme_tmp(jb,jb,spin)
8868 : end do
8869 : else
8870 0 : gwr%sigx_mat(bmin:bmax, bmin:bmax, ikcalc, spin) = sigxme_tmp(bmin:bmax, bmin:bmax, spin)
8871 : end if
8872 : else
8873 0 : if (gwr%sig_diago) then
8874 0 : do iab=1,gwr%nsig_ab
8875 0 : do jb=bmin,bmax
8876 0 : gwr%sigx_mat(jb, 1, ikcalc, iab) = sigxme_tmp(jb,jb,iab)
8877 : end do
8878 : end do
8879 : else
8880 0 : gwr%sigx_mat(bmin:bmax, bmin:bmax, ikcalc, :) = sigxme_tmp(bmin:bmax, bmin:bmax, :)
8881 : end if
8882 : end if
8883 :
8884 0 : ABI_FREE(ur_bdgw)
8885 0 : ABI_FREE(ur_prod)
8886 0 : ABI_FREE(ur_ksum)
8887 0 : ABI_FREE(eig0r)
8888 0 : ABI_FREE(sigxme_tmp)
8889 0 : ABI_FREE(sigx)
8890 0 : call ltg_k%free()
8891 0 : call cwtime_report(" Sigx_nk:", cpu_k, wall_k, gflops_k)
8892 : end do ! ikcalc
8893 : end do ! my_is
8894 :
8895 0 : if (gwr%spin_comm%nproc > 1) call xmpi_sum(gwr%sigx_mat, gwr%spin_comm%value, ierr)
8896 0 : if (gwr%nspinor == 2) gwr%sigx_mat(:,:,:,1) = sum(gwr%sigx_mat(:,:,:,:), dim=4)
8897 :
8898 0 : ABI_FREE(work)
8899 0 : call sigijtab_free(Sigxij_tab)
8900 0 : ABI_FREE(Sigxij_tab)
8901 :
8902 : ! Compute QP results. Done usually when gwr_task == G0v i.e. Hartree-Fock with KS states.
8903 0 : compute_qp__ = .False.; if (present(compute_qp)) compute_qp__ = compute_qp
8904 0 : if (compute_qp__ .and. gwr%comm%me == 0) then
8905 0 : call write_notations(units)
8906 0 : do spin=1,gwr%nsppol
8907 0 : do ikcalc=1,gwr%nkcalc
8908 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
8909 0 : ydoc = yamldoc_open('GWR_SelfEnergy_ee', width=11, real_fmt='(3f8.3)')
8910 0 : call ydoc%add_real1d('kpoint', gwr%kcalc(:, ikcalc))
8911 0 : call ydoc%add_int('spin', spin, int_fmt="(i1)")
8912 0 : call ydoc%add_int('gwr_scf_iteration', gwr%scf_iteration)
8913 0 : call ydoc%add_string('gwr_task', gwr%dtset%gwr_task)
8914 :
8915 : call ydoc%add_real('KS_gap', &
8916 : (gwr%ks_ebands%eig(gwr%ks_vbik(ik_ibz, spin)+1, ik_ibz, spin) - &
8917 0 : gwr%ks_ebands%eig(gwr%ks_vbik(ik_ibz, spin), ik_ibz, spin)) * Ha_eV)
8918 0 : call ydoc%open_tabular('data') !, tag='SigmaeeData')
8919 0 : write(msg, "(a5, *(a9))") "Band", "E0", "SigX", "Occ(E)"
8920 0 : call ydoc%add_tabular_line(msg)
8921 :
8922 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
8923 : write(msg,'(i5, *(f9.3))') &
8924 0 : band, & ! Band
8925 0 : gwr%ks_ebands%eig(band, ik_ibz, spin) * Ha_eV, & ! E0
8926 0 : real(gwr%sigx_mat(band, merge(1, band, gwr%sig_diago), ikcalc, spin), kind=dp) * Ha_eV, & ! SigX
8927 0 : gwr%qp_ebands%occ(band, ik_ibz, spin) ! Occ(E)
8928 0 : call ydoc%add_tabular_line(msg)
8929 : end do
8930 :
8931 0 : call ydoc%write_units_and_free([std_out, ab_out])
8932 : end do ! ikcalc
8933 : end do ! spin
8934 : end if
8935 :
8936 : 10 continue
8937 0 : call cwtime_report(" gwr_build_sigxme:", cpu_all, wall_all, gflops_all)
8938 0 : call timab(1920, 2, tsec)
8939 :
8940 0 : end subroutine gwr_build_sigxme
8941 : !!***
8942 :
8943 : !----------------------------------------------------------------------
8944 :
8945 : !!****f* m_gwr/gwr_get_u_ngfft
8946 : !! NAME
8947 : !! gwr_get_u_ngfft
8948 : !!
8949 : !! FUNCTION
8950 : !! Compute FFT mesh from boxcutmin.
8951 : !!
8952 : !! INPUTS
8953 : !!
8954 : !! OUTPUT
8955 : !!
8956 : !! SOURCE
8957 :
8958 0 : subroutine gwr_get_u_ngfft(gwr, boxcutmin, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8959 :
8960 : !Arguments ------------------------------------
8961 : class(gwr_t),intent(in) :: gwr
8962 : real(dp),intent(in) :: boxcutmin
8963 : integer,intent(out) :: u_ngfft(18), u_nfft, u_mgfft, u_mpw, gmax(3)
8964 :
8965 : !Local variables-------------------------------
8966 : integer :: ik_bz, npw_, ig, ii
8967 : real(dp) :: kk_bz(3)
8968 0 : integer,allocatable :: gvec_(:,:)
8969 : ! *************************************************************************
8970 :
8971 : ! All MPI procs in gwr%comm execute this part.
8972 : ! Note the loops over the full BZ to compute u_mpw
8973 : ! FIXME: umklapp, ecutsigx and q-centered G-sphere
8974 : ! TODO: Write new routine to compute best FFT mesh for ecut1 + ecut1. See set_mesh from GW code.
8975 :
8976 0 : u_ngfft = gwr%dtset%ngfft ! This to allow users to specify fftalg
8977 :
8978 0 : u_mpw = -1; gmax = 0
8979 0 : do ik_bz=1,gwr%nkbz
8980 0 : kk_bz = gwr%kbz(:, ik_bz)
8981 0 : call get_kg(kk_bz, istwfk1, gwr%dtset%ecutwfn, gwr%cryst%gmet, npw_, gvec_)
8982 0 : u_mpw = max(u_mpw, npw_)
8983 : ! TODO: g0 umklapp here can enter into play gmax may not be large enough!
8984 0 : do ig=1,npw_
8985 0 : do ii=1,3
8986 0 : gmax(ii) = max(gmax(ii), abs(gvec_(ii, ig)))
8987 : end do
8988 : end do
8989 0 : ABI_FREE(gvec_)
8990 : call getng(boxcutmin, gwr%dtset%chksymtnons, gwr%dtset%ecutwfn, gwr%cryst%gmet, &
8991 : kk_bz, me_fft0, u_mgfft, u_nfft, u_ngfft, nproc_fft1, gwr%cryst%nsym, paral_fft0, &
8992 0 : gwr%cryst%symrel, gwr%cryst%tnons, gpu_option=gwr%dtset%gpu_option, unit=dev_null)
8993 : end do
8994 :
8995 0 : end subroutine gwr_get_u_ngfft
8996 : !!***
8997 :
8998 : !----------------------------------------------------------------------
8999 :
9000 : !!****f* m_gwr/get_1d_sc_phases
9001 : !! NAME
9002 : !! get_1d_sc_phases
9003 : !!
9004 : !! FUNCTION
9005 : !! Compute one-dimensional factors in the supercell.
9006 : !!
9007 : !! INPUTS
9008 : !! sc_shape(3)=Supercell shape.
9009 : !! nkpt=Number of k-points
9010 : !! kpts(3,nkpt)=K-points in reduced coordinates.
9011 : !!
9012 : !! OUTPUT
9013 : !! ph1d(maxval(sc_shape), 3, nkpt))
9014 : !!
9015 : !! SOURCE
9016 :
9017 0 : subroutine get_1d_sc_phases(sc_shape, nkpt, kpts, ph1d)
9018 :
9019 : !Arguments ------------------------------------
9020 : integer,intent(in) :: sc_shape(3), nkpt
9021 : real(dp),intent(in) :: kpts(3, nkpt)
9022 : complex(gwp),allocatable,intent(out) :: ph1d(:,:,:)
9023 :
9024 : !Local variables-------------------------------
9025 : integer :: ikpt, ix, iy, iz
9026 : real(dp) :: arg, fact, kk(3)
9027 : ! *************************************************************************
9028 :
9029 0 : ABI_MALLOC(ph1d, (maxval(sc_shape), 3, nkpt))
9030 :
9031 0 : do ikpt=1,nkpt
9032 0 : kk = kpts(:, ikpt)
9033 0 : fact = two_pi * kk(1)
9034 0 : do ix=0,sc_shape(1) - 1
9035 0 : arg = fact * ix
9036 0 : ph1d(ix + 1, 1, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9037 : end do
9038 0 : fact = two_pi * kk(2)
9039 0 : do iy=0,sc_shape(2) - 1
9040 0 : arg = fact * iy
9041 0 : ph1d(iy + 1, 2, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9042 : end do
9043 0 : fact = two_pi * kk(3)
9044 0 : do iz=0,sc_shape(3) - 1
9045 0 : arg = fact * iz
9046 0 : ph1d(iz + 1, 3, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9047 : end do
9048 : end do ! ikpt
9049 :
9050 0 : end subroutine get_1d_sc_phases
9051 : !!***
9052 :
9053 : !!****f* m_gwr/sc_sum
9054 : !! NAME
9055 : !! sc_sum
9056 : !!
9057 : !! FUNCTION
9058 : !! Compute matrix elements of the self-energy Sigma_nk in the supercell at fixed rr.
9059 : !!
9060 : !! INPUTS
9061 : !! sc_shape(3)=Supercell shape.
9062 : !! uc_ngfft(18)=Info on the FFT mesh in the unit cell.
9063 : !! nspinor=Number of spinor componenets.
9064 : !! ph1d=1d phase factors in the supercell
9065 : !! k_is_gamma=Tru if k is gamma.
9066 : !! alpha=Coeffient
9067 : !! sc_data=Values in the supercell
9068 : !! uc_psi=Wavefunction in the unit cell
9069 : !!
9070 : !! OUTPUT
9071 : !! cout=Partial contribution to integral.
9072 : !!
9073 : !! SOURCE
9074 :
9075 0 : subroutine sc_sum(sc_shape, uc_ngfft, ph1d, k_is_gamma, alpha, sc_data, uc_psi, cout)
9076 :
9077 : !Arguments ------------------------------------
9078 : integer,intent(in) :: sc_shape(3), uc_ngfft(18)
9079 : complex(gwp),intent(in) :: ph1d(maxval(sc_shape), 3)
9080 : logical,intent(in) :: k_is_gamma
9081 : complex(gwp),target,intent(in) :: alpha, uc_psi(uc_ngfft(1)*uc_ngfft(2)*uc_ngfft(3))
9082 : complex(gwp),target,intent(in) :: &
9083 : sc_data(uc_ngfft(1)*sc_shape(1)*uc_ngfft(2)*sc_shape(2)*uc_ngfft(3)*sc_shape(3))
9084 : complex(gwp),intent(out) :: cout
9085 :
9086 : !Local variables-------------------------------
9087 : integer :: il1, il2, il3, uc_n1, uc_n2, uc_n3, ix, iy, iz !, idat
9088 : complex(gwp) :: cphase, phl32, phl3
9089 0 : complex(gwp),contiguous,pointer :: uc_psi_ptr(:,:,:), sc_data_ptr(:,:,:,:,:,:)
9090 : ! *************************************************************************
9091 :
9092 0 : uc_n1 = uc_ngfft(1); uc_n2 = uc_ngfft(2); uc_n3 = uc_ngfft(3)
9093 :
9094 0 : call c_f_pointer(c_loc(uc_psi), uc_psi_ptr, shape=[uc_n1, uc_n2, uc_n3])
9095 : call c_f_pointer(c_loc(sc_data), sc_data_ptr, &
9096 0 : shape=[uc_n1, sc_shape(1), uc_n2, sc_shape(2), uc_n3, sc_shape(3)])
9097 :
9098 0 : cout = zero
9099 :
9100 0 : if (k_is_gamma) then
9101 : ! Don't need to multiply by e^{ik.L}
9102 0 : do il3=1,sc_shape(3)
9103 0 : do iz=1,uc_n3
9104 0 : do il2=1,sc_shape(2)
9105 0 : do iy=1,uc_n2
9106 0 : do il1=1,sc_shape(1)
9107 0 : do ix=1,uc_n1
9108 0 : cout = cout + uc_psi_ptr(ix, iy, iz) * sc_data_ptr(ix, il1, iy, il2, iz, il3)
9109 : end do
9110 : end do
9111 : end do
9112 : end do
9113 : end do
9114 : end do
9115 :
9116 : else
9117 : ! Need to multiply by e^{ik.L}
9118 0 : do il3=1,sc_shape(3)
9119 0 : phl3 = ph1d(il3, 3)
9120 0 : do iz=1,uc_n3
9121 0 : do il2=1,sc_shape(2)
9122 0 : phl32 = phl3 * ph1d(il2, 2)
9123 0 : do iy=1,uc_n2
9124 0 : do il1=1,sc_shape(1)
9125 0 : cphase = phl32 * ph1d(il1, 1) ! e^{ik.L}
9126 0 : do ix=1,uc_n1
9127 0 : cout = cout + cphase * uc_psi_ptr(ix, iy, iz) * sc_data_ptr(ix, il1, iy, il2, iz, il3)
9128 : end do
9129 : end do
9130 : end do
9131 : end do
9132 : end do
9133 : end do
9134 : end if
9135 :
9136 0 : cout = alpha * cout
9137 :
9138 0 : end subroutine sc_sum
9139 : !!***
9140 :
9141 : !!****f* m_gwr/memb_limited_step
9142 : !! NAME
9143 : !! memb_limited_step
9144 : !!
9145 : !! FUNCTION
9146 : !! Compute the amount of memory needed to process all the data between start and stop,
9147 : !! and limits the number of steps to avoid exceeding maxmem_mb.
9148 : !!
9149 : !! INPUTS
9150 : !! start, stop: integer range of indices.
9151 : !! num_items: number of data items processed per index.
9152 : !! bsize: size in bytes per data item.
9153 : !! maxmem_mb: maximum allowed memory usage (in megabytes)
9154 : !!
9155 : !! OUTPUT
9156 : !!
9157 : !! SOURCE
9158 :
9159 : integer pure function memb_limited_step(start, stop, num_items, bsize, maxmem_mb) result(step)
9160 : integer,intent(in) :: start, stop, num_items, bsize
9161 : real(dp),intent(in) :: maxmem_mb
9162 :
9163 : !Local variables-------------------------------
9164 : real(dp) :: totmem_mb
9165 : ! *************************************************************************
9166 :
9167 : totmem_mb = one * (stop - start + 1) * num_items * bsize
9168 : step = stop - start + 1
9169 : if (totmem_mb > maxmem_mb) step = floor(totmem_mb / maxmem_mb)
9170 :
9171 : end function memb_limited_step
9172 : !!***
9173 :
9174 : !----------------------------------------------------------------------
9175 :
9176 : !!****f* m_gwr/gwr_gamma_gw
9177 : !! NAME
9178 : !! gwr_gamma_gw
9179 : !!
9180 : !! FUNCTION
9181 : !!
9182 : !! INPUTS
9183 : !! vpsp(nfft)=local psp (Hartree)
9184 : !!
9185 : !! OUTPUT
9186 : !!
9187 : !! SOURCE
9188 :
9189 0 : subroutine gwr_gamma_gw(gwr, nfftf, ngfftf, vpsp)
9190 :
9191 : use m_gwrdm, only : calc_rdmx,calc_rdmc,natoccs,update_hdr_bst,print_tot_occ,get_chkprdm,&
9192 : print_chkprdm,change_matrix,print_total_energy,print_band_energies
9193 : use m_spacepar, only : hartre
9194 :
9195 : !Arguments ------------------------------------
9196 : class(gwr_t),target,intent(inout) :: gwr
9197 : integer,intent(in) :: nfftf
9198 : !arrays
9199 : integer,intent(in) :: ngfftf(18)
9200 : real(dp),intent(in) :: vpsp(nfftf)
9201 :
9202 : !Local variables-------------------------------
9203 : !scalars
9204 : integer,parameter :: master = 0, cplex1 = 1, tim_fourdp5 = 5
9205 : integer :: spin, ikcalc, ik_ibz, ib, ib1, ib2, nkibz, nsppol, mband, ierr, b1gw, b2gw
9206 : !real(dp) :: cpu, wall, gflops
9207 : real(dp) :: evext_energy,den_int !,coef_hyb,exc_mbb_energy eh_energy, ekin_energy,
9208 : real(dp) :: gsqcut,boxcut,ecutf
9209 : character(len=500) :: msg
9210 0 : type(hdr_type) :: Hdr_sigma
9211 : !arrays
9212 : integer :: units(2)
9213 : real(dp),parameter :: k0(3) = zero
9214 : !real(dp) :: kgw(3) ! kk_ibz(3),
9215 0 : real(dp),allocatable :: nat_occs(:,:), gw_rhor(:,:), gw_rhog(:,:), gw_vhartr(:)
9216 0 : complex(dp),allocatable :: xrdm_k_full(:,:,:), rdm_k(:,:), pot_k(:,:), nateigv(:,:,:,:), old_ks_purex(:,:), new_hartr(:,:)
9217 0 : complex(dp) :: omega_i(gwr%ntau)
9218 0 : complex(dp),allocatable :: sigcme_k(:,:,:,:)
9219 : ! *************************************************************************
9220 :
9221 0 : call gwr%run_g0w0(free_ugb=.False.)
9222 : ! TODO: Might release some PBLAS memory for W at this point
9223 :
9224 : ! This section is copied from m_sigma_driver with small changes in order to intergrate it with the gwr% object.
9225 : associate (dtset => gwr%dtset, qp_ebands => gwr%qp_ebands, ks_me => gwr%ks_me, psps => gwr%psps, &
9226 : Wfd_nato_master => gwr%kcalc_wfd, dtfil => gwr%dtfil, cryst => gwr%cryst)
9227 :
9228 0 : units = [std_out, ab_out]
9229 0 : nkibz = gwr%nkibz; nsppol = gwr%nsppol; b1gw = gwr%b1gw; b2gw = gwr%b2gw
9230 : ! Don't take mband from ks_ebands but compute it from gwr%bstop_ks
9231 0 : mband = maxval(gwr%bstop_ks) !; mband = gwr%ks_ebands%mband
9232 :
9233 : ! Note: all subroutines of 70_gw/m_gwrdm.F90 are implemented assuming nsppol == 1
9234 0 : ABI_CHECK(dtset%nsppol == 1, "1-RDM GW correction only implemented for restricted closed-shell calculations!")
9235 0 : ABI_CHECK(.not. gwr%sig_diago, "sig_diago should be false")
9236 :
9237 0 : ABI_CALLOC(nateigv, (mband, mband, nkibz, nsppol))
9238 0 : ABI_CALLOC(nat_occs, (mband, nkibz))
9239 0 : ABI_CALLOC(xrdm_k_full, (b1gw:b2gw, b1gw:b2gw, nkibz))
9240 :
9241 0 : write(msg,'(a34,2i9)')' Bands used for the GW 1RDM arrays',b1gw,b2gw
9242 0 : call wrtout(units, msg)
9243 :
9244 0 : do ik_ibz=1,nkibz
9245 0 : do ib=b1gw,b2gw
9246 0 : xrdm_k_full(ib,ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
9247 : end do
9248 0 : do ib=1,mband
9249 : ! Copy initial occ numbers (in principle 2 or 0 from KS-DFT)
9250 0 : nat_occs(ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
9251 : ! Set to identity matrix
9252 0 : nateigv(ib,ib,ik_ibz,1) = cone
9253 : end do
9254 : end do
9255 :
9256 0 : omega_i = j_dpc * gwr%iw_mesh
9257 :
9258 0 : do spin=1,gwr%nsppol
9259 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
9260 : ! Index of the irred k-point
9261 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
9262 : !kgw = gwr%kcalc(:, ikcalc)
9263 : ! min and max band indices for GW corrections (for this k-point)
9264 0 : ib1 = gwr%bstart_ks(ikcalc, spin); ib2 = gwr%bstop_ks(ikcalc, spin)
9265 :
9266 : ! Compute Sigma_x - Vxc or DELTA Sigma_x - Vxc
9267 : ! where DELTA Sigma_x = Sigma_x - hyb_parameter Vx^exact for hyb Functionals.
9268 : ! NB: Only restricted closed-shell calcs are implemented here
9269 0 : ABI_CALLOC(pot_k, (ib1:ib2, ib1:ib2))
9270 0 : ABI_CALLOC(rdm_k, (ib1:ib2, ib1:ib2))
9271 0 : pot_k(ib1:ib2,ib1:ib2) = gwr%sigx_mat(ib1:ib2,ib1:ib2,ik_ibz,spin) - ks_me%vxcval(ib1:ib2,ib1:ib2,ik_ibz,spin)
9272 0 : call calc_rdmx(ib1, ib2, ik_ibz, pot_k, rdm_k, qp_ebands)
9273 :
9274 : ! Update the full 1RDM with the exchange corrected one for this k-point
9275 0 : xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) = xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) + rdm_k(ib1:ib2,ib1:ib2)
9276 :
9277 : ! Compute NAT ORBS for exchange corrected 1-RDM
9278 : ! Only restricted closed-shell calcs
9279 0 : do ib=ib1,ib2
9280 0 : rdm_k(ib,ib) = rdm_k(ib,ib) + qp_ebands%occ(ib,ik_ibz,1)
9281 : end do
9282 0 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=0)
9283 :
9284 : ! ================
9285 : ! Correlation part
9286 : ! ================
9287 : ! TODO
9288 : !ABI_CALLOC(sigcme_k, (gwr%ntau, ib2-ib1+1, ib2-ib1+1, nsppol*gwr%nsig_ab))
9289 : !gwr%sigc_iw_mat((gwr%ntau, ib1:, ib1:, nsppol*gwr%nsig_ab))
9290 0 : call calc_rdmc(ib1, ib2, ik_ibz, omega_i, gwr%iw_wgs, sigcme_k, qp_ebands, rdm_k)
9291 : !ABI_FREE(sigcme_k)
9292 :
9293 : ! Update the full 1RDM with the GW corrected one for this k-point
9294 : ! Only restricted closed-shell calcs
9295 0 : rdm_k(ib1:ib2,ib1:ib2) = xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) + rdm_k(ib1:ib2,ib1:ib2)
9296 : ! Compute nat orbs and occ numbers at k-point ik_ibz
9297 0 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=1)
9298 :
9299 0 : ABI_FREE(pot_k)
9300 0 : ABI_FREE(rdm_k)
9301 : end do ! ikcalc
9302 : end do ! spin
9303 :
9304 0 : ABI_CALLOC(gw_rhor, (nfftf, dtset%nspden))
9305 0 : call gwr%wfk_hdr%copy(hdr_sigma)
9306 :
9307 : ! NRM WARNING: only the master has bands on Wfd_nato_master so it prints everything and computes gw_rhor
9308 : !
9309 : ! All procs. update the qp_ebands and the Hdr_sigma
9310 0 : call update_hdr_bst(Wfd_nato_master, nat_occs, b1gw, b2gw, qp_ebands, Hdr_sigma, Dtset%ngfft(1:3))
9311 :
9312 : ! Compute unit cell (averaged) occ = \sum _k weight_k occ_k
9313 0 : call print_tot_occ(qp_ebands)
9314 :
9315 0 : if (gwr%comm%me == master) then
9316 0 : call Wfd_nato_master%rotate(cryst, nateigv) !, bmask=bdm_mask) ! Let it use bdm_mask and build NOs
9317 0 : call Wfd_nato_master%mkrho(cryst, psps, qp_ebands, ngfftf, nfftf, gw_rhor) ! Construct the density
9318 0 : if (dtset%prtwf == 1) then
9319 : ! Print WFK file, here qp_ebands contains nat. orb. occs.
9320 0 : call Wfd_nato_master%write_wfk(Hdr_sigma, qp_ebands, dtfil%fnameabo_wfk, wfknocheck=.True.)
9321 : end if
9322 0 : if (dtset%prtden == 1) then
9323 : ! Print DEN file
9324 : call fftdatar_write("density",dtfil%fnameabo_den,dtset%iomode,Hdr_sigma,&
9325 0 : Cryst,ngfftf,cplex1,nfftf,dtset%nspden,gw_rhor,gwr%mpi_enreg,ebands=qp_ebands)
9326 : end if
9327 : end if
9328 0 : call xmpi_bcast(gw_rhor, master, gwr%comm%value, ierr)
9329 0 : call hdr_sigma%free()
9330 :
9331 : ! Compute energies only if all k-points are available
9332 : ! We need the hole 1-RDM to build Fock[GW.1RDM]!
9333 0 : ABI_CALLOC(old_ks_purex, (b1gw:b2gw, gwr%nkcalc))
9334 0 : ABI_CALLOC(new_hartr, (b1gw:b2gw, gwr%nkcalc))
9335 0 : ABI_CALLOC(gw_rhog, (2, nfftf))
9336 0 : ABI_CALLOC(gw_vhartr, (nfftf))
9337 : !
9338 : ! A) Compute Evext = int rho(r) vext(r) dr -> simply dot product on the FFT grid
9339 : ! Only restricted closed-shell calcs
9340 : !
9341 0 : den_int = sum(gw_rhor(:,1)) * cryst%ucvol / nfftf
9342 0 : evext_energy = sum(gw_rhor(:,1) * vpsp(:)) * cryst%ucvol / nfftf
9343 : !
9344 : ! B) Coulomb <KS_i|Vh[NO]|KS_j>
9345 : !
9346 : ! FFT to build gw_rhog
9347 0 : call fourdp(1, gw_rhog, gw_rhor(:,1), -1, gwr%mpi_enreg, nfftf, ndat1, ngfftf, tim_fourdp5)
9348 :
9349 0 : ecutf = dtset%ecutwfn
9350 0 : if (psps%usepaw == 1) then
9351 0 : ecutf = dtset%pawecutdg
9352 0 : call wrtout(std_out, ch10//' FFT (fine) grid used in PAW GW update:')
9353 : end if
9354 :
9355 0 : call getcut(boxcut, ecutf, cryst%gmet, gsqcut, dtset%iboxcut, std_out, k0, ngfftf)
9356 : call hartre(1, gsqcut, dtset%icutcoul, psps%usepaw, gwr%mpi_enreg, nfftf, ngfftf, dtset%nkpt, dtset%rcut, &
9357 0 : gw_rhog, cryst%rprimd, dtset%vcutgeo, gw_vhartr)
9358 :
9359 : ! TODO
9360 0 : ABI_FREE(nateigv)
9361 0 : ABI_FREE(nat_occs)
9362 0 : ABI_FREE(xrdm_k_full)
9363 0 : ABI_FREE(gw_rhor)
9364 0 : ABI_FREE(old_ks_purex)
9365 0 : ABI_FREE(new_hartr)
9366 0 : ABI_FREE(gw_rhog)
9367 0 : ABI_FREE(gw_vhartr)
9368 : end associate
9369 :
9370 0 : end subroutine gwr_gamma_gw
9371 : !!***
9372 :
9373 0 : end module m_gwr
9374 : !!***
|
