Branch data 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 * Ha_eV, gwr%te_max * Ha_eV, 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 : : !!***
|
