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, 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 : gw_icutcoul_ = dtset%gw_icutcoul
1655 : :
1656 : 0 : gwr%has_vcgen_sigma = .False.
1657 [ # # ]: 0 : if (any(gw_icutcoul_ == [14, 15, 16])) then
1658 : 0 : gw_icutcoul_ = mod(gw_icutcoul_, 10); gwr%has_vcgen_sigma = .True.
1659 : : end if
1660 : :
1661 : : call gwr%vcgen_eps%init(cryst, ks_ebands%kptrlatt, gwr%nkbz, gwr%nqibz, gwr%nqbz, gwr%qbz, &
1662 : 0 : dtset%gw_rcut, gw_icutcoul_, dtset%vcutgeo, gwr%comm%value)
1663 : :
1664 [ # # ]: 0 : if (gwr%has_vcgen_sigma) then
1665 : : ! Note dtset%gw_icutcoul here.
1666 : : call gwr%vcgen_sigma%init(cryst, ks_ebands%kptrlatt, gwr%nkbz, gwr%nqibz, gwr%nqbz, gwr%qbz, &
1667 : 0 : dtset%gw_rcut, dtset%gw_icutcoul, dtset%vcutgeo, gwr%comm%value)
1668 : : end if
1669 : :
1670 : : ! Now we know the value of g_ngfft. Setup tables for zero-padded FFTs.
1671 : : ! Build descriptors for Green's functions and tchi and setup tables for zero-padded FFTs.
1672 [ # # # # : 0 : ABI_MALLOC(gwr%green_desc_kibz, (gwr%nkibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1673 : :
1674 [ # # ]: 0 : do my_iki=1,gwr%my_nkibz
1675 [ # # ]: 0 : ik_ibz = gwr%my_kibz_inds(my_iki); kk_ibz = gwr%kibz(:, ik_ibz)
1676 : 0 : call gwr%green_desc_kibz(ik_ibz)%init(kk_ibz, istwfk1, dtset%ecutwfn, gwr, kin_sorted=.False.)
1677 : : end do
1678 : :
1679 [ # # # # : 0 : ABI_MALLOC(gwr%tchi_desc_qibz, (gwr%nqibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1680 [ # # # # : 0 : ABI_ICALLOC(gwr%chinpw_qibz, (gwr%nqibz))
# # # # #
# # # # #
# # ]
1681 : :
1682 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
1683 [ # # ]: 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
1684 : : ! Note ecuteps instead of ecut. Also, sort the g-vectors by |q+g|^2/2 when q is in the IBZ to facilitate
1685 : : ! the extrapolation of the RPA energy as a function of ecut_chi
1686 : 0 : call gwr%tchi_desc_qibz(iq_ibz)%init(qq_ibz, istwfk1, dtset%ecuteps, gwr, kin_sorted=.True., rot=.True.)
1687 : :
1688 : : ! Compute sqrt(vc(q,G))
1689 : 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
1690 : 0 : if (gwr%itreat_iqibz(iq_ibz)) gwr%chinpw_qibz(iq_ibz) = desc_q%npw
1691 : 0 : q_is_gamma = (normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0)
1692 : 0 : call desc_q%get_vc_sqrt(qq_ibz, q_is_gamma, gwr, "epsilon", gwr%gtau_comm%value)
1693 [ # # # # ]: 0 : if (gwr%has_vcgen_sigma) then
1694 : 0 : call desc_q%get_vc_sqrt(qq_ibz, q_is_gamma, gwr, "sigma", gwr%gtau_comm%value)
1695 : : end if
1696 : : end associate
1697 : : end do
1698 : :
1699 : : ! Collect npwq on all procs
1700 : 0 : call xmpi_sum(gwr%chinpw_qibz, gwr%comm%value, ierr)
1701 : :
1702 : : ! Init 1D PBLAS grid to block-distribute matrices along columns.
1703 [ # # ]: 0 : call gwr%g_slkproc%init(gwr%g_comm%value, grid_dims=[1, gwr%g_comm%nproc])
1704 [ # # ]: 0 : call gwr%gtau_slkproc%init(gwr%gtau_comm%value, grid_dims=[1, gwr%gtau_comm%nproc])
1705 : :
1706 : : ! ==================================
1707 : : ! Allocate arrays of PBLAS matrices
1708 : : ! ==================================
1709 [ # # # # : 0 : ABI_MALLOC(gwr%gt_kibz, (2, gwr%nkibz, gwr%ntau, gwr%nsppol, gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1710 [ # # # # : 0 : ABI_MALLOC(gwr%tchi_qibz, (gwr%nqibz, gwr%ntau, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1711 [ # # # # : 0 : ABI_MALLOC(gwr%sigc_kibz, (2, gwr%nkibz, gwr%ntau, gwr%nsppol, gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1712 : :
1713 : : ! ====================================
1714 : : ! Create netcdf file to store results
1715 : : ! ====================================
1716 : 0 : gwr%gwrnc_write = .True.
1717 : : !gwr%gwrnc_write = .False.
1718 [ # # ]: 0 : gwr%gwrnc_path = strcat(dtfil%filnam_ds(4), "_GWR.nc")
1719 : :
1720 [ # # # # ]: 0 : if (my_rank == master .and. gwr%gwrnc_write) then
1721 : 0 : call gwr%print(units)
1722 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, gwr%gwrnc_path, xmpi_comm_self))
1723 : : ! Write structure and ebands
1724 [ # # ]: 0 : NCF_CHECK(cryst%ncwrite(ncid))
1725 [ # # ]: 0 : NCF_CHECK(ks_ebands%ncwrite(ncid))
1726 : :
1727 : : ! Add GWR dimensions.
1728 : 0 : smat_bsize1 = gwr%b2gw - gwr%b1gw + 1
1729 [ # # ]: 0 : smat_bsize2 = merge(1, gwr%b2gw - gwr%b1gw + 1, gwr%sig_diago)
1730 : : ncerr = nctk_def_dims(ncid, [ &
1731 : : nctkdim_t("nsppol", gwr%nsppol), &
1732 : : nctkdim_t("nspin_channel", gwr%nsppol*gwr%nsig_ab),&
1733 : : nctkdim_t("nsig_ab", gwr%nsig_ab),&
1734 : : nctkdim_t("ntau", gwr%ntau), &
1735 : : nctkdim_t("nwr", gwr%nwr), &
1736 : : nctkdim_t("chi_mpw", gwr%tchi_mpw), &
1737 : : nctkdim_t("nqibz", gwr%nqibz), &
1738 : : nctkdim_t("nqbz", gwr%nqbz), &
1739 : : nctkdim_t("nkcalc", gwr%nkcalc), &
1740 : : nctkdim_t("max_nbcalc", gwr%max_nbcalc), &
1741 : : nctkdim_t("smat_bsize1", smat_bsize1), &
1742 : : nctkdim_t("smat_bsize2", smat_bsize2) &
1743 [ # # ]: 0 : ], defmode=.True.)
1744 [ # # ]: 0 : NCF_CHECK(ncerr)
1745 : :
1746 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
1747 : : "gwr_completed", "sig_diago", "b1gw", "b2gw", "symsigma", "symchi", "scf_iteration" &
1748 [ # # ]: 0 : ])
1749 [ # # ]: 0 : NCF_CHECK(ncerr)
1750 : :
1751 : : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
1752 : : "wr_step", "ecuteps", "ecut", "ecutwfn", "ecutsigx", "gwr_boxcutmin", &
1753 : : "gwr_max_hwtene", "min_transition_energy_eV", "max_transition_energy_eV", &
1754 : : "eratio", "ft_max_err_t2w_cos", "ft_max_err_w2t_cos", "ft_max_err_t2w_sin", &
1755 : : "cosft_duality_error", "regterm" &
1756 [ # # ]: 0 : ])
1757 [ # # ]: 0 : NCF_CHECK(ncerr)
1758 : :
1759 : : ! Define arrays with results.
1760 : : ncerr = nctk_def_arrays(ncid, [ &
1761 : : nctkarr_t("gwr_task", "char", "character_string_length"), &
1762 : : nctkarr_t("tau_mesh", "dp", "ntau"), &
1763 : : nctkarr_t("tau_wgs", "dp", "ntau"), &
1764 : : nctkarr_t("iw_mesh", "dp", "ntau"), &
1765 : : nctkarr_t("iw_wgs", "dp", "ntau"), &
1766 : : nctkarr_t("cosft_wt", "dp", "ntau, ntau"), &
1767 : : nctkarr_t("cosft_tw", "dp", "ntau, ntau"), &
1768 : : nctkarr_t("sinft_wt", "dp", "ntau, ntau"), &
1769 : : !nctkarr_t("ngqpt", "int", "three"), &
1770 : : nctkarr_t("bstart_ks", "int", "nkcalc, nsppol"), &
1771 : : nctkarr_t("bstop_ks", "int", "nkcalc, nsppol"), &
1772 : : nctkarr_t("kcalc", "dp", "three, nkcalc"), &
1773 : : nctkarr_t("kcalc2ibz", "int", "nkcalc, six") &
1774 [ # # ]: 0 : ])
1775 [ # # ]: 0 : NCF_CHECK(ncerr)
1776 : :
1777 : : ! ======================================================
1778 : : ! Write data that do not depend on the (kpt, spin) loop.
1779 : : ! ======================================================
1780 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
1781 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
1782 : : "gwr_completed", "sig_diago", "b1gw", "b2gw", "symsigma", "symchi", "scf_iteration"], &
1783 [ # # # # : 0 : [0, merge(1, 0, gwr%sig_diago), gwr%b1gw, gwr%b2gw, gwr%dtset%symsigma, dtset%symchi, gwr%scf_iteration])
# # ]
1784 [ # # ]: 0 : NCF_CHECK(ncerr)
1785 : :
1786 : : ncerr = nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: &
1787 : : "wr_step", "ecuteps", "ecut", "ecutwfn", "ecutsigx", "gwr_boxcutmin", &
1788 : : "gwr_max_hwtene", "min_transition_energy_eV", "max_transition_energy_eV", &
1789 : : "eratio", "ft_max_err_t2w_cos", "ft_max_err_w2t_cos", "ft_max_err_t2w_sin", &
1790 : : "cosft_duality_error", "regterm"], &
1791 : : [gwr%wr_step, dtset%ecuteps, dtset%ecut, dtset%ecutwfn, dtset%ecutsigx, dtset%gwr_boxcutmin, &
1792 : : dtset%gwr_max_hwtene, gwr%te_min * Ha_eV, gwr%te_max * Ha_eV, gwr%te_max / gwr%te_min, &
1793 : : gwr%ft_max_error(1), gwr%ft_max_error(2), gwr%ft_max_error(3), gwr%cosft_duality_error, regterm &
1794 [ # # # # ]: 0 : ])
1795 [ # # ]: 0 : NCF_CHECK(ncerr)
1796 : :
1797 [ # # # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_task"), trim(dtset%gwr_task)))
1798 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_mesh"), gwr%tau_mesh))
1799 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_wgs"), gwr%tau_wgs))
1800 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_mesh"), gwr%iw_mesh))
1801 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_wgs"), gwr%iw_wgs))
1802 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("cosft_wt"), gwr%cosft_wt))
1803 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("cosft_tw"), gwr%cosft_tw))
1804 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("sinft_wt"), gwr%sinft_wt))
1805 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("bstart_ks"), gwr%bstart_ks))
1806 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("bstop_ks"), gwr%bstop_ks))
1807 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("kcalc"), gwr%kcalc))
1808 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("kcalc2ibz"), gwr%kcalc2ibz))
1809 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
1810 : : end if ! master
1811 : :
1812 : 0 : call cwtime_report(" gwr_init:", cpu, wall, gflops)
1813 [ # # # # : 0 : call timab(1920, 2, tsec)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1814 : :
1815 : : contains
1816 : 0 : integer function vid(vname)
1817 : : character(len=*),intent(in) :: vname
1818 : 0 : vid = nctk_idname(ncid, vname)
1819 : : end function vid
1820 : :
1821 : : end subroutine gwr_init
1822 : : !!***
1823 : :
1824 : : !----------------------------------------------------------------------
1825 : :
1826 : : !!****f* m_gwr/estimate
1827 : : !! NAME
1828 : : !! estimate
1829 : : !!
1830 : : !! FUNCTION
1831 : : !! Estimate memory requirements and the parallel speedup of a given `np_kgts` configuration.
1832 : : !!
1833 : : !! SOURCE
1834 : :
1835 : 0 : type(est_t) pure function estimate(gwr, np_kgts) result(est)
1836 : :
1837 : : !Arguments ------------------------------------
1838 : : class(gwr_t),intent(in) :: gwr
1839 : : integer,intent(in) :: np_kgts(4)
1840 : :
1841 : : !Local variables-------------------------------
1842 : : real(dp) :: np_k, np_g, np_t, np_s, w_k, w_g, w_t, w_s, np_tot
1843 : : ! *************************************************************************
1844 : :
1845 : : ! Use real quantities to avoid integer division
1846 : 0 : np_k = np_kgts(1); np_g = np_kgts(2); np_t = np_kgts(3); np_s = np_kgts(4)
1847 [ # # ]: 0 : np_tot = product(real(np_kgts))
1848 : :
1849 : : ! NB: array dimensioned with nkibz and nqibz do not scale as 1/np_k as we distribute the BZ, IBZ points might be replicated.
1850 : :
1851 : : !!! FIXME HT: Here we should recalculate with nsig_ab
1852 : : ! Resident memory in Mb for G(g,g',+/-tau) and chi(g,g',tau)
1853 : 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
1854 : 0 : est%mem_chi_gg = two * (one*gwr%tchi_mpw)**2 * gwr%ntau * gwr%nqibz * gwp*b2Mb / (np_g * np_t * np_k)
1855 : 0 : est%mem_ugb = two * gwr%green_mpw * gwr%nspinor * gwr%dtset%nband(1) * gwr%nkibz * gwr%nsppol * gwp*b2Mb / np_tot
1856 : :
1857 : : ! Temporary memory allocated inside the tau loops.
1858 : : ! This is the chunck we have to minimize by increasing np_g and/or np_k to avoid going OOM.
1859 : 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)
1860 : 0 : est%mem_chi_rg = two * gwr%tchi_mpw * gwr%g_nfft * gwr%nqbz * gwp*b2Mb / (np_g * np_k)
1861 : :
1862 : 0 : est%mem_total = est%mem_green_gg + est%mem_chi_gg + est%mem_ugb + est%mem_green_rg + est%mem_chi_rg
1863 : :
1864 : : ! Estimate speedup and parallel efficiency using heuristic weights. Note g_nfft instead of green_mpw.
1865 : 0 : w_k = 0.799_dp; w_g = 0.899_dp; w_t = 1.1_dp; w_s = 1.2_dp
1866 : :
1867 : : ! Promote kpt parallelism under particular circumstances.
1868 [ # # # # ]: 0 : if (gwr%nkbz > 4**3) w_k = w_g + tol2 * merge(+1, -5, np_k < 5)
1869 : :
1870 : : est%speedup = speedup(gwr%nkbz, nint(np_k), w_k) * speedup(gwr%g_nfft, nint(np_g), w_g) * &
1871 : 0 : speedup(gwr%ntau, nint(np_t), w_t) * speedup(gwr%nsppol, nint(np_s), w_s)
1872 : 0 : est%efficiency = est%speedup / np_tot
1873 : :
1874 : : contains
1875 : :
1876 : 0 : real(dp) pure function speedup(size, np, weight)
1877 : : ! Expected speedup for a `size` problem and `np` processes
1878 : : integer,intent(in) :: size, np
1879 : : real(dp),intent(in) :: weight
1880 [ # # ]: 0 : if (np == 1) then
1881 : : speedup = one
1882 : : else
1883 [ # # ]: 0 : speedup = (weight*size) / (one* ((size / np) + merge(0, 1, mod(size, np) == 0)))
1884 : : end if
1885 : 0 : end function speedup
1886 : :
1887 : : end function estimate
1888 : : !!***
1889 : :
1890 : : !----------------------------------------------------------------------
1891 : :
1892 : : !!****f* m_gwr/est_print
1893 : : !! NAME
1894 : : !! est_print
1895 : : !!
1896 : : !! FUNCTION
1897 : : !! Print memory estimate.
1898 : : !!
1899 : : !! SOURCE
1900 : :
1901 [ # # ]: 0 : subroutine est_print(est, units)
1902 : :
1903 : : !Arguments ------------------------------------
1904 : : class(est_t), intent(in) :: est
1905 : : integer,intent(in) :: units(:)
1906 : :
1907 : : !Local variables-------------------------------
1908 : : character(len=4),parameter :: fmt = "f8.1"
1909 : : ! *************************************************************************
1910 : :
1911 : 0 : call wrtout(units, "- Resident memory in Mb for G(g,g',+/-tau) and chi(g,g',tau):")
1912 : 0 : call wrtout(units, sjoin("- G_k(g,g,tau): ", ftoa(est%mem_green_gg, fmt=fmt)))
1913 : 0 : call wrtout(units, sjoin("- Chi_q(g,g,tau): ", ftoa(est%mem_chi_gg, fmt=fmt)))
1914 : 0 : call wrtout(units, sjoin("- u_k(g,b): ", ftoa(est%mem_ugb, fmt=fmt)))
1915 : 0 : call wrtout(units, "- Temporary memory allocated inside the tau loops:")
1916 : 0 : call wrtout(units, sjoin("- G_k(r,g): ", ftoa(est%mem_green_rg, fmt=fmt)))
1917 : 0 : call wrtout(units, sjoin("- chi_q(r,g): ", ftoa(est%mem_chi_rg, fmt=fmt)))
1918 : :
1919 : 0 : end subroutine est_print
1920 : : !!***
1921 : :
1922 : : !----------------------------------------------------------------------
1923 : :
1924 : : !!****f* m_gwr/gwr_malloc_free_mats
1925 : : !! NAME
1926 : : !! gwr_malloc_free_mats
1927 : : !!
1928 : : !! FUNCTION
1929 : : !! Allocate/Free PBLAS matrices according to `what` for the set of k/q-points selected by `mask_ibz`.
1930 : : !!
1931 : : !! INPUTS
1932 : : !! mask_ibz
1933 : : !! what
1934 : : !! action
1935 : : !!
1936 : : !! SOURCE
1937 : :
1938 [ # # ]: 0 : subroutine gwr_malloc_free_mats(gwr, mask_ibz, what, action)
1939 : :
1940 : : !Arguments ------------------------------------
1941 : : class(gwr_t), target, intent(inout) :: gwr
1942 : : integer,intent(in) :: mask_ibz(:)
1943 : : character(len=*),intent(in) :: what, action
1944 : :
1945 : : !Local variables-------------------------------
1946 : : integer :: my_is, my_it, ipm, npw, col_bsize, itau, spin, ik_ibz, iq_ibz, iab
1947 : : !integer :: ii, num_pm, ipm_list__(2)
1948 : : type(__slkmat_t), pointer :: mat
1949 : : character(len=500) :: msg !, gpu_action
1950 : : ! *************************************************************************
1951 : :
1952 [ # # ]: 0 : ABI_CHECK(string_in(action, "malloc, free"), sjoin("Invalid action:", action))
1953 : :
1954 : : !gpu_action = "None"; if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
1955 : :
1956 : : !num_pm = 2; ipm_list__ = [1, 2]
1957 : : !if (present(ipm_list)) then
1958 : : ! num_pm = size(ipm_list)
1959 : : ! ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
1960 : : ! ipm_list__(1:num_pm) = ipm_list(:)
1961 : : !end if
1962 : :
1963 [ # # ]: 0 : do my_is=1,gwr%my_nspins
1964 : 0 : spin = gwr%my_spins(my_is)
1965 [ # # ]: 0 : do my_it=1,gwr%my_ntau
1966 : 0 : itau = gwr%my_itaus(my_it)
1967 : : ! NB: all the PBLAS matrices are MPI distributed over g' in blocks if action == "malloc"
1968 : :
1969 : 0 : select case (what)
1970 : : case ("green")
1971 : : ! ========================
1972 : : ! Allocate/free G_k(g,g', +-itau)
1973 : : ! ========================
1974 [ # # ]: 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nkibz, "wrong mask size")
1975 : :
1976 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
1977 [ # # ]: 0 : if (mask_ibz(ik_ibz) == 0) cycle
1978 : 0 : npw = gwr%green_desc_kibz(ik_ibz)%npw
1979 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
1980 [ # # ]: 0 : do iab=1,gwr%nsig_ab
1981 : 0 : associate (gt => gwr%gt_kibz(:, ik_ibz, itau, spin, iab))
1982 [ # # ]: 0 : do ipm=1,2
1983 [ # # # # ]: 0 : if (action == "malloc") call gt(ipm)%init(npw, npw, gwr%g_slkproc, istwfk1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
1984 [ # # ]: 0 : if (action == "free") call gt(ipm)%free()
1985 : : end do
1986 : : end associate
1987 : : end do
1988 : : end do
1989 : :
1990 : : case ("tchi", "wc")
1991 : : ! ===========================
1992 : : ! Allocate/free tchi_q(g,g', +itau)
1993 : : ! ===========================
1994 [ # # ]: 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nqibz, "wrong mask size")
1995 : :
1996 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
1997 [ # # ]: 0 : if (mask_ibz(iq_ibz) == 0) cycle
1998 : 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
1999 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
2000 [ # # ]: 0 : if (what == "tchi") mat => gwr%tchi_qibz(iq_ibz, itau, spin)
2001 [ # # ]: 0 : if (what == "wc") mat => gwr%wc_qibz(iq_ibz, itau, spin)
2002 [ # # # # ]: 0 : if (action == "malloc") call mat%init(npw, npw, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
2003 [ # # ]: 0 : if (action == "free") call mat%free()
2004 : : end do
2005 : :
2006 : : case ("sigma")
2007 : : ! ================================
2008 : : ! Allocate/free sigmac_kibz(g,g', +- itau)
2009 : : ! ================================
2010 [ # # ]: 0 : ABI_CHECK_IEQ(size(mask_ibz), gwr%nkibz, "wrong mask size")
2011 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
2012 [ # # ]: 0 : if (mask_ibz(ik_ibz) == 0) cycle
2013 : 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
2014 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
2015 [ # # ]: 0 : do iab=1,gwr%nsig_ab
2016 : 0 : associate (sigc => gwr%sigc_kibz(:, ik_ibz, itau, spin, iab))
2017 [ # # ]: 0 : do ipm=1,2
2018 [ # # # # ]: 0 : if (action == "malloc") call sigc(ipm)%init(npw, npw, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
2019 [ # # ]: 0 : if (action == "free") call sigc(ipm)%free()
2020 : : end do
2021 : : end associate
2022 : : end do
2023 : : end do
2024 : :
2025 : : case default
2026 [ # # # # ]: 0 : ABI_ERROR(sjoin("Invalid what:", what))
2027 : : end select
2028 : :
2029 : : end do ! my_it
2030 : : end do ! my_is
2031 : :
2032 : 0 : call wrtout(std_out, "")
2033 [ # # ]: 0 : call gwr%print_mem([std_out])
2034 : :
2035 : 0 : end subroutine gwr_malloc_free_mats
2036 : : !!***
2037 : :
2038 : : !----------------------------------------------------------------------
2039 : :
2040 : : !!****f* m_gwr/gwr_free
2041 : : !! NAME
2042 : : !! gwr_free
2043 : : !!
2044 : : !! FUNCTION
2045 : : !! Free dynamic memory in gwr object.
2046 : : !!
2047 : : !! SOURCE
2048 : :
2049 : 0 : subroutine gwr_free(gwr)
2050 : :
2051 : : !Arguments ------------------------------------
2052 : : class(gwr_t), intent(inout) :: gwr
2053 : : ! *************************************************************************
2054 : :
2055 [ # # ]: 0 : ABI_SFREE(gwr%ks_vbik)
2056 [ # # ]: 0 : ABI_SFREE(gwr%kbz)
2057 [ # # ]: 0 : ABI_SFREE(gwr%kbz2ibz)
2058 [ # # ]: 0 : ABI_SFREE(gwr%kbz2ibz_symrel)
2059 [ # # ]: 0 : ABI_SFREE(gwr%qbz2ibz)
2060 [ # # ]: 0 : ABI_SFREE(gwr%my_kbz_inds)
2061 [ # # ]: 0 : ABI_SFREE(gwr%my_kibz_inds)
2062 [ # # ]: 0 : ABI_SFREE(gwr%my_qbz_inds)
2063 [ # # ]: 0 : ABI_SFREE(gwr%my_qibz_inds)
2064 [ # # ]: 0 : ABI_SFREE(gwr%qbz)
2065 [ # # ]: 0 : ABI_SFREE(gwr%qibz)
2066 [ # # ]: 0 : ABI_SFREE(gwr%wtq)
2067 [ # # ]: 0 : ABI_SFREE(gwr%chi0_head_myw)
2068 [ # # ]: 0 : ABI_SFREE(gwr%chi0_uwing_myw)
2069 [ # # ]: 0 : ABI_SFREE(gwr%chi0_lwing_myw)
2070 [ # # ]: 0 : ABI_SFREE(gwr%my_spins)
2071 [ # # ]: 0 : ABI_SFREE(gwr%my_itaus)
2072 [ # # ]: 0 : ABI_SFREE(gwr%tau_master)
2073 [ # # ]: 0 : ABI_SFREE(gwr%np_kibz)
2074 [ # # ]: 0 : ABI_SFREE(gwr%itreat_ikibz)
2075 [ # # ]: 0 : ABI_SFREE(gwr%np_qibz)
2076 [ # # ]: 0 : ABI_SFREE(gwr%itreat_iqibz)
2077 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%tau_mesh)
2078 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%tau_wgs)
2079 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%iw_mesh)
2080 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%iw_wgs)
2081 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%cosft_tw)
2082 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%cosft_wt)
2083 [ # # ]: 0 : ABI_SFREE_NOCOUNT(gwr%sinft_wt)
2084 [ # # ]: 0 : ABI_SFREE(gwr%kcalc)
2085 [ # # ]: 0 : ABI_SFREE(gwr%bstart_ks)
2086 [ # # ]: 0 : ABI_SFREE(gwr%bstop_ks)
2087 [ # # ]: 0 : ABI_SFREE(gwr%nbcalc_ks)
2088 [ # # ]: 0 : ABI_SFREE(gwr%kcalc2ibz)
2089 [ # # ]: 0 : ABI_SFREE(gwr%sigx_mat)
2090 [ # # ]: 0 : ABI_SFREE(gwr%sigc_iw_mat)
2091 [ # # ]: 0 : ABI_SFREE(gwr%chinpw_qibz)
2092 : :
2093 : 0 : call gwr%ks_gaps%free()
2094 : 0 : call gwr%qp_ebands%free()
2095 : 0 : call gwr%qp_ebands_prev%free()
2096 : 0 : call gwr%kcalc_wfd%free()
2097 : 0 : call gwr%wfk_hdr%free()
2098 : :
2099 : : ! Free descriptors
2100 [ # # ]: 0 : if (allocated(gwr%green_desc_kibz)) then
2101 : 0 : call desc_array_free(gwr%green_desc_kibz)
2102 [ # # # # : 0 : ABI_FREE(gwr%green_desc_kibz)
# # # # #
# # # # #
# # # # #
# # # #
# ]
2103 : : end if
2104 [ # # ]: 0 : if (allocated(gwr%tchi_desc_qibz)) then
2105 : 0 : call desc_array_free(gwr%tchi_desc_qibz)
2106 [ # # # # : 0 : ABI_FREE(gwr%tchi_desc_qibz)
# # # # #
# # # # #
# # # # #
# # # #
# ]
2107 : : end if
2108 : :
2109 : : ! Free PBLAS matrices
2110 [ # # ]: 0 : if (allocated(gwr%gt_kibz)) then
2111 : 0 : call slk_array_free(gwr%gt_kibz)
2112 [ # # # # : 0 : ABI_FREE(gwr%gt_kibz)
# # # # #
# ]
2113 : : end if
2114 [ # # ]: 0 : if (allocated(gwr%tchi_qibz)) then
2115 : 0 : call slk_array_free(gwr%tchi_qibz)
2116 [ # # # # : 0 : ABI_FREE(gwr%tchi_qibz)
# # # # #
# ]
2117 : : end if
2118 [ # # ]: 0 : if (allocated(gwr%wc_qibz)) then
2119 : 0 : call slk_array_free(gwr%wc_qibz)
2120 [ # # # # : 0 : ABI_FREE(gwr%wc_qibz)
# # # # #
# ]
2121 : : end if
2122 [ # # ]: 0 : if (allocated(gwr%sigc_kibz)) then
2123 : 0 : call slk_array_free(gwr%sigc_kibz)
2124 [ # # # # : 0 : ABI_FREE(gwr%sigc_kibz)
# # # # #
# ]
2125 : : end if
2126 : : ! Release the scalapack pressor.
2127 : 0 : call gwr%g_slkproc%free()
2128 : :
2129 [ # # ]: 0 : if (allocated(gwr%ugb)) then
2130 : 0 : call slk_array_free(gwr%ugb)
2131 [ # # # # : 0 : ABI_FREE(gwr%ugb)
# # # # #
# ]
2132 : : end if
2133 : : !if (allocated(gwr%nato_ugb)) then
2134 : : ! call slk_array_free(gwr%nato_ugb)
2135 : : ! ABI_FREE(gwr%nato_ugb)
2136 : : !end if
2137 : 0 : call gwr%gtau_slkproc%free()
2138 : :
2139 : : ! datatypes.
2140 : 0 : call gwr%ks_me%free()
2141 : 0 : call gwr%vcgen_eps%free()
2142 [ # # ]: 0 : if (gwr%has_vcgen_sigma) call gwr%vcgen_sigma%free()
2143 : :
2144 [ # # ]: 0 : if (allocated(gwr%degtab)) then
2145 : 0 : call degtab_array_free(gwr%degtab)
2146 [ # # # # : 0 : ABI_FREE(gwr%degtab)
# # # # #
# # # ]
2147 : : end if
2148 : :
2149 : : ! Free MPI communicators
2150 : 0 : call gwr%spin_comm%free(); call gwr%g_comm%free(); call gwr%tau_comm%free()
2151 : 0 : call gwr%kpt_comm%free(); call gwr%gtau_comm%free(); call gwr%kg_comm%free()
2152 : 0 : call gwr%kgt_comm%free(); call gwr%kts_comm%free(); call gwr%comm%free()
2153 : :
2154 : 0 : end subroutine gwr_free
2155 : : !!***
2156 : :
2157 : : ! Free array of desc_t objects.
2158 [ # # ]: 0 : subroutine desc_array1_free(desc_array1)
2159 : : type(desc_t),intent(inout) :: desc_array1(:)
2160 : : integer :: ii
2161 : :
2162 [ # # ]: 0 : do ii=1,size(desc_array1, dim=1)
2163 : 0 : call desc_array1(ii)%free()
2164 : : end do
2165 : 0 : end subroutine desc_array1_free
2166 : :
2167 : : !----------------------------------------------------------------------
2168 : :
2169 : : !!****f* m_gwr/gwr_load_kcalc_wfd
2170 : : !! NAME
2171 : : !! gwr_load_kcalc_wfd
2172 : : !!
2173 : : !! FUNCTION
2174 : : !! Load the KS states to compute Sigma_nk from the WFK file
2175 : : !!
2176 : : !! INPUTS
2177 : : !! wfk_path=Name of the WFK file.
2178 : : !!
2179 : : !! OUTPUT
2180 : : !! tmp_kstab
2181 : : !!
2182 : : !! SOURCE
2183 : :
2184 : 0 : subroutine gwr_load_kcalc_wfd(gwr, wfk_path, tmp_kstab)
2185 : :
2186 : : !Arguments ------------------------------------
2187 : : class(gwr_t),intent(inout) :: gwr
2188 : : character(len=*),intent(in) :: wfk_path
2189 : : integer,allocatable,intent(out) :: tmp_kstab(:,:,:)
2190 : :
2191 : : !Local variables-------------------------------
2192 : : !scalars
2193 : : integer :: mband, nkibz, nsppol, spin, ik_ibz, ikcalc
2194 : : real(dp) :: cpu, wall, gflops
2195 : : !character(len=5000) :: msg
2196 : : type(ebands_t) :: ks_ebands
2197 : 0 : type(hdr_type) :: wfk_hdr
2198 : : !arrays
2199 : 0 : integer,allocatable :: nband(:,:), wfd_istwfk(:)
2200 : 0 : logical,allocatable :: bks_mask(:,:,:), keep_ur(:,:,:)
2201 : : ! *************************************************************************
2202 : :
2203 : 0 : call cwtime(cpu, wall, gflops, "start")
2204 : :
2205 : : associate (wfd => gwr%kcalc_wfd, dtset => gwr%dtset)
2206 : :
2207 : 0 : ks_ebands = wfk_read_ebands(wfk_path, gwr%comm%value, out_hdr=wfk_hdr)
2208 : 0 : call wfk_hdr%vs_dtset(dtset)
2209 : :
2210 : : ! TODO: Add more consistency checks e.g. nkibz,...
2211 : : !cryst = wfk_hdr%get_crystal()
2212 : : !call cryst%print(header="crystal structure from WFK file")
2213 : :
2214 : 0 : nkibz = ks_ebands%nkpt; nsppol = ks_ebands%nsppol
2215 : :
2216 : : ! Don't take mband from ks_ebands but compute it from gwr%bstop_ks
2217 [ # # # # ]: 0 : mband = maxval(gwr%bstop_ks) !; mband = ks_ebands%mband
2218 : :
2219 : : ! Initialize the wave function descriptor.
2220 : : ! Only wavefunctions for the symmetrical imagine of the k wavevectors
2221 : : ! treated by this MPI rank are stored.
2222 [ # # # # : 0 : ABI_MALLOC(nband, (nkibz, nsppol))
# # # # #
# # # # #
# # ]
2223 [ # # # # : 0 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
# # # # #
# # # # #
# # # # #
# ]
2224 [ # # # # : 0 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
# # # # #
# # # # #
# # ]
2225 [ # # # # : 0 : nband = mband; bks_mask = .False.; keep_ur = .False.
# # # # #
# # # # #
# # ]
2226 : :
2227 [ # # # # : 0 : ABI_ICALLOC(tmp_kstab, (2, nkibz, nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
2228 : :
2229 [ # # ]: 0 : do spin=1,gwr%nsppol
2230 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
2231 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
2232 : 0 : associate (b1 => gwr%bstart_ks(ikcalc, spin), b2 => gwr%bstop_ks(ikcalc, spin))
2233 [ # # ]: 0 : tmp_kstab(:, ik_ibz, spin) = [b1, b2]
2234 [ # # ]: 0 : bks_mask(b1:b2, ik_ibz, spin) = .True.
2235 : : end associate
2236 : : end do
2237 : : end do
2238 : :
2239 : : ! Impose istwfk = 1 for all k-points.
2240 : : ! wfd_read_wfk will handle a possible conversion if the WFK contains istwfk /= 1.
2241 [ # # # # : 0 : ABI_MALLOC(wfd_istwfk, (nkibz))
# # # # #
# # # ]
2242 [ # # ]: 0 : wfd_istwfk = 1
2243 : :
2244 : : call wfd%init(gwr%cryst, gwr%pawtab, gwr%psps, keep_ur, mband, nband, nkibz, dtset%nsppol, bks_mask, &
2245 : : dtset%nspden, dtset%nspinor, dtset%ecutwfn, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ks_ebands%kptns, gwr%g_ngfft, &
2246 [ # # # # : 0 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, gwr%comm%value)
# # # # ]
2247 : :
2248 [ # # ]: 0 : call wfd%print([std_out], header="Wavefunctions for GWR calculation")
2249 : :
2250 [ # # ]: 0 : ABI_FREE(nband)
2251 [ # # ]: 0 : ABI_FREE(keep_ur)
2252 [ # # ]: 0 : ABI_FREE(wfd_istwfk)
2253 [ # # ]: 0 : ABI_FREE(bks_mask)
2254 : :
2255 : 0 : call ks_ebands%free(); call wfk_hdr%free()
2256 : :
2257 : : ! Read KS wavefunctions.
2258 : 0 : call wfd%read_wfk(wfk_path, iomode_from_fname(wfk_path))
2259 : : end associate
2260 : :
2261 : 0 : call cwtime_report(" gwr_load_kcalc_from_wfk:", cpu, wall, gflops)
2262 : 0 : call pstat_proc%print(_PSTAT_ARGS_)
2263 : :
2264 [ # # # # : 0 : end subroutine gwr_load_kcalc_wfd
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2265 : : !!***
2266 : :
2267 : : !----------------------------------------------------------------------
2268 : :
2269 : : !!****f* m_gwr/gwr_read_ugb_from_wfk
2270 : : !! NAME
2271 : : !! gwr_read_ugb_from_wfk
2272 : : !!
2273 : : !! FUNCTION
2274 : : !! Read wavefunctions from the WFK file `wfk_path` and store them in gwr%ugb (MPI distributed).
2275 : : !!
2276 : : !! SOURCE
2277 : :
2278 : 0 : subroutine gwr_read_ugb_from_wfk(gwr, wfk_path)
2279 : :
2280 : : !Arguments ------------------------------------
2281 : : class(gwr_t),target,intent(inout) :: gwr
2282 : : character(len=*),intent(in) :: wfk_path
2283 : :
2284 : : !Local variables-------------------------------
2285 : : !scalars
2286 : : integer,parameter :: formeig0 = 0, master = 0
2287 : : integer :: mband, min_nband, nkibz, nsppol, my_is, my_iki, spin, ik_ibz, ierr, bcast_comm, color
2288 : : integer :: npw_k, mpw_disk, istwf_k, il_b, ib, band, iloc, cg_spad, gw_spad
2289 : : integer :: nbsum, npwsp, npw_k_disk, npwsp_disk, bstart, bstop, band_step, nb, nmiss, ig, igw, spinor, icg
2290 : : logical :: print_time
2291 : : real(dp) :: cpu, wall, gflops, cpu_green, wall_green, gflops_green
2292 : : complex(gwp) :: cdum
2293 : : character(len=5000) :: msg
2294 : : logical :: have_band, need_block_ks, io_in_kcomm, cut_ug
2295 : : type(ebands_t) :: wfk_ebands
2296 [ # # ]: 0 : type(wfk_t) :: wfk
2297 : : type(dataset_type),pointer :: dtset
2298 : : type(xcomm_t), pointer :: io_comm
2299 : : !arrays
2300 : : integer :: units(2)
2301 : 0 : integer,allocatable :: kg_k_disk(:,:), gf2wfd(:)
2302 : : !logical,allocatable :: bmask(:)
2303 : : real(dp) :: kk_ibz(3), tsec(2)
2304 : 0 : real(dp),target,allocatable :: cg_work(:,:,:)
2305 : 0 : real(dp),contiguous, pointer :: cg_k(:,:)
2306 : : ! *************************************************************************
2307 : :
2308 [ # # ]: 0 : units = [std_out, ab_out]
2309 : 0 : call cwtime(cpu, wall, gflops, "start")
2310 : 0 : call timab(1921, 1, tsec)
2311 : :
2312 : 0 : dtset => gwr%dtset
2313 : 0 : wfk_ebands = wfk_read_ebands(wfk_path, gwr%comm%value, out_hdr=gwr%wfk_hdr)
2314 : 0 : call gwr%wfk_hdr%vs_dtset(dtset)
2315 : :
2316 : : ! TODO: Add more consistency checks e.g. nkibz,...
2317 : : !cryst = gwr%wfk_hdr%get_crystal()
2318 : : !call cryst%print(header="crystal structure from WFK file")
2319 : :
2320 : : ! TODO: Could read the wavefunctions twice and use ecutwfc for sigma_c and ecut for sigma_x.
2321 [ # # ]: 0 : nkibz = wfk_ebands%nkpt; nsppol = wfk_ebands%nsppol; mband = wfk_ebands%mband; min_nband = minval(wfk_ebands%nband)
2322 : :
2323 : 0 : nbsum = dtset%nband(1)
2324 [ # # ]: 0 : if (nbsum > min_nband) then
2325 : 0 : ABI_ERROR(sjoin("WFK file contains", itoa(min_nband), "states while you're asking for:", itoa(nbsum)))
2326 : 0 : nbsum = min_nband
2327 : : end if
2328 : 0 : call wfk_ebands%free()
2329 : :
2330 : 0 : cut_ug = (abs(gwr%dtset%ecut - gwr%dtset%ecutwfn) > tol3)
2331 [ # # ]: 0 : if (cut_ug) then
2332 : 0 : call wrtout(units, sjoin(" Cutting u(g) as ecutwfn:", ftoa(gwr%dtset%ecutwfn), " < ecut: ", ftoa(gwr%dtset%ecut)))
2333 : : end if
2334 : :
2335 : : ! ==============================================
2336 : : ! Build Green's functions in g-space for given k
2337 : : ! ==============================================
2338 : :
2339 : : ! for tau > 0:
2340 : : !
2341 : : ! G_k(r,r',itau) = i \sum_b^{occ} psi_b(r) \psi_b^*(r') exp(e_b tau)
2342 : : !
2343 : : ! for tau < 0:
2344 : : !
2345 : : ! G_k(r,r',itau) = -i \sum_b^{empty} psi_b(r) \psi_b^*(r') exp(e_b tau)
2346 : : !
2347 : : ! NB: G_k is constructed for k in the IBZ, then we rotate the k-point to obtain G_k in the BZ.
2348 : : !
2349 : : ! TODO:
2350 : : ! 1) Make sure that gvec in gwr and wfd agree with each other.
2351 : : ! 2) May implement trick used in gwst to add empty states approximated with LC of PWs.
2352 : :
2353 : : ! Select occupied or empty G.
2354 : : ! if (eig_nk < -tol6) then
2355 : : ! !ipm = 1
2356 : : ! !gt_cfact = j_dpc * exp(gwr%tau_mesh(itau) * eig_nk)
2357 : : ! ! Vasp convention
2358 : : ! ipm = 2
2359 : : ! gt_cfact = exp(gwr%tau_mesh(itau) * eig_nk)
2360 : : ! else if (eig_nk > tol6) then
2361 : : ! !ipm = 2
2362 : : ! !gt_cfact = -j_dpc * exp(-gwr%tau_mesh(itau) * eig_nk)
2363 : : ! ! Vasp convention
2364 : : ! ipm = 1
2365 : : ! gt_cfact = -exp(-gwr%tau_mesh(itau) * eig_nk)
2366 : : ! else
2367 : : ! ABI_WARNING("Metallic system of semiconductor with Fermi level inside bands!!!!")
2368 : : ! end if
2369 : :
2370 : 0 : call wrtout(std_out, sjoin(" Reading KS states with nbsum:", itoa(nbsum), "..."), do_flush=.True.)
2371 : :
2372 : : ! Init set of (npwsp, nbsum) PBLAS matrix distributed within the g_comm communicator.
2373 : : ! and distribute it over bands so that each proc reads a subset of bands in read_band_block
2374 : : ! Note size_blocs below that corresponds to a round-robin distribution along the band axis.
2375 : :
2376 [ # # # # : 0 : ABI_MALLOC(gwr%ugb, (gwr%nkibz, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2377 : 0 : gwr%ugb_nband = nbsum
2378 : :
2379 [ # # ]: 0 : do my_is=1,gwr%my_nspins
2380 : 0 : spin = gwr%my_spins(my_is)
2381 [ # # ]: 0 : do my_iki=1,gwr%my_nkibz
2382 : 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
2383 : 0 : npw_k = gwr%green_desc_kibz(ik_ibz)%npw; npwsp = npw_k * gwr%nspinor
2384 : 0 : call gwr%ugb(ik_ibz, spin)%init(npwsp, gwr%ugb_nband, gwr%g_slkproc, istwfk1, size_blocs=[-1, 1])
2385 : : end do
2386 : : end do
2387 [ # # ]: 0 : call gwr%print_mem([std_out])
2388 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
2389 : :
2390 [ # # ]: 0 : mpw_disk = maxval(gwr%wfk_hdr%npwarr)
2391 [ # # # # : 0 : ABI_MALLOC(kg_k_disk, (3, mpw_disk))
# # # # #
# # # ]
2392 : :
2393 : : ! Master reads and broadcasts. Much faster on lumi
2394 : 0 : call wrtout(std_out, " Using IO version based on master reads and brodcasts ...")
2395 : 0 : io_comm => gwr%comm; io_in_kcomm = .False.
2396 : 0 : io_comm => gwr%kpt_comm; io_in_kcomm = .True.
2397 : :
2398 [ # # ]: 0 : if (io_comm%me == master) then
2399 : 0 : call wfk%open_read(wfk_path, formeig0, iomode_from_fname(wfk_path), get_unit(), xmpi_comm_self)
2400 : : end if
2401 : :
2402 : : ! TODO This to maximize the size of cg_work and decrease number of IO operations.
2403 : : !min_mem_mb = pstat_proc%pstat_min_mem_mb_per_proc(gwr%comm)
2404 : :
2405 [ # # ]: 0 : do spin=1,gwr%nsppol
2406 [ # # # # : 0 : if (io_in_kcomm .and. .not. any(gwr%my_spins == spin)) cycle
# # ]
2407 : :
2408 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
2409 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (ik_ibz < LOG_MODK .or. mod(ik_ibz, LOG_MODK) == 0)
# # ]
2410 : 0 : if (print_time) call cwtime(cpu_green, wall_green, gflops_green, "start")
2411 : 0 : kk_ibz = gwr%kibz(:, ik_ibz)
2412 : 0 : npw_k = gwr%green_desc_kibz(ik_ibz)%npw
2413 : 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
2414 : :
2415 [ # # ]: 0 : ABI_CHECK_IEQ(istwf_k, 1, "istwfk_k should be 1")
2416 : : ! See m_wfd for calls to convert to istwfk 1
2417 : : !change_gsphere = istwfk_disk /= wfd%istwfk(ik_ibz)
2418 : :
2419 : : ! Create communicator with master and all procs requiring this (k,s) block (color == 1)
2420 [ # # # # : 0 : need_block_ks = any(gwr%my_spins == spin) .and. any(gwr%my_kibz_inds == ik_ibz)
# # # # ]
2421 [ # # # # ]: 0 : color = merge(1, 0, (need_block_ks .or. io_comm%me == master))
2422 : 0 : call xmpi_comm_split(io_comm%value, color, io_comm%me, bcast_comm, ierr)
2423 : :
2424 : : ! TODO: Optimize this part
2425 : : ! Find band_step that gives good compromise between memory and efficiency.
2426 : : !band_step = memb_limited_step(1, nbsum, 2*npwsp_disk, xmpi_bsize_dp, min_mem_mb * 0.8_dp)
2427 : 0 : band_step = 200
2428 : :
2429 [ # # ]: 0 : do bstart=1, nbsum, band_step
2430 : 0 : bstop = min(bstart + band_step - 1, nbsum); nb = bstop - bstart + 1
2431 : :
2432 [ # # # # : 0 : ABI_MALLOC(cg_work, (2, npwsp_disk, nb)) ! This array is always in double precision.
# # # # #
# # # # #
# # # # ]
2433 [ # # ]: 0 : if (io_comm%me == master) then
2434 [ # # ]: 0 : call c_f_pointer(c_loc(cg_work), cg_k, shape=[2, npwsp_disk * nb])
2435 [ # # ]: 0 : call wfk%read_band_block([bstart, bstop], ik_ibz, spin, xmpio_single, kg_k=kg_k_disk, cg_k=cg_k)
2436 : : end if
2437 : :
2438 [ # # ]: 0 : if (color == 1) then
2439 : 0 : call xmpi_bcast(kg_k_disk, master, bcast_comm, ierr)
2440 : 0 : call xmpi_bcast(cg_work, master, bcast_comm, ierr)
2441 : : endif
2442 : :
2443 : : ! Copy my portion of cg_work to buffer_cplx (here we have dp --> sp conversion).
2444 [ # # ]: 0 : if (need_block_ks) then
2445 : : associate (ugb => gwr%ugb(ik_ibz, spin), desc_k => gwr%green_desc_kibz(ik_ibz))
2446 : :
2447 : : ! Table with the correspondence btw the k-centered sphere of the WFK file
2448 : : ! and the one used in wfd (possibly smaller due to ecutwfn).
2449 : 0 : if (cut_ug .and. bstart == 1) then
2450 [ # # # # : 0 : ABI_MALLOC(gf2wfd, (npw_k_disk))
# # # # #
# # # #
# ]
2451 : 0 : call kg_map(npw_k, desc_k%gvec, npw_k_disk, kg_k_disk, gf2wfd, nmiss)
2452 : : end if
2453 : :
2454 [ # # # # ]: 0 : do band=bstart, bstop
2455 : 0 : ib = band - bstart + 1
2456 [ # # ]: 0 : call ugb%glob2loc(1, band, iloc, il_b, have_band); if (.not. have_band) cycle
2457 : :
2458 [ # # ]: 0 : if (.not. cut_ug) then
2459 [ # # ]: 0 : if (band == bstart) then
2460 [ # # # # : 0 : ABI_CHECK(all(kg_k_disk(:,1:npw_k_disk) == desc_k%gvec), "kg_k_disk != desc_k%gvec")
# # # # ]
2461 : : end if
2462 [ # # ]: 0 : ugb%buffer_cplx(:, il_b) = cmplx(cg_work(1,:,ib), cg_work(2,:,ib), kind=gwp)
2463 : :
2464 : : else
2465 : : !ugb%buffer_cplx(:, il_b) = zero
2466 [ # # ]: 0 : do spinor=1,gwr%nspinor
2467 : 0 : cg_spad = (spinor-1) * npw_k_disk
2468 : 0 : gw_spad = (spinor-1) * npw_k
2469 [ # # ]: 0 : do ig=1,npw_k_disk
2470 : 0 : icg = ig + cg_spad
2471 : 0 : igw = gf2wfd(ig) + gw_spad
2472 [ # # ]: 0 : if (gf2wfd(ig) /= 0) then
2473 : 0 : ugb%buffer_cplx(igw, il_b) = cmplx(cg_work(1,icg,ib), cg_work(2,icg,ib), kind=gwp)
2474 : : end if
2475 : : end do
2476 : : end do ! spinor
2477 : :
2478 : : ! Re-normalize wavefunctions..
2479 : 0 : cdum = xdotc(npw_k*gwr%nspinor, ugb%buffer_cplx(:,il_b), 1, ugb%buffer_cplx(:,il_b), 1)
2480 [ # # ]: 0 : if (istwf_k > 1) then
2481 : 0 : cdum = two * DBLE(cdum)
2482 : : associate (ug1 => ugb%buffer_cplx(1,il_b))
2483 [ # # ]: 0 : if (istwf_k == 2) cdum = cdum - conjg(ug1) * ug1
2484 : : end associate
2485 : : end if
2486 : 0 : cdum = one / sqrt(cdum)
2487 : 0 : call xscal(npw_k*gwr%nspinor, cdum, ugb%buffer_cplx(:,il_b), 1)
2488 : : !print *, "new norm:", xdotc(npw_k*gwr%nspinor, ugb%buffer_cplx(:,il_b), 1, ugb%buffer_cplx(:,il_b), 1)
2489 : : end if
2490 : :
2491 : : end do ! band
2492 : : end associate
2493 : : end if
2494 : :
2495 [ # # # # ]: 0 : ABI_FREE(cg_work)
2496 : : end do ! bstart
2497 : :
2498 [ # # ]: 0 : ABI_SFREE(gf2wfd)
2499 : 0 : call xmpi_comm_free(bcast_comm)
2500 : :
2501 [ # # ]: 0 : if (print_time) then
2502 : 0 : write(msg,'(4x,2(a,i0),a)')" Read ugb_k: ik_ibz [", ik_ibz, "/", gwr%nkibz, "]"
2503 [ # # ]: 0 : call cwtime_report(msg, cpu_green, wall_green, gflops_green); if (ik_ibz == LOG_MODK) call wrtout(std_out, " ...")
2504 : : end if
2505 : : end do ! ik_ibz
2506 : : end do ! spin
2507 [ # # ]: 0 : if (io_comm%me == master) call wfk%close()
2508 : :
2509 [ # # ]: 0 : ABI_FREE(kg_k_disk)
2510 [ # # ]: 0 : call gwr%print_mem([std_out])
2511 : :
2512 : 0 : call cwtime_report(" gwr_read_ugb_from_wfk:", cpu, wall, gflops)
2513 : 0 : call timab(1921, 2, tsec)
2514 : :
2515 [ # # # # : 0 : end subroutine gwr_read_ugb_from_wfk
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2516 : : !!***
2517 : :
2518 : : !----------------------------------------------------------------------
2519 : :
2520 : : !!****f* m_gwr/gwr_build_green
2521 : : !! NAME
2522 : : !! gwr_build_green
2523 : : !!
2524 : : !! FUNCTION
2525 : : !! Build Green's functions in imaginary time from the gwr%ugb matrices stored in memory.
2526 : : !! Store only G_k for the IBZ k-points treated by this MPI proc.
2527 : : !!
2528 : : !! INPUTS
2529 : : !! free_ugb: True if the gwr%ugb wavefunctions should be deallocated before returning.
2530 : : !!
2531 : : !! SOURCE
2532 : :
2533 : 0 : subroutine gwr_build_green(gwr, free_ugb)
2534 : :
2535 : : !Arguments ------------------------------------
2536 : : class(gwr_t),target,intent(inout) :: gwr
2537 : : logical,intent(in) :: free_ugb
2538 : :
2539 : : !Local variables-------------------------------
2540 : : !scalars
2541 : : 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
2542 : : integer :: ii, icomp
2543 : : real(dp), parameter :: eratio = 0.95_dp
2544 : : real(dp) :: eig_nk, cpu, wall, gflops, cpu_k, wall_k, gflops_k !, f_nk
2545 : : logical :: print_time, compute_svd
2546 : : character(len=500) :: msg
2547 : : real(dp) :: gt_rfact, s2_sum, s2_sum_all
2548 [ # # # # : 0 : type(__slkmat_t), target :: work_gb(gwr%nspinor), green, u_mat, vt_mat
# # # # #
# # # # #
# # # # #
# # # ]
2549 : 0 : real(gwp),allocatable :: s_vals(:)
2550 : : !arrays
2551 : 0 : integer :: mask_kibz(gwr%nkibz), units(2) !, ija(2), ijb(2)
2552 : : !integer :: occ_idx(gwr%ks_ebands%nkpt, gwr%ks_ebands%nsppol)
2553 : : real(dp) :: tsec(2) , kk_ibz(3) !, kg(3)
2554 : 0 : real(dp),contiguous, pointer :: qp_eig(:,:,:), qp_occ(:,:,:)
2555 : : integer :: iab, iiab, jiab, ispinor !,i, j
2556 : : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
2557 : : ! *************************************************************************
2558 : :
2559 : 0 : call cwtime(cpu, wall, gflops, "start")
2560 : 0 : call timab(1922, 1, tsec)
2561 [ # # ]: 0 : units = [std_out, ab_out]
2562 : 0 : nbsum = gwr%dtset%nband(1)
2563 : :
2564 : : ! Use KS or QP energies depending on the iteration state.
2565 [ # # ]: 0 : if (gwr%scf_iteration == 1) then
2566 : : call wrtout(units, " Building Green's functions from KS orbitals and KS energies...", &
2567 : 0 : pre_newlines=2, newlines=1, do_flush=.True.)
2568 : 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
2569 [ # # ]: 0 : msg = sjoin("Fermi energy is not set to zero! fermie:", ftoa(gwr%ks_ebands%fermie))
2570 [ # # ]: 0 : ABI_CHECK(abs(gwr%ks_ebands%fermie) < tol12, msg)
2571 : :
2572 : : !occ_idx = gwr%ks_ebands%get_occupied()
2573 : :
2574 : : ! Allocate my Green's functions in IBZ if this is the first iteration.
2575 [ # # # # ]: 0 : mask_kibz = 0; mask_kibz(gwr%my_kibz_inds(:)) = 1
2576 : 0 : call gwr%malloc_free_mats(mask_kibz, "green", "malloc")
2577 : :
2578 : : else
2579 : : call wrtout(units, " Building Green's functions from KS orbitals and QP energies...", &
2580 : 0 : pre_newlines=2, newlines=1, do_flush=.True.)
2581 : 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
2582 [ # # ]: 0 : msg = sjoin("Fermi energy is not set to zero! fermie:", ftoa(gwr%qp_ebands%fermie))
2583 [ # # ]: 0 : ABI_CHECK(abs(gwr%qp_ebands%fermie) < tol12, msg)
2584 : :
2585 : : !occ_idx = gwr%qp_ebands%get_occupied()
2586 : : end if
2587 : :
2588 [ # # ]: 0 : ABI_CHECK(allocated(gwr%ugb), "gwr%ugb array should be allocated!")
2589 : 0 : compute_svd = .False.
2590 : : !compute_svd = .True.
2591 : :
2592 [ # # ]: 0 : do my_is=1,gwr%my_nspins
2593 : 0 : spin = gwr%my_spins(my_is)
2594 : : ! Loop over my k-points in the IBZ
2595 [ # # ]: 0 : do my_iki=1,gwr%my_nkibz
2596 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (my_iki < LOG_MODK .or. mod(my_iki, LOG_MODK) == 0)
# # ]
2597 : 0 : if (print_time) call cwtime(cpu_k, wall_k, gflops_k, "start")
2598 : 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
2599 : 0 : kk_ibz = gwr%kibz(:, ik_ibz)
2600 : 0 : associate (ugb_ks => gwr%ugb(ik_ibz, spin), desc_k => gwr%green_desc_kibz(ik_ibz))
2601 : 0 : npw = desc_k%npw
2602 : : ! Init output of pzgemm in g-communicator
2603 : 0 : call green%init(npw, npw, gwr%g_slkproc, istwfk1) ! size_blocs=[-1, col_bsize])
2604 : :
2605 : : ! Loop over my_ntau as pzgemm is MPI-parallelized inside g_comm.
2606 [ # # ]: 0 : do my_it=1,gwr%my_ntau
2607 : 0 : itau = gwr%my_itaus(my_it)
2608 [ # # ]: 0 : do ipm=1,2
2609 [ # # ]: 0 : do ispinor = 1, gwr%nspinor
2610 [ # # ]: 0 : call ugb_ks%cut(npw, ugb_ks%size_global(2), work_gb(ispinor), ija=[(ispinor - 1)*npw + 1, 1])
2611 : :
2612 : : !work_gb(my_is)%buffer_cplx = gwr %ugb(ik_ibz, spin)%buffer_cplx
2613 : :
2614 : : !call ugb_ks%change_size_blocs(work_gb, size_blocs=, processor=)
2615 : : !call work_gb%copy(green, empty=.True.)
2616 : :
2617 : : ! Loop over my_ntau as pzgemm is MPI-parallelized inside g_comm.
2618 : : ! do my_it=1,gwr%my_ntau
2619 : : ! itau = gwr%my_itaus(my_it)
2620 : : ! do ipm=1,2
2621 : : ! Multiply my columns by exponentials in imaginary time.
2622 : : ! work_gb%buffer_cplx = ugb_ks%buffer_cplx
2623 : :
2624 : : !!!$OMP PARALLEL DO PRIVATE(band, f_nk, eig_nk, gt_rfact)
2625 : : !$OMP PARALLEL DO PRIVATE(band, eig_nk, gt_rfact)
2626 [ # # ]: 0 : do il_b = 1, work_gb(ispinor)%size_local(2)
2627 : 0 : band = work_gb(ispinor)%loc2gcol(il_b)
2628 : : !f_nk = qp_occ(band, ik_ibz, spin)
2629 : 0 : eig_nk = qp_eig(band, ik_ibz, spin)
2630 : 0 : gt_rfact = zero
2631 [ # # ]: 0 : if (ipm == 2) then
2632 [ # # ]: 0 : if (eig_nk < -tol6) gt_rfact = exp(gwr%tau_mesh(itau) * eig_nk)
2633 : : else
2634 [ # # ]: 0 : if (eig_nk > tol6) gt_rfact = exp(-gwr%tau_mesh(itau) * eig_nk)
2635 : : end if
2636 : :
2637 : : !work_gb%buffer_cplx(:,il_b) = work_gb%buffer_cplx(:,il_b) * sqrt(gt_rfact)
2638 : 0 : call xscal(npw, real(sqrt(gt_rfact), kind=gwp), work_gb(ispinor)%buffer_cplx(:, il_b), 1)
2639 : : end do ! il_b
2640 : : end do !ispinor
2641 : : ! end do ! ipm
2642 : : ! end do ! itau
2643 : :
2644 : : ! Now build G(g,g',ipm) with PZGEMM.
2645 [ # # ]: 0 : isgn = merge(1, -1, ipm == 2)
2646 [ # # ]: 0 : do iab = 1, gwr%nsig_ab
2647 : 0 : iiab = spinor_idxs(1, iab)
2648 : 0 : jiab = spinor_idxs(2, iab)
2649 : :
2650 : : ! TODO: optimize this part
2651 : : ! This wont' work for metals
2652 : : !nb_occ = occ_idx(ik_ibz, spin)
2653 : : ! nb_occ = -1
2654 : : !if (ipm == 1) then
2655 : : ! ija = [1, nb_occ]; ijb = ija
2656 : : !else
2657 : : ! ija = [nb_occ+1, gwr%ugb_nband]; ijb = ija
2658 : : !end if
2659 : 0 : call slk_pgemm("N", "C", work_gb(iiab), isgn*cone_gw, work_gb(jiab), czero_gw, green)
2660 : :
2661 : : ! SVD. NB: green matrix in destroyed in output.
2662 : : if (compute_svd) then
2663 : : call green%svd("N", "N", u_mat, s_vals, vt_mat)
2664 : : s2_sum_all = sum(s_vals**2)
2665 : : icomp = -1
2666 : : do ii=1,size(s_vals)
2667 : : s2_sum = sum(s_vals(1:ii)**2)
2668 : : if (icomp == -1 .and. s2_sum / s2_sum_all > eratio) icomp = ii
2669 : : !write(std_out, *)ii, s_vals(ii), 100 * s2_sum / s2_sum_all
2670 : : end do
2671 : : write(std_out, "(a,i0,2a,3(a,1x,i0))") &
2672 : : "SVD: For ik_ibz: ", ik_ibz, ", kpt: ", trim(ktoa(kk_ibz)), ", itau: ", itau, ", ipm: ", ipm, ", spin: ", spin
2673 : : write(std_out, "(a,i0,2(a,f5.2),a,i0)") &
2674 : : "SVD: Need ", icomp, " vectors with frac: ", (100.0_dp * icomp) / size(s_vals), &
2675 : : "% to reach eratio: ", eratio, ", G matrix size: ", size(s_vals)
2676 : : ABI_FREE(s_vals)
2677 : : end if
2678 : :
2679 : : ! Redistribute data.
2680 : 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%take_from(green)
2681 : : end do ! iab
2682 : 0 : call slk_array_free(work_gb)
2683 : :
2684 : : end do ! ipm
2685 : : end do ! my_it
2686 : :
2687 : 0 : call green%free()
2688 : : ! Free wavefunctions if asked for.
2689 [ # # ]: 0 : if (free_ugb) call ugb_ks%free()
2690 : :
2691 [ # # ]: 0 : if (print_time) then
2692 : 0 : write(msg,'(4x,3(a,i0),a)')"G_ikbz [", my_iki, "/", gwr%my_nkibz, "] (tot: ", gwr%nkibz, ")"
2693 [ # # ]: 0 : call cwtime_report(msg, cpu_k, wall_k, gflops_k); if (my_iki == LOG_MODK) call wrtout(std_out, " ...")
2694 : : end if
2695 : : end associate
2696 : : end do ! my_iki
2697 : : end do ! my_is
2698 : :
2699 [ # # ]: 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "gt_kibz")
2700 [ # # ]: 0 : call gwr%print_mem([std_out])
2701 : :
2702 : 0 : call cwtime_report(" gwr_build_green:", cpu, wall, gflops)
2703 : 0 : call timab(1922, 2, tsec)
2704 : :
2705 : : !if (compute_svd) stop "compute_svd"
2706 : :
2707 [ # # # # ]: 0 : end subroutine gwr_build_green
2708 : : !!***
2709 : :
2710 : : !----------------------------------------------------------------------
2711 : :
2712 : : !!****f* m_gwr/gwr_gk_to_scbox
2713 : : !! NAME
2714 : : !! gwr_gk_to_scbox
2715 : : !!
2716 : : !! FUNCTION
2717 : : !! Insert G_k(g',r) in the FFT box of the supercell: k+g' index.
2718 : : !!
2719 : : !! INPUTS
2720 : : !! select_my_kbz: Mask used to select a subset of gwr%my_nkbz k-points.
2721 : : !!
2722 : : !! OUTPUT
2723 : : !!
2724 : : !! SOURCE
2725 : :
2726 [ # # ]: 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)
2727 : :
2728 : : !Arguments ------------------------------------
2729 : : class(gwr_t),target,intent(in) :: gwr
2730 : : integer,intent(in) :: sc_ngfft(18)
2731 : : logical,intent(in) :: select_my_kbz(gwr%my_nkbz)
2732 : : integer,intent(out) :: green_scgvec(3, gwr%green_mpw)
2733 : : type(desc_t),intent(inout) :: desc_mykbz(gwr%my_nkbz)
2734 : : type(__slkmat_t),intent(in) :: gt_gpr(2, gwr%my_nkbz)
2735 : : integer,intent(in) :: my_ir, ndat
2736 : : complex(gwp), intent(out) :: gt_scbox(product(sc_ngfft(4:6)), gwr%sc_batch_size, 2)
2737 : : integer,optional,intent(inout) :: gt_scbox_win
2738 : :
2739 : : !Local variables-------------------------------
2740 : 0 : integer :: my_ikf, ik_bz, ipm, gg(3), idat, iepoch, ii, idat_list(gwr%kpt_comm%nproc), ierr ! ig,
2741 : : !real(dp) :: tsec(2) !, cpu, wall, gflops
2742 : : ! *************************************************************************
2743 : :
2744 : : !call cwtime(cpu, wall, gflops, "start")
2745 : : !call timab(1929, 1, tsec)
2746 : :
2747 : : ! Take the union of (k,g') for k in the BZ.
2748 : : ! Note gwr%ngkpt instead of gwr%ngqpt.
2749 [ # # ]: 0 : if (.not. present(gt_scbox_win)) then
2750 : : ! Zero output array.
2751 [ # # # # : 0 : gt_scbox = czero_gw
# # ]
2752 : :
2753 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
2754 : : if (.not. select_my_kbz(my_ikf)) continue
2755 : 0 : ik_bz = gwr%my_kbz_inds(my_ikf); gg = nint(gwr%kbz(:,ik_bz) * gwr%ngkpt)
2756 [ # # ]: 0 : do ipm=1,2
2757 : : call desc_mykbz(my_ikf)%to_scbox(gwr%kbz(:, ik_bz), gwr%ngkpt, sc_ngfft, ndat, &
2758 : 0 : gt_gpr(ipm, my_ikf)%buffer_cplx(1,my_ir), gt_scbox(:,:,ipm))
2759 : : end do
2760 : : end do ! my_ikf
2761 : :
2762 : : else
2763 : : ! Each MPI proc operates on a different idat vector at each epoch
2764 [ # # # # : 0 : idat_list = cshift([(ii, ii=1,gwr%kpt_comm%nproc)], shift=-gwr%kpt_comm%me)
# # # # ]
2765 : :
2766 [ # # ]: 0 : do iepoch=1,gwr%kpt_comm%nproc
2767 : 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! Start the RMA epoch
2768 : 0 : idat = idat_list(iepoch)
2769 [ # # ]: 0 : if (idat > ndat) goto 10
2770 [ # # ]: 0 : if (iepoch == 1) then
2771 : : ! Zero output array.
2772 [ # # ]: 0 : do ipm=1,2
2773 [ # # ]: 0 : gt_scbox(:,idat,ipm) = czero_gw
2774 : : end do
2775 : : end if
2776 : :
2777 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
2778 : : if (.not. select_my_kbz(my_ikf)) continue
2779 : 0 : ik_bz = gwr%my_kbz_inds(my_ikf); gg = nint(gwr%kbz(:, ik_bz) * gwr%ngkpt)
2780 [ # # ]: 0 : do ipm=1,2
2781 : : call desc_mykbz(my_ikf)%to_scbox(gwr%kbz(:, ik_bz), gwr%ngkpt, sc_ngfft, ndat1, &
2782 : 0 : gt_gpr(ipm, my_ikf)%buffer_cplx(1,my_ir+idat-1), gt_scbox(:,idat,ipm))
2783 : : end do
2784 : : end do ! my_ikf
2785 : : 10 continue
2786 : : !call xmpi_barrier(gwr%kpt_comm%value)
2787 : : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
2788 : 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! End the RMA epoch
2789 : : end do ! iepoch
2790 : : end if
2791 : :
2792 : : !call cwtime_report(" gwr_gk_to_scbox:", cpu, wall, gflops)
2793 : : !call timab(1929, 2, tsec)
2794 : :
2795 : 0 : end subroutine gwr_gk_to_scbox
2796 : : !!***
2797 : :
2798 : : !----------------------------------------------------------------------
2799 : :
2800 : : !!****f* m_gwr/gwr_wcq_to_scbox
2801 : : !! NAME
2802 : : !! gwr_wcq_to_scbox
2803 : : !!
2804 : : !! FUNCTION
2805 : : !! Insert W_q(g',r) in the FFT box of the supercell: q+g' index.
2806 : : !!
2807 : : !! INPUTS
2808 : : !! select_my_qbz: Mask used to select a subset of gwr%my_qkbz q-points.
2809 : : !!
2810 : : !! OUTPUT
2811 : : !!
2812 : : !! SOURCE
2813 : :
2814 : 0 : subroutine gwr_wcq_to_scbox(gwr, sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, &
2815 [ # # ]: 0 : wc_gpr, wct_scbox, wct_scbox_win)
2816 : :
2817 : : !Arguments ------------------------------------
2818 : : class(gwr_t),target,intent(in) :: gwr
2819 : : integer,intent(in) :: sc_ngfft(18)
2820 : : logical,intent(in) :: select_my_qbz(gwr%my_nqbz)
2821 : : integer,intent(out) :: wc_scgvec(3, gwr%tchi_mpw)
2822 : : type(desc_t),intent(inout) :: desc_myqbz(gwr%my_nqbz)
2823 : : type(__slkmat_t),intent(in) :: wc_gpr(gwr%my_nqbz)
2824 : : integer,intent(in) :: my_ir, ndat
2825 : : complex(gwp),intent(out) :: wct_scbox(product(sc_ngfft(4:6)), gwr%sc_batch_size)
2826 : : !complex(gwp),intent(out) :: wct_scbox(:,:)
2827 : : integer,optional,intent(inout) :: wct_scbox_win
2828 : :
2829 : : !Local variables-------------------------------
2830 : 0 : integer :: my_iqf, iq_bz, idat, iepoch, ii, idat_list(gwr%kpt_comm%nproc), ierr ! gg(3), ig,
2831 : : !real(dp) :: tsec(2) !, cpu, wall, gflops
2832 : : ! *************************************************************************
2833 : :
2834 : : !call timab(1930, 1, tsec)
2835 : :
2836 : : ! Take the union of (q,g') for q in the BZ. Note gwr%ngqpt instead of gwr%ngkpt.
2837 : :
2838 [ # # ]: 0 : if (.not. present(wct_scbox_win)) then
2839 [ # # # # ]: 0 : wct_scbox = czero_gw
2840 [ # # ]: 0 : do my_iqf=1,gwr%my_nqbz
2841 : : if (.not. select_my_qbz(my_iqf)) continue
2842 : 0 : iq_bz = gwr%my_qbz_inds(my_iqf)
2843 : :
2844 : : call desc_myqbz(my_iqf)%to_scbox(gwr%qbz(:,iq_bz), gwr%ngqpt, sc_ngfft, ndat, &
2845 : 0 : wc_gpr(my_iqf)%buffer_cplx(1,my_ir), wct_scbox)
2846 : : end do ! my_iqf
2847 : :
2848 : : else
2849 : : ! Each MPI proc operates on a different idat vector at each epoch
2850 [ # # # # : 0 : idat_list = cshift([(ii, ii=1,gwr%kpt_comm%nproc)], shift=-gwr%kpt_comm%me)
# # # # ]
2851 : :
2852 [ # # ]: 0 : do iepoch=1,gwr%kpt_comm%nproc
2853 : 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, wct_scbox_win, ierr) ! Start the RMA epoch
2854 : 0 : idat = idat_list(iepoch)
2855 [ # # ]: 0 : if (idat > ndat) goto 10
2856 [ # # # # ]: 0 : if (iepoch == 1) wct_scbox(:,idat) = czero_gw
2857 : :
2858 [ # # ]: 0 : do my_iqf=1,gwr%my_nkbz
2859 : : if (.not. select_my_qbz(my_iqf)) continue
2860 : 0 : iq_bz = gwr%my_qbz_inds(my_iqf)
2861 : : call desc_myqbz(my_iqf)%to_scbox(gwr%qbz(:,iq_bz), gwr%ngqpt, sc_ngfft, ndat1, &
2862 : 0 : wc_gpr(my_iqf)%buffer_cplx(1,my_ir+idat-1), wct_scbox(:,idat))
2863 : : end do ! my_iqf
2864 : : 10 continue
2865 : : !call xmpi_barrier(gwr%kpt_comm%value)
2866 : : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(wct_scbox)
2867 : 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, wct_scbox_win, ierr) ! End the RMA epoch
2868 : : end do ! iepoch
2869 : : end if
2870 : :
2871 : : !call timab(1930, 2, tsec)
2872 : :
2873 : 0 : end subroutine gwr_wcq_to_scbox
2874 : : !!***
2875 : :
2876 : : !----------------------------------------------------------------------
2877 : :
2878 : : !!****f* m_gwr/gwr_rotate_gpm
2879 : : !! NAME
2880 : : !! gwr_rotate_gpm
2881 : : !!
2882 : : !! FUNCTION
2883 : : !! Reconstruct the Green's functions in the BZ from the IBZ.
2884 : : !!
2885 : : !! INPUTS
2886 : : !! ik_bz = Index of the k-point in the BZ
2887 : : !! itau = tau index (global index)
2888 : : !! spin = spin index (global index)
2889 : : !! [ipm_list]=Optional list of ipm indices to be considered, e.g. ipm_list=[2] to compute the -tau component.
2890 : : !!
2891 : : !! OUTPUT
2892 : : !! desc_kbz = Descriptor in the BZ
2893 : : !! gt_pm(2) = Gk(+/-tau)
2894 : : !!
2895 : : !! NOTES
2896 : : !!
2897 : : !! * Remember the symmetry properties of \tilde\espilon^{-1}
2898 : : !!
2899 : : !! If q_bz = S q_ibz + G0:
2900 : : !!
2901 : : !! $\epsilon^{-1}_{SG1-G0, SG2-G0}(q_bz) = e^{+iS(G2-G1).\tau} \epsilon^{-1}_{G1, G2)}(q)
2902 : : !!
2903 : : !! If time-reversal symmetry can be used then:
2904 : : !!
2905 : : !! $\epsilon^{-1}_{G1,G2}(-q_bz) = e^{+i(G1-G2).\tau} \epsilon^{-1}_{-S^{-1}(G1+Go), -S^{-1}(G2+G0)}^*(q)
2906 : : !!
2907 : : !! In the present implementation we are not considering a possible umklapp vector G0 in the
2908 : : !! expression Sq = q+G0. Treating this case would require some changes in the G-sphere
2909 : : !! since we have to consider G - G0. The code however stops in sigma if a nonzero G0 is required
2910 : : !! to reconstruct the BZ.
2911 : : !!
2912 : : !! SOURCE
2913 : :
2914 [ # # # # : 0 : subroutine gwr_rotate_gpm(gwr, ik_bz, itau, spin, desc_kbz, gt_pm, ipm_list)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
2915 : :
2916 : : !Arguments ------------------------------------
2917 : : class(gwr_t),intent(in) :: gwr
2918 : : integer,intent(in) :: ik_bz, spin, itau
2919 : : type(desc_t),intent(out) :: desc_kbz
2920 : : type(__slkmat_t),intent(out) :: gt_pm(2, gwr%nsig_ab)
2921 : : integer,optional,intent(in) :: ipm_list(:)
2922 : :
2923 : : !Local variables-------------------------------
2924 : : !scalars
2925 : : 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)
2926 : : integer :: iab, iiab, jiab
2927 : : logical :: isirr_k
2928 : : !arrays
2929 : : integer :: g1(3), g2(3)
2930 : : real(dp) :: tnon(3), spinrot_k(4) !, cpu, wall, gflops
2931 : : complex(dp) :: ph2, ph1, spinrot_cmat1(2,2), spinrot_cmat2(2,2), tmp_mat(2,2)
2932 : : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
2933 : : ! *************************************************************************
2934 : :
2935 : : !call cwtime(cpu, wall, gflops, "start")
2936 : 0 : num_pm = 2; ipm_list__ = [1, 2]
2937 [ # # ]: 0 : if (present(ipm_list)) then
2938 : 0 : num_pm = size(ipm_list)
2939 [ # # ]: 0 : ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
2940 [ # # ]: 0 : ipm_list__(1:num_pm) = ipm_list(:)
2941 : : end if
2942 : :
2943 : 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
2944 [ # # ]: 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
2945 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
2946 [ # # ]: 0 : tsign_k = merge(1, -1, trev_k == 0)
2947 : : !ABI_CHECK(all(g0_k == 0), sjoin("For kbz:", ktoa(gwr%kbz(:, ik_bz)), "g0_k:", ltoa(g0_k), " != 0"))
2948 : :
2949 : : ! Copy descriptor from IBZ
2950 : : associate (desc_kibz => gwr%green_desc_kibz(ik_ibz))
2951 : 0 : call desc_kibz%copy(desc_kbz)
2952 : :
2953 [ # # ]: 0 : if (isirr_k) then
2954 : : ! Copy the PBLAS matrices with the two Green's functions and we are done.
2955 [ # # ]: 0 : do ii=1,num_pm
2956 : 0 : ipm = ipm_list__(ii)
2957 [ # # ]: 0 : do iab=1,gwr%nsig_ab
2958 : 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%copy(gt_pm(ipm, iab))
2959 : : end do
2960 : : end do
2961 : : goto 10
2962 : : end if
2963 : :
2964 : : ! From:
2965 : : !
2966 : : ! u_{Sk}(Sg) = e^{-i(Sk+Sg).tnon} u_k(g)
2967 : : !
2968 : : ! and
2969 : : !
2970 : : ! u_{k+g0}(g-g0) = u_k(g)
2971 : : !
2972 : : ! one obtains:
2973 : : !
2974 : : ! G_{Sk+g0}(Sg-g0,Sg'-g0) = e^{-i tnon.S(g-g')} G_k{g,g'}
2975 : : !
2976 : : ! For time-reversal, we have u_{-k}(g) = u_{k}{-g}^*
2977 : : !
2978 : : ! G_{-k}(-g,-g') = [G_k(g,g')]*
2979 : :
2980 : : !ABI_WARNING_IF(trev_k == 0, "green: trev_k /= 0 should be tested")
2981 : :
2982 : : ! Rotate gvec, recompute gbound and rotate vc_sqrt_eps
2983 : : ! TODO: 1) Handle TR and routine to rotate tchi/W including vc_sqrt_eps
2984 : : ! 2) Make sure that the FFT box is large enough to accommodate umklapps
2985 : :
2986 : 0 : desc_kbz%ig0 = -1
2987 : : !$OMP PARALLEL DO
2988 [ # # ]: 0 : do ig1=1,desc_kbz%npw
2989 [ # # # # : 0 : desc_kbz%gvec(:,ig1) = tsign_k * matmul(gwr%cryst%symrec(:,:,isym_k), desc_kibz%gvec(:,ig1)) - g0_k
# # # # #
# # # # #
# # ]
2990 [ # # # # : 0 : if (all(desc_kbz%gvec(:,ig1) == 0)) desc_kbz%ig0 = ig1
# # ]
2991 : : end do
2992 : 0 : desc_kbz%kin_sorted = .False.
2993 [ # # ]: 0 : ABI_CHECK(desc_kbz%ig0 /= -1, "Cannot find g=0 after rotation!")
2994 : :
2995 : 0 : call sphereboundary(desc_kbz%gbound, desc_kbz%istwfk, desc_kbz%gvec, gwr%g_mgfft, desc_kbz%npw)
2996 : :
2997 : : ! Get G_k with k in the BZ.
2998 [ # # ]: 0 : tnon = gwr%cryst%tnons(:, isym_k)
2999 [ # # ]: 0 : do ii=1,num_pm
3000 : 0 : ipm = ipm_list__(ii)
3001 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3002 : 0 : call gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%copy(gt_pm(ipm, iab))
3003 : : end do
3004 : : ! associate (gk_i => gwr%gt_kibz(ipm, ik_ibz, itau, spin, :), gk_f => gt_pm(ipm, :))
3005 : : !!$OMP PARALLEL DO PRIVATE(ig1, g2, ph2, ig1, g2, ph1)
3006 [ # # ]: 0 : do il_g2=1, gt_pm(ipm, 1)%size_local(2)
3007 : 0 : ig2 = mod(gt_pm(ipm, 1)%loc2gcol(il_g2) - 1, desc_kbz%npw) + 1
3008 [ # # ]: 0 : g2 = desc_kbz%gvec(:,ig2)
3009 [ # # ]: 0 : ph2 = exp(+j_dpc * two_pi * dot_product(g2, tnon))
3010 [ # # ]: 0 : do il_g1=1, gt_pm(ipm, 1)%size_local(1)
3011 : 0 : ig1 = mod(gt_pm(ipm, 1)%loc2grow(il_g1) - 1, desc_kbz%npw) + 1
3012 [ # # ]: 0 : g1 = desc_kbz%gvec(:,ig1)
3013 [ # # ]: 0 : ph1 = exp(-j_dpc * two_pi * dot_product(g1, tnon))
3014 [ # # ]: 0 : if (gwr%nspinor == 1) then
3015 : 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
3016 : : else
3017 [ # # ]: 0 : spinrot_k = gwr%cryst%spinrot(:, isym_k)
3018 : :
3019 : 0 : spinrot_cmat1(1,1) = spinrot_k(1) - j_dpc*spinrot_k(4)
3020 : 0 : spinrot_cmat1(1,2) =-spinrot_k(3) - j_dpc*spinrot_k(2)
3021 : 0 : spinrot_cmat1(2,1) = spinrot_k(3) - j_dpc*spinrot_k(2)
3022 : 0 : spinrot_cmat1(2,2) = spinrot_k(1) + j_dpc*spinrot_k(4)
3023 : :
3024 : 0 : spinrot_cmat2(1,1) = spinrot_k(1) + j_dpc*spinrot_k(4)
3025 : 0 : spinrot_cmat2(1,2) = spinrot_k(3) + j_dpc*spinrot_k(2)
3026 : 0 : spinrot_cmat2(2,1) =-spinrot_k(3) + j_dpc*spinrot_k(2)
3027 : 0 : spinrot_cmat2(2,2) = spinrot_k(1) - j_dpc*spinrot_k(4)
3028 : :
3029 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3030 : 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
3031 : 0 : tmp_mat(iiab, jiab) = gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%buffer_cplx(il_g1, il_g2)
3032 : : end do
3033 [ # # # # : 0 : tmp_mat = matmul(spinrot_cmat1, matmul(tmp_mat, spinrot_cmat2)) * ph1 * ph2
# # # # #
# # # # #
# # ]
3034 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3035 : 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
3036 : 0 : gt_pm(ipm, iab)%buffer_cplx(il_g1, il_g2) = tmp_mat(iiab, jiab)
3037 : : end do
3038 : : end if
3039 [ # # ]: 0 : if (trev_k == 1) then
3040 [ # # ]: 0 : if (gwr%nspinor == 1) then
3041 : 0 : gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2) = conjg(gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2))
3042 : : else
3043 : 0 : gt_pm(ipm, 1)%buffer_cplx(il_g1, il_g2) = conjg(tmp_mat(2, 2))
3044 : 0 : gt_pm(ipm, 2)%buffer_cplx(il_g1, il_g2) = conjg(tmp_mat(1, 1))
3045 : 0 : gt_pm(ipm, 3)%buffer_cplx(il_g1, il_g2) = - conjg(tmp_mat(2, 1))
3046 : 0 : gt_pm(ipm, 4)%buffer_cplx(il_g1, il_g2) = - conjg(tmp_mat(1, 2))
3047 : : end if
3048 : : end if
3049 : : end do
3050 : : end do
3051 : : ! end associate
3052 : : end do ! ii
3053 : : end associate
3054 : :
3055 : : 10 continue
3056 : : !call cwtime_report(" gwr_rotate_gpm:", cpu, wall, gflops)
3057 : :
3058 : 0 : end subroutine gwr_rotate_gpm
3059 : : !!***
3060 : :
3061 : : !----------------------------------------------------------------------
3062 : :
3063 : : !!****f* m_gwr/gwr_get_myk_green_gpr
3064 : : !! NAME
3065 : : !! gwr_get_myk_green_gpr
3066 : : !!
3067 : : !! FUNCTION
3068 : : !! 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.
3069 : : !!
3070 : : !! 1) FFT Transform the first index and multiply by e^{ik.r}:
3071 : : !!
3072 : : !! G_k(g,g') --> G_k(r,g') = e^{ik.r} \sum_g e^{ig.r} G_k(g,g')
3073 : : !!
3074 : : !! NB: This is a local operation.
3075 : : !!
3076 : : !! 2) MPI transpose the matrix to go from (r,g') to (g',r) distribution.
3077 : : !!
3078 : : !! INPUTS
3079 : : !! select_my_kbz: Mask used to select a subset of gwr%my_nkbz k-points.
3080 : : !!
3081 : : !! OUTPUT
3082 : : !!
3083 : : !! SOURCE
3084 : :
3085 [ # # # # : 0 : subroutine gwr_get_myk_green_gpr(gwr, itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3086 : :
3087 : : !Arguments ------------------------------------
3088 : : class(gwr_t),intent(in) :: gwr
3089 : : integer,intent(in) :: itau, spin
3090 : : logical,intent(in) :: select_my_kbz(gwr%my_nkbz)
3091 : : type(desc_t),intent(out) :: desc_mykbz(gwr%my_nkbz)
3092 : : type(__slkmat_t),intent(inout) :: gt_gpr(2, gwr%my_nkbz, gwr%nsig_ab)
3093 : :
3094 : : !Local variables-------------------------------
3095 : : !scalars
3096 : : integer :: my_ikf, ik_bz, ig2, ipm, npw, col_bsize, ndat, gpu_option, gpu_mode, iab
3097 : : logical :: k_is_gamma
3098 : : real(dp) :: kk_bz(3), cpu, wall, gflops, mem_mb
3099 : 0 : complex(gwp),allocatable :: ceikr(:)
3100 : : character(len=500) :: msg, gpu_action
3101 [ # # # # : 0 : type(__slkmat_t) :: rgp, gt_pm(2, gwr%nsig_ab)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3102 : 0 : type(uplan_t) :: uplan_k
3103 : : ! *************************************************************************
3104 : :
3105 : 0 : call cwtime(cpu, wall, gflops, "start")
3106 : 0 : gpu_option = gwr%dtset%gpu_option
3107 [ # # ]: 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3108 : :
3109 : 0 : mem_mb = two * gwr%my_nkbz * two * gwp * gwr%g_nfft * gwr%green_mpw * b2Mb / gwr%g_slkproc%grid%nprocs
3110 : 0 : call wrtout(std_out, sjoin(" Estimated local memory for Green's functions: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
3111 : :
3112 [ # # # # : 0 : ABI_MALLOC(ceikr, (gwr%g_nfft))
# # # # #
# # # ]
3113 : : #ifdef HAVE_OPENMP_OFFLOAD
3114 : : !$OMP TARGET ENTER DATA MAP(alloc:ceikr) IF (gpu_option == ABI_GPU_OPENMP)
3115 : : #endif
3116 : :
3117 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
3118 : : if (.not. select_my_kbz(my_ikf)) continue
3119 : 0 : ik_bz = gwr%my_kbz_inds(my_ikf)
3120 [ # # ]: 0 : kk_bz = gwr%kbz(:, ik_bz)
3121 : 0 : k_is_gamma = normv(kk_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3122 [ # # ]: 0 : if (.not. k_is_gamma) then
3123 : 0 : call calc_ceikr(kk_bz, gwr%g_ngfft, gwr%g_nfft, 1, ceikr)
3124 : : #ifdef HAVE_OPENMP_OFFLOAD
3125 : : !$omp target update to(ceikr) if (gpu_option == ABI_GPU_OPENMP)
3126 : : #endif
3127 : : end if
3128 : :
3129 : : ! Get G_kbz(+/- itau) in the BZ.
3130 : 0 : call gwr%rotate_gpm(ik_bz, itau, spin, desc_mykbz(my_ikf), gt_pm)
3131 : :
3132 : 0 : associate (desc_k => desc_mykbz(my_ikf))
3133 : : call uplan_k%init(desc_k%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_k%istwfk, &
3134 : 0 : desc_k%gvec, gwp, gpu_option)
3135 : :
3136 [ # # ]: 0 : do ipm=1,2
3137 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3138 : : ! Allocate rgp PBLAS matrix to store G_kbz(r,g')
3139 : : ! Here we're gonna have a lot of memory allocated due to loop over the full BZ!.
3140 : 0 : associate (g_gp => gt_pm(ipm, iab))
3141 : 0 : npw = desc_k%npw
3142 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3143 [ # # ]: 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_k%istwfk, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
3144 : :
3145 : : ! Perform FFT G_k(g,g') -> G_k(r,g') and store results in rgp.
3146 : 0 : gpu_mode = 1
3147 [ # # # # : 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
# # # # ]
3148 : 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3149 [ # # ]: 0 : if (k_is_gamma) then
3150 : 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), gpu_mode=gpu_mode)
3151 : : else
3152 : 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), phase_r=ceikr, gpu_mode=gpu_mode)
3153 : : end if
3154 : : end do ! ig2
3155 : :
3156 : : ! MPI transpose: G_k(r,g') -> G_k(g',r)
3157 : 0 : call rgp%ptrans("N", gt_gpr(ipm, my_ikf, iab), free=.True.)
3158 : : end associate
3159 : : end do ! iab
3160 : : end do ! ipm
3161 : :
3162 : 0 : call uplan_k%free(); call slk_array_free(gt_pm)
3163 : : end associate
3164 : : end do ! my_ikf
3165 : :
3166 [ # # # # : 0 : mem_mb = sum(slk_array_locmem_mb(gt_gpr))
# # ]
3167 : 0 : call wrtout(std_out, sjoin(" Local memory for G_kbz(g',r,itau): ", ftoa(mem_mb, fmt="f8.1"), "[Mb] <<< MEM"))
3168 : :
3169 : : #ifdef HAVE_OPENMP_OFFLOAD
3170 : : !$OMP TARGET EXIT DATA MAP(delete: ceikr) if (gpu_option == ABI_GPU_OPENMP)
3171 : : #endif
3172 [ # # ]: 0 : ABI_FREE(ceikr)
3173 : :
3174 : 0 : call cwtime_report(" gwr_get_myk_green_gpr:", cpu, wall, gflops)
3175 : :
3176 [ # # # # : 0 : end subroutine gwr_get_myk_green_gpr
# # # # #
# ]
3177 : : !!***
3178 : :
3179 : : !----------------------------------------------------------------------
3180 : :
3181 : : !!****f* m_gwr/gwr_get_gkbz_rpr_pm
3182 : : !! NAME
3183 : : !! gwr_get_gkbz_rpr_pm
3184 : : !!
3185 : : !! FUNCTION
3186 : : !! Compute G_k(r',r) from G_k(g,g') for k in the BZ and given spin and tau.
3187 : : !! Note that the output matrix `gk_rpr_pm` is transposed i.e. (r',r) instead of (r,r').
3188 : : !!
3189 : : !! INPUTS
3190 : : !!
3191 : : !! OUTPUT
3192 : : !!
3193 : : !! SOURCE
3194 : :
3195 : 0 : subroutine gwr_get_gkbz_rpr_pm(gwr, ik_bz, itau, spin, gk_rpr_pm, &
3196 [ # # # # : 0 : g0, ipm_list) ! optional
# # ]
3197 : :
3198 : : !Arguments ------------------------------------
3199 : : class(gwr_t),intent(in) :: gwr
3200 : : integer,intent(in) :: ik_bz, itau, spin
3201 : : type(__slkmat_t),intent(inout) :: gk_rpr_pm(2, gwr%nsig_ab)
3202 : : integer,optional,intent(in) :: g0(3), ipm_list(:)
3203 : :
3204 : : !Local variables-------------------------------
3205 : : !scalars
3206 : : integer :: ig2, ipm, npw, col_bsize, ir1, ndat, ii, num_pm, ipm_list__(2), gpu_option, gpu_mode, iab
3207 : : logical :: have_g0
3208 : : !real(dp) :: cpu, wall, gflops
3209 [ # # # # : 0 : type(__slkmat_t) :: rgp, gt_pm(2, gwr%nsig_ab), gpr
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
3210 [ # # ]: 0 : type(desc_t) :: desc_kbz
3211 : 0 : type(uplan_t) :: uplan_k
3212 : 0 : complex(gwp),allocatable :: ceig0r(:), conjg_ceig0r(:)
3213 : : character(len=500) :: msg, gpu_action
3214 : : ! *************************************************************************
3215 : :
3216 : : !call cwtime(cpu, wall, gflops, "start")
3217 : : ABI_NVTX_START_RANGE(NVTX_GWR_GKBZ_RPR_PM)
3218 : :
3219 : 0 : gpu_option = gwr%dtset%gpu_option
3220 : :
3221 : 0 : num_pm = 2; ipm_list__ = [1, 2]
3222 [ # # ]: 0 : if (present(ipm_list)) then
3223 : 0 : num_pm = size(ipm_list)
3224 [ # # ]: 0 : ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
3225 [ # # ]: 0 : ipm_list__(1:num_pm) = ipm_list
3226 : : end if
3227 : :
3228 : 0 : have_g0 = .False.
3229 [ # # ]: 0 : if (present(g0)) then
3230 : : ! NB: Non-zero g0, requires the application of the phase.
3231 [ # # # # : 0 : if (any(g0 /= 0)) then
# # ]
3232 : 0 : have_g0 = .True.
3233 [ # # # # : 0 : ABI_MALLOC(ceig0r, (gwr%g_nfft))
# # # # #
# # # ]
3234 [ # # ]: 0 : call calc_ceigr(-g0, gwr%g_nfft, 1, gwr%g_ngfft, ceig0r)
3235 [ # # # # : 0 : ABI_MALLOC(conjg_ceig0r, (gwr%g_nfft))
# # # # #
# # # ]
3236 [ # # # # : 0 : conjg_ceig0r = conjg(ceig0r)
# # # # ]
3237 : : #ifdef HAVE_OPENMP_OFFLOAD
3238 : : !$OMP TARGET ENTER DATA MAP(alloc:ceig0r, conjg_ceig0r) IF (gpu_option == ABI_GPU_OPENMP)
3239 : : !$omp target update to(ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3240 : : #endif
3241 : : end if
3242 : : end if
3243 : :
3244 : : ! Get G_k(g,g', +/- itau) in the BZ.
3245 : 0 : call gwr%rotate_gpm(ik_bz, itau, spin, desc_kbz, gt_pm, ipm_list=ipm_list__(1:num_pm))
3246 : :
3247 : : call uplan_k%init(desc_kbz%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_kbz%istwfk, &
3248 : 0 : desc_kbz%gvec, gwp, gpu_option)
3249 : :
3250 [ # # ]: 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3251 : :
3252 : : ! For each tau in imp_list__
3253 [ # # ]: 0 : do ii=1,num_pm
3254 : 0 : ipm = ipm_list__(ii)
3255 : : ! Allocate temporary rgp PBLAS matrix to store G(r,g')
3256 : 0 : npw = desc_kbz%npw
3257 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3258 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3259 [ # # ]: 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_kbz%istwfk, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
3260 : : associate (g_gp => gt_pm(ipm, iab))
3261 : 0 : gpu_mode = 1
3262 [ # # # # : 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
# # # # ]
3263 : : ! G_k(g,g') -> G_k(r,g') and store results in rgp.
3264 : 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3265 [ # # ]: 0 : if (have_g0) then
3266 : 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), phase_r=ceig0r, gpu_mode=gpu_mode)
3267 : : else
3268 : 0 : call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), gpu_mode=gpu_mode)
3269 : : end if
3270 : : end do ! ig2
3271 : : end associate
3272 : :
3273 : : ! MPI transpose: G_k(r,g') -> G_k(g',r) and transform g' index.
3274 : 0 : call rgp%ptrans("N", gpr, free=.True.)
3275 : :
3276 : : gpu_mode = 1
3277 [ # # # # : 0 : do ir1=1, gpr%size_local(2), gwr%uc_batch_size
# # # # ]
3278 : : ! G_k(g',r) -> G_k(r',r) and store results in rgp.
3279 : 0 : ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3280 [ # # ]: 0 : if (have_g0) then
3281 : : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), gk_rpr_pm(ipm, iab)%buffer_cplx(:,ir1), &
3282 : 0 : isign=-1, iscale=0, phase_r=conjg_ceig0r, gpu_mode=gpu_mode)
3283 : : else
3284 : : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), gk_rpr_pm(ipm, iab)%buffer_cplx(:,ir1), &
3285 : 0 : isign=-1, iscale=0, gpu_mode=gpu_mode)
3286 : : end if
3287 : : end do ! ir1
3288 : 0 : call gpr%free()
3289 : : end do
3290 : : end do ! ii
3291 : :
3292 : 0 : call slk_array_free(gt_pm); call desc_kbz%free(); call uplan_k%free()
3293 : :
3294 [ # # ]: 0 : if (have_g0) then
3295 : : #ifdef HAVE_OPENMP_OFFLOAD
3296 : : !$OMP TARGET EXIT DATA MAP(delete: ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3297 : : #endif
3298 [ # # ]: 0 : ABI_FREE(ceig0r)
3299 [ # # ]: 0 : ABI_FREE(conjg_ceig0r)
3300 : : end if
3301 : :
3302 : : ! FIXME: Transfer data from CPU to GPU.
3303 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
3304 [ # # ]: 0 : do ii=1,num_pm
3305 : 0 : ipm = ipm_list__(ii)
3306 [ # # ]: 0 : do iab=1,gwr%nsig_ab
3307 : 0 : call gk_rpr_pm(ipm, iab)%gpu_map("update_to")
3308 : : end do
3309 : : end do
3310 : : end if
3311 : :
3312 : : ABI_NVTX_END_RANGE()
3313 : : !call cwtime_report(" gwr_get_gkbz_rpr_pm:", cpu, wall, gflops)
3314 : :
3315 [ # # # # : 0 : end subroutine gwr_get_gkbz_rpr_pm
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3316 : : !!***
3317 : :
3318 : : !----------------------------------------------------------------------
3319 : :
3320 : : !! !!****f* m_gwr/gwr_ggp_to_rpr
3321 : : !! !! NAME
3322 : : !! !! gwr_ggp_to_rpr
3323 : : !! !!
3324 : : !! !! FUNCTION
3325 : : !! !! Helper function to FFT transform a two-point function: F_{g,g'} --> F_{r',r}
3326 : : !! !!
3327 : : !! !! INPUTS
3328 : : !! !!
3329 : : !! !! OUTPUT
3330 : : !! !!
3331 : : !! !! SOURCE
3332 : : !!
3333 : : !! !subroutine gwr_ggp_to_rpr(gwr, desc, g_gp, rp_r)
3334 : : !! !
3335 : : !! !!Arguments ------------------------------------
3336 : : !! ! class(gwr_t),intent(in) :: gwr
3337 : : !! ! type(desc_t),intent(in) :: desc
3338 : : !! ! type(__slkmat_t),intent(in) :: g_gp
3339 : : !! ! type(__slkmat_t),intent(inout) :: rp_r
3340 : : !! !
3341 : : !! !!Local variables-------------------------------
3342 : : !! ! integer :: ig2, npw, nrsp, col_bsize, ir1, ndat
3343 : : !! ! type(__slkmat_t) :: rgp, gpr
3344 : : !! ! character(len=500) :: msg
3345 : : !! ! type(uplan_t) :: uplan_k
3346 : : !! !! *************************************************************************
3347 : : !! !
3348 : : !! ! ABI_ERROR("Not Implemented Error")
3349 : : !! !
3350 : : !! ! ! Allocate intermediate rgp PBLAS matrix to store F(r,g')
3351 : : !! ! npw = desc%npw
3352 : : !! ! nrsp = gwr%g_nfft * gwr%nspinor
3353 : : !! ! ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3354 : : !! ! call rgp%init(nrsp, npw, gwr%g_slkproc, desc%istwfk, size_blocs=[-1, col_bsize])
3355 : : !! !
3356 : : !! ! call uplan_k%init(desc%npw, gwr%nspinor, gwr%uc_batch_size, gwr%g_ngfft, desc%istwfk, &
3357 : : !! ! desc%gvec, gwp, gwr%dtset%gpu_option)
3358 : : !! !
3359 : : !! ! ! F(g,g') --> F(r,g') and store results in rgp.
3360 : : !! ! do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
3361 : : !! ! ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3362 : : !! ! call uplan_k%execute_gr(ndat, g_gp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2))
3363 : : !! ! end do
3364 : : !! !
3365 : : !! ! ! F(r,g') --> F(g',r)
3366 : : !! ! call rgp%ptrans("N", gpr, free=.True.)
3367 : : !! !
3368 : : !! ! ! F(g',r) --> F(r',r) and store results in rp_r.
3369 : : !! ! do ir1=1, gpr%size_local(2), gwr%uc_batch_size
3370 : : !! ! ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3371 : : !! ! call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:,ir1), rp_r%buffer_cplx(:,ir1), isign=-1, iscale=0)
3372 : : !! ! end do
3373 : : !! !
3374 : : !! ! call uplan_k%free()
3375 : : !! ! call gpr%free()
3376 : : !! !
3377 : : !! !end subroutine gwr_ggp_to_rpr
3378 : : !! !!!***
3379 : :
3380 : : !----------------------------------------------------------------------
3381 : :
3382 : : !!****f* m_gwr/gwr_rpr_to_ggp
3383 : : !! NAME
3384 : : !! gwr_rpr_to_ggp
3385 : : !!
3386 : : !! FUNCTION
3387 : : !! Helper function to FFT a two-point function: F_{r',r} --> F_{g,g'}
3388 : : !! Note that rp_r is destroyed in output.
3389 : : !!
3390 : : !! INPUTS
3391 : : !!
3392 : : !! OUTPUT
3393 : : !!
3394 : : !! SOURCE
3395 : :
3396 : 0 : subroutine gwr_rpr_to_ggp(gwr, desc, rp_r, rfact, g_gp)
3397 : :
3398 : : !Arguments ------------------------------------
3399 : : class(gwr_t),intent(in) :: gwr
3400 : : type(desc_t),intent(in) :: desc
3401 : : real(dp),intent(in) :: rfact
3402 : : class(__slkmat_t),intent(inout) :: rp_r, g_gp
3403 : :
3404 : : !Local variables-------------------------------
3405 : : integer :: ig2, npw, nr, col_bsize, ir2, ndat, isign, gpu_option, gpu_mode
3406 [ # # # # : 0 : type(__slkmat_t) :: r_gp, gp_r
# # # # #
# # # ]
3407 : : character(len=500) :: msg, gpu_action
3408 : 0 : type(uplan_t) :: uplan_k
3409 : : ! *************************************************************************
3410 : :
3411 : : ABI_NVTX_START_RANGE(NVTX_GWR_RPR_TO_GGP)
3412 : :
3413 : : ! Allocate intermediate gp_r PBLAS matrix to store F(g',r)
3414 : 0 : npw = desc%npw; nr = gwr%g_nfft
3415 [ # # ]: 0 : ABI_CHECK(block_dist_1d(nr, gwr%g_comm%nproc, col_bsize, msg), msg)
3416 : :
3417 : 0 : gpu_option = gwr%dtset%gpu_option
3418 [ # # ]: 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3419 [ # # ]: 0 : call gp_r%init(npw, nr, gwr%g_slkproc, desc%istwfk, size_blocs=[-1, col_bsize])
3420 : :
3421 : : call uplan_k%init(desc%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc%istwfk, desc%gvec, gwp, &
3422 : 0 : 0)
3423 : : !gwr%dtset%gpu_option) ! FIXME GPU option
3424 : :
3425 : 0 : isign = +1 ! This should be ok
3426 : : !isign = -1
3427 : :
3428 [ # # ]: 0 : if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) call rp_r%gpu_map("update_from") ! FIXME
3429 : :
3430 : : ! F(r',r) --> F(g',r) and store results in gp_r.
3431 : 0 : gpu_mode = 1
3432 [ # # # # : 0 : do ir2=1, rp_r%size_local(2), gwr%uc_batch_size
# # # # ]
3433 : 0 : ndat = blocked_loop(ir2, rp_r%size_local(2), gwr%uc_batch_size)
3434 : : call uplan_k%execute_rg(ndat, rp_r%buffer_cplx(:,ir2), gp_r%buffer_cplx(:,ir2), &
3435 : 0 : isign=isign, iscale=0, gpu_mode=gpu_mode)
3436 : : end do
3437 : :
3438 : : ! F(g',r) --> F(r,g')
3439 : : !call gp_r%ptrans("N", r_gp, free=.True.)
3440 : : ! FIXME: I don't know why but C is needed here.
3441 : 0 : call gp_r%ptrans("C", r_gp, free=.True.)
3442 : :
3443 : : ! F(r,g') --> F(g,g') and store results in g_gp.
3444 : : gpu_mode = 1
3445 [ # # # # : 0 : do ig2=1, g_gp%size_local(2), gwr%uc_batch_size
# # # # ]
3446 : 0 : ndat = blocked_loop(ig2, g_gp%size_local(2), gwr%uc_batch_size)
3447 : : call uplan_k%execute_rg(ndat, r_gp%buffer_cplx(:,ig2), g_gp%buffer_cplx(:,ig2), &
3448 : 0 : isign=-isign, iscale=0, gpu_mode=gpu_mode)
3449 : : end do
3450 : :
3451 : : ! Scale output.
3452 [ # # # # ]: 0 : g_gp%buffer_cplx = g_gp%buffer_cplx * rfact
3453 : :
3454 [ # # ]: 0 : if (gwr%dtset%gpu_option == ABI_GPU_OPENMP) call g_gp%gpu_map("update_to") ! FIXME
3455 : :
3456 : 0 : call uplan_k%free(); call r_gp%free()
3457 : : ABI_NVTX_END_RANGE()
3458 : :
3459 [ # # # # : 0 : end subroutine gwr_rpr_to_ggp
# # # # #
# # # #
# ]
3460 : : !!***
3461 : :
3462 : : !----------------------------------------------------------------------
3463 : :
3464 : : !!****f* m_gwr/gwr_rotate_wc
3465 : : !! NAME
3466 : : !! gwr_rotate_wc
3467 : : !!
3468 : : !! FUNCTION
3469 : : !! Reconstruct Wc(q,g,g') in the BZ from the IBZ.
3470 : : !!
3471 : : !! INPUTS
3472 : : !!
3473 : : !! OUTPUT
3474 : : !!
3475 : : !! SOURCE
3476 : :
3477 [ # # # # : 0 : subroutine gwr_rotate_wc(gwr, iq_bz, itau, spin, desc_qbz, wc_qbz)
# # # # #
# # # # #
# # # # #
# ]
3478 : :
3479 : : !Arguments ------------------------------------
3480 : : class(gwr_t),intent(inout) :: gwr
3481 : : integer,intent(in) :: iq_bz, itau, spin
3482 : : type(desc_t),intent(out) :: desc_qbz
3483 : : type(__slkmat_t),intent(inout) :: wc_qbz
3484 : :
3485 : : !Local variables-------------------------------
3486 : : !scalars
3487 : : integer :: ig1, ig2, il_g1, il_g2, iq_ibz, isym_q, trev_q, tsign_q
3488 : : logical :: isirr_q, q_is_gamma
3489 : : !arrays
3490 : : integer :: g1(3), g2(3), g0_q(3)
3491 : : real(dp) :: tnon(3), qq_bz(3)
3492 : : complex(dp) :: ph2, ph1
3493 : : ! *************************************************************************
3494 : :
3495 : : ABI_NVTX_START_RANGE(NVTX_GWR_ROTATE_WC)
3496 [ # # ]: 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("wc_space:", gwr%wc_space, " != itau"))
3497 : :
3498 [ # # ]: 0 : qq_bz = gwr%qbz(:, iq_bz)
3499 : 0 : q_is_gamma = normv(qq_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3500 : :
3501 : 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz); isym_q = gwr%qbz2ibz(2, iq_bz)
3502 [ # # ]: 0 : trev_q = gwr%qbz2ibz(6, iq_bz); g0_q = gwr%qbz2ibz(3:5, iq_bz)
3503 [ # # # # : 0 : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
# # # # ]
3504 [ # # ]: 0 : tsign_q = merge(1, -1, trev_q == 0)
3505 : : ! TODO: Understand why legacy GW does not need umklapp
3506 : : !ABI_CHECK(all(g0_q == 0), sjoin("For qbz:", ktoa(gwr%qbz(:, iq_bz)), "g0_q:", ltoa(g0_q), " != 0"))
3507 : :
3508 : : ! Copy descriptor from IBZ
3509 : : associate (desc_qibz => gwr%tchi_desc_qibz(iq_ibz))
3510 : 0 : call desc_qibz%copy(desc_qbz)
3511 : :
3512 [ # # ]: 0 : if (isirr_q) then
3513 : : ! Copy the PBLAS matrix in wc_qbz and we are done.
3514 : 0 : call gwr%wc_qibz(iq_ibz, itau, spin)%copy(wc_qbz); goto 10
3515 : : end if
3516 : :
3517 : : !ABI_WARNING_IF(trev_q == 0, "trev_q should be tested")
3518 : : ! rotate gvec, recompute gbound and rotate vc_sqrt_eps.
3519 : : ! TODO: 1) Handle TR and routine to rotate tchi/W including vc_sqrt_eps
3520 : : ! 2) Make sure that FFT box is large enough to accomodate umklapps
3521 : 0 : desc_qbz%ig0 = -1
3522 [ # # ]: 0 : do ig1=1,desc_qbz%npw
3523 [ # # # # : 0 : desc_qbz%gvec(:,ig1) = tsign_q * matmul(gwr%cryst%symrec(:,:,isym_q), desc_qibz%gvec(:,ig1)) - g0_q
# # # # #
# # # # #
# # ]
3524 [ # # # # : 0 : if (all(desc_qbz%gvec(:,ig1) == 0)) desc_qbz%ig0 = ig1
# # ]
3525 : : end do
3526 : 0 : desc_qbz%kin_sorted = .False.
3527 [ # # ]: 0 : ABI_CHECK(desc_qbz%ig0 /= -1, "Cannot find g = 0 after g-vector rotation!")
3528 : :
3529 : 0 : call sphereboundary(desc_qbz%gbound, desc_qbz%istwfk, desc_qbz%gvec, gwr%g_mgfft, desc_qbz%npw)
3530 : :
3531 : : ! Compute sqrt(vc(q,G))
3532 : : ! TODO: rotate vc_sqrt_eps
3533 : : ! vc(Sq, Sg) = vc(q, g)
3534 : : ! vc(-q, -g) = vc(q, g)
3535 : 0 : call desc_qbz%get_vc_sqrt(qq_bz, q_is_gamma, gwr, "sigma", gwr%gtau_comm%value)
3536 : :
3537 : : ! Get Wc_q with q in the BZ.
3538 [ # # ]: 0 : tnon = gwr%cryst%tnons(:, isym_q)
3539 : 0 : associate (wq_i => gwr%wc_qibz(iq_ibz, itau, spin), wq_f => wc_qbz)
3540 : 0 : call wq_i%copy(wc_qbz)
3541 : :
3542 : : !!!$OMP PARALLEL DO PRIVATE(ig2, g2, ph2, ig1, g2, ph1)
3543 [ # # ]: 0 : do il_g2=1, wq_f%size_local(2)
3544 : 0 : ig2 = mod(wq_f%loc2gcol(il_g2) - 1, desc_qbz%npw) + 1
3545 [ # # ]: 0 : g2 = desc_qbz%gvec(:,ig2)
3546 [ # # ]: 0 : ph2 = exp(+j_dpc * two_pi * dot_product(g2, tnon))
3547 [ # # ]: 0 : do il_g1=1, wq_f%size_local(1)
3548 : 0 : ig1 = mod(wq_f%loc2grow(il_g1) - 1, desc_qbz%npw) + 1
3549 [ # # ]: 0 : g1 = desc_qbz%gvec(:,ig1)
3550 [ # # ]: 0 : ph1 = exp(-j_dpc * two_pi * dot_product(g1, tnon))
3551 : 0 : wq_f%buffer_cplx(il_g1, il_g2) = wq_i%buffer_cplx(il_g1, il_g2) * ph1 * ph2
3552 [ # # ]: 0 : if (trev_q == 1) wq_f%buffer_cplx(il_g1, il_g2) = conjg(wq_f%buffer_cplx(il_g1, il_g2))
3553 : : end do
3554 : : end do
3555 : : end associate
3556 : : end associate
3557 : :
3558 : : 10 continue
3559 : : ABI_NVTX_END_RANGE()
3560 : :
3561 : 0 : end subroutine gwr_rotate_wc
3562 : : !!***
3563 : :
3564 : : !----------------------------------------------------------------------
3565 : :
3566 : : !!****f* m_gwr/gwr_get_myq_wc_gpr
3567 : : !! NAME
3568 : : !! gwr_get_myq_wc_gpr
3569 : : !!
3570 : : !! FUNCTION
3571 : : !! Use FFTs to compute: Wc_q(g,g') --> Wc_q(g',r)
3572 : : !! for each q in the BZ treated by this MPI proc for given `spin` and `itau` index:
3573 : : !!
3574 : : !! 1) FFT Transform the first index: Wc(g,g',it) --> Wc(r,g',it) (local operation)
3575 : : !! 2) MPI transposition: Wc(r,g',it) --> Wc(g',r,it)
3576 : : !!
3577 : : !! INPUTS
3578 : : !! select_my_qbz: Mask used to select a subset of gwr%my_qkbz q-points.
3579 : : !!
3580 : : !! OUTPUT
3581 : : !!
3582 : : !! SOURCE
3583 : :
3584 [ # # # # : 0 : subroutine gwr_get_myq_wc_gpr(gwr, itau, spin, select_my_qbz, desc_myqbz, wc_gpr)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3585 : :
3586 : : !Arguments ------------------------------------
3587 : : class(gwr_t),intent(inout) :: gwr
3588 : : integer,intent(in) :: itau, spin
3589 : : logical,intent(in) :: select_my_qbz(gwr%my_nqbz)
3590 : : type(desc_t),target,intent(out) :: desc_myqbz(gwr%my_nqbz)
3591 : : type(__slkmat_t),intent(inout) :: wc_gpr(gwr%my_nqbz)
3592 : :
3593 : : !Local variables-------------------------------
3594 : : !scalars
3595 : : integer :: my_iqf, iq_bz, ig2, npw, col_bsize, ndat, gpu_option, gpu_mode
3596 : : real(dp) :: cpu, wall, gflops, mem_mb, qq_bz(3)
3597 : : logical :: q_is_gamma
3598 : : character(len=500) :: msg, gpu_action
3599 [ # # # # : 0 : type(__slkmat_t) :: rgp, wc_qbz
# # # # #
# # # ]
3600 : 0 : type(uplan_t) :: uplan_q
3601 : 0 : complex(gwp),allocatable :: ceiqr(:)
3602 : : ! *************************************************************************
3603 : :
3604 : 0 : call cwtime(cpu, wall, gflops, "start")
3605 : : ABI_NVTX_START_RANGE(NVTX_GWR_MYQ_WW_GPR)
3606 : :
3607 : 0 : gpu_option = gwr%dtset%gpu_option
3608 : :
3609 [ # # # # : 0 : ABI_MALLOC(ceiqr, (gwr%g_nfft))
# # # # #
# # # ]
3610 : : #ifdef HAVE_OPENMP_OFFLOAD
3611 : : !$OMP TARGET ENTER DATA MAP(alloc:ceiqr) IF (gpu_option == ABI_GPU_OPENMP)
3612 : : #endif
3613 : :
3614 [ # # ]: 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3615 : :
3616 [ # # ]: 0 : do my_iqf=1,gwr%my_nqbz
3617 : : if (.not. select_my_qbz(my_iqf)) continue
3618 [ # # ]: 0 : iq_bz = gwr%my_qbz_inds(my_iqf); qq_bz = gwr%qbz(:, iq_bz)
3619 : 0 : q_is_gamma = normv(qq_bz, gwr%cryst%gmet, "G") < GW_TOLQ0
3620 [ # # ]: 0 : if (.not. q_is_gamma) then
3621 : 0 : call calc_ceikr(qq_bz, gwr%g_ngfft, gwr%g_nfft, 1, ceiqr)
3622 : : #ifdef HAVE_OPENMP_OFFLOAD
3623 : : !$omp target update to(ceiqr) if (gpu_option == ABI_GPU_OPENMP)
3624 : : #endif
3625 : : end if
3626 : :
3627 : : ! Get Wc_q in the BZ.
3628 : 0 : call gwr%rotate_wc(iq_bz, itau, spin, desc_myqbz(my_iqf), wc_qbz)
3629 : : associate (desc_q => desc_myqbz(my_iqf))
3630 : :
3631 : : ! Allocate rgp PBLAS matrix to store Wc_q(r, g')
3632 : 0 : npw = desc_q%npw
3633 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3634 [ # # ]: 0 : call rgp%init(gwr%g_nfft, npw, gwr%g_slkproc, desc_q%istwfk, size_blocs=[-1, col_bsize])
3635 : :
3636 : : call uplan_q%init(desc_q%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_q%istwfk, &
3637 : 0 : desc_q%gvec, gwp, gpu_option)
3638 : :
3639 : : ! FFT and store results in rgp
3640 : 0 : gpu_mode = 1
3641 [ # # # # : 0 : do ig2=1,wc_qbz%size_local(2), gwr%uc_batch_size
# # # # ]
3642 : 0 : ndat = blocked_loop(ig2, wc_qbz%size_local(2), gwr%uc_batch_size)
3643 : :
3644 [ # # ]: 0 : if (q_is_gamma) then
3645 : 0 : call uplan_q%execute_gr(ndat, wc_qbz%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), gpu_mode=gpu_mode)
3646 : : else
3647 : 0 : call uplan_q%execute_gr(ndat, wc_qbz%buffer_cplx(:, ig2), rgp%buffer_cplx(:, ig2), phase_r=ceiqr, gpu_mode=gpu_mode)
3648 : : end if
3649 : : end do ! ig2
3650 : :
3651 : 0 : call uplan_q%free()
3652 : :
3653 : : ! MPI transposition: Wc(r,g') -> Wc(g',r)
3654 : 0 : call rgp%ptrans("N", wc_gpr(my_iqf), free=.True.)
3655 : : end associate
3656 : 0 : call wc_qbz%free()
3657 : :
3658 : : !if (gpu_option == ABI_GPU_OPENMP) call wc_gpr(my_iqf)%gpu_map("update_to")
3659 : : end do ! my_iqf
3660 : :
3661 : : #ifdef HAVE_OPENMP_OFFLOAD
3662 : : !$OMP TARGET EXIT DATA MAP(delete: ceiqr) if (gpu_option == ABI_GPU_OPENMP)
3663 : : #endif
3664 [ # # ]: 0 : ABI_FREE(ceiqr)
3665 : :
3666 [ # # ]: 0 : mem_mb = sum(slk_array_locmem_mb(wc_gpr))
3667 : 0 : call wrtout(std_out, sjoin(" Local memory for Wc(g',r):", ftoa(mem_mb, fmt="f8.1"), "[Mb] <<< MEM"))
3668 : 0 : call cwtime_report(" gwr_get_myq_wc_gpr:", cpu, wall, gflops)
3669 : :
3670 : : ABI_NVTX_END_RANGE()
3671 : :
3672 [ # # # # : 0 : end subroutine gwr_get_myq_wc_gpr
# # # # #
# # # #
# ]
3673 : : !!***
3674 : :
3675 : : !----------------------------------------------------------------------
3676 : :
3677 : : !!****f* m_gwr/gwr_get_wc_rpr_qbz
3678 : : !! NAME
3679 : : !! gwr_get_wc_rpr_qbz
3680 : : !!
3681 : : !! FUNCTION
3682 : : !! Compute Wc_q(r',r') for q in the BZ
3683 : : !!
3684 : : !! INPUTS
3685 : : !!
3686 : : !! OUTPUT
3687 : : !!
3688 : : !! SOURCE
3689 : :
3690 : 0 : subroutine gwr_get_wc_rpr_qbz(gwr, g0_q, iq_bz, itau, spin, wc_rpr)
3691 : :
3692 : : !Arguments ------------------------------------
3693 : : class(gwr_t),intent(inout) :: gwr
3694 : : integer,intent(in) :: g0_q(3)
3695 : : integer,intent(in) :: iq_bz, itau, spin
3696 : : type(__slkmat_t),intent(inout) :: wc_rpr
3697 : :
3698 : : !Local variables-------------------------------
3699 : : !scalars
3700 : : integer :: ig2, npw, nr, col_bsize, ir1, ndat, gpu_option, gpu_mode
3701 : : character(len=500) :: msg, gpu_action
3702 [ # # ]: 0 : type(desc_t) :: desc_qbz
3703 [ # # # # : 0 : type(__slkmat_t) :: wc_ggp, rgp, gpr
# # # # #
# # # # #
# # # # ]
3704 : 0 : type(uplan_t) :: uplan_k
3705 : 0 : complex(gwp),allocatable :: ceig0r(:), conjg_ceig0r(:)
3706 : : ! *************************************************************************
3707 : :
3708 : : ABI_NVTX_START_RANGE(NVTX_GWR_WC_RPR_QBZ)
3709 : :
3710 : 0 : gpu_option = gwr%dtset%gpu_option
3711 [ # # ]: 0 : gpu_action = "None"; if (gpu_option == ABI_GPU_OPENMP) gpu_action = "alloc"
3712 : :
3713 : : ! NB: Non-zero g0, requires the application of the phase.
3714 [ # # # # : 0 : if (any(g0_q /= 0)) then
# # ]
3715 [ # # # # : 0 : ABI_MALLOC(ceig0r, (gwr%g_nfft))
# # # # #
# # # ]
3716 [ # # # # : 0 : ABI_MALLOC(conjg_ceig0r, (gwr%g_nfft))
# # # # ]
3717 [ # # ]: 0 : call calc_ceigr(-g0_q, gwr%g_nfft, 1, gwr%g_ngfft, ceig0r)
3718 [ # # # # ]: 0 : conjg_ceig0r = conjg(ceig0r)
3719 : : #ifdef HAVE_OPENMP_OFFLOAD
3720 : : !$OMP TARGET ENTER DATA MAP(alloc:ceig0r, conjg_ceig0r) IF (gpu_option == ABI_GPU_OPENMP)
3721 : : !$omp target update to(ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3722 : : #endif
3723 : : end if
3724 : :
3725 : : ! Get W_q(g,g') in the BZ.
3726 : 0 : call gwr%rotate_wc(iq_bz, itau, spin, desc_qbz, wc_ggp)
3727 : :
3728 : : ! Allocate rgp PBLAS matrix to store Wc(r,g')
3729 : 0 : nr = gwr%g_nfft
3730 : 0 : npw = desc_qbz%npw
3731 [ # # ]: 0 : ABI_CHECK(block_dist_1d(npw, gwr%g_comm%nproc, col_bsize, msg), msg)
3732 [ # # ]: 0 : call rgp%init(nr, npw, gwr%g_slkproc, desc_qbz%istwfk, size_blocs=[-1, col_bsize]) ! , gpu_action=gpu_action)
3733 : :
3734 : : call uplan_k%init(desc_qbz%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, desc_qbz%istwfk, &
3735 : 0 : desc_qbz%gvec, gwp, gpu_option)
3736 : :
3737 : : ! FFT Wc(g,g') -> Wc(r,g') and store results in rgp
3738 : 0 : gpu_mode = 1
3739 [ # # # # : 0 : do ig2=1,wc_ggp%size_local(2), gwr%uc_batch_size
# # # # ]
3740 : 0 : ndat = blocked_loop(ig2, wc_ggp%size_local(2), gwr%uc_batch_size)
3741 : :
3742 [ # # # # : 0 : if (any(g0_q /= 0)) then
# # ]
3743 : : call uplan_k%execute_gr(ndat, wc_ggp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), &
3744 : 0 : phase_r=ceig0r, gpu_mode=gpu_mode)
3745 : : else
3746 : : call uplan_k%execute_gr(ndat, wc_ggp%buffer_cplx(:,ig2), rgp%buffer_cplx(:,ig2), &
3747 : 0 : gpu_mode=gpu_mode)
3748 : : end if
3749 : : end do ! ig2
3750 : :
3751 : : ! MPI transpose: Wc(r,g') -> Wc(g',r)
3752 : 0 : call rgp%ptrans("N", gpr, free=.True.)
3753 : :
3754 : : ! Wc_q(g',r) -> Wc_q(r',r) and store results in wc_rgp.
3755 : : gpu_mode = 1
3756 [ # # # # : 0 : do ir1=1,gpr%size_local(2), gwr%uc_batch_size
# # # # ]
3757 : 0 : ndat = blocked_loop(ir1, gpr%size_local(2), gwr%uc_batch_size)
3758 [ # # # # : 0 : if (any(g0_q /= 0)) then
# # ]
3759 : : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:, ir1), wc_rpr%buffer_cplx(:, ir1), &
3760 : 0 : isign=-1, iscale=0, phase_r=conjg_ceig0r, gpu_mode=gpu_mode)
3761 : : else
3762 : : call uplan_k%execute_gr(ndat, gpr%buffer_cplx(:, ir1), wc_rpr%buffer_cplx(:, ir1), &
3763 : 0 : isign=-1, iscale=0, gpu_mode=gpu_mode)
3764 : : end if
3765 : : end do ! ir1
3766 : :
3767 : 0 : call uplan_k%free(); call gpr%free(); call desc_qbz%free(); call wc_ggp%free()
3768 : :
3769 [ # # # # : 0 : if (any(g0_q /= 0)) then
# # ]
3770 : : #ifdef HAVE_OPENMP_OFFLOAD
3771 : : !$OMP TARGET EXIT DATA MAP(delete: ceig0r, conjg_ceig0r) if (gpu_option == ABI_GPU_OPENMP)
3772 : : #endif
3773 [ # # ]: 0 : ABI_SFREE(ceig0r)
3774 [ # # ]: 0 : ABI_SFREE(conjg_ceig0r)
3775 : : end if
3776 : :
3777 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) call wc_rpr%gpu_map("update_to")
3778 : : ABI_NVTX_END_RANGE()
3779 : :
3780 [ # # # # : 0 : end subroutine gwr_get_wc_rpr_qbz
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
3781 : : !!***
3782 : :
3783 : : !----------------------------------------------------------------------
3784 : :
3785 : : !!****f* m_gwr/gwr_cos_transform
3786 : : !! NAME
3787 : : !! gwr_cos_transform
3788 : : !!
3789 : : !! FUNCTION
3790 : : !! Perform cosine transform.
3791 : : !!
3792 : : !! INPUTS
3793 : : !! what: "tchi" or "wc"
3794 : : !! mode: "iw2t" for omega to tau or "it2w" for tau to omega.
3795 : : !! [sum_spins]: True to sum the two spin-channgels when what == "tchi". Default: False.
3796 : : !!
3797 : : !! SOURCE
3798 : :
3799 : 0 : subroutine gwr_cos_transform(gwr, what, mode, sum_spins)
3800 : :
3801 : : !Arguments ------------------------------------
3802 : : class(gwr_t),target,intent(inout) :: gwr
3803 : : character(len=*),intent(in) :: what, mode
3804 : : logical,optional,intent(in) :: sum_spins
3805 : :
3806 : : !Local variables-------------------------------
3807 : : !scalars
3808 : : integer, parameter :: TAU_SPACE = 0, W_SPACE = 1
3809 : : integer :: my_iqi, my_is, ig1, ig2, my_it, ierr, iq_ibz, itau, spin, it0, iw, cnt
3810 : : integer :: ndat, idat, loc1_size, loc2_size, batch_size, from_space, units(2)
3811 : : real(dp) :: cpu, wall, gflops !, min_abs_err, max_abs_err
3812 : : complex(dp) :: cval
3813 : : logical :: sum_spins_, do_chi_fit
3814 : : !arrays
3815 : 0 : integer :: mask_qibz(gwr%nqibz)
3816 : 0 : real(dp), contiguous, pointer :: weights_ptr(:,:)
3817 : 0 : real(dp),allocatable :: beta_r(:,:)
3818 : 0 : complex(dp) :: wgt_globmy(gwr%ntau, gwr%my_ntau) ! Complex instead of real to be able to call ZGEMM.
3819 : 0 : complex(dp),allocatable :: cwork_myit(:,:,:), glob_cwork(:,:,:), alpha_c(:,:)
3820 : 0 : type(__slkmat_t), pointer :: mats(:)
3821 : : ! *************************************************************************
3822 : :
3823 [ # # ]: 0 : units = [std_out, ab_out]
3824 : :
3825 : : ABI_NVTX_START_RANGE(NVTX_GWR_COS_TRANSFORM)
3826 : 0 : call cwtime(cpu, wall, gflops, "start")
3827 : :
3828 [ # # ]: 0 : sum_spins_ = .False.; if (present(sum_spins)) sum_spins_ = sum_spins
3829 : :
3830 : 0 : call wrtout(std_out, sjoin(" Performing cosine transform. what:", what, ", mode:", mode))
3831 [ # # # # ]: 0 : mask_qibz = 0; mask_qibz(gwr%my_qibz_inds(:)) = 1
3832 : :
3833 : : ! Target weights depending on mode.
3834 : 0 : select case(mode)
3835 : : case ("iw2t")
3836 : : ! From omega to tau
3837 : 0 : from_space = W_SPACE
3838 [ # # ]: 0 : if (what == "tchi") then
3839 [ # # ]: 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("mode:", mode, "with what:", what, "and tchi_space:", gwr%tchi_space))
3840 : 0 : gwr%tchi_space = "itau"
3841 : : end if
3842 [ # # ]: 0 : if (what == "wc") then
3843 [ # # ]: 0 : ABI_CHECK(gwr%wc_space == "iomega", sjoin("mode:", mode, "with what:", what, "and wc_space:", gwr%wc_space))
3844 : 0 : gwr%wc_space = "itau"
3845 : : end if
3846 : 0 : weights_ptr => gwr%cosft_tw
3847 : :
3848 : : case ("it2w")
3849 : : ! From tau to omega
3850 : 0 : from_space = TAU_SPACE
3851 [ # # ]: 0 : if (what == "tchi") then
3852 [ # # ]: 0 : ABI_CHECK(gwr%tchi_space == "itau", sjoin("mode:", mode, " with what:", what, "and tchi_space:", gwr%tchi_space))
3853 : 0 : gwr%tchi_space = "iomega"
3854 : : end if
3855 [ # # ]: 0 : if (what == "wc") then
3856 [ # # ]: 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("mode:", mode, " with what:", what, "and wc_space:", gwr%wc_space))
3857 : 0 : gwr%wc_space = "iomega"
3858 : : end if
3859 : 0 : weights_ptr => gwr%cosft_wt
3860 : :
3861 : : case default
3862 [ # # # ]: 0 : ABI_ERROR(sjoin("Wrong mode:", mode))
3863 : : end select
3864 : :
3865 : : ! Extract my weights from global array.
3866 [ # # ]: 0 : do my_it=1,gwr%my_ntau
3867 : 0 : itau = gwr%my_itaus(my_it)
3868 [ # # ]: 0 : do iw=1,gwr%ntau
3869 : 0 : wgt_globmy(iw, my_it) = weights_ptr(iw, itau)
3870 : : end do
3871 : : end do
3872 : :
3873 : 0 : do_chi_fit = (iand(gwr%dtset%gwr_fit, CHI_FIT) /= 0)
3874 [ # # ]: 0 : if (do_chi_fit) then
3875 : 0 : call wrtout(units, " Activating fit of matrix elements in tau/iw space")
3876 : : end if
3877 : :
3878 : : ! Perform inhomogeneous FT in parallel.
3879 [ # # ]: 0 : do my_is=1,gwr%my_nspins
3880 : 0 : spin = gwr%my_spins(my_is)
3881 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
3882 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
3883 : 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
3884 : :
3885 : 0 : mats => null()
3886 : 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz, :, spin)
3887 [ # # ]: 0 : if (what =="wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
3888 [ # # ]: 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
3889 : :
3890 : : ! Use the first itau index to get the size of the local buffer.
3891 : : ! Block over ig2 to reduce the number of MPI calls and take advantage of ZGEMM.
3892 : 0 : it0 = gwr%my_itaus(1)
3893 : 0 : loc1_size = mats(it0)%size_local(1)
3894 : 0 : loc2_size = mats(it0)%size_local(2)
3895 : :
3896 : : ! batch_size in terms of columns
3897 : : ! TODO: Determine batch_size automatically to avoid going OOM
3898 : 0 : batch_size = 48
3899 : : !batch_size = loc2_size
3900 : :
3901 [ # # # # : 0 : ABI_MALLOC(cwork_myit, (gwr%my_ntau, loc1_size, batch_size))
# # # # #
# # # # #
# # # # ]
3902 [ # # # # : 0 : ABI_MALLOC(glob_cwork, (gwr%ntau, loc1_size, batch_size))
# # # # #
# # # # #
# # # # #
# ]
3903 : :
3904 [ # # ]: 0 : if (do_chi_fit) then
3905 : : ! Allocate coefficients for the fit.
3906 [ # # # # : 0 : ABI_MALLOC(beta_r, (loc1_size, batch_size))
# # # # #
# # # # #
# # ]
3907 [ # # # # : 0 : ABI_MALLOC(alpha_c, (loc1_size, batch_size))
# # # # #
# # # # #
# # ]
3908 : : end if
3909 : :
3910 [ # # # # ]: 0 : do ig2=1,mats(it0)%size_local(2), batch_size
3911 : 0 : ndat = blocked_loop(ig2, mats(it0)%size_local(2), batch_size)
3912 : :
3913 : : ! TODO
3914 : : ! When fit mode is activated, collect all tau/omega points for this set of (g1, g2) inside tau_comm
3915 : : ! Each MPI rank performs the fit locally using the first point and all the points treated by the rank.
3916 : : ! compute loss functions of all the fits and find the one leading to the minimum loss.
3917 [ # # ]: 0 : if (do_chi_fit) then
3918 [ # # # # : 0 : glob_cwork = zero
# # ]
3919 [ # # ]: 0 : do idat=1,ndat
3920 [ # # ]: 0 : do my_it=1,gwr%my_ntau
3921 : 0 : itau = gwr%my_itaus(my_it)
3922 [ # # ]: 0 : do ig1=1,mats(it0)%size_local(1)
3923 : 0 : glob_cwork(itau, ig1, idat) = mats(itau)%buffer_cplx(ig1, ig2+idat-1)
3924 : : end do
3925 : : end do
3926 : : end do
3927 : 0 : call xmpi_sum(glob_cwork, gwr%tau_comm%value, ierr)
3928 : :
3929 : : ! Start the fit
3930 [ # # # # : 0 : cnt = 0; beta_r = zero; alpha_c = zero
# # # # ]
3931 [ # # ]: 0 : do idat=1,ndat
3932 [ # # ]: 0 : do ig1=1,mats(it0)%size_local(1)
3933 [ # # ]: 0 : cnt = cnt + 1; if (gwr%tau_comm%skip(cnt)) cycle ! MPI parallelism inside tau_comm
3934 [ # # ]: 0 : if (from_space == TAU_SPACE) then
3935 : : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, glob_cwork(:,ig1,idat), &
3936 : 0 : alpha_c(ig1,idat), beta_r(ig1,idat), ierr)
3937 [ # # ]: 0 : else if (from_space == W_SPACE) then
3938 : : call fit_iomega(gwr%ntau, gwr%iw_mesh, gwr%iw_wgs, glob_cwork(:,ig1,idat), &
3939 : 0 : alpha_c(ig1,idat), beta_r(ig1,idat), ierr)
3940 : : else
3941 : 0 : ABI_ERROR(sjoin("Invalid from_space:", itoa(from_space)))
3942 : : end if
3943 : : !if (from_space == W_SPACE) print *, "my_it, alpha, beta", alpha_c(ig1,idat), beta_r(ig1,idat)
3944 : : end do ! ig1
3945 : : end do ! idat
3946 : 0 : call xmpi_sum(alpha_c, gwr%tau_comm%value, ierr)
3947 : 0 : call xmpi_sum(beta_r, gwr%tau_comm%value, ierr)
3948 : : end if ! do_chi_fit
3949 : :
3950 : : ! Extract (g1, g2) matrix elements as a function of tau/omega
3951 : : !!$OMP PARALLEL DO PRIVATE(itau, cval) COLLAPSE(2)
3952 [ # # ]: 0 : do idat=1,ndat
3953 [ # # ]: 0 : do my_it=1,gwr%my_ntau
3954 : 0 : itau = gwr%my_itaus(my_it)
3955 : 0 : cval = zero
3956 [ # # ]: 0 : do ig1=1,mats(it0)%size_local(1)
3957 [ # # ]: 0 : if (do_chi_fit) then
3958 : : ! Evaluate the fit and remove it from the signal.
3959 [ # # ]: 0 : if (from_space == TAU_SPACE) then
3960 : 0 : cval = fit_tau_exp_eval("func", gwr%tau_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3961 [ # # ]: 0 : else if (from_space == W_SPACE) then
3962 : 0 : cval = fit_iomega_eval("func", gwr%iw_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3963 : : end if
3964 : : if (from_space == W_SPACE .and. any(my_it == [1, gwr%my_ntau])) then
3965 : : !if (from_space == TAU_SPACE .and. any(my_it == [1, gwr%my_ntau])) then
3966 : : !print * "beta_r, alpha:", beta_r(ig1,idat), alpha_c(ig1,idat)
3967 : : !write(*, "(a,i3,1x, *(es12.5,2x))") "my_it abs_diff_1", my_it, abs(cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)), &
3968 : : ! cval, mats(itau)%buffer_cplx(ig1, ig2+idat-1)
3969 : : end if
3970 : : end if
3971 : 0 : cwork_myit(my_it, ig1, idat) = mats(itau)%buffer_cplx(ig1, ig2+idat-1) - cval
3972 : : end do
3973 : : end do
3974 : : end do
3975 : :
3976 : : ! Compute contribution to itau matrix,
3977 : : call ZGEMM("N", "N", gwr%ntau, loc1_size*ndat, gwr%my_ntau, cone, &
3978 : 0 : wgt_globmy, gwr%ntau, cwork_myit, gwr%my_ntau, czero, glob_cwork, gwr%ntau)
3979 : :
3980 : 0 : call xmpi_sum(glob_cwork, gwr%tau_comm%value, ierr)
3981 : :
3982 : : ! Update my local (g1, g2) entry to have it in imaginary-frequency.
3983 : : !!$OMP PARALLEL DO PRIVATE(itau, cval) COLLAPSE(2)
3984 [ # # ]: 0 : do idat=1,ndat
3985 [ # # ]: 0 : do my_it=1,gwr%my_ntau
3986 : 0 : itau = gwr%my_itaus(my_it)
3987 : 0 : cval = zero
3988 [ # # ]: 0 : do ig1=1,mats(it0)%size_local(1)
3989 : :
3990 [ # # ]: 0 : if (do_chi_fit) then
3991 : : ! Add Fourier transform of the fitted model.
3992 [ # # ]: 0 : if (from_space == TAU_SPACE) then
3993 : 0 : cval = fit_tau_exp_eval("ft", gwr%iw_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3994 [ # # ]: 0 : else if (from_space == W_SPACE) then
3995 : 0 : cval = fit_iomega_eval("ft", gwr%tau_mesh(itau), alpha_c(ig1,idat), beta_r(ig1,idat))
3996 : : end if
3997 : : !if (from_space == W_SPACE .and. my_it == 1) then
3998 : : !if (from_space == TAU_SPACE .and. my_it == 1) then
3999 : : ! !print *, "beta_r, alpha:", beta_r(ig1,idat), alpha_c(ig1,idat)
4000 : : ! print *, "my_it, abs_diff_2", my_it, abs(cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)), &
4001 : : ! cval - mats(itau)%buffer_cplx(ig1, ig2+idat-1)
4002 : : !end if
4003 : : end if
4004 : : !if (from_space == TAU_SPACE) then
4005 : : !if (from_space == W_SPACE) then
4006 : : !write(200, *)"mats:", mats(itau)%buffer_cplx(ig1, ig2+idat-1)
4007 : : !write(300, *)"cval", cval
4008 : : !end if
4009 : :
4010 : 0 : mats(itau)%buffer_cplx(ig1, ig2+idat-1) = glob_cwork(itau, ig1, idat) + cval
4011 : : end do ! ig1
4012 : : end do ! my_it
4013 : : end do ! idat
4014 : :
4015 : : end do ! ig2
4016 : :
4017 [ # # ]: 0 : ABI_FREE(cwork_myit)
4018 [ # # ]: 0 : ABI_FREE(glob_cwork)
4019 [ # # ]: 0 : ABI_SFREE(alpha_c)
4020 [ # # # # ]: 0 : ABI_SFREE(beta_r)
4021 : : end associate
4022 : : end do ! my_iqi
4023 : : end do ! my_is
4024 : : !stop
4025 : :
4026 [ # # ]: 0 : if (sum_spins_) then ! gwr%nsppol == 2 .and.
4027 : : ! Sum over spin channels.
4028 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
4029 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
4030 [ # # ]: 0 : do my_is=1,gwr%my_nspins
4031 : 0 : spin = gwr%my_spins(my_is)
4032 : 0 : mats => null()
4033 [ # # ]: 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz,:,spin)
4034 : : !if (what =="wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
4035 [ # # ]: 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
4036 : :
4037 [ # # ]: 0 : do my_it=1,gwr%my_ntau
4038 : 0 : itau = gwr%my_itaus(my_it)
4039 : :
4040 [ # # ]: 0 : if (gwr%nsppol == 1 .and. gwr%nspinor == 1) then
4041 [ # # # # ]: 0 : mats(itau)%buffer_cplx = two * mats(itau)%buffer_cplx
4042 : :
4043 [ # # ]: 0 : else if (gwr%nsppol == 2) then
4044 [ # # ]: 0 : if (gwr%spin_comm%nproc > 1) then
4045 : : ! Spins are distributed thus we have to sum them.
4046 : 0 : call xmpi_sum(mats(itau)%buffer_cplx, gwr%spin_comm%value, ierr)
4047 : : else
4048 : : ! Spins are not distributed. This should happen only in sequential.
4049 [ # # ]: 0 : if (spin == 1) then
4050 [ # # # # : 0 : mats(itau)%buffer_cplx = mats(itau)%buffer_cplx + gwr%tchi_qibz(iq_ibz,itau,spin+1)%buffer_cplx
# # ]
4051 [ # # # # : 0 : gwr%tchi_qibz(iq_ibz,itau,spin+1)%buffer_cplx = mats(itau)%buffer_cplx
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4052 : : end if
4053 : : end if
4054 : : end if
4055 : :
4056 : : end do ! my_it
4057 : : end do ! my_is
4058 : : end do ! my_iqi
4059 : : end if
4060 : :
4061 : : ABI_NVTX_END_RANGE()
4062 : 0 : call cwtime_report(" gwr_cos_transform:", cpu, wall, gflops)
4063 : :
4064 [ # # # # : 0 : end subroutine gwr_cos_transform
# # ]
4065 : : !!***
4066 : :
4067 : : !!****f* m_gwr/fit_tau_exp
4068 : : !! NAME
4069 : : !!
4070 : : !! FUNCTION
4071 : : !! Fit values in imaginary time using A exp^{-b t} with A complex and b real and > 0.
4072 : : !! The fit passes through the first tau point, the second point is selected by
4073 : : !! minimizing the "distance" between the fit and the ab-initio results cvals.
4074 : : !!
4075 : : !! b = -\frac{\ln(y_n / y_0)}{\tau_n - \tau_0},
4076 : : !! A = y_0 e^{b \tau_0}
4077 : : !!
4078 : : !! SOURCE
4079 : :
4080 : 0 : subroutine fit_tau_exp(ntau, tau_mesh, tau_wgs, cvals, alpha_c, beta_r, ierr)
4081 : :
4082 : : !Arguments ------------------------------------
4083 : : integer,intent(in) :: ntau
4084 : : real(dp),intent(in) :: tau_mesh(ntau), tau_wgs(ntau)
4085 : : complex(dp),intent(in) :: cvals(ntau)
4086 : : complex(dp),intent(out) :: alpha_c
4087 : : real(dp),intent(out) :: beta_r
4088 : : integer,intent(out) :: ierr
4089 : :
4090 : : !Local variables-------------------------------
4091 : : integer :: ii
4092 : : real(dp) :: loss, min_loss, my_beta_r
4093 : 0 : complex(dp) :: cfit(ntau), zz, my_alpha_c
4094 : : ! *************************************************************************
4095 : :
4096 : 0 : min_loss = huge(one); alpha_c = zero; beta_r = zero
4097 [ # # ]: 0 : do ii=2,ntau
4098 : : ! Find my_beta_r. Note that we take the real part of the log to avoid oscillatory behaviour in the exp.
4099 : 0 : zz = -log(cvals(ii) / cvals(1)) / (tau_mesh(ii) - tau_mesh(1))
4100 : 0 : my_beta_r = real(zz)
4101 : 0 : my_alpha_c = cvals(1) * exp(+my_beta_r * tau_mesh(1))
4102 : : ! Compute loss function.
4103 [ # # ]: 0 : cfit(:) = my_alpha_c * exp(-my_beta_r * tau_mesh)
4104 [ # # ]: 0 : loss = sum(tau_wgs * abs(cvals - cfit)**2)
4105 [ # # ]: 0 : if (loss < min_loss) then
4106 : 0 : min_loss = loss; alpha_c = my_alpha_c; beta_r = my_beta_r
4107 : : end if
4108 : : end do
4109 : :
4110 : : ! If something goes wrong, disable the fit.
4111 : 0 : ierr = 0
4112 [ # # ]: 0 : if (beta_r <= tol12) then
4113 : 0 : alpha_c = zero; beta_r = tol6; ierr = 1
4114 : : end if
4115 : :
4116 : 0 : end subroutine fit_tau_exp
4117 : : !!***
4118 : :
4119 : : !!****f* m_gwr/fit_tau_exp_eval
4120 : : !! NAME
4121 : : !!
4122 : : !! FUNCTION
4123 : : !! Exalute tau fit or it's Fourier transform.
4124 : : !!
4125 : : !! SOURCE
4126 : :
4127 : 0 : pure complex(dp) function fit_tau_exp_eval(what, xx, alpha_c, beta_r) result(cval)
4128 : :
4129 : : !Arguments ------------------------------------
4130 : : character(len=*),intent(in) :: what
4131 : : real(dp),intent(in) :: xx, beta_r
4132 : : complex(dp),intent(in) :: alpha_c
4133 : : ! *************************************************************************
4134 : :
4135 : 0 : select case (what)
4136 : : case ("func")
4137 : 0 : cval = alpha_c * exp(-beta_r * xx)
4138 : : case ("ft")
4139 : : ! \mathcal{F}\{A e^{-b |t|} \}(\omega) = \frac{2A b}{b^2 + \omega^2}
4140 : : !cval = (two * alpha_c * beta_r) / (beta_r**2 + xx**2)
4141 : : ! Cosine-transform.
4142 : 0 : cval = (alpha_c * two * beta_r) / (beta_r**2 + xx**2)
4143 : : case default
4144 [ # # # ]: 0 : cval = huge(one)
4145 : : end select
4146 : :
4147 : 0 : end function fit_tau_exp_eval
4148 : : !!***
4149 : :
4150 : : !!****f* m_gwr/fit_iomega
4151 : : !! NAME
4152 : : !!
4153 : : !! FUNCTION
4154 : : !! To fit the function
4155 : : !!
4156 : : !! f(\omega) = \frac{A}{b^2 + \omega^2}
4157 : : !!
4158 : : !! to pass through two given points (\omega_1, y_1) and (\omega_2, y_2), follow these steps.
4159 : : !!
4160 : : !! A = \frac{y_1 y_2 (\omega_2^2 - \omega_1^2)}{y_1 - y_2}.
4161 : : !! b^2 = \frac{y_2 \omega_2^2 - y_1 \omega_1^2}{y_1 - y_2},
4162 : : !!
4163 : : !! SOURCE
4164 : :
4165 : 0 : subroutine fit_iomega(ntau, iw_mesh, iw_wgs, cvals, alpha_c, beta_r, ierr)
4166 : :
4167 : : !Arguments ------------------------------------
4168 : : integer,intent(in) :: ntau
4169 : : real(dp),intent(in) :: iw_mesh(ntau), iw_wgs(ntau)
4170 : : complex(dp),intent(in) :: cvals(ntau)
4171 : : complex(dp),intent(out) :: alpha_c
4172 : : real(dp),intent(out) :: beta_r
4173 : : integer,intent(out) :: ierr
4174 : :
4175 : : !Local variables-------------------------------
4176 : : integer :: ii
4177 : : real(dp) :: loss, min_loss, w0, wn, b2 ! my_beta_r,
4178 : 0 : complex(dp) :: my_alpha_c, cfit(ntau), f0, fn ! zz, b2_cplx,
4179 : : ! *************************************************************************
4180 : :
4181 : 0 : min_loss = huge(one); w0 = iw_mesh(1); f0 = cvals(1); alpha_c = czero; beta_r = zero
4182 : :
4183 [ # # ]: 0 : do ii=2,ntau
4184 : : ! Find alpha_c and beta_r
4185 : 0 : wn = iw_mesh(ii); fn = cvals(ii)
4186 : : !b2_cplx = (f0*w0**2 - fn*wn**2) / (fn - f0)
4187 : : !b2 = real(b2)
4188 : 0 : b2 = (real(f0) * w0**2 - real(fn) * wn**2) / (real(fn) - real(f0))
4189 : : !print *, "b2:", b2
4190 : :
4191 [ # # ]: 0 : if (b2 <= tol12) then
4192 : : b2 = tol12; my_alpha_c = zero
4193 : : else
4194 : : !my_alpha_c = f0*fn * (wn**2 - w0**2) / (f0 - fn)
4195 : : !print *, "b2:", b2
4196 : : !my_alpha_c = f0 *((fn*wn**2 - f0*w0**2)/(f0 - fn) + w0**2)
4197 : 0 : my_alpha_c = f0 * (b2 + w0**2)
4198 : : end if
4199 : :
4200 : : ! Compute loss function.
4201 [ # # ]: 0 : cfit(:) = my_alpha_c / (b2 + iw_mesh**2)
4202 [ # # ]: 0 : loss = sum(iw_wgs * abs(cvals - cfit)**2)
4203 [ # # ]: 0 : if (loss < min_loss) then
4204 : 0 : min_loss = loss; alpha_c = my_alpha_c; beta_r = sqrt(b2)
4205 : : end if
4206 : : end do
4207 : :
4208 : : ! DEBUG: disable the fit
4209 : : !beta_r = zero; alpha_c = zero
4210 : :
4211 [ # # ]: 0 : ierr = 0; if (b2 <= tol12) ierr = 1
4212 : :
4213 : : !if (alpha_c /= zero) then
4214 : : ! print *, "beta_r, alpha_c", beta_r, alpha_c, min_loss
4215 : : !end if
4216 : :
4217 : : ! If something goes wrong, disable the fit.
4218 : : !beta_r = zero; alpha_c = zero
4219 : : !if ((my_beta_r) > zero) then
4220 : : ! beta_r = my_beta_r
4221 : : ! alpha_c = my_alpha_c
4222 : : !end if
4223 : :
4224 : 0 : end subroutine fit_iomega
4225 : : !!***
4226 : :
4227 : : !!****f* m_gwr/fit_iomega_eval
4228 : : !! NAME
4229 : : !!
4230 : : !! FUNCTION
4231 : : !!
4232 : : !! SOURCE
4233 : :
4234 : 0 : pure complex(dp) function fit_iomega_eval(what, xx, alpha_c, beta_r) result(cval)
4235 : :
4236 : : !Arguments ------------------------------------
4237 : : character(len=*),intent(in) :: what
4238 : : real(dp),intent(in) :: xx, beta_r
4239 : : complex(dp),intent(in) :: alpha_c
4240 : : ! *************************************************************************
4241 : :
4242 : 0 : select case (what)
4243 : : case ("func")
4244 : 0 : cval = alpha_c / (beta_r**2 + xx**2)
4245 : : case ("ft")
4246 : 0 : cval = zero
4247 [ # # ]: 0 : if (alpha_c /= zero) then
4248 : : !cval = alpha_c * exp(-beta_r * abs(xx))
4249 : : ! TODO: check sign in prefactor
4250 : : !cval = (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4251 : : !cval = - (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4252 : : ! Cosine-transform
4253 : 0 : cval = (alpha_c / (two * beta_r)) * exp(-beta_r * abs(xx))
4254 : : end if
4255 : :
4256 : : case default
4257 [ # # # ]: 0 : cval = huge(one)
4258 : : end select
4259 : :
4260 : 0 : end function fit_iomega_eval
4261 : : !!***
4262 : :
4263 : : !----------------------------------------------------------------------
4264 : :
4265 : : !!****f* m_gwr/desc_init
4266 : : !! NAME
4267 : : !! desc_init
4268 : : !!
4269 : : !! FUNCTION
4270 : : !! Initialize the descriptor.
4271 : : !!
4272 : : !! INPUTS
4273 : : !!
4274 : : !! OUTPUT
4275 : : !!
4276 : : !! SOURCE
4277 : :
4278 : 0 : subroutine desc_init(desc, kk, istwfk, ecut, gwr, kin_sorted, rot)
4279 : :
4280 : : !Arguments ------------------------------------
4281 : : class(desc_t),intent(inout) :: desc
4282 : : real(dp),intent(in) :: kk(3)
4283 : : integer,intent(in) :: istwfk
4284 : : real(dp),intent(in) :: ecut
4285 : : class(gwr_t),intent(in) :: gwr
4286 : : logical,optional,intent(in) :: kin_sorted, rot
4287 : :
4288 : : !Local variables-------------------------------
4289 : : integer :: ig, ig1, ig2, itim, isym, istep_forward, istep_backward, grot(3)
4290 : : ! character(len=256) :: msg
4291 : : logical :: found, rot__
4292 : 0 : real(dp),allocatable :: gnorm(:)
4293 : 0 : integer,allocatable :: igvec(:)
4294 : : ! *************************************************************************
4295 : :
4296 [ # # ]: 0 : desc%kin_sorted = .False.; if (present(kin_sorted)) desc%kin_sorted = kin_sorted
4297 [ # # ]: 0 : rot__ = .False.; if (present(rot)) rot__ = rot
4298 : 0 : desc%istwfk = istwfk
4299 [ # # ]: 0 : call get_kg(kk, desc%istwfk, ecut, gwr%cryst%gmet, desc%npw, desc%gvec, kin_sorted=desc%kin_sorted)
4300 : :
4301 [ # # # # : 0 : ABI_MALLOC(desc%gbound, (2 * gwr%g_mgfft + 8, 2))
# # # # #
# # # # #
# # # # ]
4302 : 0 : call sphereboundary(desc%gbound, desc%istwfk, desc%gvec, gwr%g_mgfft, desc%npw)
4303 : :
4304 : : ! Find the index of g = 0.
4305 : 0 : desc%ig0 = -1
4306 [ # # ]: 0 : do ig=1,desc%npw
4307 [ # # # # : 0 : if (all(desc%gvec(:,ig) == 0)) then
# # ]
4308 : 0 : desc%ig0 = ig; exit
4309 : : end if
4310 : : end do
4311 : :
4312 [ # # ]: 0 : if (rot__) then
4313 [ # # # # : 0 : ABI_ICALLOC(desc%rottb, (desc%npw, gwr%cryst%timrev, gwr%cryst%nsym))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4314 [ # # # # : 0 : ABI_ICALLOC(desc%rottbm1, (desc%npw, gwr%cryst%timrev, gwr%cryst%nsym))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4315 [ # # # # : 0 : ABI_CALLOC(desc%phmGt, (desc%npw, gwr%cryst%nsym))
# # # # #
# # # # #
# # # # #
# # # ]
4316 [ # # # # : 0 : ABI_CALLOC(desc%phmSGt, (desc%npw, gwr%cryst%nsym))
# # # # #
# # # # #
# # # # #
# # # ]
4317 : : ! Fast sort for norm(desc%gvec) and store indices in igvec.
4318 [ # # # # : 0 : ABI_MALLOC(gnorm, (desc%npw))
# # # # #
# # # ]
4319 [ # # # # : 0 : ABI_MALLOC(igvec, (desc%npw))
# # # # #
# # # ]
4320 : :
4321 [ # # ]: 0 : do ig=1,desc%npw
4322 : 0 : igvec(ig) = ig
4323 : 0 : gnorm(ig) = normv(desc%gvec(:,ig), gwr%cryst%gmet, "G") ** 2
4324 : : end do
4325 : :
4326 : 0 : call sort_dp(desc%npw, gnorm, igvec, tol14)
4327 : :
4328 [ # # ]: 0 : ABI_FREE(gnorm)
4329 : :
4330 [ # # ]: 0 : do ig1=1,desc%npw
4331 [ # # ]: 0 : do itim=1,gwr%cryst%timrev
4332 [ # # ]: 0 : do isym=1,gwr%cryst%nsym
4333 [ # # # # : 0 : grot=(3-2*itim)*MATMUL(gwr%cryst%symrec(:,:,isym),desc%gvec(:,ig1))
# # # # #
# # # ]
4334 : 0 : found=.FALSE.
4335 : : ! * Loop on the shell of ig1 to speed up the search.
4336 : : istep_forward = ig1; istep_backward = ig1
4337 [ # # # # ]: 0 : do while (istep_forward <= desc%npw .or. istep_backward >= 1)
4338 [ # # ]: 0 : if (istep_forward <= desc%npw) then
4339 : 0 : ig2 = igvec(istep_forward)
4340 [ # # # # : 0 : if (ALL(ABS(grot(:)-desc%gvec(:,ig2))==0)) then
# # ]
4341 : 0 : found=.TRUE.
4342 : 0 : desc%rottb(ig1,itim,isym)=ig2
4343 : 0 : desc%rottbm1(ig2,itim,isym)=ig1
4344 [ # # ]: 0 : desc%phmGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(desc%gvec(:,ig1), gwr%cryst%tnons(:,isym)))
4345 [ # # ]: 0 : desc%phmSGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(grot(:), gwr%cryst%tnons(:,isym)))
4346 : 0 : exit
4347 : : end if
4348 : : end if
4349 [ # # ]: 0 : if (istep_backward >= 1) then
4350 : 0 : ig2 = igvec(istep_backward)
4351 [ # # # # : 0 : if (ALL(ABS(grot(:)-desc%gvec(:,ig2))==0)) then
# # ]
4352 : 0 : found=.TRUE.
4353 : 0 : desc%rottb(ig1,itim,isym)=ig2
4354 : 0 : desc%rottbm1(ig2,itim,isym)=ig1
4355 [ # # ]: 0 : desc%phmGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(desc%gvec(:,ig1), gwr%cryst%tnons(:,isym)))
4356 [ # # ]: 0 : desc%phmSGt(ig1,isym) = exp(-j_dpc*two_pi*DOT_PRODUCT(grot(:), gwr%cryst%tnons(:,isym)))
4357 : 0 : exit
4358 : : end if
4359 : : end if
4360 : 0 : istep_forward = istep_forward + 1
4361 : 0 : istep_backward = istep_backward - 1
4362 : : end do
4363 : : ! if (.not.found) then
4364 : : ! write(msg,'(3a,i5,a,i5,1x,2(3i10,a),a,i3,a,i3)')&
4365 : : ! 'G-shell not closed',ch10,&
4366 : : ! ' Initial G vector ',ig1,'/',desc%npw,desc%gvec(:,ig1),' Rotated G vector ',grot(:),ch10,&
4367 : : ! ' Through sym ',isym,' and itim ',itim
4368 : : ! ABI_ERROR(msg)
4369 : : ! end if
4370 : : end do ! itim
4371 : : end do ! isym
4372 : : end do ! ig1
4373 : :
4374 [ # # ]: 0 : ABI_FREE(igvec)
4375 : :
4376 : : end if ! rot__
4377 : :
4378 : 0 : end subroutine desc_init
4379 : : !!***
4380 : :
4381 : : !----------------------------------------------------------------------
4382 : :
4383 : : !!****f* m_gwr/desc_get_vc_sqrt
4384 : : !! NAME
4385 : : !! desc_get_vc_sqrt
4386 : : !!
4387 : : !! FUNCTION
4388 : : !! Compute square root of the Coulomb interaction vc(q,g).
4389 : : !!
4390 : : !! SOURCE
4391 : :
4392 : 0 : subroutine desc_get_vc_sqrt(desc, qpt, q_is_gamma, gwr, mode, comm)
4393 : :
4394 : : !Arguments ------------------------------------
4395 : : class(desc_t),intent(inout) :: desc
4396 : : real(dp),intent(in) :: qpt(3)
4397 : : logical, intent(in) :: q_is_gamma
4398 : : class(gwr_t),intent(in) :: gwr
4399 : : character(len=*),intent(in) :: mode
4400 : : integer,intent(in) :: comm
4401 : : ! *************************************************************************
4402 : :
4403 : : ABI_UNUSED([q_is_gamma])
4404 : :
4405 [ # # # # ]: 0 : if (mode == "epsilon" .or. .not. gwr%has_vcgen_sigma) then
4406 [ # # ]: 0 : if (allocated(desc%vc_sqrt_eps)) return
4407 [ # # # # : 0 : ABI_MALLOC(desc%vc_sqrt_eps, (desc%npw))
# # # # #
# # # #
# ]
4408 : 0 : call gwr%vcgen_eps%get_vc_sqrt(qpt, desc%npw, desc%gvec, gwr%q0, gwr%cryst, desc%vc_sqrt_eps, comm)
4409 : :
4410 [ # # ]: 0 : else if (mode == "sigma") then
4411 [ # # ]: 0 : if (allocated(desc%vc_sqrt_sigma)) return
4412 [ # # # # : 0 : ABI_MALLOC(desc%vc_sqrt_sigma, (desc%npw))
# # # # #
# # # #
# ]
4413 : 0 : call gwr%vcgen_sigma%get_vc_sqrt(qpt, desc%npw, desc%gvec, gwr%q0, gwr%cryst, desc%vc_sqrt_sigma, comm)
4414 : :
4415 : : else
4416 : 0 : ABI_ERROR(sjoin("Invalid mode:", mode))
4417 : : end if
4418 : :
4419 : : end subroutine desc_get_vc_sqrt
4420 : : !!***
4421 : :
4422 : : !----------------------------------------------------------------------
4423 : :
4424 : : !!****f* m_gwr/desc_copy
4425 : : !! NAME
4426 : : !! desc_copy
4427 : : !!
4428 : : !! FUNCTION
4429 : : !! Copy object
4430 : : !! NB: cannot use obj1 = obj2 syntax because ABINIT memory-leak detector
4431 : : !! won't see the allocation automatically performed by the compiler.
4432 : : !!
4433 : : !! SOURCE
4434 : :
4435 [ # # ]: 0 : subroutine desc_copy(in_desc, new_desc)
4436 : :
4437 : : !Arguments ------------------------------------
4438 : : class(desc_t),intent(in) :: in_desc
4439 : : class(desc_t),intent(out) :: new_desc
4440 : : ! *************************************************************************
4441 : :
4442 : 0 : call new_desc%free()
4443 : :
4444 : 0 : new_desc%istwfk = in_desc%istwfk
4445 : 0 : new_desc%npw = in_desc%npw
4446 : 0 : new_desc%ig0 = in_desc%ig0
4447 : 0 : new_desc%kin_sorted = in_desc%kin_sorted
4448 : :
4449 [ # # ]: 0 : call alloc_copy(in_desc%gvec, new_desc%gvec)
4450 [ # # ]: 0 : call alloc_copy(in_desc%gbound, new_desc%gbound)
4451 [ # # # # ]: 0 : if (allocated(in_desc%vc_sqrt_eps)) call alloc_copy(in_desc%vc_sqrt_eps, new_desc%vc_sqrt_eps)
4452 [ # # # # ]: 0 : if (allocated(in_desc%vc_sqrt_sigma)) call alloc_copy(in_desc%vc_sqrt_sigma, new_desc%vc_sqrt_sigma)
4453 : :
4454 [ # # ]: 0 : if (allocated(in_desc%g2box)) then
4455 [ # # ]: 0 : call alloc_copy(in_desc%g2box, new_desc%g2box)
4456 [ # # ]: 0 : new_desc%cached_sc_ngfft = in_desc%cached_sc_ngfft
4457 : : end if
4458 : :
4459 : 0 : end subroutine desc_copy
4460 : : !!***
4461 : :
4462 : : !----------------------------------------------------------------------
4463 : :
4464 : : !!****f* m_gwr/desc_to_scbox
4465 : : !! NAME
4466 : : !! desc_to_scbox
4467 : : !!
4468 : : !! FUNCTION
4469 : : !! Insert cg_k array defined on the k-centered g-sphere with npw vectors inside the FFT box.
4470 : : !! The main difference wrt to sphere is that cfft is not initialized to zero. See notes below.
4471 : : !!
4472 : : !! INPUTS
4473 : : !! sc_ngfft:
4474 : : !! n1,n2,n3=physical dimension of the FFT box
4475 : : !! n4,n5,n6=memory dimension of cfft
4476 : : !! npw=number of G vectors in basis at this k point
4477 : : !! ndat=number of items to process
4478 : : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere
4479 : : !!
4480 : : !! OUTPUT
4481 : : !! cfft(n4,n5,n6*ndat) = array on FFT box filled with cg data
4482 : : !! Note that cfft is intent(inout) so that we can add contributions from different k-points.
4483 : : !!
4484 : : !! SOURCE
4485 : :
4486 : 0 : subroutine desc_to_scbox(desc, kk, ngkpt, sc_ngfft, ndat, cg, cfft)
4487 : :
4488 : : !Arguments ------------------------------------
4489 : : !scalars
4490 : : class(desc_t),intent(inout) :: desc
4491 : : real(dp),intent(in) :: kk(3)
4492 : : integer,intent(in) :: ngkpt(3)
4493 : : integer,intent(in) :: sc_ngfft(6), ndat
4494 : : !arrays
4495 : : complex(gwp),intent(in) :: cg(desc%npw, ndat)
4496 : : complex(gwp),intent(inout) :: cfft(sc_ngfft(4)*sc_ngfft(5)*sc_ngfft(6),ndat)
4497 : :
4498 : : !Local variables-------------------------------
4499 : : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw, kg(3), gg(3), ifft, npw
4500 : : logical :: compute_mapping
4501 : : !real(dp) :: tsec(2)
4502 : : ! *************************************************************************
4503 : :
4504 : : ! TODO: Add op_type
4505 : : !call timab(1931, 1, tsec)
4506 : :
4507 : 0 : npw = desc%npw
4508 : 0 : n1 = sc_ngfft(1); n2 = sc_ngfft(2); n3 = sc_ngfft(3)
4509 : 0 : n4 = sc_ngfft(4); n5 = sc_ngfft(5); n6 = sc_ngfft(6)
4510 [ # # ]: 0 : gg = nint(kk * ngkpt)
4511 : :
4512 [ # # # # : 0 : compute_mapping = .not. allocated(desc%g2box) .or. any(desc%cached_sc_ngfft /= sc_ngfft(1:6))
# # # # ]
4513 : :
4514 : : ! FIXME This is not thread safe
4515 : : if (compute_mapping) then
4516 [ # # # # : 0 : ABI_REMALLOC(desc%g2box, (npw))
# # # # #
# # # # #
# # ]
4517 [ # # ]: 0 : desc%cached_sc_ngfft = sc_ngfft(1:6)
4518 [ # # ]: 0 : do ipw=1,npw
4519 [ # # ]: 0 : kg = gg + ngkpt * desc%gvec(:,ipw) ! k+g
4520 : 0 : i1 = modulo(kg(1), n1)
4521 : 0 : i2 = modulo(kg(2), n2)
4522 : 0 : i3 = modulo(kg(3), n3)
4523 : 0 : desc%g2box(ipw) = 1 + i1 + n4*(i2+i3*n5)
4524 : : end do
4525 : : end if
4526 : :
4527 : : !do ipw=1,npw
4528 : : ! if (any(desc%gvec(:,ipw) > sc_ngfft(1:3)/2) .or. any(desc%gvec(:,ipw) < -(sc_ngfft(1:3)-1)/2) ) then
4529 : : ! ABI_ERROR(sjoin(" The G-vector: ",ltoa(desc%gvec(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
4530 : : ! end if
4531 : : !end do
4532 : :
4533 : : ! Insert cg into cfft
4534 : : !$OMP PARALLEL DO PRIVATE(ifft) IF (ndat > 1)
4535 [ # # ]: 0 : do idat=1,ndat
4536 [ # # ]: 0 : do ipw=1,npw
4537 : 0 : ifft = desc%g2box(ipw)
4538 : 0 : cfft(ifft,idat) = cg(ipw,idat)
4539 : : end do
4540 : : end do
4541 : :
4542 : : !call timab(1931, 2, tsec)
4543 : :
4544 : 0 : end subroutine desc_to_scbox
4545 : : !!***
4546 : :
4547 : : !----------------------------------------------------------------------
4548 : :
4549 : : !!****f* m_gwr/desc_free
4550 : : !! NAME
4551 : : !! desc_free
4552 : : !!
4553 : : !! FUNCTION
4554 : : !! Free memory
4555 : : !!
4556 : : !! SOURCE
4557 : :
4558 : 0 : subroutine desc_free(desc)
4559 : :
4560 : : !Arguments ------------------------------------
4561 : : class(desc_t),intent(inout) :: desc
4562 : : ! *************************************************************************
4563 : :
4564 [ # # ]: 0 : ABI_SFREE(desc%gvec)
4565 [ # # ]: 0 : ABI_SFREE(desc%gbound)
4566 [ # # ]: 0 : ABI_SFREE(desc%vc_sqrt_eps)
4567 [ # # ]: 0 : ABI_SFREE(desc%vc_sqrt_sigma)
4568 [ # # ]: 0 : ABI_SFREE(desc%g2box)
4569 [ # # ]: 0 : ABI_SFREE(desc%rottb)
4570 [ # # ]: 0 : ABI_SFREE(desc%rottbm1)
4571 [ # # ]: 0 : ABI_SFREE(desc%phmGt)
4572 [ # # ]: 0 : ABI_SFREE(desc%phmSGt)
4573 [ # # ]: 0 : desc%cached_sc_ngfft = -1
4574 : :
4575 : 0 : end subroutine desc_free
4576 : : !!***
4577 : :
4578 : : !----------------------------------------------------------------------
4579 : :
4580 : : !!****f* m_gwr/gwr_print
4581 : : !! NAME
4582 : : !! gwr_print
4583 : : !!
4584 : : !! FUNCTION
4585 : : !! Print info on the gwr object.
4586 : : !!
4587 : : !! INPUTS
4588 : : !!
4589 : : !! SOURCE
4590 : :
4591 : 0 : subroutine gwr_print(gwr, units, header)
4592 : :
4593 : : !Arguments ------------------------------------
4594 : : class(gwr_t),intent(in) :: gwr
4595 : : integer,intent(in) :: units(:)
4596 : : character(len=*),optional,intent(in) :: header
4597 : :
4598 : : !Local variables-------------------------------
4599 : : integer :: ii
4600 : : character(len=500) :: msg
4601 : : type(yamldoc_t) :: ydoc
4602 : : ! *********************************************************************
4603 : :
4604 [ # # # # ]: 0 : msg = ' ==== Info on the gwr_t object ==== '; if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
4605 : 0 : call wrtout(units, msg)
4606 : :
4607 : 0 : ydoc = yamldoc_open('GWR_params') !, width=11, real_fmt='(3f8.3)')
4608 : 0 : call ydoc%add_string("gwr_task", gwr%dtset%gwr_task)
4609 : 0 : call ydoc%add_int("nband", gwr%dtset%nband(1))
4610 : 0 : call ydoc%add_int("ntau", gwr%ntau)
4611 : 0 : call ydoc%add_int1d("ngkpt", gwr%ngkpt)
4612 : 0 : call ydoc%add_int1d("ngqpt", gwr%ngqpt)
4613 [ # # ]: 0 : msg = "supercell"; if (.not. gwr%use_supercell_for_tchi) msg = "BZ-convolutions"
4614 : 0 : call ydoc%add_string("chi_algo", msg)
4615 [ # # ]: 0 : msg = "supercell"; if (.not. gwr%use_supercell_for_sigma) msg = "BZ-convolutions"
4616 : 0 : call ydoc%add_string("sigma_algo", msg)
4617 : 0 : call ydoc%add_int("nkibz", gwr%nkibz)
4618 : 0 : call ydoc%add_int("nqibz", gwr%nqibz)
4619 : 0 : call ydoc%add_int("inclvkb", gwr%dtset%inclvkb)
4620 : 0 : call ydoc%add_real1d("q0", gwr%q0) ! "for long-wavelenght limit"))
4621 : 0 : call ydoc%add_int("gw_icutcoul", gwr%dtset%gw_icutcoul)
4622 : 0 : call ydoc%add_int("green_mpw", gwr%green_mpw)
4623 : 0 : call ydoc%add_int("tchi_mpw", gwr%tchi_mpw)
4624 : 0 : call ydoc%add_int1d("g_ngfft", gwr%g_ngfft(1:6))
4625 : 0 : call ydoc%add_real("gwr_boxcutmin", gwr%dtset%gwr_boxcutmin)
4626 : 0 : call ydoc%add_int1d("P gwr_np_kgts", gwr%dtset%gwr_np_kgts)
4627 : 0 : call ydoc%add_int1d("P np_kibz", gwr%np_kibz)
4628 : 0 : call ydoc%add_int1d("P np_qibz", gwr%np_qibz)
4629 : : ! Print Max error due to the inhomogeneous FT.
4630 : 0 : call ydoc%add_real("min_transition_energy_eV", gwr%te_min * Ha_eV)
4631 : 0 : call ydoc%add_real("max_transition_energy_eV", gwr%te_max * Ha_eV)
4632 : 0 : call ydoc%add_real("eratio", gwr%te_max / gwr%te_min)
4633 : 0 : call ydoc%add_real("ft_max_err_t2w_cos", gwr%ft_max_error(1))
4634 : 0 : call ydoc%add_real("ft_max_err_w2t_cos", gwr%ft_max_error(2))
4635 : 0 : call ydoc%add_real("ft_max_err_t2w_sin", gwr%ft_max_error(3))
4636 : 0 : call ydoc%add_real("cosft_duality_error", gwr%cosft_duality_error)
4637 : : ! Print imaginary time/frequency mesh with weights.
4638 : 0 : call ydoc%open_tabular("Minimax imaginary tau/omega mesh in a.u.", comment="tau, weight(tau), omega, weight(omega)")
4639 [ # # ]: 0 : do ii=1,gwr%ntau
4640 : 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)
4641 : 0 : call ydoc%add_tabular_line(msg)
4642 : : end do
4643 : :
4644 : 0 : call ydoc%write_units_and_free(units)
4645 : :
4646 [ # # # # ]: 0 : end subroutine gwr_print
4647 : : !!***
4648 : :
4649 : : !!****f* m_gwr/gwr_print_mem
4650 : : !! NAME
4651 : : !! gwr_print_mem
4652 : : !!
4653 : : !! FUNCTION
4654 : : !! Print memory allocated for matrices.
4655 : : !!
4656 : : !! SOURCE
4657 : :
4658 [ # # ]: 0 : subroutine gwr_print_mem(gwr, units)
4659 : :
4660 : : !Arguments ------------------------------------
4661 : : class(gwr_t),intent(in) :: gwr
4662 : : integer,intent(in) :: units(:)
4663 : :
4664 : : !Local variables-------------------------------
4665 : : !scalars
4666 : : real(dp) :: mem_mb
4667 : : !character(len=500) :: msg
4668 : : ! *********************************************************************
4669 : :
4670 [ # # ]: 0 : if (allocated(gwr%gt_kibz)) then
4671 [ # # # # : 0 : mem_mb = sum(slk_array_locmem_mb(gwr%gt_kibz))
# # # # #
# ]
4672 [ # # ]: 0 : if (mem_mb > zero) then
4673 : 0 : call wrtout(units, sjoin("- Local memory for G(g,g',kibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4674 : : end if
4675 : : end if
4676 [ # # ]: 0 : if (allocated(gwr%tchi_qibz)) then
4677 [ # # # # : 0 : mem_mb = sum(slk_array_locmem_mb(gwr%tchi_qibz))
# # ]
4678 [ # # ]: 0 : if (mem_mb > zero) then
4679 : 0 : call wrtout(units, sjoin("- Local memory for Chi(g,g',qibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4680 : : end if
4681 : : end if
4682 [ # # ]: 0 : if (allocated(gwr%wc_qibz)) then
4683 [ # # # # : 0 : mem_mb = sum(slk_array_locmem_mb(gwr%wc_qibz))
# # ]
4684 [ # # ]: 0 : if (mem_mb > zero) then
4685 : 0 : call wrtout(units, sjoin("- Local memory for Wc(g,g,qibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4686 : : end if
4687 : : end if
4688 [ # # ]: 0 : if (allocated(gwr%sigc_kibz)) then
4689 [ # # # # : 0 : mem_mb = sum(slk_array_locmem_mb(gwr%sigc_kibz))
# # # # #
# ]
4690 [ # # ]: 0 : if (mem_mb > zero) then
4691 : 0 : call wrtout(units, sjoin("- Local memory for Sigma_c(g,g',kibz,itau): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4692 : : end if
4693 : : end if
4694 [ # # ]: 0 : if (allocated(gwr%ugb)) then
4695 [ # # # # ]: 0 : mem_mb = sum(slk_array_locmem_mb(gwr%ugb))
4696 [ # # ]: 0 : if (mem_mb > zero) then
4697 : 0 : call wrtout(units, sjoin('- Local memory for u_gb wavefunctions: ', ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4698 : : end if
4699 : : end if
4700 : 0 : call wrtout(units, " ")
4701 : :
4702 : 0 : end subroutine gwr_print_mem
4703 : : !!***
4704 : :
4705 : : !----------------------------------------------------------------------
4706 : :
4707 : : !!****f* m_gwr/gwr_build_tchi
4708 : : !! NAME
4709 : : !! gwr_build_tchi
4710 : : !!
4711 : : !! FUNCTION
4712 : : !! High-level routine to compute the irreducible polarizability.
4713 : : !!
4714 : : !! SOURCE
4715 : :
4716 : 0 : subroutine gwr_build_tchi(gwr)
4717 : :
4718 : : !Arguments ------------------------------------
4719 : : class(gwr_t),target,intent(inout) :: gwr
4720 : :
4721 : : !Local variables-------------------------------
4722 : : !scalars
4723 : : 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
4724 : : integer :: idat, ndat, max_ndat, sc_nfft, sc_nfftsp, spin, ik_bz, iq_ibz, ikq_ibz, ikq_bz, ierr, ipm, itau, ig2, ifft !, ii
4725 : : integer :: use_umklp, gpu_mode ! ik_ibz, isym_k, trev_k, tsign_k, ! g0_k(3),
4726 : : !integer :: my_ikf_start, my_ikf_stop !, nkf_batch_size, nkf_now, op_type
4727 : : integer :: itim, isym
4728 : : integer(kind=XMPI_ADDRESS_KIND) :: buf_count
4729 : : real(dp) :: cpu_tau, wall_tau, gflops_tau, cpu_all, wall_all, gflops_all, cpu_ir, wall_ir, gflops_ir
4730 : : real(dp) :: cpu_ikf, wall_ikf, gflops_ikf
4731 : : real(dp) :: tchi_rfact, mem_mb, local_max, max_abs_imag_chit
4732 : : real(gwp) :: wtqp, wtqm
4733 : : complex(gwp) :: head_q
4734 : : complex(dp) :: chq(3), wng(3)
4735 : : logical :: q_is_gamma, use_shmem_for_k, use_mpi_for_k, print_time, keep_tchim !, doit ! isirr_k,
4736 : : character(len=5000) :: msg
4737 : : character(len=50) :: gpu_action
4738 : : type(desc_t),pointer :: desc_q ! desc_k,
4739 [ # # # # : 0 : type(__slkmat_t) :: chi_rgp
# # ]
4740 : : type(c_ptr) :: void_ptr
4741 : : !arrays
4742 : 0 : integer :: sc_ngfft(18), gg(3), g0_kq(3), mask_qibz(gwr%nqibz), need_kibz(gwr%nkibz), got_kibz(gwr%nkibz), units(2)
4743 : 0 : integer,allocatable :: green_scgvec(:,:), chi_scgvec(:,:)
4744 : 0 : logical :: select_my_kbz(gwr%my_nkbz)
4745 : : real(dp) :: kk_bz(3), kpq_bz(3), qq_ibz(3), tsec(2)
4746 : 0 : complex(gwp) ABI_ASYNC, contiguous, pointer :: gt_scbox(:,:,:)
4747 : 0 : complex(gwp),allocatable :: low_wing_q(:), up_wing_q(:), cemiqr(:)
4748 : : !complex(gwp),contiguous, pointer :: buf_cplx(:,:)
4749 [ # # # # : 0 : type(__slkmat_t) :: gkq_rpr_pm(2, gwr%nsig_ab), gk_rpr_pm(2, gwr%nsig_ab), work2, work1, chiq_ggp
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4750 : 0 : type(__slkmat_t),target,allocatable :: gt_gpr(:,:,:), chiq_gpr(:), chiq_rpr(:)
4751 : 0 : type(desc_t),target,allocatable :: desc_mykbz(:)
4752 : 0 : type(littlegroup_t),allocatable :: ltg_qibz(:)
4753 : : type(fftbox_plan3_t) :: green_plan
4754 : 0 : type(uplan_t) :: uplan_q
4755 : : ! *************************************************************************
4756 : :
4757 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
4758 : 0 : call timab(1923, 1, tsec)
4759 : :
4760 [ # # ]: 0 : units = [std_out, ab_out]
4761 : 0 : gpu_option = gwr%dtset%gpu_option
4762 : :
4763 [ # # ]: 0 : ABI_CHECK(gwr%tchi_space == "none", sjoin("tchi_space: ", gwr%tchi_space, " != none"))
4764 : 0 : gwr%tchi_space = "itau"
4765 : :
4766 : : ! Allocate tchi_q(g,g') matrices
4767 [ # # # # ]: 0 : mask_qibz = 0; mask_qibz(gwr%my_qibz_inds(:)) = 1
4768 [ # # ]: 0 : call gwr%print_mem([std_out])
4769 : :
4770 : 0 : call gwr%malloc_free_mats(mask_qibz, "tchi", "malloc")
4771 : 0 : max_abs_imag_chit = zero
4772 : :
4773 : : ! Setup FFT mesh in the supercell.
4774 [ # # ]: 0 : sc_ngfft = gwr%g_ngfft
4775 [ # # # # ]: 0 : sc_ngfft(1:3) = gwr%ngkpt * gwr%g_ngfft(1:3); sc_ngfft(4:6) = sc_ngfft(1:3)
4776 [ # # ]: 0 : sc_nfft = product(sc_ngfft(1:3)); sc_nfftsp = sc_nfft !* gwr%nspinor
4777 : :
4778 [ # # ]: 0 : if (gwr%use_supercell_for_tchi) then
4779 : : ! ============================
4780 : : ! Chi algorithm with supercell
4781 : : ! ============================
4782 : 0 : call print_chi_header()
4783 : :
4784 : : ! Be careful when using the FFT plan with ndat as ndat can change inside the loop if we start to block.
4785 : : ! Perhaps the safest approach would be to generate the plan on the fly.
4786 : 0 : max_ndat = gwr%sc_batch_size
4787 [ # # # # ]: 0 : use_mpi_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
4788 : : !use_mpi_for_k = .False.
4789 : :
4790 [ # # # # ]: 0 : use_shmem_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
4791 [ # # # # ]: 0 : use_shmem_for_k = use_shmem_for_k .and. gwr%kpt_comm%can_use_shmem()
4792 [ # # ]: 0 : if (gwr%dtset%userie == 234) use_shmem_for_k = .False.
4793 : : #ifndef HAVE_MPI_ALLOCATE_SHARED_CPTR
4794 : : use_shmem_for_k = .False.
4795 : : #endif
4796 : :
4797 [ # # ]: 0 : if (use_shmem_for_k) then
4798 : 0 : buf_count = 2 * (sc_nfftsp * max_ndat * 2)
4799 : 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, gt_scbox_win)
4800 [ # # ]: 0 : call c_f_pointer(void_ptr, gt_scbox, shape=[sc_nfftsp, max_ndat, 2])
4801 : : end if
4802 : :
4803 : 0 : call wrtout(std_out, sjoin(" use_mpi_for_k:", yesno(use_mpi_for_k)))
4804 : 0 : call wrtout(std_out, sjoin(" use_shmem_for_k:", yesno(use_shmem_for_k)))
4805 : 0 : mem_mb = (sc_nfftsp * max_ndat * 2 * gwp) * b2Mb
4806 : 0 : call wrtout(std_out, sjoin(" Memory for gt_scbox array:", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4807 : :
4808 [ # # ]: 0 : if (.not. use_shmem_for_k) then
4809 [ # # # # : 0 : ABI_MALLOC(gt_scbox, (sc_nfftsp, max_ndat, 2))
# # # # #
# # # # #
# # # # ]
4810 : : #ifdef HAVE_OPENMP_OFFLOAD
4811 : : !$OMP TARGET ENTER DATA MAP(alloc:gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) IF (gpu_option == ABI_GPU_OPENMP)
4812 : : #endif
4813 : : end if
4814 : :
4815 : : ! Build plan for dense FFTs.
4816 : 0 : call green_plan%from_ngfft(sc_ngfft, max_ndat*2, gpu_option)
4817 : :
4818 : : ! The g-vectors in the supercell for G and tchi.
4819 [ # # # # : 0 : ABI_MALLOC(green_scgvec, (3, gwr%green_mpw))
# # # # #
# # # ]
4820 [ # # # # : 0 : ABI_MALLOC(chi_scgvec, (3, gwr%tchi_mpw))
# # # # #
# # # ]
4821 [ # # # # : 0 : ABI_MALLOC(gt_gpr, (2, gwr%my_nkbz, gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
4822 [ # # # # : 0 : ABI_MALLOC(chiq_gpr, (gwr%my_nqibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4823 [ # # # # : 0 : ABI_MALLOC(desc_mykbz, (gwr%my_nkbz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4824 : :
4825 [ # # # # : 0 : ABI_MALLOC(cemiqr, (gwr%g_nfft)) ! The phase e^{-iq.r} in the unit cell.
# # # # #
# # # ]
4826 : : #ifdef HAVE_OPENMP_OFFLOAD
4827 : : !$OMP TARGET ENTER DATA MAP(alloc:cemiqr) IF (gpu_option == ABI_GPU_OPENMP)
4828 : : #endif
4829 : :
4830 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4831 : 0 : call wrtout(std_out, " Allocating PBLAS arrays for tchi_q(g',r) for all q in the IBZ treated by this MPI rank.")
4832 : 0 : call wrtout(std_out, " Here we're gonna have a big allocation peak...")
4833 : : ! TODO: To reduce memory one could use a diagonal approximation for chi at large G so that we can use a smaller ecuteps.
4834 : :
4835 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
4836 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
4837 : 0 : npw = gwr%tchi_desc_qibz(iq_ibz)%npw
4838 : 0 : ncol_glob = gwr%g_nfft
4839 [ # # ]: 0 : ABI_CHECK(block_dist_1d(ncol_glob, gwr%g_comm%nproc, col_bsize, msg), msg)
4840 [ # # ]: 0 : call chiq_gpr(my_iqi)%init(npw, gwr%g_nfft, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
4841 [ # # # # ]: 0 : if (gwr%comm%me == 0 .and. mod(my_iqi, 2) == 0) call pstat_proc%print(_PSTAT_ARGS_)
4842 : : end do
4843 : :
4844 [ # # ]: 0 : mem_mb = sum(slk_array_locmem_mb(chiq_gpr))
4845 : 0 : call wrtout(std_out, sjoin(" Local memory for Chi_q(g',r) matrices: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
4846 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4847 : :
4848 [ # # ]: 0 : select_my_kbz = .True.
4849 : : !nkf_batch_size = gwr%my_nkbz
4850 : :
4851 : : ! Loop over my spins and my taus.
4852 [ # # ]: 0 : do my_is=1,gwr%my_nspins
4853 : 0 : spin = gwr%my_spins(my_is)
4854 [ # # ]: 0 : do my_it=1,gwr%my_ntau
4855 : 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
4856 : 0 : itau = gwr%my_itaus(my_it)
4857 : :
4858 : : ! TODO: To reduce memory one could allocate and then accumulate chi only for a subset of k-points in the BZ
4859 : : ! inside an extra loop over k-groups. This increase the number of FFTs by ngroups but memory decreases
4860 : : ! get_myk_green_gpr should receive a mask and box2gsph should accumulate for ik_group > 1.
4861 : : ! First of all, I need to undestand if get_myk_green_gpr is responsible for the OOM (very likely)
4862 : :
4863 : : ! This trick cannot be used for chi as we have GG but it might be implemented for GW
4864 : : ! where Sigma = G1_k W + G2_k W + G3_k W ...
4865 : :
4866 : : !do my_ikf_start=1, gwr%my_nkbz, nkf_batch_size
4867 : : ! nkf_now = blocked_loop(my_ikf_start, gwr%my_nkbz, nkf_batch_size)
4868 : : ! my_ikf_stop = min(my_ikf_start + nkf_now, gwr%my_nkbz)
4869 : : ! !select_my_kbz = .False.; select_my_kbz(my_ifk_start:my_ifk_stop) = .True.
4870 : : ! !op_type = OP_COPY; if (my_ifk_start /= 0) op_type = OP_SUM
4871 : : !end do ! my_ifk_start
4872 : :
4873 : : ! G_k(g,g') --> G_k(g',r) e^{ik.r} for each k in the BZ treated by me.
4874 : 0 : call gwr%get_myk_green_gpr(itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
4875 [ # # # # ]: 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
4876 : :
4877 : : ! Loop over r in the unit cell that is now MPI-distributed inside g_comm.
4878 : : ! This is a bottleneck but perhaps one can take advantage of localization.
4879 : : ! Also, one can save all the FFTs in a matrix G(mnfft * ndat, my_nkbz) multiply by the e^{-ikr} phase
4880 : : ! and then use zgemm to compute Out(r,L) = [e^{-ikr}G_k(r)] e^{-ikL} with precomputed e^{-iLk} phases.
4881 : 0 : my_nr = gt_gpr(1,1,1)%size_local(2)
4882 [ # # # # : 0 : do my_ir=1, my_nr, gwr%sc_batch_size
# # # # ]
4883 : 0 : ndat = blocked_loop(my_ir, my_nr, gwr%sc_batch_size)
4884 [ # # # # : 0 : print_time = (gwr%comm%me == 0 .and. (my_ir <= 6 * gwr%sc_batch_size .or. mod(my_ir, LOG_MODR) == 0))
# # ]
4885 : 0 : if (print_time) call cwtime(cpu_ir, wall_ir, gflops_ir, "start")
4886 [ # # ]: 0 : do iab=1, gwr%nsig_ab
4887 : :
4888 : : ! TODO: GPU version
4889 [ # # ]: 0 : if (.not. use_shmem_for_k) then
4890 : :
4891 : : ! Insert G_k(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir).
4892 : 0 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox)
4893 : : #ifdef HAVE_OPENMP_OFFLOAD
4894 : : !$omp target update to(gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
4895 : : #endif
4896 : :
4897 [ # # ]: 0 : if (.not. use_mpi_for_k) then
4898 : : ! G(G',r) --> G(R',r) = sum_{k,g'} e^{-i(k+g').R'} G_k(g',r)
4899 [ # # ]: 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_sum(gt_scbox, gwr%kpt_comm%value, ierr)
4900 : 0 : call green_plan%execute(gt_scbox(:,1,1), -1, max_ndat*2, iscale=0)
4901 : :
4902 : : ! Compute tchi(R',r) for this r and store it in (:,:,1). Note that results are real so one might use r2c FFT.
4903 : : ! Then back to tchi(G'=q+g',r) immediately with isign + 1.
4904 : : !gt_scbox(:,:,1) = gt_scbox(:,:,1) * conjg(gt_scbox(:,:,2))
4905 : : #ifdef HAVE_OPENMP_OFFLOAD
4906 : : !$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)
4907 : : #endif
4908 [ # # ]: 0 : do idat=1,max_ndat
4909 [ # # ]: 0 : do ifft=1,sc_nfftsp
4910 : 0 : gt_scbox(ifft,idat,1) = gt_scbox(ifft,idat,1) * conjg(gt_scbox(ifft,idat,2))
4911 : : end do
4912 : : end do
4913 : : !max_abs_imag_chit = max(max_abs_imag_chit, maxval(abs(aimag(gt_scbox(:,:,1)))))
4914 : :
4915 : 0 : call green_plan%execute(gt_scbox(:,1,1), +1, max_ndat*2)
4916 : : #ifdef HAVE_OPENMP_OFFLOAD
4917 : : !$omp target update from(gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
4918 : : #endif
4919 : :
4920 : : else
4921 : : ! Reduce one G_k(tau) on the idat-1 proc and perform ndat FFTs in parallel.
4922 : : ! Finally, broadcast from the (idat-1) proc inside gwr%kpt_comm.
4923 [ # # ]: 0 : do ipm=1,2
4924 [ # # ]: 0 : do idat=1,ndat
4925 : 0 : call xmpi_sum_master(gt_scbox(:,idat,ipm), idat-1, gwr%kpt_comm%value, ierr)
4926 : : end do
4927 : : end do
4928 : 0 : idat = gwr%kpt_comm%me + 1
4929 [ # # ]: 0 : do ipm=1,2
4930 : 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
4931 : : end do
4932 [ # # ]: 0 : gt_scbox(:,idat,1) = gt_scbox(:,idat,1) * conjg(gt_scbox(:,idat,2))
4933 : 0 : call green_plan%execute(gt_scbox(:,idat,1), +1, ndat=1)
4934 [ # # ]: 0 : do idat=1,ndat
4935 : 0 : call xmpi_bcast(gt_scbox(:,idat,1), idat-1, gwr%kpt_comm%value, ierr)
4936 : : end do
4937 : : end if
4938 : :
4939 : : else
4940 : : ! use_shmem_for_k --> MPI shared window version. Only gt_scbox is shared.
4941 : :
4942 : : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox, &
4943 : 0 : gt_scbox_win=gt_scbox_win)
4944 : :
4945 : : ! Now each MPI proc operates on different idat entries.
4946 : : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
4947 : 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! Start the RMA epoch
4948 : 0 : idat = gwr%kpt_comm%me + 1
4949 [ # # ]: 0 : if (idat <= ndat) then
4950 [ # # ]: 0 : do ipm=1,2
4951 : 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
4952 : : end do
4953 [ # # ]: 0 : gt_scbox(:,idat,1) = gt_scbox(:,idat,1) * conjg(gt_scbox(:,idat,2))
4954 : 0 : call green_plan%execute(gt_scbox(:,idat,1), +1, ndat=1)
4955 : : end if
4956 : : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
4957 : : !call xmpi_barrier(gwr%kpt_comm%value)
4958 : 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! End the RMA epoch
4959 : : end if
4960 : :
4961 : : ! Now extract tchi_q(g',r) on the ecuteps (q+g)-sphere from the FFT box in the supercell
4962 : : ! and save data in chiq_gpr PBLAS matrix. Only my q-points in the IBZ are considered.
4963 : : ! Alternatively, one can avoid the above FFT, use zero-padded to go from the supercell
4964 : : ! to the ecuteps g-sphere inside the my_iqi loop. This approach should play well with k-point parallelism.
4965 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
4966 [ # # ]: 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz); desc_q => gwr%tchi_desc_qibz(iq_ibz)
4967 [ # # ]: 0 : gg = nint(qq_ibz * gwr%ngqpt)
4968 [ # # ]: 0 : do ig=1,desc_q%npw
4969 [ # # ]: 0 : chi_scgvec(:,ig) = gg + gwr%ngqpt(:) * desc_q%gvec(:,ig) ! q+g
4970 : : end do
4971 : : call box2gsph(merge(OP_COPY, OP_ACC, iab == 1),&
4972 : : sc_ngfft, desc_q%npw, ndat, chi_scgvec, &
4973 [ # # ]: 0 : gt_scbox(:,1,1), chiq_gpr(my_iqi)%buffer_cplx(:,my_ir))
4974 : : ! TODO:
4975 : : !call desc_q%box2gsph(qq_ibz, gwr%ngqpt, sc_ngfft, gwr%nspinor * ndat, &
4976 : : ! gt_scbox(:,1,1), chiq_gpr(my_iqi)%buffer_cplx(:,my_ir))
4977 : : end do ! my_iqi
4978 : : end do ! iab
4979 : :
4980 [ # # ]: 0 : if (print_time) then
4981 : 0 : write(msg,'(4x,3(a,i0),a)')"Chi my_ir [", my_ir, "/", my_nr, "] (tot: ", gwr%g_nfft, ")"
4982 : 0 : call cwtime_report(msg, cpu_ir, wall_ir, gflops_ir)
4983 : : end if
4984 : : end do ! my_ir (end cpu intensive loop)
4985 : :
4986 : : ! Free descriptors and PBLAS matrices in kBZ.
4987 : 0 : call desc_array_free(desc_mykbz); call slk_array_free(gt_gpr)
4988 : :
4989 : : ! Now we have tchi_q(g',r).
4990 : : ! For each IBZ q-point treated by this MPI proc, do:
4991 : : !
4992 : : ! 1) MPI transpose to have tchi_q(r,g')
4993 : : ! 2) FFT along the first dimension to get tchi_q(g,g') and store it in gwr%tchi_qibz
4994 : : !
4995 : 0 : tchi_rfact = one / gwr%g_nfft / gwr%cryst%ucvol / (gwr%nkbz * gwr%nqbz)
4996 : :
4997 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
4998 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
4999 : 0 : q_is_gamma = normv(gwr%qibz(:,iq_ibz), gwr%cryst%gmet, "G") < GW_TOLQ0
5000 : 0 : desc_q => gwr%tchi_desc_qibz(iq_ibz)
5001 : :
5002 : : ! Note the minus sign in q.
5003 [ # # # # ]: 0 : call calc_ceikr(-gwr%qibz(:,iq_ibz), gwr%g_ngfft, gwr%g_nfft, 1, cemiqr)
5004 [ # # ]: 0 : cemiqr = cemiqr * tchi_rfact
5005 : : #ifdef HAVE_OPENMP_OFFLOAD
5006 : : !$omp target update to(cemiqr) if (gpu_option == ABI_GPU_OPENMP)
5007 : : #endif
5008 : :
5009 : : ! MPI-transposition: tchi_q(g',r) => tchi_q(r,g')
5010 : 0 : call chiq_gpr(my_iqi)%ptrans("N", chi_rgp)
5011 : :
5012 : : ! FFT tchi_q(r,g') --> tchi_q(g,g'). Results stored in gwr%tchi_qibz.
5013 : : call uplan_q%init(desc_q%npw, 1, gwr%uc_batch_size, gwr%g_ngfft, istwfk1, &
5014 : 0 : desc_q%gvec, gwp, gpu_option)
5015 : :
5016 : 0 : gpu_mode = 1
5017 [ # # # # : 0 : do ig2=1, chi_rgp%size_local(2), gwr%uc_batch_size
# # # # ]
5018 : 0 : ndat = blocked_loop(ig2, chi_rgp%size_local(2), gwr%uc_batch_size)
5019 : :
5020 : : call uplan_q%execute_rg(ndat, chi_rgp%buffer_cplx(:, ig2), &
5021 : 0 : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:, ig2), phase_r=cemiqr, gpu_mode=gpu_mode)
5022 : : end do ! ig2
5023 : :
5024 : 0 : call uplan_q%free()
5025 : 0 : call chi_rgp%free()
5026 : :
5027 : 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%set_imag_diago_to_zero(local_max)
5028 : : end do ! my_iqi
5029 : :
5030 : 0 : write(msg,'(3(a,i0),a)')" My itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
5031 : 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau, end_str=ch10)
5032 : : end do ! my_it
5033 : : end do ! my_is
5034 : :
5035 [ # # ]: 0 : if (use_shmem_for_k) then
5036 : 0 : call xmpi_win_free(gt_scbox_win, ierr)
5037 : : else
5038 : : #ifdef HAVE_OPENMP_OFFLOAD
5039 : : !$OMP TARGET EXIT DATA MAP(delete: gt_scbox(1:sc_nfftsp,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
5040 : : #endif
5041 [ # # ]: 0 : ABI_FREE(gt_scbox)
5042 : : end if
5043 : :
5044 [ # # ]: 0 : ABI_FREE(green_scgvec)
5045 [ # # ]: 0 : ABI_FREE(chi_scgvec)
5046 [ # # # # : 0 : ABI_FREE(gt_gpr)
# # # # #
# ]
5047 [ # # # # : 0 : ABI_FREE(desc_mykbz)
# # # # #
# # # # #
# # # # #
# # # #
# ]
5048 : 0 : call slk_array_free(chiq_gpr)
5049 [ # # # # : 0 : ABI_FREE(chiq_gpr)
# # # # #
# ]
5050 : 0 : call green_plan%free()
5051 : :
5052 : : #ifdef HAVE_OPENMP_OFFLOAD
5053 : : !$OMP TARGET EXIT DATA MAP(delete:cemiqr) IF (gpu_option == ABI_GPU_OPENMP)
5054 : : #endif
5055 [ # # ]: 0 : ABI_FREE(cemiqr)
5056 : :
5057 : : else ! not gwr%use_supercell_for_tchi
5058 : : ! ===================================================================
5059 : : ! Mixed-space algorithm in the unit cell with convolutions in k-space
5060 : : ! ===================================================================
5061 : 0 : call print_chi_header()
5062 : :
5063 : 0 : call wrtout(std_out, " Allocating memory for G_k(r',r) and chi_q(r',r)...")
5064 : 0 : call wrtout(std_out, " Here we're gonna have a big allocation peak...")
5065 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5066 : :
5067 : : ! Need all nqibz matrices in chi_q here as the iq_ibz loop is the innermost one unlike in the legacy GW code.
5068 : 0 : nr = gwr%g_nfft
5069 [ # # ]: 0 : col_bsize = nr / gwr%g_comm%nproc; if (mod(nr, gwr%g_comm%nproc) /= 0) col_bsize = col_bsize + 1
5070 : 0 : tchi_rfact = one / gwr%cryst%ucvol
5071 : :
5072 : 0 : gpu_action = "None";
5073 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
5074 : 0 : gpu_action = "alloc"; call wrtout(std_out, " Allocating Chi_q(r,r', +tau) on the GPU...")
5075 : : end if
5076 : :
5077 [ # # # # : 0 : ABI_MALLOC(chiq_rpr, (gwr%nqibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5078 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5079 [ # # ]: 0 : call chiq_rpr(iq_ibz)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize], gpu_action=gpu_action)
5080 : : end do
5081 : :
5082 : 0 : call pstat_proc%print(_PSTAT_ARGS_)
5083 : :
5084 : : ! Allocate G_k(r',r, +/- tau) and G_kq(r',r, +/- tau)
5085 : : ! TODO: Can save memory here as we don't need +/- tau for each k+q.
5086 [ # # ]: 0 : do ipm=1,2
5087 [ # # ]: 0 : do iab=1,gwr%nsig_ab
5088 [ # # ]: 0 : call gk_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
5089 [ # # ]: 0 : call gkq_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize]) !, gpu_action=gpu_action)
5090 : : end do
5091 : : end do
5092 : :
5093 [ # # # # : 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))
# # # # #
# ]
5094 : 0 : call wrtout(std_out, sjoin(" Local memory for Chi_q(r',r) (gt_gpr): ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
5095 : 0 : call pstat_proc%print(_PSTAT_ARGS_)
5096 : :
5097 : : ! The little group is needed when symchi == 1 (default)
5098 : : ! If use_umklp == 1 then symmetries requiring an umklapp to preserve qibz are included as well.
5099 : : ! 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.
5100 [ # # # # : 0 : ABI_MALLOC(ltg_qibz, (gwr%nqibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5101 : 0 : use_umklp = 0
5102 : : !gw_timrev = kpts_timrev_from_kptopt(gwr%ks_ebands%kptopt) + 1
5103 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5104 : : call ltg_qibz(iq_ibz)%init(gwr%qibz(:,iq_ibz), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, &
5105 : 0 : npwe=gwr%tchi_desc_qibz(iq_ibz)%npw, gvec=gwr%tchi_desc_qibz(iq_ibz)%gvec)
5106 : : !call ltg_qibz(iq_ibz)%init(gwr%qibz(:,iq_ibz), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, npwe=0, timrev=1)
5107 [ # # # # ]: 0 : if (gwr%comm%me == 0) call ltg_qibz(iq_ibz)%print([std_out], prtvol=gwr%dtset%prtvol)
5108 : : end do
5109 : :
5110 : : ! Compute mask with the k+q points in the IBZ required by this MPI proc.
5111 [ # # ]: 0 : need_kibz = 0
5112 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
5113 [ # # ]: 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
5114 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5115 [ # # # # ]: 0 : qq_ibz = gwr%qibz(:, iq_ibz); kpq_bz = kk_bz + qq_ibz
5116 : 0 : call findqg0(ikq_bz, g0_kq, kpq_bz, gwr%nkbz, gwr%kbz, gwr%mG0)
5117 : : ! TODO: here I may need to take into account the umklapp
5118 : : !ABI_CHECK(all(g0_kq == 0), sjoin("g0_kq != 0, kk_bz", ktoa(kpq_bz), "qq_ibz:", ktoa(qq_ibz)))
5119 : 0 : ikq_ibz = gwr%kbz2ibz(1, ikq_bz)
5120 : 0 : need_kibz(ikq_ibz) = 1
5121 : : end do
5122 : : end do
5123 : :
5124 : : ! Begin loop over spin and tau points.
5125 [ # # ]: 0 : do my_is=1,gwr%my_nspins
5126 : 0 : spin = gwr%my_spins(my_is)
5127 [ # # ]: 0 : do my_it=1,gwr%my_ntau
5128 : 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
5129 : 0 : itau = gwr%my_itaus(my_it)
5130 : :
5131 : : ! Redistribute G_k(g,g') with k in the IBZ so that each MPI proc
5132 : : ! can reconstruct G_{k+q} in the BZ inside the MPI-distributed loops.
5133 : : ! TODO: support for ipm_list else we have a memory leak.
5134 : 0 : call gwr%redistrib_gt_kibz(itau, spin, need_kibz, got_kibz, "communicate") !ipm_list=
5135 [ # # # # ]: 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5136 : :
5137 : : ! Sum over my k-points in the BZ.
5138 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
5139 : 0 : call slk_array_gpu_set_zero(chiq_rpr)
5140 : : else
5141 [ # # ]: 0 : call slk_array_set_zero(chiq_rpr)
5142 : : end if
5143 : :
5144 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
5145 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0)
# # ]
5146 : 0 : if (print_time) call cwtime(cpu_ikf, wall_ikf, gflops_ikf, "start")
5147 [ # # ]: 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
5148 : :
5149 : : ! Use symmetries to get G_kbz(g,g') from the IBZ, then G_kbz(g,g') -> G_kbz(r',r).
5150 : : ! TODO: here I may need to take into account the umklapp
5151 : 0 : call gwr%get_gkbz_rpr_pm(ik_bz, itau, spin, gk_rpr_pm, ipm_list=[1]) ! g0=??
5152 : :
5153 : : ! Accumulate contribution to chi_q(r',r) with q in the IBZ.
5154 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5155 [ # # # # ]: 0 : if (gwr%dtset%symchi /= 0 .and. ltg_qibz(iq_ibz)%ibzq(ik_bz) == 0) cycle
5156 [ # # # # ]: 0 : qq_ibz = gwr%qibz(:,iq_ibz); kpq_bz = kk_bz + qq_ibz
5157 : :
5158 : 0 : call findqg0(ikq_bz, g0_kq, kpq_bz, gwr%nkbz, gwr%kbz, gwr%mG0)
5159 : : ! TODO: here I may need to take into account the umklapp if k+q is outside the BZ.
5160 : : !ABI_CHECK(all(g0_kq == 0), sjoin("g0_kq != 0, kk_bz", ktoa(kpq_bz), "qq_ibz:", ktoa(qq_ibz)))
5161 : :
5162 : : ! Use symmetries to get G_kqbz(g,g') from the IBZ, then G_kqbz(g,g') -> G_kqbz(r',r).
5163 : : ! Note that only G_kq(-itau) is needed.
5164 : 0 : call gwr%get_gkbz_rpr_pm(ikq_bz, itau, spin, gkq_rpr_pm, g0=g0_kq, ipm_list=[2])
5165 : :
5166 : : ! The weight depends on q_ibz and the symmetries of the little group of qq_ibz.
5167 : 0 : wtqp = one / gwr%nkbz; wtqm = zero
5168 [ # # ]: 0 : if (gwr%dtset%symchi /= 0) then
5169 [ # # ]: 0 : wtqp = (one * sum(ltg_qibz(iq_ibz)%wtksym(1,:,ik_bz))) / gwr%nkbz
5170 [ # # ]: 0 : wtqm = (one * sum(ltg_qibz(iq_ibz)%wtksym(2,:,ik_bz))) / gwr%nkbz
5171 : : !ABI_CHECK(wtqm == zero, sjoin("TR is not yet implemented:, wqtm:", ftoa(wtqm)))
5172 : : end if
5173 : :
5174 : : ! Accumulate.
5175 : :
5176 : : !chiq_rpr(iq_ibz)%buffer_cplx = chiq_rpr(iq_ibz)%buffer_cplx + &
5177 : : ! wtqp * gk_rpr_pm(1)%buffer_cplx * conjg(gkq_rpr_pm(2)%buffer_cplx) ! RECHECK EQ. This one works but requires ptrans with C
5178 : : ! !wtqp * gkq_rpr_pm(1)%buffer_cplx * conjg(gk_rpr_pm(2)%buffer_cplx) ! This should be OK
5179 [ # # ]: 0 : do iab=1,gwr%nsig_ab
5180 : : call cplx_mat_plus_bc(chiq_rpr(iq_ibz)%bufsize, chiq_rpr(iq_ibz)%buffer_cplx(:,1), &
5181 : 0 : wtqp+wtqm, "C", gkq_rpr_pm(2, iab)%buffer_cplx(:,1), gk_rpr_pm(1, iab)%buffer_cplx(:,1), gpu_option)
5182 : : end do ! iab
5183 : :
5184 : : end do ! iq_ibz
5185 : :
5186 [ # # ]: 0 : if (print_time) then
5187 : 0 : write(msg,'(4x,3(a,i0),a)')"Chi my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
5188 : 0 : call cwtime_report(msg, cpu_ikf, wall_ikf, gflops_ikf)
5189 : : end if
5190 : : end do ! my_ikf
5191 : :
5192 : : ! Deallocate got_kibz Green's functions.
5193 : 0 : call gwr%redistrib_gt_kibz(itau, spin, need_kibz, got_kibz, "free")
5194 : :
5195 : : ! From chi_q(r',r) to chi_q(g,g') for each q in the IBZ.
5196 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5197 : 0 : call xmpi_sum(chiq_rpr(iq_ibz)%buffer_cplx, gwr%kpt_comm%value, ierr)
5198 : : end do
5199 : :
5200 : 0 : tchi_rfact = one / gwr%cryst%ucvol
5201 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5202 [ # # # # : 0 : if (.not. any(iq_ibz == gwr%my_qibz_inds)) cycle
# # ]
5203 : 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%copy(chiq_ggp, empty=.True.)
5204 : 0 : call gwr%rpr_to_ggp(gwr%tchi_desc_qibz(iq_ibz), chiq_rpr(iq_ibz), tchi_rfact, chiq_ggp)
5205 : 0 : call chiq_ggp%copy(work1, empty=.True.)
5206 : :
5207 : : ! Here we symmetrize chi0 to get the integral in the BZ.
5208 : : ! This section is needed only if symchi /= 0.
5209 : : ! TODO: Timrev should be tested. At present is disabled.
5210 : : associate(desc => gwr%tchi_desc_qibz(iq_ibz), ltg => ltg_qibz(iq_ibz))
5211 : 0 : call gwr%rpr_to_ggp(gwr%tchi_desc_qibz(iq_ibz), chiq_rpr(iq_ibz), tchi_rfact, chiq_ggp)
5212 [ # # ]: 0 : do itim=1, ltg%timrev
5213 [ # # ]: 0 : do isym=1, ltg%nsym_sg
5214 [ # # ]: 0 : if (ltg%preserve(itim,isym) /= 1) cycle
5215 : : associate(sglist => desc%rottbm1(ltg%igmG0(1:desc%npw, itim, isym), itim, isym), &
5216 : 0 : phase => desc%phmGt(:, isym))
5217 : 0 : call slk_array_set_zero(work1)
5218 : : ! (g,g') --> (Sg, g')
5219 [ # # ]: 0 : do ig2=1,work1%size_local(2)
5220 [ # # ]: 0 : if (itim == 1) then
5221 [ # # ]: 0 : work1%buffer_cplx(:,ig2) = chiq_ggp%buffer_cplx(sglist, ig2) * phase
5222 : : else
5223 [ # # ]: 0 : work1%buffer_cplx(:,ig2) = GWPC_CONJG(chiq_ggp%buffer_cplx(sglist, ig2)) * phase
5224 : : end if
5225 : : end do
5226 : : ! (Sg, g') --> (g', Sg)
5227 : 0 : call work1%ptrans("C", work2, free=.False.)
5228 : : ! (g', Sg) --> (Sg', Sg)
5229 [ # # ]: 0 : do ig2=1,work2%size_local(2)
5230 [ # # # # : 0 : work2%buffer_cplx(:,ig2) = work2%buffer_cplx(sglist, ig2) * phase
# # ]
5231 : : end do
5232 : : ! (Sg', Sg) --> (Sg, Sg')
5233 : 0 : call work2%ptrans("C", work1, free=.True.)
5234 [ # # # # : 0 : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) = gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:)+work1%buffer_cplx(:,:)
# # # # #
# ]
5235 : : end associate
5236 : : end do ! isym
5237 : : end do ! itim
5238 : :
5239 : 0 : call work1%free()
5240 : : gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) = gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx(:,:) &
5241 [ # # # # ]: 0 : & / ltg%nsym_ltg
5242 : :
5243 : : end associate
5244 : 0 : call chiq_ggp%free()
5245 : : end do ! iq_ibz
5246 : :
5247 : 0 : write(msg,'(3(a,i0),a)')" My itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
5248 : 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau)
5249 : : end do ! my_it
5250 : : end do ! spin
5251 : :
5252 : : ! Free memory
5253 : 0 : call slk_array_free(gk_rpr_pm); call slk_array_free(gkq_rpr_pm); call slk_array_free(chiq_rpr)
5254 [ # # # # : 0 : ABI_FREE(chiq_rpr)
# # # # #
# ]
5255 : :
5256 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5257 : 0 : call ltg_qibz(iq_ibz)%free()
5258 : : end do
5259 [ # # # # : 0 : ABI_FREE(ltg_qibz)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5260 : 0 : call wrtout(std_out, " Mixed space algorithm for chi completed.")
5261 : :
5262 : : end if ! super cell or mixed space algorithm.
5263 : : !call wrtout(std_out, sjoin(" max_abs_imag_chit", ftoa(max_abs_imag_chit)))
5264 : :
5265 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
5266 : :
5267 : : ! Print trace of chi_q(i tau) matrices for testing purposes.
5268 [ # # ]: 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "tchi_qibz")
5269 : :
5270 : : ! Write tchi(i tau). NB: this option is not documented in the docs.
5271 : 0 : keep_tchim = .False.
5272 [ # # ]: 0 : if (gwr%dtset%prtsuscep == -1) then
5273 [ # # ]: 0 : call gwr%ncwrite_tchi_wc("tchi", "tau", keep_tchim, trim(gwr%dtfil%filnam_ds(4))//'_TCHIM.nc')
5274 : 0 : keep_tchim = .True.
5275 : : end if
5276 : :
5277 : : ! Transform irreducible tchi from imaginary tau to imaginary omega.
5278 : : ! Also, sum over spins to get total tchi if collinear spin.
5279 : 0 : call gwr%cos_transform("tchi", "it2w", sum_spins=.True.)
5280 : :
5281 [ # # ]: 0 : if (gwr%kpt_comm%me == 0) then
5282 : : ! ===================================================
5283 : : ! ==== Construct head and wings from the tensor =====
5284 : : ! ===================================================
5285 : : associate (desc_q0 => gwr%tchi_desc_qibz(1), mat_ts => gwr%tchi_qibz(1,:,:))
5286 : 0 : ABI_CHECK_IEQ(desc_q0%ig0, 1, "ig0 should be 1")
5287 [ # # # # : 0 : ABI_MALLOC(up_wing_q, (desc_q0%npw))
# # # # #
# # # ]
5288 [ # # # # : 0 : ABI_MALLOC(low_wing_q, (desc_q0%npw))
# # # # ]
5289 : :
5290 [ # # # # ]: 0 : do my_is=1,gwr%my_nspins
5291 : 0 : spin = gwr%my_spins(my_is)
5292 [ # # ]: 0 : do my_it=1,gwr%my_ntau
5293 : 0 : itau = gwr%my_itaus(my_it)
5294 : :
5295 [ # # ]: 0 : do ig=2,desc_q0%npw
5296 [ # # ]: 0 : wng = gwr%chi0_uwing_myw(:,ig, my_it)
5297 : 0 : up_wing_q(ig) = vdotw(gwr%q0, wng, gwr%cryst%gmet, "G")
5298 [ # # ]: 0 : wng = gwr%chi0_lwing_myw(:,ig,my_it)
5299 : 0 : low_wing_q(ig) = vdotw(gwr%q0, wng, gwr%cryst%gmet, "G")
5300 : : end do
5301 [ # # # # : 0 : chq = matmul(gwr%chi0_head_myw(:,:,my_it), gwr%q0)
# # # # #
# ]
5302 : 0 : head_q = vdotw(gwr%q0, chq, gwr%cryst%gmet, "G")
5303 : :
5304 : 0 : call mat_ts(itau, spin)%set_head_and_wings(head_q, low_wing_q, up_wing_q)
5305 : : end do ! my_it
5306 : : end do ! my_is
5307 : : end associate
5308 [ # # ]: 0 : ABI_FREE(up_wing_q)
5309 [ # # ]: 0 : ABI_FREE(low_wing_q)
5310 : : end if
5311 : :
5312 : : ! Print trace of chi_q(i omega) matrices for testing purposes.
5313 [ # # ]: 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "tchi_qibz")
5314 : :
5315 : : ! Write file with chi0(i omega).
5316 [ # # ]: 0 : if (abs(gwr%dtset%prtsuscep) == 1) then
5317 [ # # ]: 0 : call gwr%ncwrite_tchi_wc("tchi", "omega", keep_tchim, trim(gwr%dtfil%filnam_ds(4))//'_TCHIM.nc')
5318 : : end if
5319 : :
5320 : 0 : call cwtime_report(" gwr_build_tchi:", cpu_all, wall_all, gflops_all)
5321 [ # # # # : 0 : call timab(1923, 2, tsec)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5322 : :
5323 : : contains
5324 : :
5325 : 0 : subroutine print_chi_header()
5326 [ # # ]: 0 : if (gwr%comm%me /= 0) return
5327 [ # # ]: 0 : if (gwr%use_supercell_for_tchi) then
5328 : 0 : call wrtout(std_out, " Building chi0(r,R, itau) in the supercell with FFTs ", pre_newlines=2)
5329 : : else
5330 : 0 : call wrtout(std_out, " Building chi_q(r,r', itau) with convolutions in k-space:", pre_newlines=2)
5331 : : end if
5332 : 0 : call wrtout(std_out, sjoin(" gwr_np_kgts:", ltoa(gwr%dtset%gwr_np_kgts)))
5333 : 0 : call wrtout(std_out, sjoin(" ngkpt:", ltoa(gwr%ngkpt), ", ngqpt:", ltoa(gwr%ngqpt)))
5334 : 0 : call wrtout(std_out, sjoin(" gwr_boxcutmin:", ftoa(gwr%dtset%gwr_boxcutmin)))
5335 : 0 : call wrtout(std_out, sjoin(" sc_ngfft:", ltoa(sc_ngfft(1:8))))
5336 : 0 : call wrtout(std_out, sjoin(" my_ntau:", itoa(gwr%my_ntau), ", ntau:", itoa(gwr%ntau)))
5337 : 0 : call wrtout(std_out, sjoin(" my_nkbz:", itoa(gwr%my_nkbz), ", nkbz:", itoa(gwr%nkbz)))
5338 : 0 : call wrtout(std_out, sjoin(" my_nkibz:", itoa(gwr%my_nkibz), ", nkibz:", itoa(gwr%nkibz)))
5339 : 0 : call wrtout(std_out, sjoin("- FFT uc_batch_size:", itoa(gwr%uc_batch_size)))
5340 : 0 : call wrtout(std_out, sjoin("- FFT sc_batch_size:", itoa(gwr%sc_batch_size)), do_flush=.True.)
5341 : : end subroutine print_chi_header
5342 : :
5343 : : end subroutine gwr_build_tchi
5344 : : !!***
5345 : :
5346 : : !----------------------------------------------------------------------
5347 : :
5348 : : !!****f* m_gwr/gwr_redistrib_gt_kibz
5349 : : !! NAME
5350 : : !! gwr_redistrib_gt_kibz
5351 : : !!
5352 : : !! FUNCTION
5353 : : !! Redistribute/deallocate G_k
5354 : : !!
5355 : : !! If action == "communicate":
5356 : : !! Redistribute G_k for fixed (itau, spin) according to `need_kibz` table.
5357 : : !! Also, set got_kibz to 1 for each IBZ k-point that has been received.
5358 : : !!
5359 : : !! If action == "free":
5360 : : !! Use input `got_kibz` array to deallocate matrices received in a previous call.
5361 : : !!
5362 : : !! INPUTS
5363 : : !!
5364 : : !! OUTPUT
5365 : : !!
5366 : : !! SOURCE
5367 : :
5368 : 0 : subroutine gwr_redistrib_gt_kibz(gwr, itau, spin, need_kibz, got_kibz, action)
5369 : :
5370 : : !Arguments ------------------------------------
5371 : : class(gwr_t),target,intent(inout) :: gwr
5372 : : integer,intent(in) :: itau, spin, need_kibz(gwr%nkibz)
5373 : : integer,intent(inout) :: got_kibz(gwr%nkibz)
5374 : : character(len=*),intent(in) :: action
5375 : : !integer,optional,intent(in) :: ipm_list(:)
5376 : :
5377 : : !Local variables-------------------------------
5378 : 0 : integer :: ik_ibz, ipm, ierr, do_mpi_kibz(gwr%nkibz), sender_kibz(gwr%nkibz)
5379 : : integer :: bcast_comm, sender_in_bcast_comm, color, iab
5380 : : logical :: im_sender
5381 : : !integer :: num_pm, ipm_list__(2)
5382 : : real(dp) :: kk_ibz(3), cpu, wall, gflops
5383 : 0 : complex(gwp),contiguous, pointer :: ck_ptr(:,:)
5384 : : ! *************************************************************************
5385 : :
5386 : 0 : call cwtime(cpu, wall, gflops, "start")
5387 : :
5388 : : !num_pm = 2; ipm_list__ = [1, 2]
5389 : : !if (present(ipm_list)) then
5390 : : ! num_pm = size(ipm_list)
5391 : : ! ABI_CHECK_IRANGE(num_pm, 1, 2, "num_pm not in [1, 2]")
5392 : : ! ipm_list__(1:num_pm) = ipm_list(:)
5393 : : !end if
5394 : :
5395 : : select case (action)
5396 : : case ("communicate")
5397 [ # # ]: 0 : do_mpi_kibz = need_kibz
5398 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
5399 [ # # ]: 0 : if (allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) do_mpi_kibz(ik_ibz) = 0
5400 : : end do
5401 : 0 : call xmpi_sum(do_mpi_kibz, gwr%kpt_comm%value, ierr)
5402 : : !do_mpi_kibz = 1
5403 : :
5404 : : ! All procs enter the loop. Sender_kibz stores the rank of the sender in gwr%kpt_comm
5405 [ # # # # ]: 0 : got_kibz = 0; sender_kibz(:) = huge(1)
5406 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
5407 [ # # ]: 0 : if (do_mpi_kibz(ik_ibz) == 0) cycle
5408 [ # # ]: 0 : kk_ibz = gwr%kibz(:, ik_ibz)
5409 [ # # ]: 0 : if (allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) sender_kibz(ik_ibz) = gwr%kpt_comm%me
5410 [ # # # # ]: 0 : if (need_kibz(ik_ibz) /= 0 .and. .not. allocated(gwr%green_desc_kibz(ik_ibz)%gvec)) then
5411 : : ! NB: Use same args as those used to init the descriptors in gwr_init
5412 : : ! so that the ordering of gvec is consistent across MPI procs.
5413 : 0 : got_kibz(ik_ibz) = 1
5414 : 0 : call gwr%green_desc_kibz(ik_ibz)%init(kk_ibz, istwfk1, gwr%dtset%ecutwfn, gwr)
5415 : : end if
5416 : : end do
5417 : :
5418 : : ! Define the sender for each kibz in do_mpi_kibz.
5419 : 0 : call xmpi_min_ip(sender_kibz, gwr%kpt_comm%value, ierr)
5420 : :
5421 : : ! Allocate memory
5422 : 0 : call gwr%malloc_free_mats(got_kibz, "green", "malloc")
5423 : :
5424 : : ! MPI communication
5425 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
5426 [ # # ]: 0 : if (do_mpi_kibz(ik_ibz) == 0) cycle
5427 : :
5428 : : ! Create subcommunicators with color and bcast only inside subcomm.
5429 : 0 : im_sender = gwr%kpt_comm%me == sender_kibz(ik_ibz)
5430 [ # # # # ]: 0 : color = merge(1, 0, im_sender .or. need_kibz(ik_ibz) /= 0)
5431 : 0 : call xmpi_comm_split(gwr%kpt_comm%value, color, gwr%kpt_comm%me, bcast_comm, ierr)
5432 : :
5433 [ # # ]: 0 : if (color == 1) then
5434 : 0 : sender_in_bcast_comm = xmpi_comm_translate_rank(gwr%kpt_comm%value, sender_kibz(ik_ibz), bcast_comm)
5435 [ # # ]: 0 : do ipm=1,2
5436 [ # # ]: 0 : do iab=1,gwr%nsig_ab
5437 : 0 : ck_ptr => gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%buffer_cplx
5438 : 0 : call xmpi_bcast(ck_ptr, sender_in_bcast_comm, bcast_comm, ierr)
5439 : : end do
5440 : : end do
5441 : : end if
5442 : 0 : call xmpi_comm_free(bcast_comm)
5443 : : end do
5444 : :
5445 : : case ("free")
5446 : : ! Use got_kibz to free previously allocated memory.
5447 [ # # ]: 0 : do ik_ibz=1,gwr%nkibz
5448 [ # # ]: 0 : if (got_kibz(ik_ibz) == 1) call gwr%green_desc_kibz(ik_ibz)%free()
5449 : : end do
5450 : 0 : call gwr%malloc_free_mats(got_kibz, "green", "free")
5451 : :
5452 : : case default
5453 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid action:", action))
5454 : : end select
5455 : :
5456 [ # # ]: 0 : if (action == "communicate") call cwtime_report(" gwr_redistrib_gt_kibz:", cpu, wall, gflops)
5457 : :
5458 : 0 : end subroutine gwr_redistrib_gt_kibz
5459 : : !!***
5460 : :
5461 : : !!****f* m_gwr/gwr_redistrib_mats_qibz
5462 : : !! NAME
5463 : : !! gwr_redistrib_mats_qibz
5464 : : !!
5465 : : !! FUNCTION
5466 : : !! If action == "communicate":
5467 : : !! Redistribute chi_q (wc_q) for fixed (itau, spin) according to `need_qibz` table.
5468 : : !! Also, set `got_qibz` to 1 for each IBZ q-point that has been received.
5469 : : !! If action == "free":
5470 : : !! Use `got_qibz` to deallocate matrices received in a previous call with "communicate".
5471 : : !!
5472 : : !! INPUTS
5473 : : !!
5474 : : !! OUTPUT
5475 : : !!
5476 : : !! SOURCE
5477 : :
5478 : 0 : subroutine gwr_redistrib_mats_qibz(gwr, what, itau, spin, need_qibz, got_qibz, action)
5479 : :
5480 : : !Arguments ------------------------------------
5481 : : class(gwr_t),target,intent(inout) :: gwr
5482 : : character(len=*),intent(in) :: what
5483 : : integer,intent(in) :: itau, spin, need_qibz(gwr%nqibz)
5484 : : integer,intent(inout) :: got_qibz(gwr%nqibz)
5485 : : character(len=*),intent(in) :: action
5486 : :
5487 : : !Local variables-------------------------------
5488 : 0 : integer :: iq_ibz, ierr, bcast_comm, color, do_mpi_qibz(gwr%nqibz), sender_qibz(gwr%nqibz), sender_in_bcast_comm
5489 : : logical :: im_sender
5490 : : logical, parameter :: timeit = .False.
5491 : : real(dp) :: qq_ibz(3), cpu, wall, gflops
5492 : 0 : complex(gwp),contiguous, pointer :: cq_ptr(:,:)
5493 : : ! *************************************************************************
5494 : :
5495 [ # # ]: 0 : ABI_CHECK(what == "tchi" .or. what == "wc", sjoin("Invalid what:", what))
5496 : : if (timeit) call cwtime(cpu, wall, gflops, "start")
5497 : :
5498 : : select case (action)
5499 : : case ("communicate")
5500 [ # # ]: 0 : do_mpi_qibz = need_qibz
5501 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5502 : 0 : select case (what)
5503 : : case ("tchi")
5504 [ # # ]: 0 : if (allocated(gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx)) do_mpi_qibz(iq_ibz) = 0
5505 : : case ("wc")
5506 [ # # ]: 0 : if (allocated(gwr%wc_qibz(iq_ibz, itau, spin)%buffer_cplx)) do_mpi_qibz(iq_ibz) = 0
5507 : : case default
5508 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid what:", what))
5509 : : end select
5510 : : end do
5511 : :
5512 : 0 : call xmpi_sum(do_mpi_qibz, gwr%kpt_comm%value, ierr)
5513 : : !do_mpi_qibz = 1
5514 : :
5515 : : ! All procs enter the loop. Sender_qibz stores the rank of the sender in gwr%kpt_comm
5516 [ # # # # ]: 0 : got_qibz = 0; sender_qibz(:) = huge(1)
5517 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5518 [ # # ]: 0 : if (do_mpi_qibz(iq_ibz) == 0) cycle
5519 [ # # ]: 0 : qq_ibz = gwr%qibz(:, iq_ibz)
5520 [ # # ]: 0 : if (allocated(gwr%tchi_desc_qibz(iq_ibz)%gvec)) sender_qibz(iq_ibz) = gwr%kpt_comm%me
5521 [ # # # # ]: 0 : if (need_qibz(iq_ibz) /= 0 .and. .not. allocated(gwr%tchi_desc_qibz(iq_ibz)%gvec)) then
5522 : : ! NB: Use same args as those used to init the descriptors in gwr_init
5523 : : ! so that gvec ordering is consistent across MPI procs.
5524 : 0 : got_qibz(iq_ibz) = 1
5525 : 0 : call gwr%tchi_desc_qibz(iq_ibz)%init(qq_ibz, istwfk1, gwr%dtset%ecuteps, gwr, kin_sorted=.True.)
5526 : : end if
5527 : : end do
5528 : :
5529 : : ! Define the sender for each qibz in do_mpi_qibz
5530 : 0 : call xmpi_min_ip(sender_qibz, gwr%kpt_comm%value, ierr)
5531 : :
5532 : : ! Allocate memory
5533 : 0 : call gwr%malloc_free_mats(got_qibz, what, "malloc")
5534 : :
5535 : : ! MPI communication
5536 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5537 [ # # ]: 0 : if (do_mpi_qibz(iq_ibz) == 0) cycle
5538 : :
5539 : : ! Create subcommunicators with color and bcast only inside subcomm.
5540 : 0 : im_sender = gwr%kpt_comm%me == sender_qibz(iq_ibz)
5541 [ # # # # ]: 0 : color = merge(1, 0, im_sender .or. need_qibz(iq_ibz) /= 0)
5542 : 0 : call xmpi_comm_split(gwr%kpt_comm%value, color, gwr%kpt_comm%me, bcast_comm, ierr)
5543 : :
5544 [ # # ]: 0 : if (color == 1) then
5545 [ # # ]: 0 : if (what == "tchi") cq_ptr => gwr%tchi_qibz(iq_ibz, itau, spin)%buffer_cplx
5546 [ # # ]: 0 : if (what == "wc") cq_ptr => gwr%wc_qibz(iq_ibz, itau, spin)%buffer_cplx
5547 : 0 : sender_in_bcast_comm = xmpi_comm_translate_rank(gwr%kpt_comm%value, sender_qibz(iq_ibz), bcast_comm)
5548 : 0 : call xmpi_bcast(cq_ptr, sender_in_bcast_comm, bcast_comm, ierr)
5549 : : end if
5550 : 0 : call xmpi_comm_free(bcast_comm)
5551 : : end do ! iq_ibz
5552 : :
5553 : : case ("free")
5554 : : ! Use got_qibz table to free previously allocated memory
5555 [ # # ]: 0 : do iq_ibz=1,gwr%nqibz
5556 [ # # ]: 0 : if (got_qibz(iq_ibz) /= 0) call gwr%tchi_desc_qibz(iq_ibz)%free()
5557 : : end do
5558 : 0 : call gwr%malloc_free_mats(got_qibz, what, "free")
5559 : :
5560 : : case default
5561 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid action:", action))
5562 : : end select
5563 : :
5564 : : if (timeit) call cwtime_report(" gwr_redistrib_mats_qibz:", cpu, wall, gflops)
5565 : :
5566 [ # # ]: 0 : end subroutine gwr_redistrib_mats_qibz
5567 : : !!***
5568 : :
5569 : : !----------------------------------------------------------------------
5570 : :
5571 : : !!****f* m_gwr/gwr_print_trace
5572 : : !! NAME
5573 : : !! gwr_print_trace
5574 : : !!
5575 : : !! FUNCTION
5576 : : !! Print traces of PBLAS matrices to units.
5577 : : !! NB: This is a global routine that should be called by all procs inside gwr%comm.
5578 : : !!
5579 : : !! INPUTS
5580 : : !!
5581 : : !! OUTPUT
5582 : : !!
5583 : : !! SOURCE
5584 : :
5585 [ # # ]: 0 : subroutine gwr_print_trace(gwr, units, what)
5586 : :
5587 : : !Arguments ------------------------------------
5588 : : class(gwr_t),target,intent(inout) :: gwr
5589 : : integer,intent(in) :: units(:)
5590 : : character(len=*),intent(in) :: what
5591 : :
5592 : : !Local variables-------------------------------
5593 : : integer,parameter :: master = 0
5594 : : integer :: my_is, spin, my_it, itau, iq_ibz, ierr, my_iqi, my_iki, ik_ibz, ipm, iab
5595 : : character(len=5000) :: comment
5596 : 0 : complex(dp),allocatable :: ctrace3(:,:,:), ctrace5(:,:,:,:,:) !, ctrace4(:,:,:,:)
5597 : 0 : type(__slkmat_t),contiguous, pointer :: mats(:,:,:)
5598 : : ! *************************************************************************
5599 : :
5600 : : ! NB: The same q/k point in the IBZ might be available on different procs in kpt_comm
5601 : : ! hence we have to rescale the trace before summing the results in gwr%comm.
5602 : 0 : comment = "Invalid space!"
5603 : :
5604 : 0 : select case (what)
5605 : : case ("tchi_qibz", "wc_qibz")
5606 : : ! Trace of tchi or Wc
5607 [ # # # # : 0 : ABI_CALLOC(ctrace3, (gwr%nqibz, gwr%ntau, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5608 : :
5609 [ # # ]: 0 : if (what == "tchi_qibz") then
5610 : 0 : mats => gwr%tchi_qibz
5611 [ # # ]: 0 : if (gwr%tchi_space == "iomega") comment = " (iq_ibz, iomega) table"
5612 [ # # ]: 0 : if (gwr%tchi_space == "itau") comment = " (iq_ibz, itau) table"
5613 [ # # ]: 0 : else if (what == "wc_qibz") then
5614 : 0 : mats => gwr%wc_qibz
5615 [ # # ]: 0 : if (gwr%wc_space == "iomega") comment = " (iq_ibz, iomega) table"
5616 [ # # ]: 0 : if (gwr%wc_space == "itau") comment = " (iq_ibz, itau) table"
5617 : : end if
5618 : :
5619 [ # # ]: 0 : do my_is=1,gwr%my_nspins
5620 : 0 : spin = gwr%my_spins(my_is)
5621 [ # # ]: 0 : do my_it=1,gwr%my_ntau
5622 : 0 : itau = gwr%my_itaus(my_it)
5623 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
5624 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
5625 : 0 : ctrace3(iq_ibz, itau, spin) = mats(iq_ibz, itau, spin)%get_trace() / gwr%np_qibz(iq_ibz)
5626 : : end do
5627 : : end do
5628 : : end do
5629 : :
5630 : 0 : call xmpi_sum_master(ctrace3, 0, gwr%kts_comm%value, ierr)
5631 : :
5632 [ # # ]: 0 : if (gwr%comm%me == master) then
5633 [ # # ]: 0 : do spin=1,gwr%nsppol
5634 : 0 : call wrtout(units, sjoin(" Trace of:", what, "for spin:", itoa(spin), "for testing purposes:"))
5635 : 0 : call wrtout(units, comment, pre_newlines=2)
5636 : 0 : call print_arr(units, ctrace3(:,:,spin))
5637 : : end do
5638 : : end if
5639 [ # # ]: 0 : ABI_FREE(ctrace3)
5640 : :
5641 : : case ("gt_kibz")
5642 : : ! Trace of Green's functions.
5643 [ # # # # : 0 : ABI_CALLOC(ctrace5, (gwr%nkibz, gwr%ntau, 2, gwr%nsppol, gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5644 : :
5645 [ # # ]: 0 : do my_is=1,gwr%my_nspins
5646 : 0 : spin = gwr%my_spins(my_is)
5647 [ # # ]: 0 : do my_it=1,gwr%my_ntau
5648 : 0 : itau = gwr%my_itaus(my_it)
5649 [ # # ]: 0 : do my_iki=1,gwr%my_nkibz
5650 : 0 : ik_ibz = gwr%my_kibz_inds(my_iki)
5651 [ # # ]: 0 : do ipm=1,2
5652 [ # # ]: 0 : do iab=1,gwr%nsig_ab
5653 : 0 : ctrace5(ik_ibz, itau, ipm, spin, iab) = gwr%gt_kibz(ipm, ik_ibz, itau, spin, iab)%get_trace() / gwr%np_kibz(ik_ibz)
5654 : : end do
5655 : : end do
5656 : : end do
5657 : : end do
5658 : : end do
5659 : 0 : comment = " (ik_ibz, itau) table"
5660 : :
5661 : 0 : call xmpi_sum_master(ctrace5, master, gwr%kts_comm%value, ierr)
5662 : :
5663 [ # # ]: 0 : if (gwr%comm%me == master) then
5664 [ # # ]: 0 : do spin=1,gwr%nsppol
5665 [ # # ]: 0 : do ipm=1,2
5666 [ # # ]: 0 : do iab=1,gwr%nsig_ab
5667 [ # # ]: 0 : if (gwr%nspinor == 2) then
5668 : 0 : call wrtout(units, sjoin(" Trace of:", what, "for ipm:", itoa(ipm), ", spin:", itoa(spin), ", iab:", itoa(iab), "for testing purposes:"))
5669 : : else
5670 : 0 : call wrtout(units, sjoin(" Trace of:", what, "for ipm:", itoa(ipm), ", spin:", itoa(spin), "for testing purposes:"))
5671 : : end if
5672 : 0 : call wrtout(units, comment, newlines=1)
5673 : 0 : call print_arr(units, ctrace5(:,:, ipm, spin, iab))
5674 : : end do
5675 : : end do
5676 : : end do
5677 : : end if
5678 [ # # ]: 0 : ABI_FREE(ctrace5)
5679 : :
5680 : : case default
5681 : 0 : ABI_ERROR(sjoin("Invalid value of what:", what))
5682 : : end select
5683 : :
5684 [ # # # # : 0 : end subroutine gwr_print_trace
# # # ]
5685 : : !!***
5686 : :
5687 : : !----------------------------------------------------------------------
5688 : :
5689 : : !!****f* m_gwr/gwr_build_wc
5690 : : !! NAME
5691 : : !! gwr_build_wc
5692 : : !!
5693 : : !! FUNCTION
5694 : : !! Compute Wc(i tau,g,g') from tchi(i omega,g,g')
5695 : : !!
5696 : : !! INPUTS
5697 : : !!
5698 : : !! OUTPUT
5699 : : !!
5700 : : !! SOURCE
5701 : :
5702 : 0 : subroutine gwr_build_wc(gwr)
5703 : :
5704 : : !Arguments ------------------------------------
5705 : : class(gwr_t),target,intent(inout) :: gwr
5706 : :
5707 : : !Local variables-------------------------------
5708 : : !scalars
5709 : : integer,parameter :: master = 0
5710 : : integer :: my_iqi, my_it, my_is, iq_ibz, spin, itau, iw, ierr, npwe
5711 : : integer :: il_g1, il_g2, ig1, ig2, iglob1, iglob2, ig0
5712 : : real(dp) :: cpu_all, wall_all, gflops_all, cpu_q, wall_q, gflops_q, i_sz !, cpu_tmp, wall_tmp, gflops_tmp
5713 : : logical :: q_is_gamma, free_tchi, print_time, keep_wcimw
5714 : : character(len=5000) :: msg
5715 : : complex(dp) :: vcs_g1, vcs_g2
5716 [ # # # # : 0 : type(__slkmat_t) :: em1
# # ]
5717 : : type(yamldoc_t) :: ydoc
5718 : : !arrays
5719 : : integer :: units(2)
5720 : : real(dp) :: qq_ibz(3), tsec(2)
5721 : 0 : complex(dp) :: em1_wq(gwr%ntau, gwr%nqibz), eps_wq(gwr%ntau, gwr%nqibz)
5722 : : ! *************************************************************************
5723 : :
5724 : : ABI_NVTX_START_RANGE(NVTX_GWR_BUILD_WC)
5725 [ # # ]: 0 : units = [std_out, ab_out]
5726 : :
5727 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
5728 : 0 : call timab(1924, 1, tsec)
5729 : 0 : call wrtout(units, " Building correlated screening Wc(i omega) ...", pre_newlines=2)
5730 : :
5731 : 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in epsilon and W", gwr%dtset%prtvol)
5732 : :
5733 [ # # ]: 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("tchi_space: ", gwr%tchi_space, " != iomega"))
5734 : :
5735 [ # # ]: 0 : if (allocated(gwr%wc_qibz)) then
5736 : 0 : call slk_array_free(gwr%wc_qibz)
5737 [ # # # # : 0 : ABI_FREE(gwr%wc_qibz)
# # # # #
# ]
5738 : 0 : gwr%wc_space = "none"
5739 : : end if
5740 : :
5741 [ # # ]: 0 : ABI_CHECK(gwr%wc_space == "none", sjoin("wc_space: ", gwr%wc_space, " != none"))
5742 : 0 : gwr%wc_space = "iomega"
5743 : :
5744 : : ! =======================================
5745 : : ! Allocate PBLAS arrays for wc_qibz(g,g')
5746 : : ! =======================================
5747 : : ! Note that we have already summed tchi over spin.
5748 : : ! Also, G=0 corresponds to iglob = 1 as only q-points in the IBZ are treated here.
5749 : : ! This is not true for the other q-points in the full BZ as we may have a non-zero umklapp g0_q.
5750 [ # # # # : 0 : ABI_MALLOC(gwr%wc_qibz, (gwr%nqibz, gwr%ntau, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5751 : :
5752 : 0 : free_tchi = .True.; if (free_tchi) gwr%tchi_space = "none"
5753 [ # # # # : 0 : em1_wq = zero; eps_wq = zero
# # # # ]
5754 : :
5755 : : ! If possible, use 2d rectangular grid of processors for diagonalization.
5756 : : !call slkproc_4diag%init(gwr%g_comm%value)
5757 : :
5758 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
5759 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (my_iqi <= LOG_MODK .or. mod(my_iqi, LOG_MODK) == 0)
# # ]
5760 : 0 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
5761 [ # # ]: 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
5762 : 0 : q_is_gamma = normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0
5763 : :
5764 : : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
5765 : 0 : ig0 = desc_q%ig0
5766 : 0 : npwe = desc_q%npw
5767 : :
5768 : : ! The spin loop is needed so that procs in different pools can operate
5769 : : ! on their own matrix that has been already summed over (collinear) spins.
5770 [ # # ]: 0 : do my_is=1,gwr%my_nspins
5771 : 0 : spin = gwr%my_spins(my_is)
5772 [ # # ]: 0 : do my_it=1,gwr%my_ntau
5773 : 0 : itau = gwr%my_itaus(my_it)
5774 : :
5775 : : ! Build symmetrized RPA epsilon: 1 - Vc^{1/2} chi0 Vc^{1/2}
5776 : : ! Note vc_sqrt_eps here.
5777 : 0 : associate (wc => gwr%wc_qibz(iq_ibz, itau, spin))
5778 : 0 : call gwr%tchi_qibz(iq_ibz, itau, spin)%copy(wc)
5779 : 0 : if (free_tchi) call gwr%tchi_qibz(iq_ibz, itau, spin)%free()
5780 : :
5781 [ # # ]: 0 : do il_g2=1,wc%size_local(2)
5782 : 0 : iglob2 = wc%loc2gcol(il_g2)
5783 : 0 : ig2 = mod(iglob2 - 1, desc_q%npw) + 1
5784 : 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2)
5785 [ # # ]: 0 : do il_g1=1,wc%size_local(1)
5786 : 0 : iglob1 = wc%loc2grow(il_g1)
5787 : 0 : ig1 = mod(iglob1 - 1, desc_q%npw) + 1
5788 : 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1)
5789 : 0 : wc%buffer_cplx(il_g1, il_g2) = -wc%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2
5790 [ # # ]: 0 : if (iglob1 == iglob2) then
5791 : 0 : wc%buffer_cplx(il_g1, il_g2) = one + wc%buffer_cplx(il_g1, il_g2)
5792 [ # # ]: 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5793 : : ! Store epsilon_{iw, iq_ibz}(0, 0). Rescale by np_qibz because we will MPI reduce this array.
5794 : 0 : eps_wq(itau, iq_ibz) = wc%buffer_cplx(il_g1, il_g2) / gwr%np_qibz(iq_ibz)
5795 : : end if
5796 : : end if
5797 : : end do ! il_g1
5798 : : end do ! il_g2
5799 : :
5800 : : ! Invert symmetrized epsilon.
5801 : : ! NB: PZGETRF requires square block cyclic decomposition along the two axes
5802 : : ! hence we have to redistribute the data before calling invert and then
5803 : : ! go back to colum-distribution, that is: wc --> em1 --> wc
5804 : :
5805 : 0 : call wc%change_size_blocs(em1) ! processor=slkproc_4diag
5806 : : ! Use hpd_invert as eps along imag axis is always hermitian.
5807 : : !call em1%invert()
5808 : 0 : call em1%hpd_invert("U")
5809 : 0 : call wc%take_from(em1, free=.True.) ! processor=wc%processor)
5810 : :
5811 : : !call wrtout(std_out, sjoin(" e-1 at q:", ktoa(qq_ibz), "i omega:", ftoa(gwr%iw_mesh(itau) * Ha_eV), "eV"))
5812 : : !call print_arr(units, wc%buffer_cplx)
5813 : :
5814 : : ! Build Wc(q, iw) = e^{-1}_q(g,g',iw) - delta_{gg'} v_q(g,g') by removing bare vc.
5815 [ # # ]: 0 : do il_g2=1,wc%size_local(2)
5816 : 0 : iglob2 = wc%loc2gcol(il_g2)
5817 : 0 : ig2 = mod(iglob2 - 1, desc_q%npw) + 1
5818 : 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2)
5819 [ # # ]: 0 : if (gwr%has_vcgen_sigma) vcs_g2 = desc_q%vc_sqrt_sigma(ig2)
5820 [ # # ]: 0 : do il_g1=1,wc%size_local(1)
5821 : 0 : iglob1 = wc%loc2grow(il_g1)
5822 : 0 : ig1 = mod(iglob1 - 1, desc_q%npw) + 1
5823 : 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1)
5824 [ # # ]: 0 : if (gwr%has_vcgen_sigma) vcs_g1 = desc_q%vc_sqrt_sigma(ig1)
5825 : :
5826 [ # # ]: 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5827 : : ! Store epsilon^{-1}_{iw, iq_ibz}(0, 0). Rescale by np_qibz because we will MPI reduce this array.
5828 : 0 : em1_wq(itau, iq_ibz) = wc%buffer_cplx(il_g1, il_g2) / gwr%np_qibz(iq_ibz)
5829 : : end if
5830 : :
5831 : : ! Subtract exchange part.
5832 [ # # ]: 0 : if (iglob1 == iglob2) wc%buffer_cplx(il_g1, il_g2) = wc%buffer_cplx(il_g1, il_g2) - one
5833 : :
5834 : : ! Handle divergence in Wc for q --> 0
5835 : : ! Here we always use vcgen_eps
5836 : 0 : i_sz = gwr%vcgen_eps%i_sz
5837 [ # # ]: 0 : if (gwr%has_vcgen_sigma) i_sz = gwr%vcgen_sigma%i_sz
5838 : :
5839 [ # # # # ]: 0 : if (q_is_gamma .and. (iglob1 == ig0 .or. iglob2 == ig0)) then
5840 [ # # ]: 0 : if (iglob1 == ig0 .and. iglob2 == ig0) then
5841 : 0 : vcs_g1 = sqrt(i_sz); vcs_g2 = sqrt(i_sz)
5842 [ # # ]: 0 : else if (iglob1 == ig0) then
5843 : 0 : vcs_g1 = sqrt(i_sz)
5844 [ # # ]: 0 : else if (iglob2 == ig0) then
5845 : 0 : vcs_g2 = sqrt(i_sz)
5846 : : end if
5847 : : end if
5848 : :
5849 : 0 : wc%buffer_cplx(il_g1, il_g2) = wc%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2 / gwr%cryst%ucvol
5850 : : end do ! il_g1
5851 : : end do ! il_g2
5852 : : end associate
5853 : :
5854 : : end do ! my_it
5855 : : end do ! my_is
5856 : : end associate
5857 : :
5858 [ # # ]: 0 : if (print_time) then
5859 : 0 : write(msg,'(4x,2(a,i0),a)')"My iq_ibz [", my_iqi, "/", gwr%my_nqibz, "]"
5860 : 0 : call cwtime_report(msg, cpu_q, wall_q, gflops_q)
5861 : : end if
5862 : : end do ! my_iqi
5863 : :
5864 : : !call slkproc_4diag%free()
5865 : :
5866 : 0 : call xmpi_sum_master(em1_wq, master, gwr%kgt_comm%value, ierr)
5867 : 0 : call xmpi_sum_master(eps_wq, master, gwr%kgt_comm%value, ierr)
5868 : :
5869 [ # # ]: 0 : if (gwr%comm%me == master) then
5870 : : ! Print results to ab_out for testing purposes.
5871 : 0 : ydoc = yamldoc_open('EMACRO_WITHOUT_LOCAL_FIELDS') !, width=11, real_fmt='(3f8.3)')
5872 : 0 : call ydoc%open_tabular("epsilon_{iw, q -> Gamma}(0,0)") ! comment="(iomega, iq_ibz)")
5873 [ # # ]: 0 : do iw=1,gwr%ntau
5874 : 0 : write(msg, "(3(es16.8,2x))") gwr%iw_mesh(iw), real(eps_wq(iw, 1)), aimag(eps_wq(iw, 1))
5875 : 0 : call ydoc%add_tabular_line(msg)
5876 : : end do
5877 : 0 : call ydoc%write_units_and_free(units)
5878 : :
5879 : 0 : ydoc = yamldoc_open('EMACRO_WITH_LOCAL_FIELDS') !, width=11, real_fmt='(3f8.3)')
5880 : 0 : call ydoc%open_tabular("epsilon_{iw, q -> Gamma}(0,0)") !, comment="(iomega, iq_ibz)")
5881 [ # # ]: 0 : do iw=1,gwr%ntau
5882 : 0 : write(msg, "(3(es16.8,2x))") gwr%iw_mesh(iw), real(em1_wq(iw, 1)), aimag(em1_wq(iw, 1))
5883 : 0 : call ydoc%add_tabular_line(msg)
5884 : : end do
5885 : 0 : call ydoc%write_units_and_free(units)
5886 : : end if
5887 : :
5888 : : ! Print trace of wc_q(iomega) matrices for testing purposes.
5889 [ # # ]: 0 : if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5890 : :
5891 : : ! Write file with Wc(i omega)
5892 : 0 : keep_wcimw = .False.
5893 [ # # ]: 0 : if (gwr%dtset%prtsuscep == -1) then
5894 [ # # ]: 0 : call gwr%ncwrite_tchi_wc("wc", "omega", keep_wcimw, trim(gwr%dtfil%filnam_ds(4))//'_WCIM.nc')
5895 : 0 : keep_wcimw = .True.
5896 : : end if
5897 : :
5898 : : ! Cosine transform from iomega to itau to get Wc(i tau)
5899 : 0 : call gwr%cos_transform("wc", "iw2t")
5900 : :
5901 : : ! Print trace of wc_q(itau) matrices for testing purposes.
5902 : : ! if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5903 : :
5904 : : ! Write file with Wc(i tau)
5905 [ # # ]: 0 : if (abs(gwr%dtset%prtsuscep) == 1) then
5906 [ # # ]: 0 : call gwr%ncwrite_tchi_wc("wc", "tau", keep_wcimw, trim(gwr%dtfil%filnam_ds(4))//'_WCIM.nc')
5907 : : end if
5908 : :
5909 : : ! Print trace of wc_q(iomega) matrices for testing purposes.
5910 : : !if (gwr%dtset%prtvol > 0) call gwr%print_trace(units, "wc_qibz")
5911 : :
5912 : 0 : call cwtime_report(" gwr_build_wc:", cpu_all, wall_all, gflops_all)
5913 : 0 : call timab(1924, 2, tsec)
5914 : : ABI_NVTX_END_RANGE()
5915 : :
5916 [ # # # # ]: 0 : end subroutine gwr_build_wc
5917 : : !!***
5918 : :
5919 : : !----------------------------------------------------------------------
5920 : :
5921 : : !!****f* m_gwr/gwr_build_sigmac
5922 : : !! NAME
5923 : : !! gwr_build_sigmac
5924 : : !!
5925 : : !! FUNCTION
5926 : : !! Build Sigma_c(i tau) and compute matrix elements in the KS basis set.
5927 : : !!
5928 : : !! INPUTS
5929 : : !!
5930 : : !! OUTPUT
5931 : : !!
5932 : : !! SOURCE
5933 : :
5934 : 0 : subroutine gwr_build_sigmac(gwr)
5935 : :
5936 : : !Arguments ------------------------------------
5937 : : class(gwr_t),target,intent(inout) :: gwr
5938 : :
5939 : : !Local variables-------------------------------
5940 : : !scalars
5941 : : integer,parameter :: master = 0
5942 : : 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
5943 : : integer :: iq_ibz, iq_bz, itau, ierr, ibc, ib1, ib2, bmin, bmax, band, band1, ifft, gpu_option
5944 : : integer :: band2, band2_start, band2_stop, nbc
5945 : : integer :: my_ikf, ipm, ik_bz, ikcalc, uc_ir, ir, ncid, col_bsize, nr, sc_nfftsp, iter_ncid
5946 : : integer :: isym_k, trev_k, g0_k(3), tsign_k !, b1gw, b2gw, ! my_iqi, sc_ir, ig, my_iqf
5947 : : integer :: gt_request, wct_request
5948 : : integer :: band_val, ibv, unt_it, unt_iw, unt_rw ! ncerr,
5949 : : integer(kind=XMPI_ADDRESS_KIND) :: buf_count
5950 : : integer :: gt_scbox_win, wct_scbox_win, use_umklp, ideg, nstates, nb1, nb2, nspinor
5951 : : integer(c_size_t) :: bufsize
5952 : : !integer :: my_ikf_start, my_ikf_stop, nkf_batch_size, nkf_now, op_type
5953 : : real(dp) :: e0, ks_gap, qp_gap, qp_pade_gap, sigx, vxc_val, vu, v_meanf, eshift, sigma_fact
5954 : : real(dp) :: cpu_tau, wall_tau, gflops_tau, cpu_all, wall_all, gflops_all !, cpu, wall, gflops
5955 : : real(dp) :: mem_mb, cpu_ir, wall_ir, gflops_ir, cpu_ikf, wall_ikf, gflops_ikf
5956 : : real(dp) :: max_abs_imag_wct, max_abs_re_wct, sck_ucvol, scq_ucvol, beta_r
5957 : : real(gwp) :: wtqm, wtqp
5958 : : complex(dp) :: zz, zsc, sigc_e0__, dsigc_de0, z_e0, sig_xc, hhartree_bk, qp_ene, qp_ene_prev, alpha_c, sigc_zsc
5959 : : logical :: k_is_gamma, use_shmem_for_k, use_mpi_for_k, isirr_k, do_sigma_fit
5960 : : logical :: compute_this_kbz, print_time, sigc_is_herm, band_inversion ! define,
5961 : : character(len=500) :: msg, gpu_action
5962 : 0 : type(gaps_t) :: new_gaps
5963 : : type(yamldoc_t) :: ydoc
5964 : : type(c_ptr) :: void_ptr
5965 : 0 : type(sigma_pade_t) :: spade
5966 : : !arrays
5967 : 0 : integer :: sc_ngfft(18), need_qibz(gwr%nqibz), got_qibz(gwr%nqibz), units(2), dat_units(3), g0_q(3) ! gg(3),
5968 : 0 : integer,allocatable :: green_scgvec(:,:), wc_scgvec(:,:)
5969 : 0 : logical :: select_my_kbz(gwr%my_nkbz), select_my_qbz(gwr%my_nqbz)
5970 : : real(dp) :: kk_bz(3), kcalc_bz(3), qq_bz(3), tsec(2) !, qq_ibz(3)
5971 : 0 : real(dp),allocatable :: betas_r(:,:,:), zcut_pm(:,:,:)
5972 : : complex(gwp) :: cpsi_r, sigc_pm(2)
5973 : 0 : complex(dp) :: odd_t(gwr%ntau), even_t(gwr%ntau), avg_2ntau(2,gwr%ntau), cvals(gwr%ntau)
5974 : 0 : complex(dp),target,allocatable :: sigc_it_mat(:,:,:,:,:,:), alphas_c(:,:,:)
5975 : 0 : complex(gwp),allocatable :: loc_cwork(:)
5976 : 0 : complex(gwp) ABI_ASYNC, contiguous, pointer :: gt_scbox(:,:,:), wct_scbox(:,:)
5977 : 0 : complex(gwp),allocatable :: uc_psir_bk(:,:,:), scph1d_kcalc(:,:,:), uc_ceikr(:), ur(:), ucpsi_r(:)
5978 [ # # # # : 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)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5979 [ # # # # : 0 : type(__slkmat_t), target :: sigc_rpr(2,2,gwr%nkcalc, gwr%nsig_ab)
# # # # #
# # # # #
# # # # #
# # # ]
5980 [ # # # # : 0 : type(desc_t), target :: desc_mykbz(gwr%my_nkbz), desc_myqbz(gwr%my_nqbz)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
5981 : : type(fftbox_plan3_t) :: green_plan, wt_plan
5982 [ # # # # : 0 : type(littlegroup_t) :: ltg_kcalc(gwr%nkcalc)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5983 : : integer, parameter :: spinor_idxs(2, 4) = RESHAPE([1, 1, 2, 2, 1, 2, 2, 1], [2, 4])
5984 : 0 : integer,allocatable :: iperm(:)
5985 : 0 : real(dp),allocatable :: sorted_qpe(:)
5986 : 0 : real(dp) :: e0_kcalc(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol), rw_mesh(gwr%nwr)
5987 : 0 : real(dp) :: spfunc_diag(gwr%nwr, gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5988 : 0 : integer :: pade_solver_ierr(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5989 : 0 : real(dp) :: ks_gaps(gwr%nkcalc, gwr%nsppol), qpz_gaps(gwr%nkcalc, gwr%nsppol), qp_pade_gaps(gwr%nkcalc, gwr%nsppol)
5990 : 0 : complex(dp) :: ze0_kcalc(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5991 : 0 : complex(dp) :: sigc_e0(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5992 : 0 : complex(dp) :: qpz_ene(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol), imag_zmesh(gwr%ntau)
5993 : 0 : complex(dp) :: qp_pade(gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5994 : 0 : complex(dp) :: sigxc_rw_diag(gwr%nwr, gwr%b1gw:gwr%b2gw, gwr%nkcalc, gwr%nsppol)
5995 : : !complex(gwp),contiguous, pointer :: buf_cplx(:,:)
5996 : 0 : type(sigijtab_t),allocatable :: Sigxij_tab(:,:), Sigcij_tab(:,:)
5997 : : ! *************************************************************************
5998 : :
5999 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6000 : 0 : call timab(1925, 1, tsec)
6001 : :
6002 : 0 : nspinor = gwr%nspinor
6003 [ # # ]: 0 : units = [std_out, ab_out]
6004 : 0 : gpu_option = gwr%dtset%gpu_option
6005 [ # # ]: 0 : if (gwr%sig_diago) then
6006 : 0 : call wrtout(units, " Computing diagonal matrix elements of Sigma_c", pre_newlines=1)
6007 : : else
6008 : 0 : call wrtout(units, " Computing diagonal + off-diagonal matrix elements of Sigma_c", pre_newlines=1)
6009 : : end if
6010 : :
6011 [ # # ]: 0 : if (gwr%has_vcgen_sigma) then
6012 : 0 : call gwr%vcgen_sigma%print(units, " Info on Coulomb term used in Sigma_c", gwr%dtset%prtvol)
6013 : : else
6014 : 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in Sigma_c", gwr%dtset%prtvol)
6015 : : end if
6016 : :
6017 [ # # ]: 0 : ABI_CHECK(gwr%wc_space == "itau", sjoin("wc_space: ", gwr%wc_space, " != itau"))
6018 : :
6019 : : !mask_kibz = 0; mask_kibz(gwr%my_kibz_inds(:)) = 1
6020 : : !call gwr%malloc_free_mats(mask_kibz, "sigma" "malloc")
6021 : :
6022 : : !if (gwr%scf_iteration == 1) then
6023 : : !else
6024 : : !end if
6025 : :
6026 : : ! Set FFT mesh in the supercell.
6027 : : ! Be careful when using the FFT plan as ndat can change inside the loop if we start to block.
6028 : : ! Perhaps the safest approach would be to generate the plan on the fly.
6029 : :
6030 [ # # ]: 0 : sc_ngfft = gwr%g_ngfft
6031 [ # # ]: 0 : sc_ngfft(1:3) = gwr%ngkpt * gwr%g_ngfft(1:3)
6032 [ # # ]: 0 : sc_ngfft(4:6) = sc_ngfft(1:3)
6033 [ # # ]: 0 : sc_nfft = product(sc_ngfft(1:3)); sc_nfftsp = sc_nfft !* gwr%nspinor
6034 : : !sc_mgfft = maxval(sc_ngfft(1:3))
6035 [ # # ]: 0 : sck_ucvol = gwr%cryst%ucvol * product(gwr%ngkpt)
6036 [ # # ]: 0 : scq_ucvol = gwr%cryst%ucvol * product(gwr%ngqpt)
6037 : :
6038 : : ! Set FFT mesh used to compute u(r) in the unit cell.
6039 : 0 : call gwr%kcalc_wfd%change_ngfft(gwr%cryst, gwr%psps, gwr%g_ngfft)
6040 : :
6041 : : ! Table for \Sigmac_ij matrix elements.
6042 : 0 : sigc_is_herm = .False.
6043 : : call sigtk_sigma_tables(gwr%nkcalc, gwr%nkibz, gwr%nsppol, gwr%bstart_ks, gwr%bstop_ks, gwr%kcalc2ibz(:,1), &
6044 : 0 : gwr%sig_diago, sigc_is_herm, sigxij_tab, sigcij_tab)
6045 : :
6046 : 0 : call sigijtab_free(Sigxij_tab)
6047 [ # # # # : 0 : ABI_FREE(Sigxij_tab)
# # # # #
# # # ]
6048 : :
6049 : : ! Allocate matrix elements Sigmac_(itau) in the KS basis set.
6050 : 0 : ii = gwr%b1gw; jj = gwr%b2gw
6051 [ # # ]: 0 : if (gwr%sig_diago) then
6052 : 0 : ii = 1; jj = 1
6053 : : end if
6054 [ # # # # : 0 : ABI_CALLOC(sigc_it_mat, (2, gwr%ntau, gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6055 [ # # # # : 0 : ABI_RECALLOC(gwr%sigc_iw_mat, (gwr%ntau, gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6056 : :
6057 : 0 : do_sigma_fit = (iand(gwr%dtset%gwr_fit, SIGMA_FIT) /= 0)
6058 [ # # # # : 0 : ABI_CALLOC(alphas_c, (2, gwr%b1gw:gwr%b2gw, ii:jj))
# # # # #
# # # # #
# # # # #
# # # ]
6059 [ # # # # : 0 : ABI_CALLOC(betas_r, (2, gwr%b1gw:gwr%b2gw, ii:jj))
# # # # #
# # # # #
# # # # #
# # # ]
6060 [ # # # # : 0 : ABI_CALLOC(zcut_pm, (2, gwr%b1gw:gwr%b2gw, ii:jj))
# # # # #
# # # # #
# # # # ]
6061 [ # # # # : 0 : zcut_pm = gwr%dtset%zcut
# # ]
6062 : :
6063 [ # # ]: 0 : if (do_sigma_fit) then
6064 : 0 : call wrtout(units, " Activating fit of sigma matrix elements in tau space")
6065 : : end if
6066 : :
6067 : 0 : max_abs_imag_wct = zero; max_abs_re_wct = zero
6068 [ # # ]: 0 : call gwr%print_mem([std_out])
6069 : :
6070 [ # # ]: 0 : if (gwr%use_supercell_for_sigma) then
6071 : :
6072 : : ! NOTE:
6073 : : ! There are two possibilities here:
6074 : : !
6075 : : ! 1) Compute the matrix elements of Sigma_c in the KS basis set by integrating over the real-space supercell.
6076 : : !
6077 : : ! 2) Compute and store Sigma_c^k(g,g',iomega) and then compute the matrix elements in g-space.
6078 : : !
6079 : : ! The first option requires less memory provided we are interested in a small set of KS states.
6080 : : ! The second option is interesting if we need to compute several matrix elements, including off-diagonal terms.
6081 : 0 : call print_sigma_header()
6082 : :
6083 : 0 : max_ndat = gwr%sc_batch_size
6084 : : use_mpi_for_k = gwr%sc_batch_size > 1 .and. gwr%sc_batch_size == gwr%kpt_comm%nproc
6085 : 0 : use_mpi_for_k = .False.
6086 : :
6087 [ # # # # ]: 0 : use_shmem_for_k = gwr%sc_batch_size == gwr%kpt_comm%nproc .and. gwr%kpt_comm%nproc > 1
6088 [ # # # # ]: 0 : use_shmem_for_k = use_shmem_for_k .and. gwr%kpt_comm%can_use_shmem()
6089 : : #ifndef HAVE_MPI_ALLOCATE_SHARED_CPTR
6090 : : use_shmem_for_k = .False.
6091 : : #endif
6092 : :
6093 [ # # ]: 0 : if (use_shmem_for_k) then
6094 : 0 : buf_count = 2 * (sc_nfftsp * max_ndat * 2)
6095 : 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, gt_scbox_win)
6096 [ # # ]: 0 : call c_f_pointer(void_ptr, gt_scbox, shape=[sc_nfftsp, max_ndat, 2])
6097 : 0 : buf_count = 2 * (sc_nfftsp * max_ndat)
6098 : 0 : call gwr%kpt_comm%allocate_shared_master(buf_count, gwp, xmpi_info_null, void_ptr, wct_scbox_win)
6099 [ # # ]: 0 : call c_f_pointer(void_ptr, wct_scbox, shape=[sc_nfftsp, max_ndat])
6100 : : end if
6101 : :
6102 : 0 : call wrtout(std_out, sjoin(" use_mpi_for_k:", yesno(use_mpi_for_k)))
6103 : 0 : call wrtout(std_out, sjoin(" use_shmem_for_k:", yesno(use_shmem_for_k)))
6104 : 0 : mem_mb = 3 * (sc_nfftsp * max_ndat * gwp) * b2Mb
6105 : 0 : call wrtout(std_out, sjoin(" Memory for gt_scbox/wct_scbox arrays:", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
6106 : :
6107 [ # # ]: 0 : if (.not. use_shmem_for_k) then
6108 [ # # # # : 0 : ABI_CALLOC(gt_scbox, (sc_nfft, max_ndat, 2))
# # # # #
# # # # #
# # # # #
# # # #
# ]
6109 [ # # # # : 0 : ABI_CALLOC(wct_scbox, (sc_nfft, max_ndat))
# # # # #
# # # # #
# # # # #
# ]
6110 : : #ifdef HAVE_OPENMP_OFFLOAD
6111 : : !$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)
6112 : : #endif
6113 : : end if
6114 : :
6115 : : ! Build plans for dense FFTs.
6116 : 0 : call green_plan%from_ngfft(sc_ngfft, max_ndat*2, gpu_option)
6117 : 0 : call wt_plan%from_ngfft(sc_ngfft, max_ndat, gpu_option)
6118 : :
6119 : 0 : sigma_fact = one / (sck_ucvol * scq_ucvol)
6120 : :
6121 : : ! The g-vectors in the supercell for G and tchi.
6122 [ # # # # : 0 : ABI_MALLOC(green_scgvec, (3, gwr%green_mpw))
# # # # #
# # # ]
6123 [ # # # # : 0 : ABI_MALLOC(wc_scgvec, (3, gwr%tchi_mpw))
# # # # #
# # # ]
6124 : :
6125 [ # # # # ]: 0 : select_my_kbz = .True.; select_my_qbz = .True.
6126 : :
6127 [ # # ]: 0 : do my_is=1,gwr%my_nspins
6128 : 0 : spin = gwr%my_spins(my_is)
6129 : :
6130 : : ! Load wavefunctions for GW corrections in the unit cell.
6131 : : ! TODO: MPI distribute or use MPI shared memory
6132 [ # # # # ]: 0 : bmin = minval(gwr%bstart_ks(:, spin)); bmax = maxval(gwr%bstop_ks(:, spin))
6133 [ # # # # : 0 : ABI_MALLOC_OR_DIE(uc_psir_bk, (gwr%g_nfft * gwr%nspinor, bmin:bmax, gwr%nkcalc), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
6134 [ # # # # : 0 : ABI_MALLOC(ur, (gwr%g_nfft * gwr%nspinor))
# # # # #
# # # ]
6135 [ # # # # : 0 : ABI_MALLOC(uc_ceikr, (gwr%g_nfft * gwr%nspinor))
# # # # ]
6136 [ # # # # : 0 : ABI_MALLOC(ucpsi_r, (gwr%g_nfft))
# # # # #
# # # ]
6137 : :
6138 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6139 [ # # ]: 0 : kcalc_bz = gwr%kcalc(:, ikcalc); ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1) ! NB: Assuming wfs in the IBZ.
6140 : : ! Compute e^{ik.r} phases in the unit cell.
6141 : 0 : call calc_ceikr(kcalc_bz, gwr%g_ngfft, gwr%g_nfft, gwr%nspinor, uc_ceikr)
6142 : :
6143 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6144 : 0 : call gwr%kcalc_wfd%get_ur(band, ikcalc_ibz, spin, ur)
6145 [ # # ]: 0 : uc_psir_bk(:, band, ikcalc) = ur * uc_ceikr
6146 : : end do
6147 : : end do ! ikcalc
6148 : :
6149 [ # # ]: 0 : ABI_FREE(ur)
6150 [ # # ]: 0 : ABI_FREE(uc_ceikr)
6151 : :
6152 : : ! Pre-compute one-dimensional factors to get 3d e^{ik.L}
6153 [ # # ]: 0 : call get_1d_sc_phases(gwr%ngkpt, gwr%nkcalc, gwr%kcalc, scph1d_kcalc)
6154 : :
6155 : : ! Construct Sigma(itau) in the supercell.
6156 [ # # ]: 0 : do my_it=1,gwr%my_ntau
6157 : 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
6158 : 0 : itau = gwr%my_itaus(my_it)
6159 : :
6160 : : ! G_k(g,g') --> G_k(g',r) e^{ik.r} for each k in the BZ treated by me.
6161 : 0 : call gwr%get_myk_green_gpr(itau, spin, select_my_kbz, desc_mykbz, gt_gpr)
6162 [ # # # # ]: 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6163 : :
6164 : : ! Wc_q(g,g') --> Wc_q(g',r) e^{iq.r} for each q in the BZ treated by me.
6165 : 0 : call gwr%get_myq_wc_gpr(itau, spin, select_my_qbz, desc_myqbz, wc_gpr)
6166 [ # # # # ]: 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6167 : :
6168 : 0 : my_nr = gt_gpr(1,1,1)%size_local(2)
6169 [ # # ]: 0 : ABI_CHECK(my_nr == wc_gpr(1)%size_local(2), "my_nr != wc_gpr(1)%size_local(2)")
6170 : :
6171 : : ! Loop over r in the unit cell that is now MPI-distributed inside g_comm.
6172 [ # # # # : 0 : do my_ir=1, my_nr, gwr%sc_batch_size
# # # # ]
6173 [ # # # # : 0 : print_time = (gwr%comm%me == 0 .and. (my_ir <= 3 * gwr%sc_batch_size .or. mod(my_ir, LOG_MODR) == 0))
# # ]
6174 : 0 : if (print_time) call cwtime(cpu_ir, wall_ir, gflops_ir, "start")
6175 : 0 : ndat = blocked_loop(my_ir, my_nr, gwr%sc_batch_size)
6176 : 0 : uc_ir = gt_gpr(1,1,1)%loc2gcol(my_ir) ! FIXME: This won't work if nspinor 2
6177 : :
6178 [ # # ]: 0 : if (.not. use_shmem_for_k) then
6179 : : ! Insert Wc_q(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir)
6180 : 0 : call gwr%wcq_to_scbox(sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, wc_gpr, wct_scbox)
6181 : : #ifdef HAVE_OPENMP_OFFLOAD
6182 : : !$omp target update to(wct_scbox(1:sc_nfft,1:max_ndat)) if (gpu_option == ABI_GPU_OPENMP)
6183 : : #endif
6184 [ # # ]: 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_isum_ip(wct_scbox, gwr%kpt_comm%value, wct_request, ierr)
6185 : :
6186 : : ! Wc(G',r) --> Wc(R',r)
6187 [ # # ]: 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_wait(wct_request, ierr)
6188 : 0 : call wt_plan%execute(wct_scbox(:,1), -1, max_ndat, iscale=0)
6189 : : else
6190 : : call gwr%wcq_to_scbox(sc_ngfft, select_my_qbz, desc_myqbz, wc_scgvec, my_ir, ndat, wc_gpr, wct_scbox, &
6191 : 0 : wct_scbox_win=wct_scbox_win)
6192 : : end if
6193 : :
6194 : : ! TODO: Should block using nproc in kpt_comm, scatter data and perform multiple FFTs in parallel.
6195 [ # # ]: 0 : do iab=1,gwr%nsig_ab
6196 : 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
6197 [ # # ]: 0 : if (.not. use_shmem_for_k) then
6198 : :
6199 : : ! Insert G_k(g',r) in G'-space in the supercell FFT box (ndat vectors starting at my_ir).
6200 : 0 : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox)
6201 : : #ifdef HAVE_OPENMP_OFFLOAD
6202 : : !$omp target update to(gt_scbox(1:sc_nfft,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
6203 : : #endif
6204 [ # # ]: 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_isum_ip(gt_scbox, gwr%kpt_comm%value, gt_request, ierr)
6205 : :
6206 : : ! G(G',r) --> G(R',r)
6207 [ # # ]: 0 : if (gwr%kpt_comm%nproc > 1) call xmpi_wait(gt_request, ierr)
6208 : 0 : call green_plan%execute(gt_scbox(:,1,1), -1, max_ndat*2, iscale=0)
6209 : :
6210 : : ! Use gt_scbox to store GW (R',r, +/- i tau) for this set of ndat r-point
6211 : : !gt_scbox(:,:,1) = gt_scbox(:,:,1) * wct_scbox(:,:) * sigma_fact
6212 : : !gt_scbox(:,:,2) = gt_scbox(:,:,2) * wct_scbox(:,:) * sigma_fact
6213 : : #ifdef HAVE_OPENMP_OFFLOAD
6214 : : !$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)
6215 : : #endif
6216 [ # # ]: 0 : do ipm=1,2
6217 [ # # ]: 0 : do idat=1,max_ndat
6218 [ # # ]: 0 : do ifft=1,sc_nfft
6219 : 0 : gt_scbox(ifft,idat,ipm) = gt_scbox(ifft,idat,ipm) * wct_scbox(ifft,idat) * sigma_fact
6220 : : end do
6221 : : end do
6222 : : end do
6223 : : #ifdef HAVE_OPENMP_OFFLOAD
6224 : : !$omp target update from(gt_scbox(1:sc_nfft,1:max_ndat,1:2)) if (gpu_option == ABI_GPU_OPENMP)
6225 : : #endif
6226 : : !print *, "Maxval abs imag G:", maxval(abs(aimag(gt_scbox)))
6227 : :
6228 : : else
6229 : : ! use_shmem_for_k --> MPI shared window version. Only gt_scbox are wct_scbox are shared.
6230 : : call gwr%gk_to_scbox(sc_ngfft, select_my_kbz, desc_mykbz, green_scgvec, my_ir, ndat, gt_gpr(:,:,iab), gt_scbox, &
6231 : 0 : gt_scbox_win=gt_scbox_win)
6232 : :
6233 : : ! Now each MPI proc operates on different idat entries.
6234 : 0 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, gt_scbox_win, ierr) ! Start the RMA epoch
6235 : 0 : idat = gwr%kpt_comm%me + 1
6236 [ # # ]: 0 : if (idat <= ndat) then
6237 : 0 : call wt_plan%execute(wct_scbox(:,idat), -1, ndat=1, iscale=0)
6238 [ # # ]: 0 : do ipm=1,2
6239 : 0 : call green_plan%execute(gt_scbox(:,idat,ipm), -1, ndat=1, iscale=0)
6240 [ # # # # : 0 : gt_scbox(:,idat,ipm) = gt_scbox(:,idat,ipm) * wct_scbox(:,idat) * sigma_fact
# # ]
6241 : : end do
6242 : : end if
6243 : : !IF (.not. MPI_ASYNC_PROTECTS_NONBLOCKING) CALL MPI_F_SYNC_REG(gt_scbox)
6244 : : !call xmpi_barrier(gwr%kpt_comm%value)
6245 : 0 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, gt_scbox_win, ierr) ! End the RMA epoch
6246 : : end if
6247 : :
6248 : : ! Integrate Sigma matrix elements in the R-supercell for ndat r-points and accumulate.
6249 : : ! possibly including off-diagonal terms.
6250 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6251 [ # # ]: 0 : if (gwr%kpt_comm%skip(ikcalc)) cycle ! FIXME: Temporary hack till I find a better MPI algo for k-points.
6252 : 0 : k_is_gamma = normv(gwr%kcalc(:,ikcalc), gwr%cryst%gmet, "G") < GW_TOLQ0
6253 : :
6254 [ # # ]: 0 : do band2=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6255 [ # # ]: 0 : do irow=1,Sigcij_tab(ikcalc, spin)%col(band2)%size1
6256 : 0 : band1 = Sigcij_tab(ikcalc, spin)%col(band2)%bidx(irow)
6257 [ # # ]: 0 : do idat=1,ndat
6258 : : !if (use_shmem_for_k .and. idat /= gwr%kpt_comm + 1) cycle
6259 : 0 : ir = uc_ir + idat - 1
6260 : 0 : cpsi_r = conjg(uc_psir_bk((iiab-1)*gwr%g_nfft + ir, band1, ikcalc))
6261 [ # # # # : 0 : ucpsi_r = uc_psir_bk((jiab-1)*gwr%g_nfft+1:jiab*gwr%g_nfft, band2, ikcalc)
# # # # ]
6262 [ # # ]: 0 : do ipm=1,2
6263 : : call sc_sum(gwr%ngkpt, gwr%g_ngfft, scph1d_kcalc(:,:,ikcalc), k_is_gamma, &
6264 : 0 : cpsi_r, gt_scbox(:,idat,ipm), ucpsi_r, sigc_pm(ipm))
6265 : : end do
6266 [ # # ]: 0 : if (gwr%sig_diago) then
6267 [ # # ]: 0 : sigc_it_mat(:, itau,band1,1,ikcalc,spin) = sigc_it_mat(:,itau,band1,1,ikcalc,spin) + sigc_pm(:)
6268 : : else
6269 [ # # ]: 0 : sigc_it_mat(:,itau,band1,band2,ikcalc,spin) = sigc_it_mat(:,itau,band1,band2,ikcalc,spin) + sigc_pm(:)
6270 : : end if
6271 : : end do ! idat
6272 : : end do
6273 : : end do ! band2
6274 : : end do ! ikcalc
6275 : : end do ! iab
6276 : :
6277 : : !if (use_shmem_for_k) call xmpi_sum
6278 : :
6279 [ # # ]: 0 : if (print_time) then
6280 : 0 : write(msg,'(4x,3(a,i0),a)')"Sigma_c my_ir [", my_ir, "/", my_nr, "] (tot: ", gwr%g_nfft, ")"
6281 : 0 : call cwtime_report(msg, cpu_ir, wall_ir, gflops_ir)
6282 : : end if
6283 : : end do ! my_ir
6284 : :
6285 : : ! Free descriptors and PBLAS matrices in kBZ and qBZ.
6286 : 0 : call desc_array_free(desc_mykbz); call desc_array_free(desc_myqbz)
6287 : 0 : call slk_array_free(gt_gpr); call slk_array_free(wc_gpr)
6288 : :
6289 : 0 : write(msg,'(1x,3(a,i0),a)')"Sigma_c my_itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
6290 : 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau, end_str=ch10)
6291 : : end do ! my_it
6292 : :
6293 [ # # ]: 0 : ABI_FREE(scph1d_kcalc)
6294 [ # # ]: 0 : ABI_FREE(ucpsi_r)
6295 [ # # ]: 0 : ABI_FREE(uc_psir_bk)
6296 : : end do ! my_is
6297 : :
6298 [ # # # # : 0 : sigc_it_mat = -sigc_it_mat * (gwr%cryst%ucvol / gwr%g_nfft) ** 2
# # # # #
# # # ]
6299 : :
6300 : : !call wrtout(std_out, sjoin(" Maxval abs re W:", ftoa(max_abs_re_wct)))
6301 : : !call wrtout(std_out, sjoin(" Maxval abs imag W:", ftoa(max_abs_imag_wct)))
6302 [ # # ]: 0 : if (.not. use_shmem_for_k) then
6303 : : #ifdef HAVE_OPENMP_OFFLOAD
6304 : : !$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)
6305 : : #endif
6306 [ # # ]: 0 : ABI_FREE(gt_scbox)
6307 [ # # ]: 0 : ABI_FREE(wct_scbox)
6308 : : else
6309 : 0 : call xmpi_win_free(gt_scbox_win, ierr)
6310 : 0 : call xmpi_win_free(wct_scbox_win, ierr)
6311 : : end if
6312 : :
6313 : 0 : call green_plan%free(); call wt_plan%free()
6314 : :
6315 [ # # ]: 0 : ABI_FREE(green_scgvec)
6316 [ # # ]: 0 : ABI_FREE(wc_scgvec)
6317 : :
6318 : : else
6319 : : ! ===================================================================
6320 : : ! Mixed-space algorithm in the unit cell with convolutions in k-space
6321 : : ! ===================================================================
6322 : 0 : call print_sigma_header()
6323 : :
6324 : : ! Define tables to account for symmetries:
6325 : : ! - when looping over the BZ, we only need to include the union of IBZ_x for x in kcalc.
6326 : : ! - when accumulating the self-energy, we have to use weights that depend on x.
6327 : :
6328 : : ! The little group is needed when symsigma == 1
6329 : : ! If use_umklp == 1 then symmetries requiring an umklapp to preserve k_gw are included as well.
6330 : : ! Note that TR is not yet supported so timrev is set to 1 even if TR has been used to generate the GS IBZ.
6331 : 0 : use_umklp = 1
6332 : : !gw_timrev = kpts_timrev_from_kptopt(gwr%ks_ebands%kptopt) + 1
6333 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6334 : 0 : call ltg_kcalc(ikcalc)%init(gwr%kcalc(:,ikcalc), gwr%nkbz, gwr%kbz, gwr%cryst, use_umklp, npwe=0)
6335 [ # # # # ]: 0 : if (gwr%comm%me == 0 .and. gwr%dtset%symsigma /= 0) then
6336 [ # # ]: 0 : call ltg_kcalc(ikcalc)%print([std_out], prtvol=gwr%dtset%prtvol)
6337 : : end if
6338 : : end do
6339 : :
6340 : 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.")
6341 : 0 : nr = gwr%g_nfft
6342 [ # # ]: 0 : col_bsize = nr / gwr%g_comm%nproc; if (mod(nr, gwr%g_comm%nproc) /= 0) col_bsize = col_bsize + 1
6343 : :
6344 [ # # ]: 0 : call wc_rpr%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
6345 : :
6346 : 0 : gpu_action = "None"
6347 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
6348 : 0 : gpu_action = "alloc"; call wrtout(std_out, " Allocating Sigma_k(r,r', +/-tau) on the GPU...")
6349 : : end if
6350 : :
6351 [ # # ]: 0 : do ipm=1,2
6352 [ # # ]: 0 : do iab=1,gwr%nsig_ab
6353 [ # # ]: 0 : call gk_rpr_pm(ipm, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize])
6354 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6355 [ # # ]: 0 : do itim=1,2
6356 [ # # ]: 0 : call sigc_rpr(itim,ipm,ikcalc, iab)%init(nr, nr, gwr%g_slkproc, 1, size_blocs=[-1, col_bsize], gpu_action=gpu_action)
6357 : : end do
6358 : : end do
6359 : : end do
6360 : : end do
6361 : :
6362 [ # # # # : 0 : mem_mb = slk_array_locmem_mb(wc_rpr) + sum(slk_array_locmem_mb(gk_rpr_pm)) + sum(slk_array_locmem_mb(sigc_rpr))
# # # # #
# # # ]
6363 : 0 : call wrtout(std_out, sjoin(" Local memory for PBLAS (r,r') matrices: ", ftoa(mem_mb, fmt="f8.1"), ' [Mb] <<< MEM'))
6364 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6365 : :
6366 : 0 : ii = sigc_rpr(1,1,1,1)%size_local(2)
6367 [ # # # # : 0 : ABI_MALLOC(loc_cwork, (ii))
# # # # #
# # # ]
6368 : :
6369 [ # # ]: 0 : do my_is=1,gwr%my_nspins
6370 : 0 : spin = gwr%my_spins(my_is)
6371 : :
6372 : : ! Load wavefunctions for GW corrections in the real-space unit cell.
6373 : : ! TODO: MPI distribute or use MPI shared memory
6374 [ # # # # ]: 0 : bmin = minval(gwr%bstart_ks(:, spin)); bmax = maxval(gwr%bstop_ks(:, spin))
6375 [ # # # # : 0 : ABI_MALLOC_OR_DIE(uc_psir_bk, (nr * gwr%nspinor, bmin:bmax, gwr%nkcalc), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
6376 : : #ifdef HAVE_OPENMP_OFFLOAD
6377 : : !$OMP TARGET ENTER DATA MAP(alloc:uc_psir_bk) IF (gpu_option == ABI_GPU_OPENMP)
6378 : : #endif
6379 : :
6380 : : !! !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(ikcalc_ibz)
6381 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6382 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6383 : 0 : ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1) ! NB: Assuming wfs in IBZ
6384 : 0 : call gwr%kcalc_wfd%get_ur(band, ikcalc_ibz, spin, uc_psir_bk(:, band, ikcalc))
6385 : : end do
6386 : : end do
6387 : : #ifdef HAVE_OPENMP_OFFLOAD
6388 : : !$omp target update to(uc_psir_bk) if (gpu_option == ABI_GPU_OPENMP)
6389 : : #endif
6390 : :
6391 [ # # ]: 0 : need_qibz = 0
6392 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
6393 [ # # ]: 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
6394 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6395 [ # # ]: 0 : qq_bz = gwr%kcalc(:,ikcalc) - kk_bz !; qq_bz = -qq_bz
6396 : : ! TODO: here I may need to take into account the umklapp
6397 : 0 : call findqg0(iq_bz, g0_q, qq_bz, gwr%nqbz, gwr%qbz, gwr%mG0)
6398 : : !ABI_CHECK(all(g0_q == 0), sjoin("g0_q != 0, kcalc", ktoa(gwr%kcalc(:,ikcalc)), "kk_bz:", ktoa(kk_bz)))
6399 : 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz)
6400 : 0 : need_qibz(iq_ibz) = 1
6401 : : end do
6402 : : end do
6403 : :
6404 : : ! Construct Sigma(itau) using convolutions in k-space and real-space representation in the unit cell.
6405 [ # # ]: 0 : do my_it=1,gwr%my_ntau
6406 : 0 : call cwtime(cpu_tau, wall_tau, gflops_tau, "start")
6407 : 0 : itau = gwr%my_itaus(my_it)
6408 : :
6409 : : ! Redistribute W_q(g,g') in the IBZ so that each MPI proc can reconstruct Wc_q in the BZ inside the loops
6410 : 0 : call gwr%redistrib_mats_qibz("wc", itau, spin, need_qibz, got_qibz, "communicate")
6411 [ # # # # ]: 0 : if (my_it == 1 .and. gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6412 : :
6413 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
6414 : 0 : call slk_array_gpu_set_zero(sigc_rpr)
6415 : : end if
6416 : : !else
6417 [ # # # # : 0 : call slk_array_set_zero(sigc_rpr)
# # # # ]
6418 : : !end if
6419 : :
6420 : : ! Sum over my k-points in the BZ.
6421 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
6422 [ # # # # : 0 : print_time = (gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0))
# # ]
6423 : 0 : if (print_time) call cwtime(cpu_ikf, wall_ikf, gflops_ikf, "start")
6424 [ # # ]: 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:,ik_bz)
6425 : :
6426 : 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
6427 : 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
6428 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
6429 : : tsign_k = merge(1, -1, trev_k == 0)
6430 : : !if (.not. isirr_k) cycle
6431 : :
6432 : : ! Skip this BZ k-point if it is not in the IBZ(ikcalc) of some ikcalc.
6433 : 0 : compute_this_kbz = .True.
6434 [ # # ]: 0 : if (gwr%dtset%symsigma /= 0) then
6435 : 0 : compute_this_kbz = .False.
6436 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6437 [ # # ]: 0 : if (ltg_kcalc(ikcalc)%ibzq(ik_bz) == 1) then
6438 : : compute_this_kbz = .True.; exit
6439 : : end if
6440 : : end do
6441 : : end if
6442 [ # # ]: 0 : if (.not. compute_this_kbz) cycle ! my_ikf loop
6443 : :
6444 : : ! Use symmetries to get G_kbz from the IBZ then G_k(g,g') --> G_k(r',r)
6445 : 0 : call gwr%get_gkbz_rpr_pm(ik_bz, itau, spin, gk_rpr_pm)
6446 : :
6447 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6448 [ # # # # ]: 0 : if (gwr%dtset%symsigma /= 0 .and. ltg_kcalc(ikcalc)%ibzq(ik_bz) == 0) cycle ! FIXME: iq_bz or ikq?
6449 [ # # ]: 0 : qq_bz = gwr%kcalc(:, ikcalc) - kk_bz !; qq_bz = -qq_bz
6450 : : ! TODO: here I may need to take into account the umklapp
6451 : 0 : call findqg0(iq_bz, g0_q, qq_bz, gwr%nqbz, gwr%qbz, gwr%mG0)
6452 : : !ABI_CHECK(all(g0_q == 0), sjoin("g0_q != 0", ktoa(gwr%kcalc(:,ikcalc)), "kk_bz", ktoa(kk_bz)))
6453 : : !iq_ibz = gwr%qbz2ibz(1, iq_bz)
6454 : 0 : call gwr%get_wc_rpr_qbz(g0_q, iq_bz, itau, spin, wc_rpr)
6455 : :
6456 : : ! The integration weight depends on ikcalc.
6457 : 0 : wtqp = one / gwr%nkbz; wtqm = zero
6458 [ # # ]: 0 : if (gwr%dtset%symsigma /= 0) then
6459 : : ! If symsigma, sum only q"s in IBZ_k, then symmetrize the matrix elements.
6460 : : ! In this case elements are weighted according to wtqp and wtqm. wtqm is for time-reversal.
6461 : : associate (ltg_k => ltg_kcalc(ikcalc))
6462 [ # # ]: 0 : wtqp = (one * sum(ltg_k%wtksym(1,:,ik_bz))) / gwr%nkbz ! FIXME: iq_bz or ik_bz?
6463 [ # # ]: 0 : wtqm = (one * sum(ltg_k%wtksym(2,:,ik_bz))) / gwr%nkbz
6464 : : end associate
6465 : : end if
6466 : :
6467 [ # # ]: 0 : do ipm=1,2
6468 : : !sigc_rpr(1,ipm,ikcalc)%buffer_cplx = sigc_rpr(1,ipm,ikcalc)%buffer_cplx + &
6469 : : ! wtqp * gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx
6470 [ # # ]: 0 : do iab=1,gwr%nsig_ab
6471 : 0 : bufsize = sigc_rpr(1,ipm,ikcalc,iab)%bufsize
6472 : : call cplx_mat_plus_bc(bufsize, sigc_rpr(1,ipm,ikcalc,iab)%buffer_cplx(:,1), &
6473 : : wtqp, "N", gk_rpr_pm(ipm,iab)%buffer_cplx(:,1), wc_rpr%buffer_cplx(:,1), &
6474 : 0 : gpu_option)
6475 : :
6476 : : call cplx_mat_plus_bc(bufsize, sigc_rpr(2,ipm,ikcalc,iab)%buffer_cplx(:,1), &
6477 : : wtqm, "N", gk_rpr_pm(ipm,iab)%buffer_cplx(:,1), wc_rpr%buffer_cplx(:,1), &
6478 : 0 : gpu_option)
6479 : :
6480 : : !sigc_rpr(1, ipm, ikcalc)%buffer_cplx = sigc_rpr(1, ipm, ikcalc)%buffer_cplx + &
6481 : : ! (wtqp + wtqm) * real(gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx, kind=gwp) &
6482 : : ! + (wtqp - wtqm) * j_gw * aimag(gk_rpr_pm(ipm)%buffer_cplx * wc_rpr%buffer_cplx)
6483 : : end do ! iab
6484 : : end do ! ipm
6485 : :
6486 : : end do ! ikcalc
6487 : :
6488 [ # # ]: 0 : if (print_time) then
6489 : 0 : write(msg,'(4x,3(a,i0),a)')"Sigma_c my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
6490 : 0 : call cwtime_report(msg, cpu_ikf, wall_ikf, gflops_ikf)
6491 : : end if
6492 : : end do ! my_ikf
6493 : :
6494 : : ! Deallocate extra Wc matrices defined by got_qibz.
6495 : 0 : call gwr%redistrib_mats_qibz("wc", itau, spin, need_qibz, got_qibz, "free")
6496 : :
6497 : : ! Integrate self-energy matrix elements in the unit cell.
6498 : : ! Remember that Sigma is stored as (r',r) and that the second dimension is MPI-distributed.
6499 : : ! In case of k or g distribution, sigc_pm is a partial 6d integral that will be ALL_REDUCED in gwr%comm afterwards.
6500 : : ! TODO: Off-diagonal terms although this is not the most efficient algorithm
6501 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6502 [ # # ]: 0 : do iab=1,gwr%nsig_ab
6503 : 0 : iiab = spinor_idxs(1, iab); jiab = spinor_idxs(2, iab)
6504 [ # # ]: 0 : if (gpu_option == ABI_GPU_OPENMP) then
6505 [ # # ]: 0 : do ipm=1,2
6506 [ # # ]: 0 : do itim=1,2
6507 : 0 : call sigc_rpr(itim,ipm,ikcalc,iab)%gpu_map("update_from")
6508 : : end do
6509 : : end do
6510 : : end if
6511 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6512 : : call sig_braket_ur(sigc_rpr(:,:,ikcalc,iab), gwr%g_nfft, &
6513 : : uc_psir_bk((jiab-1)*gwr%g_nfft+1:jiab*gwr%g_nfft, band, ikcalc), &
6514 : : uc_psir_bk((iiab-1)*gwr%g_nfft+1:iiab*gwr%g_nfft, band, ikcalc), &
6515 : 0 : sigc_pm, loc_cwork)
6516 [ # # # # ]: 0 : if (gwr%sig_diago) sigc_it_mat(:, itau, band, 1, ikcalc, spin) = sigc_it_mat(:, itau, band, 1, ikcalc, spin) + sigc_pm(:)
6517 : : end do ! band
6518 : : end do ! iab
6519 : : end do ! ikcalc
6520 : :
6521 : 0 : write(msg,'(3(a,i0),a)')" Sigma_c my_itau [", my_it, "/", gwr%my_ntau, "] (tot: ", gwr%ntau, ")"
6522 : 0 : call cwtime_report(msg, cpu_tau, wall_tau, gflops_tau)
6523 : : end do ! my_it
6524 : :
6525 : : #ifdef HAVE_OPENMP_OFFLOAD
6526 : : !$OMP TARGET EXIT DATA MAP(delete:uc_psir_bk) IF (gpu_option == ABI_GPU_OPENMP)
6527 : : #endif
6528 [ # # ]: 0 : ABI_FREE(uc_psir_bk)
6529 : : end do ! my_is
6530 : :
6531 [ # # # # : 0 : sigc_it_mat = -sigc_it_mat * (one/gwr%g_nfft) ** 2
# # # # #
# # # ]
6532 : :
6533 [ # # ]: 0 : ABI_FREE(loc_cwork)
6534 : 0 : call wc_rpr%free(); call slk_array_free(sigc_rpr); call slk_array_free(gk_rpr_pm)
6535 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6536 : 0 : call ltg_kcalc(ikcalc)%free()
6537 : : end do
6538 : 0 : call wrtout(std_out, " Mixed space algorithm for sigma completed")
6539 : : end if
6540 : :
6541 [ # # ]: 0 : if (gwr%comm%me == 0) call pstat_proc%print(_PSTAT_ARGS_)
6542 : :
6543 : 0 : call sigijtab_free(Sigcij_tab)
6544 [ # # # # : 0 : ABI_FREE(Sigcij_tab)
# # # # #
# # # ]
6545 : :
6546 : : ! Collect results and average
6547 : 0 : call xmpi_sum(sigc_it_mat, gwr%comm%value, ierr)
6548 : :
6549 : : ! Average over degenerate states.
6550 : : ! if (gwr%dtset%symsigma == +1 .and. .not. gwr%use_supercell_for_sigma) then
6551 [ # # ]: 0 : if (gwr%dtset%symsigma == +1) then
6552 : 0 : call wrtout(std_out, " Symsigma 1 --> Averaging Sig_c matrix elements within degenerate subspaces.")
6553 [ # # ]: 0 : ABI_CHECK(gwr%sig_diago, "symsigma = 1 requires diagonal Sigma_c")
6554 [ # # ]: 0 : do spin=1,gwr%nsppol
6555 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6556 [ # # ]: 0 : do ideg=1,size(gwr%degtab(ikcalc, spin)%bids)
6557 : 0 : associate (bids => gwr%degtab(ikcalc, spin)%bids(ideg)%vals)
6558 : 0 : nstates = size(bids)
6559 [ # # # # : 0 : avg_2ntau = sum(sigc_it_mat(:,:,bids(:), 1,ikcalc, spin), dim=3) / nstates
# # ]
6560 [ # # ]: 0 : do ii=1,nstates
6561 [ # # # # ]: 0 : sigc_it_mat(:,:,bids(ii), 1,ikcalc, spin) = avg_2ntau
6562 : : end do
6563 : : end associate
6564 : : end do ! ideg
6565 : : end do
6566 : : end do
6567 : : end if ! symsigma == +1
6568 : :
6569 : : ! Store matrix elements of Sigma_c(it), separate even and odd part
6570 : : ! then use sine/cosine transform to get Sigma_c(i omega).
6571 : : ! Finally, perform analytic continuation with Pade' to go to the real-frequency axis
6572 : : ! for computing QP corrections and spectral functions. All procs execute this part as it's very cheap.
6573 : :
6574 [ # # ]: 0 : imag_zmesh(:) = j_dpc * gwr%iw_mesh
6575 : :
6576 : : ! Save previous QP bands in qp_ebands_prev (needed for self-consistency)
6577 : : ! In the loop below, we also update gwr%qp_ebands%eig with the QP results and recompute occ/fermie.
6578 [ # # # # : 0 : gwr%qp_ebands_prev%eig = gwr%qp_ebands%eig
# # # # #
# # # # #
# # # # #
# # # ]
6579 [ # # # # : 0 : gwr%qp_ebands_prev%occ = gwr%qp_ebands%occ
# # # # #
# # # # #
# # # # #
# # # ]
6580 : :
6581 [ # # # # : 0 : e0_kcalc = zero; spfunc_diag = zero; pade_solver_ierr = 0; ze0_kcalc = zero; sigc_e0 = zero
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6582 [ # # # # : 0 : qpz_ene = zero; qp_pade = zero; sigxc_rw_diag = zero
# # # # #
# # # # #
# # # # #
# ]
6583 [ # # # # : 0 : ks_gaps = -one; qpz_gaps = -one ; qp_pade_gaps = -one
# # # # #
# # # ]
6584 : :
6585 [ # # ]: 0 : do spin=1,gwr%nsppol
6586 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6587 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6588 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6589 : 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6590 : 0 : nb1 = gwr%bstop_ks(ikcalc, spin) - gwr%bstart_ks(ikcalc, spin) + 1
6591 : :
6592 : : ! FT Sigma(itau) --> Sigma(iw)
6593 : 0 : band2_start = 1; band2_stop = 1
6594 [ # # ]: 0 : if (.not. gwr%sig_diago) then
6595 : 0 : band2_start = gwr%bstart_ks(ikcalc, spin); band2_stop = gwr%bstop_ks(ikcalc, spin)
6596 : : end if
6597 : :
6598 [ # # ]: 0 : do band2=band2_start, band2_stop
6599 : 0 : associate (cvals_pmt => sigc_it_mat(:, :, band, band2, ikcalc, spin))
6600 : 0 : ib2 = band2 - band2_start + 1
6601 : 0 : nb2 = band2_stop - band2_start + 1
6602 : :
6603 : 0 : if (do_sigma_fit) then
6604 [ # # ]: 0 : cvals = cvals_pmt(1,:)
6605 : 0 : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, cvals, alpha_c, beta_r, ierr)
6606 : 0 : alphas_c(1,band, band2) = alpha_c; betas_r(1,band,band2) = beta_r
6607 : 0 : zcut_pm(1, band, band2) = gwr%dtset%zcut
6608 : : ! Remove the fit from the ab-initio data.
6609 [ # # ]: 0 : cvals_pmt(1,:) = cvals_pmt(1,:) - alpha_c * exp(-beta_r * gwr%tau_mesh)
6610 [ # # ]: 0 : if (gwr%comm%value == master) then
6611 : 0 : write(100, "(a,2(i0,1x))")"# +tau fit for band, band2: ", band, band2
6612 : 0 : write(100, *)"# alpha_c, beta_r: ", alpha_c, beta_r
6613 [ # # ]: 0 : do ii=1,gwr%ntau
6614 [ # # # # ]: 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)
6615 : : end do
6616 : : end if
6617 : : ! TODO: Recheck this part, in particular the order of -tau
6618 [ # # ]: 0 : cvals = cvals_pmt(2,:)
6619 : 0 : call fit_tau_exp(gwr%ntau, gwr%tau_mesh, gwr%tau_wgs, cvals, alpha_c, beta_r, ierr)
6620 : 0 : alphas_c(2, band, band2) = alpha_c; betas_r(2, band, band2) = beta_r
6621 : 0 : zcut_pm(2, band, band2) = gwr%dtset%zcut
6622 : : ! Remove the fit from the ab-initio data.
6623 [ # # ]: 0 : cvals_pmt(2,:) = cvals_pmt(2,:) - alpha_c * exp(-beta_r * gwr%tau_mesh)
6624 [ # # ]: 0 : if (gwr%comm%value == master) then
6625 : 0 : write(101, "(a,2(i0,1x))")"# -tau fit for band, band2: ", band, band2
6626 : 0 : write(101, *)"# alpha_c, beta_r: ", alpha_c, beta_r
6627 [ # # ]: 0 : do ii=1,gwr%ntau
6628 [ # # # # ]: 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)
6629 : : end do
6630 : : end if
6631 : : end if ! do_sigma_fit
6632 : :
6633 : : ! f(t) = E(t) + O(t) = (f(t) + f(-t)) / 2 + (f(t) - f(-t)) / 2
6634 [ # # # # ]: 0 : even_t = (cvals_pmt(1,:) + cvals_pmt(2,:)) / two; odd_t = (cvals_pmt(1,:) - cvals_pmt(2,:)) / two
6635 [ # # # # : 0 : gwr%sigc_iw_mat(:, band, band2, ikcalc, spin) = matmul(gwr%cosft_wt, even_t) + j_dpc * matmul(gwr%sinft_wt, odd_t)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6636 : : end associate
6637 : : end do ! band2
6638 : :
6639 : : ! NB: e0 is always set to the KS energy even in case of self-consistency.
6640 : 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6641 [ # # ]: 0 : if ( gwr%sig_diago) sigx = gwr%sigx_mat(band, 1, ikcalc, spin)
6642 [ # # ]: 0 : if (.not. gwr%sig_diago) sigx = gwr%sigx_mat(band, band, ikcalc, spin)
6643 : :
6644 : : ! Note vxc[n_val] instead of vxc[n_val + n_nlcc] with the model core charge.
6645 [ # # ]: 0 : if (gwr%nspinor == 2) then
6646 [ # # ]: 0 : vxc_val = SUM(gwr%ks_me%vxcval(band, band, ik_ibz, :))
6647 : : else
6648 : 0 : vxc_val = gwr%ks_me%vxcval(band, band, ik_ibz, spin)
6649 : : end if
6650 [ # # ]: 0 : vu = zero; if (gwr%dtset%usepawu /= 0) vu = gwr%ks_me%vu(band, band, ik_ibz, spin)
6651 : 0 : v_meanf = vxc_val + vu
6652 : :
6653 [ # # ]: 0 : band2 = merge(1, band, gwr%sig_diago)
6654 : :
6655 : : call spade%init(gwr%ntau, imag_zmesh, gwr%sigc_iw_mat(:, band, band2, ikcalc, spin), &
6656 : 0 : alphas_c(:, band, band2), betas_r(:, band, band2), zcut_pm(:, band, band2))
6657 : 0 : spade%do_sigma_fit = do_sigma_fit
6658 : :
6659 : : ! Solve the QP equation with Newton-Rapson starting from e0.
6660 : 0 : zz = cmplx(e0, zero)
6661 : 0 : call spade%qp_solve(e0, v_meanf, sigx, zz, zsc, sigc_zsc, msg, ierr)
6662 : 0 : qp_pade(band, ikcalc, spin) = zsc
6663 : 0 : pade_solver_ierr(band, ikcalc, spin) = ierr
6664 [ # # ]: 0 : ABI_WARNING_IF(ierr /= 0, msg)
6665 : :
6666 : 0 : call spade%eval(zz, sigc_e0__, dvdz=dsigc_de0)
6667 : :
6668 : : ! Z = (1 - dSigma / domega(E0))^{-1}
6669 : 0 : z_e0 = one / (one - dsigc_de0)
6670 : :
6671 : : ! Compute linearized QP solution and store results
6672 : 0 : qp_ene = e0 + z_e0 * (sigc_e0__ + sigx - v_meanf)
6673 : 0 : qpz_ene(band, ikcalc, spin) = qp_ene
6674 : 0 : e0_kcalc(band, ikcalc, spin) = e0
6675 : 0 : sigc_e0(band, ikcalc, spin) = sigc_e0__
6676 : 0 : ze0_kcalc(band, ikcalc, spin) = z_e0
6677 : :
6678 : : ! IMPORTANT: Here we update qp_ebands%eig with the new ones obtained with the linearized QP equation.
6679 : 0 : gwr%qp_ebands%eig(band, ik_ibz, spin) = real(qp_ene)
6680 : :
6681 : : ! Compute Spectral function using linear mesh **centered** around KS e0.
6682 : 0 : rw_mesh = arth(e0 - gwr%wr_step * (gwr%nwr / 2), gwr%wr_step, gwr%nwr)
6683 : 0 : hhartree_bk = gwr%ks_ebands%eig(band, ik_ibz, spin) - v_meanf
6684 [ # # ]: 0 : do iw=1,gwr%nwr
6685 : 0 : zz = rw_mesh(iw)
6686 : 0 : call spade%eval(zz, sigc_e0__)
6687 : 0 : sig_xc = sigx + sigc_e0__
6688 : 0 : sigxc_rw_diag(iw, band, ikcalc, spin) = sig_xc
6689 : :
6690 : : spfunc_diag(iw, band, ikcalc, spin) = one / pi * abs(aimag(sigc_e0__)) &
6691 : 0 : / ( (real(rw_mesh(iw) - hhartree_bk - sig_xc)) ** 2 + (aimag(sigc_e0__)) ** 2) ! / Ha_eV
6692 : :
6693 : : !Sr%hhartree = hdft - KS_me%vxcval
6694 : : !spfunc_diag(iw, band, ikcalc, spin) = &
6695 : : ! one / pi * abs(aimag(sigc_e0__)) &
6696 : : ! /( (real(rw_mesh(iw) - Sr%hhartree(ib, ib, ik_ibz, spin) - sigx_xc)) ** 2 &
6697 : : ! +(aimag(sigc_e0__)) ** 2) / Ha_eV
6698 : : end do ! iw
6699 : 0 : call spade%free()
6700 : :
6701 : : end do ! band
6702 : : end do ! ikcalc
6703 : : end do ! spin
6704 : :
6705 [ # # ]: 0 : ABI_SFREE(alphas_c)
6706 [ # # ]: 0 : ABI_SFREE(betas_r)
6707 [ # # ]: 0 : ABI_SFREE(zcut_pm)
6708 : :
6709 [ # # ]: 0 : if (gwr%nkcalc == gwr%nkibz) then
6710 : : ! Shift the bands that are not explicitly included in the SCF calculation.
6711 : : ! using the correction evaluated at bstop_ks/bstart_ks to accelerate self-consistent calculations.
6712 [ # # ]: 0 : do spin=1,gwr%nsppol
6713 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6714 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6715 : 0 : band = gwr%bstop_ks(ikcalc, spin)
6716 [ # # ]: 0 : if (band + 1 <= size(gwr%qp_ebands%eig, dim=1)) then
6717 : 0 : eshift = gwr%qp_ebands%eig(band, ik_ibz, spin) - gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6718 : 0 : call wrtout(std_out, sjoin(" Correcting bands >= ", itoa(band+1), " with eshift:", ftoa(eshift * Ha_meV), "(meV)"))
6719 [ # # ]: 0 : gwr%qp_ebands%eig(band + 1:, ik_ibz, spin) = gwr%qp_ebands%eig(band + 1:, ik_ibz, spin) + eshift
6720 : : end if
6721 : 0 : band = gwr%bstart_ks(ikcalc, spin)
6722 [ # # ]: 0 : if (band > 1) then ! unlikely
6723 : 0 : eshift = gwr%qp_ebands%eig(band, ik_ibz, spin) - gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6724 : 0 : call wrtout(std_out, sjoin(" Correcting bands < ", itoa(band), " with eshift:", ftoa(eshift * Ha_meV), "(meV)"))
6725 [ # # ]: 0 : gwr%qp_ebands%eig(:band - 1, ik_ibz, spin) = gwr%qp_ebands%eig(:band - 1, ik_ibz, spin) + eshift
6726 : : end if
6727 : : end do
6728 : : end do
6729 : :
6730 : : ! Recompute occupancies and set fermie to zero.
6731 : : ! FIXME: Possible problem here if the QP energies are not ordered!
6732 : 0 : call gwr%qp_ebands%update_occ(gwr%dtset%spinmagntarget, prtvol=gwr%dtset%prtvol, fermie_to_zero=.True.)
6733 : : end if
6734 : :
6735 [ # # ]: 0 : if (gwr%comm%me == 0) then
6736 : : ! Master writes results to ab_out, std_out and GWR.nc
6737 [ # # # # : 0 : if (any(pade_solver_ierr /= 0)) then
# # # # #
# ]
6738 : : ! Write warning if QP solver failed.
6739 [ # # # # : 0 : ierr = count(pade_solver_ierr /= 0)
# # # # ]
6740 [ # # ]: 0 : call wrtout([ab_out, std_out], sjoin(" WARNING: QP solver failed for:", itoa(ierr), "states"))
6741 : : end if
6742 : :
6743 [ # # ]: 0 : call write_notations([std_out, ab_out])
6744 [ # # ]: 0 : do spin=1,gwr%nsppol
6745 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6746 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6747 : :
6748 : 0 : ydoc = yamldoc_open('GWR_SelfEnergy_ee', width=11, real_fmt='(3f8.3)')
6749 : 0 : call ydoc%add_real1d('kpoint', gwr%kcalc(:, ikcalc))
6750 : 0 : call ydoc%add_int('spin', spin, int_fmt="(i1)")
6751 : 0 : call ydoc%add_int('gwr_scf_iteration', gwr%scf_iteration)
6752 : 0 : call ydoc%add_string('gwr_task', gwr%dtset%gwr_task)
6753 : :
6754 : : ! Compute gaps assuming KS band indices.
6755 : 0 : band_val = gwr%ks_vbik(ik_ibz, spin)
6756 : 0 : nbc = gwr%bstop_ks(ikcalc, spin) - gwr%bstart_ks(ikcalc, spin) + 1
6757 : 0 : ib1 = gwr%bstart_ks(ikcalc, spin); ib2 = gwr%bstop_ks(ikcalc, spin)
6758 : :
6759 [ # # # # ]: 0 : if (band_val >= gwr%bstart_ks(ikcalc, spin) .and. band_val + 1 <= gwr%bstop_ks(ikcalc, spin)) then
6760 : 0 : ibv = band_val - gwr%bstart_ks(ikcalc, spin) + 1
6761 : 0 : ks_gap = gwr%ks_ebands%eig(band_val+1, ik_ibz, spin) - gwr%ks_ebands%eig(band_val, ik_ibz, spin)
6762 : :
6763 : : ! This to detect a possible band inversion and compute qp_gaps accordingly.
6764 : 0 : band_inversion = .False.
6765 [ # # # # : 0 : call sort_rvals(nbc, real(qpz_ene(ib1:, ikcalc, spin)), iperm, sorted_qpe, tol=tol6)
# # # # #
# ]
6766 : :
6767 [ # # # # ]: 0 : if (iperm(ibv) /= ibv .or. iperm(ibv + 1) /= ibv + 1) then
6768 : 0 : band_inversion = .True.
6769 : 0 : call ydoc%add_int('QP_VBM_band', iperm(ibv) + gwr%bstart_ks(ikcalc, spin) - 1)
6770 : 0 : call ydoc%add_int('QP_CBM_band', iperm(ibv+1) + gwr%bstart_ks(ikcalc, spin) - 1)
6771 : 0 : qp_gap = sorted_qpe(ibv+1) - sorted_qpe(ibv)
6772 : 0 : qp_pade_gap = qp_pade(band_val+1, ikcalc, spin) - qp_pade(band_val, ikcalc, spin)
6773 : : else
6774 : 0 : call ydoc%add_int('QP_VBM_band', ibv + gwr%bstart_ks(ikcalc, spin) - 1)
6775 : 0 : call ydoc%add_int('QP_CBM_band', ibv+1 + gwr%bstart_ks(ikcalc, spin) - 1)
6776 : 0 : qp_gap = gwr%qp_ebands%eig(band_val+1, ik_ibz, spin) - gwr%qp_ebands%eig(band_val, ik_ibz, spin)
6777 : 0 : qp_pade_gap = qp_pade(band_val+1, ikcalc, spin) - qp_pade(band_val, ikcalc, spin)
6778 : : end if
6779 : 0 : ABI_FREE(iperm)
6780 [ # # ]: 0 : ABI_FREE(sorted_qpe)
6781 : :
6782 : 0 : call ydoc%add_real('KS_gap', ks_gap * Ha_eV)
6783 : 0 : call ydoc%add_real('QP_gap', qp_gap * Ha_eV)
6784 : 0 : call ydoc%add_real('Delta_QP_KS', (qp_gap - ks_gap) * Ha_eV)
6785 : 0 : ks_gaps(ikcalc, spin)= ks_gap
6786 : 0 : qpz_gaps(ikcalc, spin) = qp_gap
6787 : 0 : qp_pade_gaps(ikcalc, spin) = qp_pade_gap
6788 : : end if
6789 : :
6790 : 0 : call ydoc%open_tabular('data') !, tag='SigmaeeData')
6791 : 0 : write(msg, "(a5, *(a9))") "Band", "E0", "<VxcDFT>", "SigX", "SigC(E0)", "Z", "E-E0", "E-Eprev", "E", "Occ(E)"
6792 : 0 : call ydoc%add_tabular_line(msg)
6793 : :
6794 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6795 : 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6796 : 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6797 : 0 : qp_ene = gwr%qp_ebands%eig(band, ik_ibz, spin)
6798 : 0 : qp_ene_prev = gwr%qp_ebands_prev%eig(band, ik_ibz, spin)
6799 [ # # ]: 0 : if ( gwr%sig_diago) sigx = gwr%sigx_mat(band, 1, ikcalc, spin)
6800 [ # # ]: 0 : if (.not. gwr%sig_diago) sigx = gwr%sigx_mat(band, band, ikcalc, spin)
6801 [ # # ]: 0 : if (gwr%nspinor == 2) then
6802 [ # # ]: 0 : vxc_val = SUM(gwr%ks_me%vxcval(band, band, ik_ibz, :))
6803 : : else
6804 : 0 : vxc_val = gwr%ks_me%vxcval(band, band, ik_ibz, spin)
6805 : : end if
6806 : :
6807 : : write(msg,'(i5, *(f9.3))') &
6808 : 0 : band, & ! Band
6809 : 0 : e0 * Ha_eV, & ! E0
6810 : 0 : real(vxc_val)*Ha_eV, & ! <VxcDFT>
6811 : 0 : real(sigx) * Ha_eV, & ! SigX
6812 : 0 : real(sigc_e0(band, ikcalc, spin)) * Ha_eV, & ! SigC(E0)
6813 : 0 : real(ze0_kcalc(band, ikcalc, spin)), & ! Z
6814 : 0 : (real(qp_ene - e0)) * Ha_eV, & ! E-E0
6815 : 0 : real(qp_ene - qp_ene_prev) * Ha_eV, & ! E-Eprev
6816 : 0 : real(qp_ene) * Ha_eV, & ! E
6817 : 0 : gwr%qp_ebands%occ(band, ik_ibz, spin) ! Occ(E)
6818 : 0 : call ydoc%add_tabular_line(msg)
6819 : : end do
6820 : :
6821 [ # # ]: 0 : call ydoc%write_units_and_free([std_out, ab_out])
6822 : : end do ! ikcalc
6823 : : end do ! spin
6824 : :
6825 : : ! Print KS and QP gaps
6826 : 0 : call gwr%ks_gaps%print(units, header="Kohn-Sham gaps and band edges from IBZ mesh")
6827 : :
6828 [ # # # # : 0 : new_gaps = gwr%qp_ebands%get_gaps(ierr)
# # # # #
# # # # #
# # ]
6829 : 0 : write(msg,"(a,i0,a)")" QP gaps and band edges taking into account Sigma_nk corrections for ",gwr%nkcalc," k-points"
6830 : 0 : call new_gaps%print(units, header=msg)
6831 [ # # ]: 0 : if (ierr /= 0) then
6832 : 0 : ABI_WARNING("Cannot compute QP fundamental and direct gap (likely metal)")
6833 : : end if
6834 : 0 : call new_gaps%free()
6835 : :
6836 : : ! Write results to text files.
6837 [ # # ]: 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGC_IT'), msg, newunit=unt_it, action="write") /= 0) then
6838 : 0 : ABI_ERROR(msg)
6839 : : end if
6840 : 0 : write(unt_it, "(a)")"# Diagonal elements of Sigma_c(i tau, +/-) in atomic units"
6841 : 0 : write(unt_it, "(a)")"# tau Re/Im Sigma_c(+itau) Re/Im Sigma_c(-itau)"
6842 : :
6843 [ # # ]: 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGXC_IW'), msg, newunit=unt_iw, action="write") /= 0) then
6844 : 0 : ABI_ERROR(msg)
6845 : : end if
6846 : 0 : write(unt_iw, "(a)")"# Diagonal elements of Sigma_xc(i omega) in eV units"
6847 : 0 : write(unt_iw, "(a)")"# omega Re/Im Sigma_c(i omega)"
6848 : :
6849 [ # # ]: 0 : if (open_file(strcat(gwr%dtfil%filnam_ds(4), '_SIGXC_RW'), msg, newunit=unt_rw, action="write") /= 0) then
6850 : 0 : ABI_ERROR(msg)
6851 : : end if
6852 : 0 : write(unt_rw, "(a)")"# Diagonal elements of Sigma_xc(omega) in eV units and spectral function A(omega)"
6853 : 0 : write(unt_rw, "(a)")"# omega Re/Im Sigma_xc(omega), A(omega)"
6854 : :
6855 [ # # ]: 0 : dat_units = [unt_it, unt_iw, unt_rw]
6856 : 0 : call write_units(dat_units, "# Fermi energy set to zero. Energies in eV")
6857 : 0 : call write_units(dat_units, sjoin("# nkcalc:", itoa(gwr%nkcalc), ", nsppol:", itoa(gwr%nsppol)))
6858 : :
6859 : : ! TODO: Improve file format. Add compatibility with gnuplot format for datasets?
6860 [ # # ]: 0 : do spin=1,gwr%nsppol
6861 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
6862 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
6863 : 0 : call write_units(dat_units, sjoin("# kpt:", ktoa(gwr%kcalc(:, ikcalc)), "spin:", itoa(spin)))
6864 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
6865 : 0 : ibc = band - gwr%bstart_ks(ikcalc, spin) + 1
6866 : 0 : e0 = gwr%ks_ebands%eig(band, ik_ibz, spin)
6867 [ # # ]: 0 : band2 = merge(1, band, gwr%sig_diago)
6868 : 0 : sigx = gwr%sigx_mat(band, band2, ikcalc, spin)
6869 : :
6870 : 0 : call write_units(dat_units, sjoin("# band:", itoa(band), ", spin:", itoa(spin)))
6871 : 0 : call write_units(dat_units, sjoin("# sigx_ev:", ftoa(sigx * Ha_eV)))
6872 : :
6873 [ # # ]: 0 : do itau=1,gwr%ntau
6874 : : ! FIXME itau is not ordered
6875 : : write(unt_it, "(*(es16.8))") &
6876 : 0 : gwr%tau_mesh(itau), &
6877 [ # # ]: 0 : c2r(sigc_it_mat(1, itau, band, band2, ikcalc, spin)), &
6878 [ # # ]: 0 : c2r(sigc_it_mat(2, itau, band, band2, ikcalc, spin))
6879 : : write(unt_iw, "(*(es16.8))") &
6880 : 0 : gwr%iw_mesh(itau) * Ha_eV, &
6881 [ # # ]: 0 : (c2r(gwr%sigc_iw_mat(itau, band, band2, ikcalc, spin) + sigx)) * Ha_eV
6882 : : end do
6883 : :
6884 : : ! Write Sigma_xc(omega) and A(omega)
6885 [ # # ]: 0 : rw_mesh = arth(e0 - gwr%wr_step * (gwr%nwr / 2), gwr%wr_step, gwr%nwr) * Ha_eV
6886 [ # # ]: 0 : do iw=1,gwr%nwr
6887 : : write(unt_rw, "(*(es16.8))") &
6888 : 0 : rw_mesh(iw), &
6889 [ # # ]: 0 : c2r(sigxc_rw_diag(iw, band, ikcalc, spin)) * Ha_eV, &
6890 : 0 : spfunc_diag(iw, band, ikcalc, spin) / Ha_eV
6891 : : end do
6892 : : end do
6893 : : end do
6894 : : end do
6895 : :
6896 : 0 : close(unt_it); close(unt_iw); close(unt_rw)
6897 : :
6898 : : ! ======================
6899 : : ! Add results to GWR.nc
6900 : : ! ======================
6901 [ # # ]: 0 : if (gwr%gwrnc_write) then
6902 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gwr%gwrnc_path, xmpi_comm_self))
6903 : :
6904 : : ! Define arrays with results.
6905 : : ! TODO: Add matrix elements of vxc, have to trasfer data from vxcval to nkcalc packing
6906 : 0 : call ncwrite_sigmac(ncid)
6907 : :
6908 : : if (.true.) then
6909 [ # # ]: 0 : NCF_CHECK(nf90_def_grp(ncid, strcat("iter", itoa(gwr%scf_iteration)), iter_ncid))
6910 : 0 : call ncwrite_sigmac(iter_ncid)
6911 : : end if
6912 : :
6913 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("scf_iteration"), gwr%scf_iteration))
6914 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_completed"), 1))
6915 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
6916 : : end if
6917 : : end if ! master
6918 : :
6919 [ # # ]: 0 : ABI_FREE(sigc_it_mat)
6920 : : !ABI_FREE(sigc_iw_mat)
6921 : :
6922 : 0 : call cwtime_report(" gwr_build_sigmac:", cpu_all, wall_all, gflops_all)
6923 [ # # # # : 0 : call timab(1925, 2, tsec)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
6924 : :
6925 : : contains
6926 : 0 : integer function vid(vname)
6927 : : character(len=*),intent(in) :: vname
6928 : 0 : vid = nctk_idname(ncid, vname)
6929 : : end function vid
6930 : :
6931 : 0 : subroutine print_sigma_header()
6932 : :
6933 [ # # ]: 0 : if (gwr%comm%me /= 0) return
6934 [ # # ]: 0 : if (gwr%use_supercell_for_sigma) then
6935 : 0 : call wrtout(std_out, sjoin(" Building Sigma_c in the supercell with FFT mesh:", ltoa(sc_ngfft(1:3))), pre_newlines=2)
6936 : : else
6937 [ # # ]: 0 : call wrtout([std_out,ab_out], " Building Sigma_c with convolutions in k-space:", pre_newlines=2)
6938 : : end if
6939 : 0 : call wrtout(std_out, sjoin(" gwr_np_kgts:", ltoa(gwr%dtset%gwr_np_kgts)))
6940 : 0 : call wrtout(std_out, sjoin(" ngkpt:", ltoa(gwr%ngkpt), " ngqpt:", ltoa(gwr%ngqpt)))
6941 : 0 : call wrtout(std_out, sjoin(" gwr_boxcutmin:", ftoa(gwr%dtset%gwr_boxcutmin)))
6942 : 0 : call wrtout(std_out, sjoin(" my_ntau:", itoa(gwr%my_ntau), "ntau:", itoa(gwr%ntau)))
6943 : 0 : call wrtout(std_out, sjoin(" my_nkbz:", itoa(gwr%my_nkbz), "nkibz:", itoa(gwr%nkibz)))
6944 : 0 : call wrtout(std_out, sjoin("- FFT uc_batch_size:", itoa(gwr%uc_batch_size)))
6945 : 0 : call wrtout(std_out, sjoin("- FFT sc_batch_size:", itoa(gwr%sc_batch_size)), do_flush=.True.)
6946 : :
6947 : : end subroutine print_sigma_header
6948 : :
6949 : 0 : subroutine ncwrite_sigmac(myncid)
6950 : : integer,intent(in) :: myncid
6951 : : !logical,intent(in), optional :: mydefine
6952 : : integer :: myncerr
6953 : :
6954 : : ! Write Sigma_c to GWR.nc
6955 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(myncid))
6956 : : ! if (.not. present(mydefine) .or. mydefine) then
6957 : : if (.true.) then
6958 : : myncerr = nctk_def_arrays(myncid, [ &
6959 : : nctkarr_t("e0_kcalc", "dp", "smat_bsize1, nkcalc, nsppol"), &
6960 : : nctkarr_t("ze0_kcalc", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6961 : : !nctkarr_t("vxc_kcalc", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6962 : : nctkarr_t("qpz_ene", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6963 : : nctkarr_t("qp_pade", "dp", "two, smat_bsize1, nkcalc, nsppol"), &
6964 : : nctkarr_t("pade_solver_ierr", "int", "smat_bsize1, nkcalc, nsppol"), &
6965 : : nctkarr_t("ks_gaps", "dp", "nkcalc, nsppol"), &
6966 : : nctkarr_t("qpz_gaps", "dp", "nkcalc, nsppol"), &
6967 : : nctkarr_t("qp_pade_gaps", "dp", "nkcalc, nsppol"), &
6968 : : nctkarr_t("sigx_mat", "dp", "two, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6969 : : nctkarr_t("sigc_it_mat", "dp", "two, two, ntau, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6970 : : nctkarr_t("sigc_iw_mat", "dp", "two, ntau, smat_bsize1, smat_bsize2, nkcalc, nsppol"), &
6971 : : nctkarr_t("sigxc_rw_diag", "dp", "two, nwr, smat_bsize1, nkcalc, nsppol"), &
6972 : : nctkarr_t("spfunc_diag", "dp", "nwr, smat_bsize1, nkcalc, nsppol") &
6973 [ # # ]: 0 : ])
6974 [ # # ]: 0 : NCF_CHECK(myncerr)
6975 : : end if
6976 : : ! Write data.
6977 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(myncid))
6978 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "e0_kcalc"), e0_kcalc))
6979 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "ze0_kcalc"), c2r(ze0_kcalc)))
# # ]
6980 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigx_mat"), c2r(gwr%sigx_mat(:,:,:,1:gwr%nsppol))))
# # ]
6981 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qpz_ene"), c2r(qpz_ene)))
# # ]
6982 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qp_pade"), c2r(qp_pade)))
# # ]
6983 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "pade_solver_ierr"), pade_solver_ierr))
6984 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "ks_gaps"), ks_gaps))
6985 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qpz_gaps"), qpz_gaps))
6986 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "qp_pade_gaps"), qp_pade_gaps))
6987 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigc_it_mat"), c2r(sigc_it_mat)))
# # ]
6988 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigc_iw_mat"), c2r(gwr%sigc_iw_mat)))
# # ]
6989 [ # # # # : 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "sigxc_rw_diag"), c2r(sigxc_rw_diag)))
# # ]
6990 [ # # ]: 0 : NCF_CHECK(nf90_put_var(myncid, nctk_idname(myncid, "spfunc_diag"), spfunc_diag))
6991 : :
6992 : 0 : end subroutine ncwrite_sigmac
6993 : :
6994 : : end subroutine gwr_build_sigmac
6995 : : !!***
6996 : :
6997 : : !!****f* m_gwr/write_notations
6998 : : !! NAME
6999 : : !! write_notations
7000 : : !!
7001 : : !! FUNCTION
7002 : : !! Write the meaning of the different columns.
7003 : : !!
7004 : : !! SOURCE
7005 : :
7006 [ # # ]: 0 : subroutine write_notations(units)
7007 : : integer,intent(in) :: units(:)
7008 : : integer :: ii, unt
7009 : :
7010 [ # # ]: 0 : do ii=1,size(units)
7011 : 0 : unt = units(ii)
7012 : 0 : write(unt,"(a)")repeat("=", 80)
7013 : 0 : write(unt,"(a)")" QP results (energies in eV)"
7014 : 0 : write(unt,"(a)")" Notations:"
7015 : 0 : write(unt,"(a)")" E0: Kohn-Sham energy"
7016 : 0 : write(unt,"(a)")" <VxcDFT>: Matrix elements of Vxc[n_val] without non-linear core correction (if any)"
7017 : 0 : write(unt,"(a)")" SigX: Matrix elements of Sigma_x"
7018 : 0 : write(unt,"(a)")" SigC(E0): Matrix elements of Sigma_c at E0"
7019 : 0 : write(unt,"(a)")" Z: Renormalization factor"
7020 : 0 : write(unt,"(a)")" E-E0: Difference between the QP and the KS energy."
7021 : 0 : write(unt,"(a)")" E-Eprev: Difference between QP energy at iteration i and i-1"
7022 : 0 : write(unt,"(a)")" E: Quasi-particle energy"
7023 : 0 : write(unt,"(a)")" Occ(E): Occupancy of QP state"
7024 : : !write(unt,"(a)")" SE1(eKS): Real part of the self-energy computed at the KS energy, SE2 for imaginary part."
7025 : 0 : write(unt,"(a)")" "
7026 : 0 : write(unt,"(a)")" "
7027 : : end do
7028 : 0 : end subroutine write_notations
7029 : : !!***
7030 : :
7031 : : !----------------------------------------------------------------------
7032 : :
7033 : : !!****f* m_gwr/sig_braket_ur
7034 : : !! NAME
7035 : : !! sig_braket_ur
7036 : : !!
7037 : : !! FUNCTION
7038 : : !! Integrate self-energy matrix elements in the unit cell.
7039 : : !!
7040 : : !! INPUTS
7041 : : !!
7042 : : !! OUTPUT
7043 : : !!
7044 : : !! SOURCE
7045 : :
7046 : 0 : subroutine sig_braket_ur(sig_rpr, nfftsp, ur_bra_glob, ur_ket_glob, sigm_pm, loc_cwork)
7047 : :
7048 : : !Arguments ------------------------------------
7049 : : type(__slkmat_t),intent(in) :: sig_rpr(2,2)
7050 : : integer,intent(in) :: nfftsp
7051 : : complex(gwp),intent(in) :: ur_bra_glob(nfftsp)
7052 : : complex(gwp),intent(in) :: ur_ket_glob(nfftsp)
7053 : :
7054 : : complex(gwp),intent(out) :: sigm_pm(2)
7055 : : complex(gwp),intent(inout) :: loc_cwork(sig_rpr(1,1)%size_local(2))
7056 : :
7057 : : !Local variables-------------------------------
7058 : : integer :: ipm, ir1, il_r1, nrows, ncols, itim
7059 : : !complex(gwp),allocatable :: loc_cwork(:)
7060 : : ! *************************************************************************
7061 : :
7062 : : ABI_NVTX_START_RANGE(NVTX_GWR_BRAKET_UR)
7063 : :
7064 : : ! (r',r) with r' local and r-index PBLAS-distributed.
7065 : 0 : sigm_pm = czero_gw
7066 [ # # ]: 0 : do itim=1,2
7067 [ # # ]: 0 : do ipm=1,2
7068 : 0 : associate (rp_r => sig_rpr(itim,ipm))
7069 : : ! Integrate over r'
7070 : : !ABI_CHECK_IEQ(nfftsp, rp_r%size_local(1), "First dimension should be local to each MPI proc!")
7071 : : !ABI_MALLOC(loc_cwork, (rp_r%size_local(2)))
7072 : : !loc_cwork(:) = matmul(transpose(rp_r%buffer_cplx), ur_glob)
7073 : :
7074 : 0 : nrows = rp_r%size_local(1); ncols = rp_r%size_local(2)
7075 : 0 : call xgemv('T', nrows, ncols, cone_gw, rp_r%buffer_cplx, nrows, ur_ket_glob, 1, czero_gw, loc_cwork, 1)
7076 : :
7077 : : ! Integrate over r. Note complex conjugate.
7078 [ # # ]: 0 : do il_r1=1,rp_r%size_local(2)
7079 : 0 : ir1 = rp_r%loc2gcol(il_r1)
7080 [ # # ]: 0 : if (itim == 1) then
7081 : 0 : sigm_pm(ipm) = sigm_pm(ipm) + conjg(ur_bra_glob(ir1)) * loc_cwork(il_r1)
7082 : : else
7083 : 0 : sigm_pm(ipm) = sigm_pm(ipm) + ur_bra_glob(ir1) * conjg(loc_cwork(il_r1))
7084 : : end if
7085 : : end do
7086 : : !ABI_FREE(loc_cwork)
7087 : : end associate
7088 : : end do
7089 : : end do
7090 : :
7091 : : ABI_NVTX_END_RANGE()
7092 : :
7093 : 0 : end subroutine sig_braket_ur
7094 : : !!***
7095 : :
7096 : : !----------------------------------------------------------------------
7097 : :
7098 : : !!****f* m_gwr/gwr_rpa_energy
7099 : : !! NAME
7100 : : !! gwr_rpa_energy
7101 : : !!
7102 : : !! FUNCTION
7103 : : !! Compute the correlated part of the total energy within ACFDT.
7104 : : !!
7105 : : !! INPUTS
7106 : : !!
7107 : : !! OUTPUT
7108 : : !!
7109 : : !! SOURCE
7110 : :
7111 : 0 : subroutine gwr_rpa_energy(gwr)
7112 : :
7113 : : !Arguments ------------------------------------
7114 : : class(gwr_t),target,intent(inout) :: gwr
7115 : :
7116 : : !Local variables-------------------------------
7117 : : !scalars
7118 : : integer,parameter :: master = 0
7119 : : integer :: my_is, my_iqi, my_it, itau, spin, iq_ibz, ii, ierr, ig, ncut, icut, mat_size
7120 : : integer :: il_g1, il_g2, ig1, ig2, npw_q, ig0, ncid, ncerr
7121 : : logical :: q_is_gamma, print_time
7122 : : real(dp) :: weight, qq_ibz(3), estep, aa, bb, rmsq, ecut_soft, damp, tsec(2)
7123 : : real(dp) :: cpu_all, wall_all, gflops_all, cpu_q, wall_q, gflops_q, cpu_cut, wall_cut, gflops_cut
7124 : : complex(dp) :: vcs_g1, vcs_g2
7125 : : type(desc_t),pointer :: desc_q
7126 : : character(len=500) :: msg
7127 : : !arrays
7128 [ # # # # : 0 : type(__slkmat_t) :: chi_tmp, dummy_vec, chi_4diag
# # # # #
# # # # #
# # # # ]
7129 : : type(slk_processor_t) :: proc_4diag
7130 : 0 : real(gwp),allocatable :: eig(:)
7131 : 0 : real(dp),allocatable :: kin_qg(:), ec_rpa(:), ec_mp2(:), ecut_chi(:)
7132 : : ! *************************************************************************
7133 : :
7134 : 0 : call gwr%build_chi0_head_and_wings()
7135 : 0 : call gwr%build_green(free_ugb=.True.)
7136 : 0 : call gwr%build_tchi()
7137 : :
7138 : : ! Compute RPA energy for ncut cutoff energies in order to extrapolate for ecuteps --> oo
7139 : : ! See also calc_rpa_functional in m_screening_driver
7140 : 0 : ncut = max(1, gwr%dtset%gwr_rpa_ncut) ! Usually 5
7141 : 0 : estep = -gwr%dtset%ecuteps * 0.05_dp
7142 : :
7143 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
7144 : 0 : call timab(1928, 1, tsec)
7145 : 0 : call wrtout(std_out, sjoin(" Begin computation of RPA energy with gwr_rpa_ncut:", itoa(ncut), " ..."))
7146 [ # # ]: 0 : ABI_CHECK(gwr%tchi_space == "iomega", sjoin("tchi_space:", gwr%tchi_space, "!= iomega"))
7147 : :
7148 [ # # # # : 0 : ABI_CALLOC(ec_rpa, (ncut))
# # # # #
# # # ]
7149 [ # # # # : 0 : ABI_CALLOC(ec_mp2, (ncut))
# # # # #
# ]
7150 [ # # # # : 0 : ABI_MALLOC(ecut_chi, (ncut))
# # # # ]
7151 [ # # ]: 0 : ecut_chi = arth(gwr%dtset%ecuteps + tol12, estep, ncut)
7152 : :
7153 : : ! Polarizability has been summed over spins inside build_tchi.
7154 : : ! The loop over spins is needed to parallelize the loop over my_iqi if nsppol == 2.
7155 [ # # ]: 0 : do my_is=1,gwr%my_nspins
7156 : 0 : spin = gwr%my_spins(my_is)
7157 [ # # # # ]: 0 : if (gwr%spin_comm%nproc == 1 .and. spin == 2) cycle
7158 : :
7159 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
7160 [ # # ]: 0 : if (gwr%spin_comm%skip(my_iqi)) cycle
7161 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (my_iqi < LOG_MODK .or. mod(my_iqi, LOG_MODK) == 0)
# # ]
7162 : 0 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
7163 : :
7164 [ # # ]: 0 : iq_ibz = gwr%my_qibz_inds(my_iqi); qq_ibz = gwr%qibz(:, iq_ibz)
7165 : 0 : q_is_gamma = normv(qq_ibz, gwr%cryst%gmet, "G") < GW_TOLQ0
7166 : : !if (q_is_gamma) then
7167 : : ! call wrtout([std_out, ab_out], "RPA: Ignoring q==0"); cycle
7168 : : !end if
7169 : :
7170 : : ! iq_ibz might be replicated inside gwr%kpt_comm.
7171 [ # # ]: 0 : if (.not. gwr%itreat_iqibz(iq_ibz)) cycle
7172 : :
7173 : 0 : desc_q => gwr%tchi_desc_qibz(iq_ibz)
7174 [ # # ]: 0 : ABI_CHECK(desc_q%kin_sorted, "g-vectors are not sorted by |q+g|^2/2 !")
7175 : 0 : npw_q = desc_q%npw; ig0 = desc_q%ig0
7176 : :
7177 [ # # # # : 0 : ABI_MALLOC(kin_qg, (npw_q))
# # # # #
# # # #
# ]
7178 [ # # ]: 0 : do ig=1,npw_q
7179 [ # # ]: 0 : kin_qg(ig) = half * normv(qq_ibz + desc_q%gvec(:,ig), gwr%cryst%gmet, "G") ** 2
7180 : : end do
7181 : :
7182 [ # # ]: 0 : do my_it=1,gwr%my_ntau
7183 : 0 : itau = gwr%my_itaus(my_it)
7184 : 0 : associate (tchi => gwr%tchi_qibz(iq_ibz, itau, spin))
7185 : 0 : if (my_it == 1) then
7186 : : ! Allocate workspace. NB: npw_q is the total number of PWs for this q.
7187 : 0 : call tchi%copy(chi_tmp)
7188 : : !ABI_CHECK_IEQ(npw_q, tchi%sizeb_global(1), "npw_q")
7189 [ # # # # : 0 : ABI_MALLOC(eig, (npw_q))
# # # # #
# ]
7190 : : end if
7191 : :
7192 [ # # ]: 0 : do icut=1,ncut
7193 : 0 : call cwtime(cpu_cut, wall_cut, gflops_cut, "start")
7194 : :
7195 : : ! Damp Coulomb kernel in order to have smooth E(V).
7196 : : ! See also https://www.vasp.at/wiki/index.php/ENCUTGWSOFT
7197 : : ! and Harl's PhD thesis available at: https://utheses.univie.ac.at/detail/2259
7198 : 0 : ecut_soft = 0.8_dp * ecut_chi(icut)
7199 : :
7200 : : ! TODO: Contribution due to the head for q --> 0 is ignored.
7201 : : ! This is not optimal but consistent with calc_rpa_functional
7202 [ # # ]: 0 : do il_g2=1,tchi%size_local(2)
7203 : : !ig2 = mod(tchi%loc2gcol(il_g2) - 1, desc_q%npw) + 1
7204 : 0 : ig2 = tchi%loc2gcol(il_g2)
7205 : 0 : damp = one
7206 : : !if (kin_qg(ig2) > ecut_soft) then
7207 : : ! damp = sqrt(half * (one + cos(pi * (kin_qg(ig2) - ecut_soft) / (ecut_chi(icut) - ecut_soft))))
7208 : : !end if
7209 : 0 : vcs_g2 = desc_q%vc_sqrt_eps(ig2) * damp
7210 [ # # ]: 0 : if (q_is_gamma .and. ig2 == ig0) vcs_g2 = zero
7211 : :
7212 [ # # ]: 0 : do il_g1=1,tchi%size_local(1)
7213 : : !ig1 = mod(tchi%loc2grow(il_g1) - 1, desc_q%npw) + 1
7214 : 0 : ig1 = tchi%loc2grow(il_g1)
7215 : 0 : damp = one
7216 : : !if (kin_qg(ig1) > ecut_soft) then
7217 : : ! damp = sqrt(half * (one + cos(pi * (kin_qg(ig1) - ecut_soft) / (ecut_chi(icut) - ecut_soft))))
7218 : : !end if
7219 : 0 : vcs_g1 = desc_q%vc_sqrt_eps(ig1) * damp
7220 [ # # ]: 0 : if (q_is_gamma .and. ig1 == ig0) vcs_g1 = zero
7221 : :
7222 : 0 : chi_tmp%buffer_cplx(il_g1, il_g2) = tchi%buffer_cplx(il_g1, il_g2) * vcs_g1 * vcs_g2
7223 : : end do
7224 : : end do
7225 : :
7226 : : ! Diagonalize sub-matrix and perform integration in imaginary frequency.
7227 : : ! Eq (6) in 10.1103/PhysRevB.81.115126
7228 : : ! NB: have to build chi_tmp inside loop over icut as matrix is destroyed by pzheev.
7229 : 0 : mat_size = bisect(kin_qg, ecut_chi(icut))
7230 : :
7231 : : ! Change size block and, if possible, use 2D rectangular grid of processors for diagonalization
7232 : 0 : call proc_4diag%init(chi_tmp%processor%comm)
7233 : 0 : call chi_tmp%change_size_blocs(chi_4diag, processor=proc_4diag)
7234 : : !call chi_4diag%copy(dummy_vec)
7235 : 0 : call chi_4diag%heev("N", "U", dummy_vec, eig, mat_size=mat_size)
7236 : 0 : call chi_4diag%free()
7237 : : !call dummy_vec%free()
7238 : 0 : call proc_4diag%free()
7239 : :
7240 : : ! TODO: ELPA
7241 : : !call compute_eigen_problem(processor, matrix, results, eigen, comm, istwf_k, nev)
7242 : :
7243 [ # # ]: 0 : if (xmpi_comm_rank(chi_tmp%processor%comm) == 0) then
7244 : 0 : weight = gwr%wtq(iq_ibz) * gwr%iw_wgs(itau) / two_pi
7245 [ # # ]: 0 : do ii=1,mat_size
7246 : 0 : ec_rpa(icut) = ec_rpa(icut) + weight * (log(one - eig(ii)) + eig(ii))
7247 : : ! second order Moeller Plesset.
7248 : 0 : ec_mp2(icut) = ec_mp2(icut) - weight * eig(ii) ** 2 / two
7249 : : !if (eig(ii) > zero) then
7250 : : ! write(msg, "(a, es16.8)")"Positive eigenvalue:", eig(ii)
7251 : : ! ABI_ERROR(msg)
7252 : : !end if
7253 : : end do
7254 : : end if
7255 : :
7256 : 0 : write(msg,'(4x,2(a,i0),a)')"icut [", icut, "/", ncut, "]"
7257 : 0 : call cwtime_report(msg, cpu_cut, wall_cut, gflops_cut)
7258 : : end do ! icut
7259 : :
7260 [ # # # # ]: 0 : if (my_it == gwr%my_ntau) then
7261 : : ! Free workspace
7262 : 0 : call chi_tmp%free()
7263 [ # # ]: 0 : ABI_FREE(eig)
7264 : : end if
7265 : : end associate
7266 : : end do ! my_it
7267 : :
7268 [ # # ]: 0 : ABI_FREE(kin_qg)
7269 [ # # ]: 0 : if (print_time) then
7270 : 0 : write(msg,'(4x,2(a,i0),a)')"My iqi [", my_iqi, "/", gwr%my_nqibz, "]"
7271 : 0 : call cwtime_report(msg, cpu_q, wall_q, gflops_q)
7272 : : end if
7273 : : end do ! my_iqi
7274 : : end do ! my_is
7275 : :
7276 : : ! Collect results on the master node.
7277 : 0 : call xmpi_sum_master(ec_rpa, master, gwr%comm%value, ierr)
7278 : 0 : call xmpi_sum_master(ec_mp2, master, gwr%comm%value, ierr)
7279 : :
7280 [ # # ]: 0 : if (gwr%comm%me == master) then
7281 : : ! Print results to ab_out.
7282 : : ! TODO: Add metadata: nband, nqbz...
7283 : 0 : write(ab_out, "(4a16)")"ecut_chi", "ecut_chi^(-3/2)", "RPA Ec (eV)", "RPA Ec (Ha)"
7284 [ # # ]: 0 : do icut=ncut,1,-1
7285 : 0 : write(ab_out, "(*(es16.8))") ecut_chi(icut), ecut_chi(icut) ** (-three/two), ec_rpa(icut) * Ha_eV, ec_rpa(icut)
7286 : : end do
7287 [ # # ]: 0 : if (ncut > 1) then
7288 : : ! Add last line with extrapolated value.
7289 [ # # # # ]: 0 : rmsq = linfit(ncut, ecut_chi(:) ** (-three/two), ec_rpa, aa, bb)
7290 : 0 : write(ab_out, "(2a16,*(es16.8))") "oo", "0", bb * Ha_eV, bb
7291 : : end if
7292 : :
7293 : : ! ======================
7294 : : ! Add results to GWR.nc
7295 : : ! ======================
7296 [ # # ]: 0 : if (gwr%gwrnc_write) then
7297 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gwr%gwrnc_path, xmpi_comm_self))
7298 [ # # ]: 0 : ncerr = nctk_def_dims(ncid, [nctkdim_t("ncut", ncut)], defmode=.True.)
7299 [ # # ]: 0 : NCF_CHECK(ncerr)
7300 : :
7301 : : ncerr = nctk_def_arrays(ncid, [ &
7302 : : nctkarr_t("ecut_chi", "dp", "ncut"), &
7303 : : nctkarr_t("ec_rpa_ecut", "dp", "ncut"), &
7304 : : nctkarr_t("ec_mp2_ecut", "dp", "ncut") &
7305 [ # # ]: 0 : ])
7306 [ # # ]: 0 : NCF_CHECK(ncerr)
7307 : :
7308 : : ! Write data.
7309 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
7310 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("ecut_chi"), ecut_chi))
7311 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("ec_rpa_ecut"), ec_rpa))
7312 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("ec_mp2_ecut"), ec_mp2))
7313 : : end if
7314 : : end if ! master
7315 : :
7316 [ # # ]: 0 : ABI_FREE(ec_rpa)
7317 [ # # ]: 0 : ABI_FREE(ec_mp2)
7318 [ # # ]: 0 : ABI_FREE(ecut_chi)
7319 : :
7320 : 0 : call cwtime_report(" gwr_rpa_energy:", cpu_all, wall_all, gflops_all)
7321 [ # # # # : 0 : call timab(1928, 2, tsec)
# # # # #
# # # # #
# # # # #
# ]
7322 : :
7323 : : contains
7324 : 0 : integer function vid(vname)
7325 : : character(len=*),intent(in) :: vname
7326 : 0 : vid = nctk_idname(ncid, vname)
7327 : : end function vid
7328 : :
7329 : : end subroutine gwr_rpa_energy
7330 : : !!***
7331 : :
7332 : : !----------------------------------------------------------------------
7333 : :
7334 : : !!****f* m_gwr/gwr_run_g0w0
7335 : : !! NAME
7336 : : !! gwr_run_g0w0
7337 : : !!
7338 : : !! FUNCTION
7339 : : !! Driver to compute QP energies within the G0W0 approximation and minimax meshes along the imaginary axis.
7340 : : !!
7341 : : !! INPUTS
7342 : : !! [free_ugb]: True if array with empty KS states should be freed as soon as possibile. Default: True
7343 : : !!
7344 : : !! OUTPUT
7345 : : !!
7346 : : !! SOURCE
7347 : :
7348 : 0 : subroutine gwr_run_g0w0(gwr, free_ugb)
7349 : :
7350 : : !Arguments ------------------------------------
7351 : : class(gwr_t),intent(inout) :: gwr
7352 : : logical,optional,intent(in) :: free_ugb
7353 : :
7354 : : !Local variables-------------------------------
7355 : : logical :: free_ugb__
7356 : : ! *************************************************************************
7357 : :
7358 : : ! Use ugb wavefunctions and the Lehmann representation to compute head/wings and Sigma_x matrix elements.
7359 : 0 : call gwr%build_chi0_head_and_wings()
7360 : 0 : call gwr%build_sigxme()
7361 : :
7362 : : ! Now compute G(itau) from ugb and start the GWR algorithm.
7363 [ # # ]: 0 : free_ugb__ = .True.; if (present(free_ugb)) free_ugb__ = free_ugb
7364 : 0 : call gwr%build_green(free_ugb=free_ugb__)
7365 : 0 : call gwr%build_tchi()
7366 : 0 : call gwr%build_wc()
7367 : 0 : call gwr%build_sigmac()
7368 : :
7369 : 0 : end subroutine gwr_run_g0w0
7370 : : !!***
7371 : :
7372 : : !!****f* m_gwr/gwr_run_chi0
7373 : : !! NAME
7374 : : !! gwr_run_chi0
7375 : : !!
7376 : : !! FUNCTION
7377 : : !! Driver to compute CHI0 along the imaginary axis.
7378 : : !!
7379 : : !! INPUTS
7380 : : !! [free_ugb]: True if array with empty KS states should freed as soon as possibile. Default: True
7381 : : !!
7382 : : !! OUTPUT
7383 : : !!
7384 : : !! SOURCE
7385 : :
7386 : 0 : subroutine gwr_run_chi0(gwr, free_ugb)
7387 : :
7388 : : !Arguments ------------------------------------
7389 : : class(gwr_t),intent(inout) :: gwr
7390 : : logical,optional,intent(in) :: free_ugb
7391 : :
7392 : : !Local variables-------------------------------
7393 : : logical :: free_ugb__
7394 : : ! *************************************************************************
7395 : :
7396 : : ! Use ugb wavefunctions and the Lehmann representation to compute head/wings.
7397 : 0 : call gwr%build_chi0_head_and_wings()
7398 : :
7399 : : ! Now compute G(itau) from ugb and start the GWR algorithm for chi.
7400 [ # # ]: 0 : free_ugb__ = .True.; if (present(free_ugb)) free_ugb__ = free_ugb
7401 : 0 : call gwr%build_green(free_ugb=free_ugb__)
7402 : 0 : call gwr%build_tchi()
7403 : :
7404 : 0 : end subroutine gwr_run_chi0
7405 : : !!***
7406 : :
7407 : : !----------------------------------------------------------------------
7408 : :
7409 : : !!****f* m_gwr/gwr_run_energy_scf
7410 : : !! NAME
7411 : : !! gwr_run_energy_scf
7412 : : !!
7413 : : !! FUNCTION
7414 : : !! Compute QP energies within energy-only self-consistent GW approximation
7415 : : !! and minimax meshes along the imaginary axis.
7416 : : !!
7417 : : !! INPUTS
7418 : : !!
7419 : : !! OUTPUT
7420 : : !!
7421 : : !! SOURCE
7422 : :
7423 : 0 : subroutine gwr_run_energy_scf(gwr)
7424 : :
7425 : : !Arguments ------------------------------------
7426 : : class(gwr_t),intent(inout) :: gwr
7427 : :
7428 : : !Local variables-------------------------------
7429 : : integer,parameter :: master = 0
7430 : : integer :: units(2)
7431 : : logical :: converged
7432 : : character(len=500) :: msg
7433 : : ! *************************************************************************
7434 : :
7435 : : ! TODO:
7436 : : ! To implement restart capabilities we need to read scf_iteration, qp_ebands and gwr_task from GWR.nc
7437 : : ! build_sigmac should be responsible for writing checkpoint data with qp_ebands at each iteration.
7438 [ # # ]: 0 : units = [std_out, ab_out]
7439 : :
7440 [ # # ]: 0 : ABI_CHECK_IEQ(gwr%nkcalc, gwr%nkibz, "For energy-only GW, one should include all k-points in the IBZ")
7441 : :
7442 : 0 : select case (gwr%dtset%gwr_task)
7443 : : case ("EGEW")
7444 : 0 : converged = .False.
7445 : 0 : call wrtout(units, " Begin energy-only self-consistency in both G and W (EGEW)")
7446 [ # # # # ]: 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7447 : 0 : call gwr%run_g0w0(free_ugb=.False.)
7448 : 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7449 : 0 : call gwr%check_scf_cycle(converged)
7450 : : end do
7451 : :
7452 : : case ("EGW0")
7453 : 0 : call wrtout(units, " Begin energy-only self-consistency in G (EGW0)")
7454 : 0 : call gwr%run_g0w0(free_ugb=.False.)
7455 : 0 : converged = .False.
7456 [ # # # # ]: 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7457 : 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7458 : 0 : call gwr%build_green(free_ugb=.False.)
7459 : 0 : call gwr%build_sigxme() ! NB: This should not change in semiconductors
7460 : 0 : call gwr%build_sigmac()
7461 : 0 : call gwr%check_scf_cycle(converged)
7462 : : end do
7463 : :
7464 : : case ("G0EW")
7465 : : ! This is more difficult to implement as we need to store G0 and eG
7466 : : ! and then use G only for chi and not in Sigma
7467 : 0 : call wrtout(units, " Begin energy-only self-consistency in W (G0EW)")
7468 : 0 : ABI_ERROR("G0EW is not yet implemented")
7469 : 0 : call gwr%run_g0w0(free_ugb=.False.)
7470 : 0 : converged = .False.
7471 [ # # # # ]: 0 : do while (.not. converged .and. gwr%scf_iteration <= gwr%dtset%gwr_nstep)
7472 : 0 : gwr%scf_iteration = gwr%scf_iteration + 1
7473 : : !call gwr%build_green(free_ugb=.False.)
7474 : 0 : call gwr%build_chi0_head_and_wings()
7475 : 0 : call gwr%build_tchi()
7476 : 0 : call gwr%build_wc()
7477 : 0 : call gwr%build_sigmac()
7478 : 0 : call gwr%check_scf_cycle(converged)
7479 : : end do
7480 : :
7481 : : case default
7482 [ # # # # ]: 0 : ABI_ERROR(sjoin("Invalid gwr_task:", gwr%dtset%gwr_task))
7483 : : end select
7484 : :
7485 [ # # ]: 0 : if (gwr%comm%me == master) then
7486 [ # # ]: 0 : if (converged) then
7487 : : write(msg, "(1x,4a,i0,a,f8.3,a)") &
7488 : 0 : trim(gwr%dtset%gwr_task), " self-consistent loop:", ch10, &
7489 : 0 : " Convergence achieved at iteration: ", gwr%scf_iteration, &
7490 : 0 : " with gwr_tolqpe: ",gwr%dtset%gwr_tolqpe * Ha_meV, " (meV)"
7491 : 0 : call wrtout(units, msg)
7492 : : else
7493 : : write(msg, "(1x,4a,f8.3,3a,i0,a)") &
7494 : 0 : trim(gwr%dtset%gwr_task), " self-consistent loop:", ch10, &
7495 : 0 : " WARNING: Could not converge with gwr_tolqpe: ",gwr%dtset%gwr_tolqpe * Ha_meV, " (meV)", ch10, &
7496 : 0 : " after: ", gwr%dtset%gwr_nstep, " steps"
7497 : 0 : call wrtout(units, msg)
7498 : : end if
7499 : : end if
7500 : :
7501 : 0 : end subroutine gwr_run_energy_scf
7502 : : !!***
7503 : :
7504 : : !----------------------------------------------------------------------
7505 : :
7506 : : !!****f* m_gwr/check_scf_cyle
7507 : : !! NAME
7508 : : !! check_scf_cycle
7509 : : !!
7510 : : !! FUNCTION
7511 : : !!
7512 : : !! INPUTS
7513 : : !!
7514 : : !! OUTPUT
7515 : : !!
7516 : : !! SOURCE
7517 : :
7518 : 0 : subroutine gwr_check_scf_cycle(gwr, converged)
7519 : :
7520 : : !Arguments ------------------------------------
7521 : : class(gwr_t),intent(in) :: gwr
7522 : : logical,intent(out) :: converged
7523 : :
7524 : : !Local variables-------------------------------
7525 : : integer,parameter :: master = 0
7526 : : integer :: spin, ikcalc, ik_ibz, band, ib, jb
7527 : : character(len=500) :: msg
7528 : 0 : real(dp) :: max_adiff, adiff(gwr%qp_ebands%mband)
7529 : : integer :: units(2)
7530 : : ! *************************************************************************
7531 : :
7532 [ # # ]: 0 : max_adiff = -one; converged = .True.; units = [std_out, ab_out]
7533 : :
7534 [ # # ]: 0 : if (gwr%comm%me == master) then
7535 : 0 : call wrtout(units, sjoin(" Checking for convergence at iteration:", itoa(gwr%scf_iteration)))
7536 : : end if
7537 : :
7538 : : associate (now => gwr%qp_ebands, prev => gwr%qp_ebands_prev)
7539 [ # # ]: 0 : do spin=1,gwr%nsppol
7540 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
7541 : : ! Compute max abs difference between QP at iteration i and i-1.
7542 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
7543 : 0 : ib = gwr%bstart_ks(ikcalc, spin); jb = gwr%bstop_ks(ikcalc, spin)
7544 [ # # # # ]: 0 : adiff = zero; adiff(ib:jb) = abs(now%eig(ib:jb, ik_ibz, spin) - prev%eig(ib:jb, ik_ibz, spin))
7545 [ # # # # : 0 : band = maxloc(adiff, dim=1)
# # # # #
# ]
7546 : 0 : max_adiff = max(max_adiff, adiff(band))
7547 [ # # ]: 0 : if (adiff(band) > gwr%dtset%gwr_tolqpe) converged = .False.
7548 [ # # ]: 0 : if (gwr%comm%me == master) then
7549 : : ! Write info
7550 [ # # ]: 0 : write(msg, "(a,i0,1x,2a,i0)") " For k-point: ", ik_ibz, trim(ktoa(now%kptns(:,ik_ibz))),", spin: ", spin
7551 : 0 : call wrtout(units, msg)
7552 : 0 : write(msg, "(4x,a,es12.5,a,i0)")"max(abs(E_i - E_{i-1})): ", adiff(band) * Ha_meV, " (meV) for band: ", band
7553 : 0 : call wrtout(units, msg)
7554 : : end if
7555 : : end do
7556 : : end do
7557 : : end associate
7558 : :
7559 : : ! Make sure that all MPI procs agree on this!
7560 : 0 : call xmpi_land(converged, gwr%comm%value)
7561 : :
7562 [ # # ]: 0 : if (gwr%comm%me == master) then
7563 : 0 : write(msg, "(a,i0,a)") "QP gaps at iteration: ",gwr%scf_iteration," (Fermi energy set to zero)"
7564 : 0 : call gwr%qp_ebands%print_gaps(units, header=msg)
7565 [ # # ]: 0 : if (.not. converged) then
7566 : 0 : call wrtout(units," Not converged --> start new iteration ...")
7567 : : !else
7568 : : ! call wrtout(units, sjoin(" Convergence achieved at iteration", itoa(gwr%scf_iteration)))
7569 : : end if
7570 : : ! TODO: Increment scf_iteration in GWR.nc
7571 : : end if
7572 : :
7573 : 0 : end subroutine gwr_check_scf_cycle
7574 : : !!***
7575 : :
7576 : : !----------------------------------------------------------------------
7577 : :
7578 : : !!****f* m_gwr/gwr_ncwrite_tchi_wc
7579 : : !! NAME
7580 : : !! gwr_ncwrite_tchi_wc
7581 : : !!
7582 : : !! FUNCTION
7583 : : !! Write tchi or wc to netcdf file
7584 : : !!
7585 : : !! INPUTS
7586 : : !! what: "tchi" or "wc"
7587 : : !! wt_space: "omega" or "tau"
7588 : : !!
7589 : : !! OUTPUT
7590 : : !!
7591 : : !! SOURCE
7592 : :
7593 : 0 : subroutine gwr_ncwrite_tchi_wc(gwr, what, wt_space, keep_file, filepath)
7594 : :
7595 : : !Arguments ------------------------------------
7596 : : class(gwr_t),target,intent(in) :: gwr
7597 : : logical,intent(in) :: keep_file
7598 : : character(len=*),intent(in) :: what, wt_space, filepath
7599 : :
7600 : : !Local variables-------------------------------
7601 : : !scalars
7602 : : integer,parameter :: master = 0
7603 : : integer :: my_is, my_iqi, my_it, spin, iq_ibz, itau, npwtot_q, my_ncols, my_gcol_start, ncid, ncerr, var_id !, ierr
7604 : : real(dp) :: cpu, wall, gflops
7605 : : !arrays
7606 : 0 : real(dp), contiguous, pointer :: fptr(:,:,:)
7607 : 0 : type(__slkmat_t), pointer :: mats(:)
7608 : : ! *************************************************************************
7609 : :
7610 : : ! Cannot reuse SCR.nc/SUSC.nc fileformat as:
7611 : : ! - hscr_new requires ep% instance
7612 : : ! - old file formats assume Gamma-centered G vectors.
7613 : :
7614 : 0 : call cwtime(cpu, wall, gflops, "start")
7615 : :
7616 [ # # ]: 0 : if (gwr%comm%me == master) then
7617 : 0 : call wrtout(std_out, sjoin(" Writing", what, "with wt_space:", wt_space, "to:", filepath))
7618 [ # # ]: 0 : if (keep_file) then
7619 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, filepath, xmpi_comm_self))
7620 : : else
7621 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, filepath, xmpi_comm_self))
7622 : : end if
7623 : :
7624 : : ! Write structure and qp_ebands
7625 [ # # ]: 0 : NCF_CHECK(gwr%cryst%ncwrite(ncid))
7626 [ # # ]: 0 : NCF_CHECK(gwr%qp_ebands%ncwrite(ncid))
7627 : :
7628 : : ! Add dimensions.
7629 : : ncerr = nctk_def_dims(ncid, [ &
7630 : : nctkdim_t("nsppol", gwr%nsppol), nctkdim_t("ntau", gwr%ntau), nctkdim_t("mpw", gwr%tchi_mpw), &
7631 : : nctkdim_t("nqibz", gwr%nqibz), nctkdim_t("nqbz", gwr%nqbz)], &
7632 [ # # ]: 0 : defmode=.True.)
7633 [ # # ]: 0 : NCF_CHECK(ncerr)
7634 : :
7635 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
7636 : : "gwr_completed" &
7637 [ # # ]: 0 : ])
7638 : :
7639 : : ! Define arrays with results.
7640 : : ! TODO: Add metadata for mats: spin sum, vc cutoff, t/w mesh, handle nspinor 2
7641 : : ncerr = nctk_def_arrays(ncid, [ &
7642 : : nctkarr_t("ngkpt", "int", "three"), &
7643 : : nctkarr_t("ngqpt", "int", "three"), &
7644 : : nctkarr_t("qibz", "dp", "three, nqibz"), &
7645 : : nctkarr_t("wtq", "dp", "nqibz"), &
7646 : : nctkarr_t("tau_mesh", "dp", "ntau"), &
7647 : : nctkarr_t("tau_wgs", "dp", "ntau"), &
7648 : : nctkarr_t("iw_mesh", "dp", "ntau"), &
7649 : : nctkarr_t("iw_wgs", "dp", "ntau"), &
7650 : : nctkarr_t("gvecs", "int", "three, mpw, nqibz"), &
7651 : : nctkarr_t("chinpw_qibz", "int", "nqibz") &
7652 [ # # ]: 0 : ])
7653 [ # # ]: 0 : NCF_CHECK(ncerr)
7654 : :
7655 [ # # ]: 0 : if (wt_space == "omega") then
7656 [ # # # # : 0 : NCF_CHECK(nctk_def_arrays(ncid, [nctkarr_t("mats_w", "dp", "two, mpw, mpw, ntau, nqibz, nsppol")]))
# # ]
7657 [ # # ]: 0 : else if (wt_space == "tau") then
7658 [ # # # # : 0 : NCF_CHECK(nctk_def_arrays(ncid, [nctkarr_t("mats_tau", "dp", "two, mpw, mpw, ntau, nqibz, nsppol")]))
# # ]
7659 : : end if
7660 : :
7661 : : ! Write global arrays.
7662 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
7663 : :
7664 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
7665 : : "gwr_completed"], &
7666 [ # # ]: 0 : [0])
7667 [ # # ]: 0 : NCF_CHECK(ncerr)
7668 : :
7669 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("ngkpt"), gwr%ngkpt))
7670 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("ngqpt"), gwr%ngqpt))
7671 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("qibz"), gwr%qibz))
7672 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("wtq"), gwr%wtq))
7673 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_mesh"), gwr%tau_mesh))
7674 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("tau_wgs"), gwr%tau_wgs))
7675 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_mesh"), gwr%iw_mesh))
7676 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("iw_wgs"), gwr%iw_wgs))
7677 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("chinpw_qibz"), gwr%chinpw_qibz))
7678 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7679 : : end if
7680 : :
7681 : 0 : call xmpi_barrier(gwr%comm%value)
7682 : :
7683 : : ! Reopen the file in gwr%comm.
7684 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, filepath, gwr%comm%value))
7685 : :
7686 [ # # ]: 0 : if (wt_space == "omega") then
7687 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(ncid, "mats_w"))
7688 [ # # ]: 0 : else if (wt_space == "tau") then
7689 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(ncid, "mats_tau"))
7690 : : end if
7691 : :
7692 [ # # ]: 0 : do my_is=1,gwr%my_nspins
7693 : 0 : spin = gwr%my_spins(my_is)
7694 [ # # ]: 0 : do my_iqi=1,gwr%my_nqibz
7695 : 0 : iq_ibz = gwr%my_qibz_inds(my_iqi)
7696 : :
7697 : : ! The same q-point in the IBZ might be stored on different pools.
7698 : : ! To avoid writing the same array multiple times, we use itreat_qibz
7699 : : ! to select the procs inside gwr%kpt_comm who are gonna write this iq_ibz q-point.
7700 [ # # ]: 0 : if (.not. gwr%itreat_iqibz(iq_ibz)) cycle
7701 : :
7702 : 0 : associate (desc_q => gwr%tchi_desc_qibz(iq_ibz))
7703 : 0 : npwtot_q = desc_q%npw
7704 : :
7705 [ # # ]: 0 : if (spin == 1 .and. gwr%gtau_comm%me == 0) then
7706 : : ! Write all G-vectors for this q
7707 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, vid("gvecs"), desc_q%gvec, start=[1,1,iq_ibz], count=[3,npwtot_q,1]))
# # # # #
# ]
7708 : : end if
7709 : :
7710 : 0 : mats => null()
7711 [ # # ]: 0 : if (what == "tchi") mats => gwr%tchi_qibz(iq_ibz, :, spin)
7712 [ # # ]: 0 : if (what == "wc") mats => gwr%wc_qibz(iq_ibz, :, spin)
7713 [ # # ]: 0 : ABI_CHECK(associated(mats), sjoin("Invalid value for what:", what))
7714 : :
7715 [ # # # # ]: 0 : do my_it=1,gwr%my_ntau
7716 : 0 : itau = gwr%my_itaus(my_it)
7717 : :
7718 : : ! FIXME: Assuming PBLAS matrix distributed in contiguous blocks along the column index.
7719 : : ! This part must be changed if we use round robin distribution.
7720 : 0 : my_ncols = mats(itau)%size_local(2)
7721 : 0 : my_gcol_start = mats(itau)%loc2gcol(1)
7722 : :
7723 : : ! FIXME: This is wrong if spc
7724 : : !call c_f_pointer(c_loc(mats(itau)%buffer_cplx), fptr, shape=[2, npwtot_q, my_ncols])
7725 [ # # # # : 0 : ABI_MALLOC(fptr, (2, npwtot_q, my_ncols))
# # # # #
# # # # #
# # ]
7726 [ # # # # ]: 0 : fptr(1,:,:) = dble(mats(itau)%buffer_cplx)
7727 [ # # # # ]: 0 : fptr(2,:,:) = aimag(mats(itau)%buffer_cplx)
7728 : :
7729 [ # # ]: 0 : if (wt_space == "omega") then
7730 : 0 : var_id = vid("mats_w")
7731 [ # # ]: 0 : else if (wt_space == "tau") then
7732 : 0 : var_id = vid("mats_tau")
7733 : : else
7734 : 0 : ABI_ERROR(sjoin("Invalid wt_space:", wt_space))
7735 : : end if
7736 : :
7737 : : ncerr = nf90_put_var(ncid, var_id, fptr, &
7738 : : start=[1, 1, my_gcol_start, itau, iq_ibz, spin], &
7739 [ # # # # ]: 0 : count=[2, npwtot_q, my_ncols, 1, 1, 1])
7740 : : !stride=[1, gwr%g_comm%nproc, 1, 1, 1])
7741 [ # # ]: 0 : ABI_FREE(fptr)
7742 [ # # ]: 0 : NCF_CHECK(ncerr)
7743 : : end do
7744 : : end associate
7745 : : end do ! my_iqi
7746 : : end do ! my_is
7747 : :
7748 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gwr_completed"), 1))
7749 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7750 : 0 : call cwtime_report(" gwr_ncwrite_tchi_wc:", cpu, wall, gflops)
7751 : :
7752 : : contains
7753 : 0 : integer function vid(vname)
7754 : : character(len=*),intent(in) :: vname
7755 : 0 : vid = nctk_idname(ncid, vname)
7756 : : end function vid
7757 : :
7758 : : end subroutine gwr_ncwrite_tchi_wc
7759 : : !!***
7760 : :
7761 : : !----------------------------------------------------------------------
7762 : :
7763 : : !!****f* m_gwr/gsph2box
7764 : : !! NAME
7765 : : !! gsph2box
7766 : : !!
7767 : : !! FUNCTION
7768 : : !! Insert cg_k array defined on the k-centered g-sphere with npw vectors inside the FFT box.
7769 : : !! The main difference wrt to sphere is that cfft is not initialized to zero. See notes below.
7770 : : !!
7771 : : !! INPUTS
7772 : : !! ngfft:
7773 : : !! n1,n2,n3=physical dimension of the FFT box
7774 : : !! n4,n5,n6=memory dimension of cfft
7775 : : !! npw=number of G vectors in basis at this k point
7776 : : !! ndat=number of items to process
7777 : : !! kg_k(3,npw)=integer coordinates of G vectors in basis sphere
7778 : : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere
7779 : : !!
7780 : : !! OUTPUT
7781 : : !! cfft(n4,n5,n6*ndat) = array on FFT box filled with cg data
7782 : : !! Note that cfft is intent(inout) so that we can add contributions from different k-points.
7783 : : !!
7784 : : !! SOURCE
7785 : :
7786 : : subroutine gsph2box(ngfft, npw, ndat, kg_k, cg, cfft)
7787 : :
7788 : : !Arguments ------------------------------------
7789 : : !scalars
7790 : : integer,intent(in) :: ngfft(6), npw, ndat
7791 : : !arrays
7792 : : integer,intent(in) :: kg_k(3, npw)
7793 : : complex(gwp),intent(in) :: cg(npw * ndat)
7794 : : complex(gwp),target,intent(inout) :: cfft(ngfft(4)*ngfft(5)*ngfft(6)*ndat)
7795 : :
7796 : : !Local variables-------------------------------
7797 : : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw
7798 : : complex(gwp),contiguous,pointer :: cfft_ptr(:,:,:,:)
7799 : : ! *************************************************************************
7800 : :
7801 : : !call timab(1931, 1, tsec)
7802 : : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
7803 : : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
7804 : : call c_f_pointer(c_loc(cfft), cfft_ptr, shape=[n4, n5, n6, ndat])
7805 : :
7806 : : ! Insert cg into cfft
7807 : : !$OMP PARALLEL DO PRIVATE(i1, i2, i3) IF (ndat > 1)
7808 : : do idat=1,ndat
7809 : : do ipw=1,npw
7810 : : i1 = modulo(kg_k(1, ipw), n1) + 1
7811 : : i2 = modulo(kg_k(2, ipw), n2) + 1
7812 : : i3 = modulo(kg_k(3, ipw), n3) + 1
7813 : : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7814 : : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7815 : : !end if
7816 : : cfft_ptr(i1,i2,i3,idat) = cg(ipw+npw*(idat-1))
7817 : : end do
7818 : : end do
7819 : : !call timab(1931, 2, tsec)
7820 : :
7821 : : end subroutine gsph2box
7822 : : !!***
7823 : :
7824 : : !----------------------------------------------------------------------
7825 : :
7826 : : !!****f* m_gwr/box2gsph
7827 : : !! NAME
7828 : : !! box2gsph
7829 : : !!
7830 : : !! FUNCTION
7831 : : !! Extract cg_k array defined on the k-centered g-sphere with npw vectors from the FFT box.
7832 : : !!
7833 : : !! INPUTS
7834 : : !! op_type: OP_COPY to transfer data, OP_ACC to transfer and accumulate
7835 : : !! ngfft:
7836 : : !! n1,n2,n3=physical dimension of the FFT box
7837 : : !! n4,n5,n6=memory dimension of cfft
7838 : : !! npw=number of G vectors in basis at this k point
7839 : : !! ndat=number of items to process
7840 : : !! kg_k(3,npw)=integer coordinates of G vectors in basis sphere
7841 : : !! cfft(n4,n5,n6, ndat) = array on FFT box
7842 : : !!
7843 : : !! SIZE
7844 : : !! cg(npw*ndat)= contains values for npw G vectors in basis sphere. See also op_type
7845 : : !!
7846 : : !! SOURCE
7847 : :
7848 : 0 : subroutine box2gsph(op_type, ngfft, npw, ndat, kg_k, cfft, cg)
7849 : :
7850 : : !Arguments ------------------------------------
7851 : : !scalars
7852 : : integer,intent(in) :: op_type, ngfft(6), npw, ndat
7853 : : !arrays
7854 : : integer,intent(in) :: kg_k(3, npw)
7855 : : complex(gwp),target,intent(in) :: cfft(ngfft(4)*ngfft(5)*ngfft(6)*ndat)
7856 : : complex(gwp),intent(inout) :: cg(npw*ndat)
7857 : :
7858 : : !Local variables-------------------------------
7859 : : integer :: n1, n2, n3, n4, n5, n6, i1, i2, i3, idat, ipw, icg
7860 : 0 : complex(gwp),contiguous,pointer :: cfft_ptr(:,:,:,:)
7861 : : ! *************************************************************************
7862 : :
7863 : 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
7864 : 0 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
7865 [ # # ]: 0 : call c_f_pointer(c_loc(cfft), cfft_ptr, shape=[n4, n5, n6, ndat])
7866 : :
7867 : 0 : select case (op_type)
7868 : :
7869 : : case (OP_COPY)
7870 : : ! Extract cg from cfft, ignoring components outside range of cg sphere
7871 : : !$OMP PARALLEL DO PRIVATE(i1, i2, i3, icg) IF (ndat > 1)
7872 [ # # ]: 0 : do idat=1,ndat
7873 [ # # ]: 0 : do ipw=1,npw
7874 : 0 : i1 = modulo(kg_k(1, ipw), n1) + 1
7875 : 0 : i2 = modulo(kg_k(2, ipw), n2) + 1
7876 : 0 : i3 = modulo(kg_k(3, ipw), n3) + 1
7877 : : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7878 : : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7879 : : !end if
7880 : 0 : icg = ipw + (idat - 1) * npw
7881 : 0 : cg(icg) = cfft_ptr(i1, i2, i3, idat)
7882 : : end do
7883 : : end do
7884 : :
7885 : : case (OP_ACC)
7886 : : ! Extract cg from cfft, ignoring components outside range of cg sphere and accumulate
7887 : : !$OMP PARALLEL DO PRIVATE(i1, i2, i3, icg) IF (ndat > 1)
7888 [ # # ]: 0 : do idat=1,ndat
7889 [ # # ]: 0 : do ipw=1,npw
7890 : 0 : i1 = modulo(kg_k(1, ipw), n1) + 1
7891 : 0 : i2 = modulo(kg_k(2, ipw), n2) + 1
7892 : 0 : i3 = modulo(kg_k(3, ipw), n3) + 1
7893 : : !if (any(kg_k(:,ipw) > ngfft(1:3)/2) .or. any(kg_k(:,ipw) < -(ngfft(1:3)-1)/2) ) then
7894 : : ! ABI_ERROR(sjoin("The G-vector: ",ltoa(kg_k(:, ipw))," falls outside the FFT box. Increase boxcutmin (?)"))
7895 : : !end if
7896 : 0 : icg = ipw + (idat - 1) * npw
7897 : 0 : cg(icg) = cg(icg) + cfft_ptr(i1, i2, i3, idat)
7898 : : end do
7899 : : end do
7900 : :
7901 : : case default
7902 [ # # # ]: 0 : ABI_BUG(sjoin("Invalid op_type:" ,itoa(op_type)))
7903 : : end select
7904 : :
7905 : 0 : end subroutine box2gsph
7906 : : !!***
7907 : :
7908 : : !----------------------------------------------------------------------
7909 : :
7910 : : !!****f* m_gwr/gwr_build_chi0_head_and_wings
7911 : : !! NAME
7912 : : !! gwr_build_chi0_head_and_wings
7913 : : !!
7914 : : !! FUNCTION
7915 : : !! Compute head and wings of chi0 on the minimax frequency grid.
7916 : : !!
7917 : : !! SOURCE
7918 : :
7919 : 0 : subroutine gwr_build_chi0_head_and_wings(gwr)
7920 : :
7921 : : !Arguments ------------------------------------
7922 : : class(gwr_t),target,intent(inout) :: gwr
7923 : :
7924 : : !Local variables-------------------------------
7925 : : !scalars
7926 : : integer,parameter :: two_poles = 2, one_pole = 1, gwcomp0 = 0, spmeth0 = 0
7927 : : integer :: nsppol, nspinor, ierr, my_is, spin, my_ikf, itau, my_it
7928 : : integer :: ik_bz, ik_ibz, isym_k, trev_k, g0_k(3)
7929 : : !integer :: iq_bz, iq_ibz, isym_q, trev_q, g0_q(3)
7930 : : integer :: nkpt_summed, use_umklp, band1, band2, band1_start, band1_stop, band1_max
7931 : : integer :: ib, il_b2, nb, block_size, ii, mband, block_counter !,idir !, iab
7932 : : integer :: istwf_ki, npw_ki, istwf_kf, nI, nJ, nomega, io, iq, nq, dim_rtwg !ig,
7933 : : integer :: npwe, u_nfft, u_mgfft, u_mpw
7934 : : logical :: isirr_k, use_tr, is_metallic, print_time, use_ddk
7935 : : real(dp) :: spin_fact, weight, deltaf_b1b2, deltaeGW_b1b2, gwr_boxcutmin_c, zcut, qlen, eig_nk, eig_mk, e0
7936 : : real(dp) :: cpu_all, wall_all, gflops_all, cpu_k, wall_k, gflops_k
7937 : : complex(dp) :: deltaeKS_b1b2
7938 : : type(__slkmat_t),pointer :: ugb_kibz
7939 : : character(len=5000) :: msg
7940 : : type(crystal_t),pointer :: cryst
7941 : : type(dataset_type),pointer :: dtset
7942 : : type(ebands_t),pointer :: now_ebands
7943 : 0 : type(littlegroup_t) :: ltg_q
7944 : : type(desc_t),pointer :: desc_ki
7945 : : !arrays
7946 : : integer :: gmax(3), u_ngfft(18), work_ngfft(18), units(2) !, spinor_pad(2,4), spad1, spad2 !, ! g0(3),
7947 : 0 : integer,contiguous, pointer :: kg_ki(:,:)
7948 : 0 : integer,allocatable :: gvec_q0(:,:), gbound_q0(:,:), u_gbound(:,:)
7949 : : real(dp) :: kk_ibz(3), kk_bz(3), tsec(2) !, rtmp(2)
7950 : 0 : real(dp),contiguous, pointer :: qp_eig(:,:,:), qp_occ(:,:,:), ks_eig(:,:,:)
7951 : 0 : real(dp),allocatable :: work(:,:,:,:), qdirs(:,:)
7952 : 0 : logical :: gradk_not_done(gwr%nkibz)
7953 : 0 : logical,allocatable :: bbp_mask(:,:)
7954 : : complex(dp) :: chq(3)
7955 : 0 : complex(gwp) :: rhotwx(3, gwr%nspinor**2)
7956 : 0 : complex(gwp),allocatable :: ug2(:), ur1_kibz(:), ur2_kibz(:), ur_prod(:), rhotwg(:), ug1_block(:,:), ug1(:)
7957 : 0 : complex(dp) :: green_w(gwr%ntau), omega(gwr%ntau)
7958 : 0 : complex(dp),allocatable :: chi0_lwing(:,:,:), chi0_uwing(:,:,:), chi0_head(:,:,:), head_qvals(:)
7959 : 0 : real(dp), allocatable :: ddk_ug1(:,:,:), cg2_dp(:,:)
7960 : 0 : type(vkbr_t),allocatable :: vkbr(:)
7961 : 0 : type(gsphere_t) :: gsph
7962 [ # # # # : 0 : type(ddkop_t) :: ddkop
# # ]
7963 : 0 : type(pawcprj_type),allocatable :: cwaveprj(:,:)
7964 : : ! *************************************************************************
7965 : :
7966 [ # # ]: 0 : units = [std_out, ab_out]
7967 : 0 : call timab(1927, 1, tsec)
7968 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
7969 : 0 : call wrtout(units, sjoin(" Computing chi0 head and wings with inclvkb:", itoa(gwr%dtset%inclvkb)), pre_newlines=1)
7970 : :
7971 : 0 : nspinor = gwr%nspinor; nsppol = gwr%nsppol; dtset => gwr%dtset; cryst => gwr%cryst
7972 : 0 : use_tr = gwr%dtset%awtr == 1; zcut = gwr%dtset%zcut ! well, it's not used in g0w0 when omega is complex.
7973 : :
7974 : : ! Use KS or QP energies depending on the iteration state.
7975 [ # # ]: 0 : if (gwr%scf_iteration == 1) then
7976 : 0 : call wrtout(units, " Using KS orbitals and KS energies...", newlines=1, do_flush=.True.)
7977 : 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
7978 : 0 : now_ebands => gwr%ks_ebands
7979 : : else
7980 : 0 : call wrtout(units, " Using KS orbitals and QP energies...", newlines=1, do_flush=.True.)
7981 : 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
7982 : 0 : now_ebands => gwr%qp_ebands
7983 : : end if
7984 : :
7985 : 0 : ks_eig => gwr%ks_ebands%eig
7986 : 0 : mband = gwr%ks_ebands%mband
7987 : :
7988 : 0 : is_metallic = now_ebands%has_metal_scheme()
7989 : :
7990 : : ! Setup weight (2 for spin unpolarized systems, 1 for polarized).
7991 : : ! spin_fact is used to normalize the occupation factors to one.
7992 : : ! Consider also the AFM case.
7993 : 0 : select case (nsppol)
7994 : : case (1)
7995 : 0 : weight = two / gwr%nkbz; spin_fact = half
7996 [ # # ]: 0 : if (gwr%nspden == 2) then
7997 : 0 : weight = one / gwr%nkbz; spin_fact = half
7998 : : end if
7999 [ # # ]: 0 : if (nspinor == 2) then
8000 : 0 : weight = one / gwr%nkbz; spin_fact = one
8001 : : end if
8002 : : case (2)
8003 : 0 : weight = one / gwr%nkbz; spin_fact = one
8004 : : case default
8005 [ # # # ]: 0 : ABI_BUG(sjoin("Wrong nsppol:", itoa(nsppol)))
8006 : : end select
8007 : :
8008 : : ! TODO: Replace vkbr with ddk and factorize calls to DDK |bra>
8009 [ # # # # : 0 : ABI_MALLOC(vkbr, (gwr%nkibz))
# # # # #
# # # #
# ]
8010 [ # # ]: 0 : gradk_not_done = .TRUE.
8011 : :
8012 : : ! TODO: Big allocation. Might become 1b
8013 [ # # # # : 0 : ABI_MALLOC(bbp_mask, (mband, mband))
# # # # #
# # # # #
# # ]
8014 : :
8015 : : ! =========================================
8016 : : ! Find FFT mesh and max number of g-vectors
8017 : : ! =========================================
8018 : : ! TODO: Can be decreased. Consider also fftgw
8019 : 0 : gwr_boxcutmin_c = two
8020 : : !gwr_boxcutmin_c = one
8021 : 0 : call gwr%get_u_ngfft(gwr_boxcutmin_c, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8022 : :
8023 : : ! Init work_ngfft
8024 [ # # ]: 0 : gmax = gmax + 4 ! FIXME: this is to account for umklapp, should also consider Gamma-only and istwfk
8025 [ # # ]: 0 : gmax = 2 * gmax + 1
8026 : 0 : call ngfft_seq(work_ngfft, gmax)
8027 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
8028 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
8029 : :
8030 [ # # # # ]: 0 : if (gwr%comm%me == 0) call print_ngfft([std_out], u_ngfft, header="FFT mesh for chi0 head/wings computation")
8031 : :
8032 : : ! Need to broadcast G-vectors at q = 0 if k/q-point parallelism is activated.
8033 [ # # ]: 0 : if (gwr%kpt_comm%me == 0) then
8034 : 0 : npwe = gwr%tchi_desc_qibz(1)%npw
8035 [ # # ]: 0 : ABI_CHECK(gwr%tchi_desc_qibz(1)%kin_sorted, "g-vectors are not sorted by |q+g|^2/2 !")
8036 : : end if
8037 : 0 : call xmpi_bcast(npwe, 0, gwr%kpt_comm%value, ierr)
8038 [ # # # # : 0 : ABI_MALLOC(gvec_q0, (3, npwe))
# # # # #
# # # ]
8039 [ # # # # : 0 : if (gwr%kpt_comm%me == 0) gvec_q0 = gwr%tchi_desc_qibz(1)%gvec
# # # # #
# # # # #
# # # # ]
8040 : 0 : call xmpi_bcast(gvec_q0, 0, gwr%kpt_comm%value, ierr)
8041 : :
8042 : : ! This is needed to call accumulate_head_wings_imagw
8043 : 0 : call gsph%init(cryst, npwe, gvec_q0)
8044 : :
8045 [ # # # # : 0 : ABI_MALLOC(gbound_q0, (2 * u_mgfft + 8, 2))
# # # # #
# # # # #
# # ]
8046 : 0 : call sphereboundary(gbound_q0, istwfk1, gvec_q0, u_mgfft, npwe)
8047 : :
8048 : : ! Init little group to find IBZ_q
8049 : 0 : use_umklp = 0
8050 : 0 : call ltg_q%init([zero, zero, zero], gwr%nkbz, gwr%kbz, cryst, use_umklp, npwe) !, gvec=gvec_kss)
8051 : :
8052 : 0 : nkpt_summed = gwr%nkbz
8053 [ # # ]: 0 : if (dtset%symchi /= 0) then
8054 : 0 : nkpt_summed = ltg_q%nibz_ltg
8055 [ # # ]: 0 : call ltg_q%print([std_out], prtvol=dtset%prtvol)
8056 : : end if
8057 : 0 : call wrtout(std_out, sjoin(' Calculation status: ', itoa(nkpt_summed), ' k-points to be completed'))
8058 : :
8059 : : ! ============================================
8060 : : ! === Begin big fat loop over transitions ====
8061 : : ! ============================================
8062 : :
8063 : : ! NB: One might reduce the number of bands as head and wings converge fast wrt nband and slow wrt k-mesh.
8064 : : ! Should introduce a tolerance on the frequency part computed at the first minimax frequency and
8065 : : ! compute max_nband from this.
8066 : :
8067 : : ! Find band1_max from gwr_max_hwtene
8068 : 0 : band1_max = gwr%ugb_nband
8069 [ # # ]: 0 : if (gwr%dtset%gwr_max_hwtene > zero) then
8070 : : ! Set e0 to top of valence band if semiconductor else Fermi level
8071 : 0 : e0 = now_ebands%fermie
8072 [ # # # # : 0 : if (all(gwr%ks_gaps%ierr == 0)) e0 = minval(gwr%ks_gaps%vb_max)
# # # # #
# # # #
# ]
8073 [ # # ]: 0 : do band1_start=1, gwr%ugb_nband
8074 [ # # # # : 0 : if (all(qp_eig(band1_start,:,:) - e0 > gwr%dtset%gwr_max_hwtene)) then
# # # # ]
8075 : 0 : band1_max = band1_start; exit
8076 : : end if
8077 : : end do
8078 : : !else if (gwr%dtset%gwr_max_hwtene < zero) then
8079 : : ! band1_max = min(nint(-gwr%dtset%gwr_max_hwtene) gwr%ugb_nband)
8080 : : end if
8081 : :
8082 : 0 : call wrtout(std_out, sjoin(" gwr_max_hwtene:", ftoa(gwr%dtset%gwr_max_hwtene * Ha_eV), " (eV)"))
8083 : 0 : call wrtout(std_out, sjoin(" Using: ", itoa(band1_max), "/", itoa(gwr%ugb_nband), "bands for chi0 head and wings."))
8084 : :
8085 : : ! Loop on spin to calculate $\chi_{\up,\up} + \chi_{\down,\down}$
8086 : : ! TODO: nspinor 2
8087 : 0 : nI = 1; nJ = 1; nomega = gwr%ntau
8088 [ # # ]: 0 : omega(:) = j_dpc * gwr%iw_mesh(:)
8089 [ # # # # : 0 : ABI_CALLOC(chi0_lwing, (npwe*nI, nomega, 3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
8090 [ # # # # : 0 : ABI_CALLOC(chi0_uwing, (npwe*nJ, nomega, 3))
# # # # #
# # # # #
# # # # ]
8091 [ # # # # : 0 : ABI_CALLOC(chi0_head, (3, 3, nomega))
# # # # #
# # # # #
# # # # ]
8092 : :
8093 [ # # # # : 0 : ABI_MALLOC(u_gbound, (2 * u_mgfft + 8, 2))
# # # # ]
8094 [ # # # # : 0 : ABI_MALLOC(ur1_kibz, (u_nfft * nspinor))
# # # # #
# # # ]
8095 [ # # # # : 0 : ABI_MALLOC(ur2_kibz, (u_nfft * nspinor))
# # # # ]
8096 [ # # # # : 0 : ABI_MALLOC(ur_prod, (u_nfft * nspinor))
# # # # ]
8097 [ # # ]: 0 : dim_rtwg = 1; if (nspinor == 2) dim_rtwg = 2 ! Can reduce size depending on Ep%nI and Ep%nj
8098 [ # # # # : 0 : ABI_MALLOC(rhotwg, (npwe * dim_rtwg))
# # # # #
# # # ]
8099 : :
8100 : : ! TODO: use ddkop instead of commutator so that we can handle SOC terms.
8101 : : use_ddk = .False.
8102 : 0 : use_ddk = gwr%dtset%userie == 432
8103 : 0 : use_ddk = .True.
8104 : : if (use_ddk) then
8105 : 0 : call wrtout(std_out, " Using DDK to compute the commutator matrix elements.")
8106 [ # # # # : 0 : call ddkop%init(dtset, gwr%cryst, gwr%pawtab, gwr%psps, gwr%mpi_enreg, u_mpw, u_ngfft)
# # # # ]
8107 : : end if
8108 : :
8109 [ # # ]: 0 : ABI_CHECK_IEQ(dtset%symchi, 1, "symchi 0 not implemented")
8110 : : if (dtset%nspinor == 2 .and. .not. use_ddk) then
8111 : : ABI_CHECK_IEQ(dtset%inclvkb, 0, "inclvkb must be 0 when nspinor == 2 as SOC term is not coded.")
8112 : : end if
8113 : :
8114 : : ! Loop over collinear spins.
8115 [ # # ]: 0 : do my_is=1,gwr%my_nspins
8116 : 0 : spin = gwr%my_spins(my_is)
8117 : :
8118 : : ! Loop over my k-points in the BZ.
8119 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
8120 : 0 : ik_bz = gwr%my_kbz_inds(my_ikf); kk_bz = gwr%kbz(:, ik_bz)
8121 : 0 : istwf_kf = 1
8122 : : !istwf_kf = gwt% ???
8123 : :
8124 [ # # # # ]: 0 : if (dtset%symchi == 1 .and. ltg_q%ibzq(ik_bz) /= 1) CYCLE ! Only IBZ_q
8125 [ # # # # : 0 : print_time = gwr%comm%me == 0 .and. (my_ikf <= LOG_MODK .or. mod(my_ikf, LOG_MODK) == 0)
# # ]
8126 : 0 : if (print_time) call cwtime(cpu_k, wall_k, gflops_k, "start")
8127 : : !write(*, *)" For kpoint:", trim(ktoa(kk_bz))
8128 : :
8129 : : ! FIXME: Be careful with the symmetry conventions here! and the interplay between umklapp in q and FFT
8130 : : ! Also, the assembly_chi0 routines assume symrec and trev_k in [1, 2]
8131 : 0 : ik_ibz = gwr%kbz2ibz_symrel(1, ik_bz); isym_k = gwr%kbz2ibz_symrel(2, ik_bz)
8132 : 0 : trev_k = gwr%kbz2ibz_symrel(6, ik_bz); g0_k = gwr%kbz2ibz_symrel(3:5, ik_bz)
8133 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
8134 [ # # ]: 0 : kk_ibz = gwr%kibz(:, ik_ibz)
8135 : :
8136 : 0 : ugb_kibz => gwr%ugb(ik_ibz, spin)
8137 : 0 : desc_ki => gwr%green_desc_kibz(ik_ibz)
8138 : 0 : npw_ki = desc_ki%npw
8139 : 0 : istwf_ki = desc_ki%istwfk
8140 : 0 : kg_ki => desc_ki%gvec
8141 : :
8142 [ # # # # : 0 : ABI_MALLOC(ug1, (npw_ki * nspinor))
# # # # #
# # # ]
8143 [ # # # # : 0 : ABI_MALLOC(ug2, (npw_ki * nspinor))
# # # # ]
8144 [ # # # # : 0 : ABI_MALLOC(cg2_dp, (2, npw_ki * nspinor))
# # # # #
# # # ]
8145 : :
8146 : 0 : call sphereboundary(u_gbound, istwf_ki, kg_ki, u_mgfft, npw_ki)
8147 : :
8148 [ # # # # : 0 : if (gwr%usepaw == 0 .and. dtset%inclvkb /= 0 .and. gradk_not_done(ik_ibz)) then
# # ]
8149 : : ! Include term <n,k|[Vnl,iqr]|n"k>' for q -> 0.
8150 : 0 : call vkbr_init(vkbr(ik_ibz), cryst, gwr%psps, dtset%inclvkb, istwf_ki, npw_ki, kk_ibz, kg_ki)
8151 : 0 : gradk_not_done(ik_ibz) = .FALSE.
8152 : : end if
8153 : :
8154 : : if (use_ddk) then
8155 : 0 : call ddkop%setup_spin_kpoint(gwr%dtset, gwr%cryst, gwr%psps, spin, kk_ibz, istwf_ki, npw_ki, kg_ki)
8156 : : end if
8157 : :
8158 : : call chi0_bbp_mask(ik_ibz, ik_ibz, spin, spin_fact, use_tr, &
8159 : 0 : gwcomp0, spmeth0, gwr%ugb_nband, mband, now_ebands, bbp_mask)
8160 : : !bbp_mask = .True.
8161 : :
8162 : : ! FIXME: This part should be tested with tau/g-para
8163 : : ! TODO:
8164 : : ! 1) Logic to determine block_size from memory.
8165 : : ! 2) Add support for symchi = 0
8166 : : ! 3) Invert the loops
8167 : :
8168 : 0 : block_size = min(48, gwr%ugb_nband)
8169 : :
8170 : 0 : block_counter = 0
8171 [ # # # # : 0 : do band1_start=1, gwr%ugb_nband, block_size
# # # # ]
8172 : 0 : block_counter = block_counter + 1
8173 : : ! Distribute blocks inside tau_comm as wavefunctions are replicated.
8174 [ # # ]: 0 : if (gwr%tau_comm%skip(block_counter)) cycle
8175 : :
8176 [ # # # # : 0 : if (all(.not. bbp_mask(band1_start:, :))) then
# # # # ]
8177 : : !print *, "exiting band1_start loop"
8178 : : exit
8179 : : end if
8180 : :
8181 : : !print *, "band1_start, gwr%ugb_nband, block_size", band1_start, gwr%ugb_nband, block_size
8182 : 0 : nb = blocked_loop(band1_start, gwr%ugb_nband, block_size)
8183 : 0 : band1_stop = band1_start + nb - 1
8184 [ # # ]: 0 : if (band1_stop > band1_max) exit
8185 : :
8186 : : ! Collect nb bands starting from band1_start on each proc.
8187 [ # # # # ]: 0 : call ugb_kibz%collect_cplx(npw_ki * nspinor, nb, [1, band1_start], ug1_block)
8188 : :
8189 : : ! Precompute DH_DK |psi_b1>.
8190 [ # # # # : 0 : ABI_MALLOC(ddk_ug1, (2, npw_ki * nspinor, 3))
# # # # #
# # # # #
# # ]
8191 : :
8192 : : ! Loop over "conduction" states.
8193 : : !do band1=band1_start, band1_stop
8194 [ # # ]: 0 : do ib=1,nb
8195 : 0 : band1 = band1_start + ib - 1
8196 : 0 : eig_nk = gwr%ks_ebands%eig(band1, ik_ibz, spin)
8197 : :
8198 : : ! FFT band1 from g to r
8199 [ # # # # : 0 : ug1 = ug1_block(:, ib)
# # # # ]
8200 : 0 : call fft_ug(npw_ki, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_ki, kg_ki, u_gbound, ug1, ur1_kibz)
8201 : :
8202 : : if (use_ddk) then
8203 : : ! Compute DH_DK |psi_k,bi>, store results in ddk_ug1
8204 [ # # ]: 0 : ddk_ug1(1,:,1) = real(ug1)
8205 [ # # ]: 0 : ddk_ug1(2,:,1) = aimag(ug1)
8206 : 0 : call ddkop%apply(eig_nk, npw_ki, nspinor, ddk_ug1(:,:,1), cwaveprj)
8207 : : end if
8208 : :
8209 : : ! Loop over "valence" states.
8210 : : !do band2=1,gwr%ugb_nband
8211 [ # # ]: 0 : do il_b2=1, ugb_kibz%size_local(2)
8212 : 0 : band2 = ugb_kibz%loc2gcol(il_b2)
8213 : :
8214 : 0 : eig_mk = gwr%ks_ebands%eig(band2, ik_ibz, spin)
8215 : :
8216 : 0 : deltaeKS_b1b2 = ks_eig(band1, ik_ibz, spin) - ks_eig(band2, ik_ibz, spin)
8217 : 0 : deltaf_b1b2 = spin_fact * (qp_occ(band1, ik_ibz, spin) - qp_occ(band2, ik_ibz, spin))
8218 : 0 : deltaeGW_b1b2 = qp_eig(band1, ik_ibz, spin) - qp_eig(band2, ik_ibz, spin)
8219 : :
8220 : : ! Skip negligible transitions.
8221 [ # # ]: 0 : if (abs(deltaf_b1b2) < GW_TOL_DOCC) CYCLE
8222 : : ! Adler-Wiser expression.
8223 : : ! Add small imaginary of the Time-Ordered response function but only for non-zero real omega
8224 : : ! FIXME What about metals?
8225 [ # # ]: 0 : if (.not. use_tr) then
8226 : : ! Adler-Wiser without time-reversal.
8227 [ # # ]: 0 : do io=1,nomega
8228 : 0 : green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, one_pole)
8229 : : end do
8230 : :
8231 : : else
8232 [ # # ]: 0 : if (band1 < band2) CYCLE ! Here we GAIN a factor ~2
8233 : :
8234 [ # # ]: 0 : do io=1,nomega
8235 : : ! Rangel: In metals, the intra-band transitions term does not contain the antiresonant part
8236 : : ! if(abs(deltaeGW_b1b2)>GW_TOL_W0) green_w(io) = g0g0w(omega(io),deltaf_b1b2,deltaeGW_b1b2,zcut,GW_TOL_W0)
8237 [ # # ]: 0 : if (band1 == band2) green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, one_pole)
8238 [ # # ]: 0 : if (band1 /= band2) green_w(io) = g0g0w(omega(io), deltaf_b1b2, deltaeGW_b1b2, zcut, GW_TOL_W0, two_poles)
8239 : : end do
8240 : : end if
8241 : :
8242 : : ! FFT band2 from g to r
8243 [ # # # # : 0 : ug2 = ugb_kibz%buffer_cplx(:, il_b2)
# # # # ]
8244 : 0 : call fft_ug(npw_ki, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_ki, kg_ki, u_gbound, ug2, ur2_kibz)
8245 : :
8246 [ # # ]: 0 : ur_prod(:) = conjg(ur1_kibz(:)) * ur2_kibz
8247 : 0 : call fft_ur(npwe, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwfk1, gvec_q0, gbound_q0, ur_prod, rhotwg)
8248 : : ! if nspinor == 2, sum 11, 22 terms in spin space
8249 [ # # # # ]: 0 : if (nspinor == 2) rhotwg(1:npwe) = rhotwg(1:npwe) + rhotwg(npwe+1:2*npwe)
8250 : :
8251 : : if (.not. use_ddk) then
8252 : : if (gwr%usepaw == 0 ) then
8253 : : ! Matrix elements of i[H,r] for NC pseudopotentials.
8254 : : ! NB ug1 and ug2 are kind=gwp
8255 : : rhotwx = nc_ihr_comm(vkbr(ik_ibz), cryst, gwr%psps, npw_ki, nspinor, istwf_ki, gwr%dtset%inclvkb, &
8256 : : kk_ibz, ug1, ug2, kg_ki)
8257 : : end if
8258 : : else
8259 [ # # ]: 0 : cg2_dp(1,:) = real(ug2)
8260 [ # # ]: 0 : cg2_dp(2,:) = aimag(ug2)
8261 : :
8262 : : ! DH_DK operator is Hermitian.
8263 : 0 : call ddkop%get_ihr_comm(cryst, eig_mk, istwf_ki, npw_ki, nspinor, cg2_dp, rhotwx)
8264 [ # # # # ]: 0 : rhotwx = conjg(rhotwx)
8265 : :
8266 : : ! debug section
8267 : : !do idir=1,3
8268 : : ! write(std_out, "(a, *(es12.5,2x))")"rhotwx: ", rhotwx(:, 1)
8269 : : ! write(std_out, "(a, *(es12.5,2x))")"new_rhotwx:", new_rhotwx(:, 1)
8270 : : ! !write(std_out, "(a, *(es12.5,2x))")"ratio old/new:", rhotwx(:, 1) / new_rhotwx(:, 1)
8271 : : ! do iab=1,gwr%nspinor**2
8272 : : ! if (abs(rhotwx(iab,1) - new_rhotwx(iab,1)) > tol6 .and. &
8273 : : ! (abs(rhotwx(iab,1)) > tol6 .or. abs(new_rhotwx(iab,1)) > tol6)) then
8274 : : ! write(std_out, "(a, *(es12.5,2x))")"rhotwx: ", rhotwx(iab, 1)
8275 : : ! write(std_out, "(a, *(es12.5,2x))")"new_rhotwx:", new_rhotwx(iab, 1)
8276 : : ! ABI_ERROR("Too large diff")
8277 : : ! end if
8278 : : ! end do
8279 : : !end do
8280 : : end if ! use_ddk
8281 : :
8282 : : ! Treat a possible degeneracy between v and c.
8283 : : ! Adler-Wiser expression, to be consistent here we use the KS eigenvalues (?)
8284 [ # # ]: 0 : if (abs(deltaeKS_b1b2) > GW_TOL_W0) then
8285 [ # # # # ]: 0 : rhotwx = -rhotwx / deltaeKS_b1b2
8286 : : else
8287 [ # # # # ]: 0 : rhotwx = czero_gw
8288 : : end if
8289 : :
8290 : : ! NB: Using symrec conventions here
8291 : 0 : ik_ibz = gwr%kbz2ibz(1, ik_bz); isym_k = gwr%kbz2ibz(2, ik_bz)
8292 : 0 : trev_k = gwr%kbz2ibz(6, ik_bz); g0_k = gwr%kbz2ibz(3:5, ik_bz)
8293 : 0 : trev_k = trev_k + 1 ! NB: GW routines assume trev in [1, 2]
8294 : :
8295 : : ! TODO: Metals
8296 : : ! Note: if nspinor == 2, only rhotgw(1:npwe) with the 11 + 22 sum is used.
8297 : : call accumulate_head_wings_imagw( &
8298 : : npwe, nomega, nI, nJ, dtset%symchi, &
8299 : : is_metallic, ik_bz, isym_k, trev_k, nspinor, cryst, ltg_q, gsph, &
8300 : 0 : rhotwx, rhotwg, green_w, chi0_head, chi0_lwing, chi0_uwing)
8301 : : end do ! band2
8302 : : end do ! band1
8303 : :
8304 [ # # ]: 0 : ABI_FREE(ug1_block)
8305 [ # # ]: 0 : ABI_SFREE(ddk_ug1)
8306 : : end do ! band1_start
8307 : :
8308 [ # # ]: 0 : ABI_FREE(ug1)
8309 [ # # ]: 0 : ABI_FREE(ug2)
8310 [ # # ]: 0 : ABI_FREE(cg2_dp)
8311 : :
8312 [ # # ]: 0 : if (print_time) then
8313 : 0 : write(msg,'(4x,3(a,i0),a)')"my_ikf [", my_ikf, "/", gwr%my_nkbz, "] (tot: ", gwr%nkbz, ")"
8314 [ # # ]: 0 : call cwtime_report(msg, cpu_k, wall_k, gflops_k); if (my_ikf == LOG_MODK) call wrtout(std_out, " ...")
8315 : : end if
8316 : : end do ! my_ikf
8317 : : end do ! my_is
8318 : :
8319 [ # # ]: 0 : ABI_FREE(bbp_mask)
8320 [ # # ]: 0 : ABI_FREE(gvec_q0)
8321 [ # # ]: 0 : ABI_FREE(gbound_q0)
8322 [ # # ]: 0 : ABI_FREE(work)
8323 [ # # ]: 0 : ABI_FREE(ur1_kibz)
8324 [ # # ]: 0 : ABI_FREE(ur2_kibz)
8325 [ # # ]: 0 : ABI_FREE(ur_prod)
8326 [ # # ]: 0 : ABI_FREE(rhotwg)
8327 [ # # ]: 0 : ABI_FREE(u_gbound)
8328 : :
8329 : 0 : if (use_ddk) call ddkop%free()
8330 : 0 : call vkbr_free(vkbr)
8331 [ # # # # : 0 : ABI_FREE(vkbr)
# # # # #
# ]
8332 : :
8333 : : ! Collect head and wings.
8334 : 0 : call xmpi_sum(chi0_head, gwr%comm%value, ierr)
8335 : 0 : call xmpi_sum(chi0_lwing, gwr%comm%value, ierr)
8336 : 0 : call xmpi_sum(chi0_uwing, gwr%comm%value, ierr)
8337 : :
8338 [ # # # # : 0 : chi0_head = chi0_head * weight / cryst%ucvol
# # ]
8339 : : ! Tensor in terms of reciprocal lattice vectors.
8340 [ # # ]: 0 : do io=1,nomega
8341 [ # # # # : 0 : chi0_head(:,:,io) = matmul(chi0_head(:,:,io), cryst%gmet) * (two_pi**2)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
8342 : : end do
8343 [ # # # # : 0 : chi0_lwing = chi0_lwing * weight / cryst%ucvol
# # ]
8344 [ # # # # : 0 : chi0_uwing = chi0_uwing * weight / cryst%ucvol
# # ]
8345 : :
8346 : : ! ===============================================
8347 : : ! ==== Symmetrize chi0 in case of AFM system ====
8348 : : ! ===============================================
8349 : : ! Reconstruct $chi0{\down,\down}$ from $chi0{\up,\up}$.
8350 : : ! Works only in the case of magnetic group Shubnikov type IV.
8351 [ # # ]: 0 : if (cryst%use_antiferro) then
8352 : : call symmetrize_afm_chi0(Cryst, gsph, ltg_q, npwe, nomega, &
8353 : 0 : chi0_head=chi0_head, chi0_lwing=chi0_lwing, chi0_uwing=chi0_uwing)
8354 : : end if
8355 : :
8356 [ # # # # ]: 0 : if (gwr%comm%me == 0 .and. gwr%dtset%prtvol >= 1) then
8357 : : ! Construct head and wings from the tensor and output results.
8358 : 0 : qlen = tol3
8359 : 0 : call cryst%get_redcart_qdirs(nq, qdirs, qlen=qlen)
8360 [ # # # # : 0 : ABI_MALLOC(head_qvals, (nq))
# # # # #
# # # ]
8361 : 0 : call wrtout(units, " Head of the irreducible polarizability for q --> 0", pre_newlines=1)
8362 : 0 : call wrtout(units, sjoin(" q0_len:", ftoa(qlen), "(Bohr^-1)"))
8363 : 0 : write(msg, "(*(a14))") "iomega (eV)", "[100]", "[010]", "[001]", "x", "y", "z"
8364 : 0 : call wrtout(units, msg)
8365 [ # # ]: 0 : do io=1,nomega
8366 [ # # ]: 0 : do iq=1,nq
8367 [ # # # # : 0 : chq = matmul(chi0_head(:,:,io), qdirs(:,iq))
# # # # #
# # # ]
8368 : 0 : head_qvals(iq) = vdotw(qdirs(:, iq), chq, cryst%gmet, "G")
8369 : : end do
8370 [ # # ]: 0 : write(msg, "(*(es12.5,2x))") gwr%iw_mesh(io) * Ha_eV, real(head_qvals(:))
8371 : 0 : call wrtout(units, msg)
8372 : : ! Write imag part to std_out only
8373 [ # # ]: 0 : write(msg, "(*(es12.5,2x))") gwr%iw_mesh(io) * Ha_eV, aimag(head_qvals(:))
8374 : 0 : call wrtout(std_out, msg)
8375 : : end do
8376 : 0 : call wrtout(units, " ")
8377 [ # # ]: 0 : ABI_FREE(qdirs)
8378 [ # # ]: 0 : ABI_FREE(head_qvals)
8379 : : end if
8380 : :
8381 : : ! Save quantities for later use as this routine must be called before build_tchi.
8382 [ # # ]: 0 : if (gwr%kpt_comm%me == 0) then
8383 [ # # # # : 0 : ABI_REMALLOC(gwr%chi0_head_myw, (3, 3, gwr%my_ntau) )
# # # # #
# # # # #
# # ]
8384 [ # # # # : 0 : ABI_REMALLOC(gwr%chi0_uwing_myw, (3, npwe, gwr%my_ntau) )
# # # # #
# # # # #
# # # # #
# ]
8385 [ # # # # : 0 : ABI_REMALLOC(gwr%chi0_lwing_myw, (3, npwe, gwr%my_ntau) )
# # # # #
# # # # #
# # # # #
# ]
8386 : :
8387 [ # # ]: 0 : do my_it=1,gwr%my_ntau
8388 : 0 : itau = gwr%my_itaus(my_it)
8389 [ # # # # ]: 0 : gwr%chi0_head_myw(:,:,my_it) = chi0_head(:,:,itau)
8390 [ # # ]: 0 : do ii=1,3
8391 [ # # ]: 0 : gwr%chi0_uwing_myw(ii,:,my_it) = chi0_uwing(:,itau,ii)
8392 [ # # ]: 0 : gwr%chi0_lwing_myw(ii,:,my_it) = chi0_lwing(:,itau,ii)
8393 : : end do
8394 : : end do
8395 : : end if
8396 : :
8397 [ # # ]: 0 : ABI_FREE(chi0_lwing)
8398 [ # # ]: 0 : ABI_FREE(chi0_uwing)
8399 [ # # ]: 0 : ABI_FREE(chi0_head)
8400 : 0 : call ltg_q%free()
8401 : 0 : call gsph%free()
8402 : :
8403 : 0 : call cwtime_report(" gwr_build_chi0_head_and_wings:", cpu_all, wall_all, gflops_all)
8404 : 0 : call timab(1927, 2, tsec)
8405 : :
8406 : : !if (use_ddk) stop "gwr_build_chi0_head_and_wings"
8407 : :
8408 [ # # # # : 0 : end subroutine gwr_build_chi0_head_and_wings
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
8409 : : !!***
8410 : :
8411 : : !----------------------------------------------------------------------
8412 : :
8413 : : !!****f* m_gwr/gwr_build_sigxme
8414 : : !! NAME
8415 : : !! gwr_build_sigxme
8416 : : !!
8417 : : !! FUNCTION
8418 : : !! Compute matrix elements of the exchange part.
8419 : : !!
8420 : : !! INPUTS
8421 : : !!
8422 : : !! OUTPUT
8423 : : !!
8424 : : !! SOURCE
8425 : :
8426 : 0 : subroutine gwr_build_sigxme(gwr, compute_qp)
8427 : :
8428 : : !Arguments ------------------------------------
8429 : : class(gwr_t),target,intent(inout) :: gwr
8430 : : logical,optional,intent(in) :: compute_qp
8431 : :
8432 : : !Local variables-------------------------------
8433 : : !scalars
8434 : : integer :: nsppol, nspinor, ierr, my_ikf, band_sum, ii, jj, kb, il_b, iab !ig_start, ig,
8435 : : integer :: my_is, ikcalc, ikcalc_ibz, bmin, bmax, band, istwf_k, npw_k
8436 : : integer :: spin, jb, is_idx, use_umklp, spad, wtqm, wtqp, irow, spadx1, spadx2, npwx, u_nfft, u_mgfft, u_mpw
8437 : : integer :: ik_bz, ik_ibz, isym_k, trev_k, g0_k(3)
8438 : : integer :: iq_bz, iq_ibz, isym_q, trev_q, g0_q(3)
8439 : : logical :: isirr_k, isirr_q, sigc_is_herm, compute_qp__
8440 : : real(dp) :: fact_spin, theta_mu_minus_esum, theta_mu_minus_esum2, tol_empty, tol_empty_in, gwr_boxcutmin_x, i_sz
8441 : : real(dp) :: cpu_k, wall_k, gflops_k, cpu_all, wall_all, gflops_all
8442 : : complex(gwp) :: gwpc_sigxme, gwpc_sigxme2, xdot_tmp, ctmp
8443 : : character(len=5000) :: msg
8444 : : logical :: q_is_gamma
8445 : : type(__slkmat_t),pointer :: ugb_kibz
8446 : : type(crystal_t),pointer :: cryst
8447 : : type(dataset_type),pointer :: dtset
8448 : 0 : type(littlegroup_t) :: ltg_k
8449 : : type(desc_t),pointer :: desc_ki
8450 : : !arrays
8451 : : integer :: g0(3), gmax(3), spinor_padx(2,4), u_ngfft(18), work_ngfft(18), units(2)
8452 : 0 : integer,allocatable :: gbound_kcalc(:,:), gvec_x(:,:), gbound_x(:,:), kg_k(:,:), gbound_ksum(:,:)
8453 : : 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)
8454 : 0 : real(dp),contiguous, pointer :: ks_eig(:,:,:), qp_eig(:,:,:), qp_occ(:,:,:), cg2_ptr(:,:) ! cg1_ptr(:,:),
8455 : 0 : real(dp),allocatable :: work(:,:,:,:), cg1_ibz(:,:) !, cg2_bz(:,:)
8456 : 0 : complex(gwp),allocatable :: vc_sqrt_qbz(:), ur_bdgw(:,:)
8457 : 0 : complex(gwp),allocatable :: rhotwg(:), rhotwgp(:), rhotwg_ki(:,:), ur_ksum(:), ur_prod(:), eig0r(:)!, ugb_kcalcibz(:)
8458 : 0 : complex(gwp),allocatable :: ug_ksum(:)
8459 : 0 : complex(dp),target,allocatable :: ug_ksum_dp(:)
8460 : 0 : complex(dp),allocatable :: sigxme_tmp(:,:,:), sigx(:,:,:,:)
8461 : 0 : type(sigijtab_t),allocatable :: Sigxij_tab(:,:), Sigcij_tab(:,:)
8462 : : type(yamldoc_t) :: ydoc
8463 : : ! *************************************************************************
8464 : :
8465 : 0 : call timab(1920, 1, tsec)
8466 : 0 : call cwtime(cpu_all, wall_all, gflops_all, "start")
8467 : :
8468 [ # # ]: 0 : units = [std_out, ab_out]
8469 [ # # ]: 0 : if (gwr%sig_diago) then
8470 : 0 : call wrtout(units, " Computing diagonal matrix elements of Sigma_x", pre_newlines=1)
8471 : : else
8472 : 0 : call wrtout(units, " Computing diagonal + off-diagonal matrix elements of Sigma_x", pre_newlines=1)
8473 : : end if
8474 : :
8475 [ # # ]: 0 : if (gwr%scf_iteration /= 1) then
8476 : : associate (now => gwr%qp_ebands, prev => gwr%qp_ebands_prev)
8477 [ # # # # : 0 : if (all(now%occ == prev%occ)) then
# # # # #
# ]
8478 : 0 : call wrtout(units, " Occupations have not changed since last iteration, skipping Sigma_x matrix elements computation...", pre_newlines=1)
8479 : : else
8480 : 0 : call wrtout(units, " Occupations have changed since last iteration, recomputing Sigma_x matrix elements...", pre_newlines=1)
8481 : : end if
8482 : : end associate
8483 : : goto 10
8484 : : end if
8485 : :
8486 [ # # ]: 0 : if (gwr%has_vcgen_sigma) then
8487 : 0 : call gwr%vcgen_sigma%print(units, " Info on Coulomb term used in Sigma_x", gwr%dtset%prtvol)
8488 : : else
8489 : 0 : call gwr%vcgen_eps%print(units, " Info on Coulomb term used in Sigma_x", dtset%prtvol)
8490 : : end if
8491 : :
8492 : 0 : nsppol = gwr%nsppol; nspinor = gwr%nspinor; cryst => gwr%cryst; dtset => gwr%dtset
8493 : :
8494 : : ! Table for \Sigmax_ij matrix elements.
8495 : 0 : sigc_is_herm = .False.
8496 : : call sigtk_sigma_tables(gwr%nkcalc, gwr%nkibz, gwr%nsppol, gwr%bstart_ks, gwr%bstop_ks, gwr%kcalc2ibz(:,1), &
8497 : 0 : gwr%sig_diago, sigc_is_herm, sigxij_tab, sigcij_tab)
8498 : :
8499 : 0 : call sigijtab_free(Sigcij_tab)
8500 [ # # # # : 0 : ABI_FREE(Sigcij_tab)
# # # # #
# # # ]
8501 : :
8502 : : ! Allocate array with Sigma_x matrix elements depending on sig_diago
8503 : 0 : ii = gwr%b1gw; jj = gwr%b2gw
8504 [ # # ]: 0 : if (gwr%sig_diago) then
8505 : 0 : ii = 1; jj = 1
8506 : : end if
8507 [ # # # # : 0 : ABI_RECALLOC(gwr%sigx_mat, (gwr%b1gw:gwr%b2gw, ii:jj, gwr%nkcalc, gwr%nsppol*gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
8508 : :
8509 : 0 : ks_eig => gwr%ks_ebands%eig
8510 [ # # ]: 0 : if (gwr%scf_iteration == 1) then
8511 : 0 : call wrtout(units, " Using KS orbitals and KS energies...", newlines=1, do_flush=.True.)
8512 : 0 : qp_eig => gwr%ks_ebands%eig; qp_occ => gwr%ks_ebands%occ
8513 : : else
8514 : 0 : call wrtout(units, " Using KS orbitals and QP energies...", newlines=1, do_flush=.True.)
8515 : 0 : qp_eig => gwr%qp_ebands%eig; qp_occ => gwr%qp_ebands%occ
8516 : : end if
8517 : :
8518 : : ! Set tolerance used to decide if a band is empty
8519 : 0 : tol_empty_in = 0.01
8520 : 0 : call get_fact_spin_tol_empty(nsppol, nspinor, tol_empty_in, fact_spin, tol_empty)
8521 : :
8522 : : ! =========================================
8523 : : ! Find FFT mesh and max number of g-vectors
8524 : : ! =========================================
8525 : 0 : gwr_boxcutmin_x = two
8526 : 0 : call gwr%get_u_ngfft(gwr_boxcutmin_x, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8527 : :
8528 [ # # # # ]: 0 : if (gwr%comm%me == 0) call print_ngfft([std_out], u_ngfft, header="FFT mesh for Sigma_x")
8529 : :
8530 : : ! Init work_ngfft
8531 [ # # ]: 0 : gmax = gmax + 4 ! FIXME: this is to account for umklapp, should also consider Gamma-only and istwfk
8532 [ # # ]: 0 : gmax = 2 * gmax + 1
8533 : 0 : call ngfft_seq(work_ngfft, gmax)
8534 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
8535 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
8536 : :
8537 [ # # ]: 0 : do my_is=1,gwr%my_nspins
8538 : 0 : spin = gwr%my_spins(my_is)
8539 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
8540 : 0 : call cwtime(cpu_k, wall_k, gflops_k, "start")
8541 : 0 : ikcalc_ibz = gwr%kcalc2ibz(ikcalc, 1)
8542 [ # # ]: 0 : kgw = gwr%kcalc(:, ikcalc)
8543 : 0 : bmin = gwr%bstart_ks(ikcalc, spin); bmax = gwr%bstop_ks(ikcalc, spin)
8544 : :
8545 : : ! ==============================================================
8546 : : ! ==== Find little group of the k-points for GW corrections ====
8547 : : ! ==============================================================
8548 : : ! * The little group is used only if symsigma == 1
8549 : : ! * If use_umklp == 1 then symmetries requiring an umklapp to preserve k_gw are included as well.
8550 : 0 : use_umklp = 1
8551 : 0 : call ltg_k%init(kgw, gwr%nqbz, gwr%qbz, cryst, use_umklp, npwe=0)
8552 : : !if (gwr%comm%me == 0) call ltg_k%print([std_out], prtvol=gwr%dtset%prtvol)
8553 : :
8554 : 0 : write(msg,'(5a)') ch10, &
8555 [ # # # # : 0 : ' Calculating <nk|Sigma_x|nk> at k: ',trim(ktoa(kgw)), ", for band range: ", trim(ltoa([bmin, bmax]))
# # ]
8556 : 0 : call wrtout(std_out, msg)
8557 : :
8558 : : ! ===============================================
8559 : : ! Load wavefunctions for Sigma_x matrix elements
8560 : : ! ===============================================
8561 : : ! All procs need ur_bdgw but the IBZ is distributed and, possibly, replicated in gwr%kpt_comm.
8562 : : ! Here we select the right procs, fill the buffer with the FFT results and then use
8563 : : ! a dumb xmpi_sum + rescaling to gather the results.
8564 : : ! FIXME: g-vectors from Green's descriptor or use another array to be able to deal with istwfk == 2?
8565 : :
8566 [ # # # # : 0 : ABI_MALLOC_OR_DIE(ur_bdgw, (u_nfft * nspinor, bmin:bmax), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
8567 [ # # # # ]: 0 : ur_bdgw = czero_gw
8568 : :
8569 [ # # # # : 0 : if (any(ikcalc_ibz == gwr%my_kibz_inds)) then
# # ]
8570 : : associate (desc_kcalc => gwr%green_desc_kibz(ikcalc_ibz), ugb_kcalc => gwr%ugb(ikcalc_ibz, spin))
8571 [ # # # # : 0 : ABI_MALLOC(gbound_kcalc, (2 * u_mgfft + 8, 2))
# # # # #
# # # #
# ]
8572 : 0 : call sphereboundary(gbound_kcalc, desc_kcalc%istwfk, desc_kcalc%gvec, u_mgfft, desc_kcalc%npw)
8573 : :
8574 [ # # ]: 0 : do il_b=1,ugb_kcalc%size_local(2)
8575 [ # # ]: 0 : band = ugb_kcalc%loc2gcol(il_b); if (band < bmin .or. band > bmax) CYCLE
8576 : : call fft_ug(desc_kcalc%npw, u_nfft, nspinor, ndat1, &
8577 : : u_mgfft, u_ngfft, desc_kcalc%istwfk, desc_kcalc%gvec, gbound_kcalc, &
8578 : : gwr%ugb(ikcalc_ibz, spin)%buffer_cplx(:, il_b), & ! in
8579 : 0 : ur_bdgw(:, band)) ! out
8580 : : end do
8581 [ # # # # ]: 0 : ABI_FREE(gbound_kcalc)
8582 : : end associate
8583 : : end if
8584 : :
8585 : : ! Collect and rescale
8586 : : !call xmpi_sum(ur_bdgw, gwr%kgt_comm%value, ierr)
8587 : 0 : call xmpi_sum(ur_bdgw, gwr%kg_comm%value, ierr)
8588 [ # # # # ]: 0 : ur_bdgw = ur_bdgw / gwr%np_kibz(ikcalc_ibz)
8589 : :
8590 [ # # # # : 0 : ABI_MALLOC(ur_prod, (u_nfft * nspinor))
# # # # #
# # # ]
8591 [ # # # # : 0 : ABI_MALLOC(ur_ksum, (u_nfft * nspinor))
# # # # ]
8592 [ # # # # : 0 : ABI_MALLOC(eig0r, (u_nfft * nspinor))
# # # # ]
8593 : :
8594 [ # # # # : 0 : ABI_CALLOC(sigxme_tmp, (bmin:bmax, bmin:bmax, nsppol * gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
8595 [ # # # # : 0 : ABI_CALLOC(sigx, (2, bmin:bmax, bmin:bmax, nsppol * gwr%nsig_ab))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
8596 : :
8597 : : ! ========================================
8598 : : ! ==== Sum over my k-points in the BZ ====
8599 : : ! ========================================
8600 : :
8601 [ # # ]: 0 : do my_ikf=1,gwr%my_nkbz
8602 : 0 : ik_bz = gwr%my_kbz_inds(my_ikf)
8603 [ # # ]: 0 : ksum = gwr%kbz(:, ik_bz)
8604 : :
8605 : : ! Find the symmetrical image of ksum in the IBZ
8606 : : ! FIXME: Be careful with the symmetry conventions here and the interplay between umklapp in q and FFT
8607 : 0 : ik_ibz = gwr%kbz2ibz_symrel(1, ik_bz); isym_k = gwr%kbz2ibz_symrel(2, ik_bz)
8608 [ # # ]: 0 : trev_k = gwr%kbz2ibz_symrel(6, ik_bz); g0_k = gwr%kbz2ibz_symrel(3:5, ik_bz)
8609 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
8610 [ # # ]: 0 : kk_ibz = gwr%kibz(:, ik_ibz)
8611 : :
8612 : : ! Identify q and G0 where q + G0 = k_GW - ksum
8613 [ # # ]: 0 : kgw_m_ksum = kgw - ksum
8614 : 0 : call findqg0(iq_bz, g0, kgw_m_ksum, gwr%nqbz, gwr%qbz, gwr%mG0)
8615 : : !ABI_CHECK(all(g0 == 0), sjoin("g0 = ", ltoa(g0)))
8616 : :
8617 : 0 : call calc_ceigr(g0, u_nfft, nspinor, u_ngfft, eig0r)
8618 : :
8619 : : ! If symmetries are exploited, only q-points in the IBZ_k are computed.
8620 : : ! In this case elements are weighted according to wtqp and wtqm. wtqm is for time-reversal.
8621 : 0 : wtqp = 1; wtqm = 0
8622 : : !if (can_symmetrize(spin)) then
8623 [ # # ]: 0 : if (gwr%dtset%symsigma == 1) then
8624 [ # # ]: 0 : if (ltg_k%ibzq(iq_bz) /= 1) CYCLE
8625 [ # # ]: 0 : wtqp = sum(ltg_k%wtksym(1,:,iq_bz))
8626 [ # # ]: 0 : wtqm = sum(ltg_k%wtksym(2,:,iq_bz))
8627 : : end if
8628 : :
8629 [ # # ]: 0 : qq_bz = gwr%qbz(:, iq_bz)
8630 : 0 : iq_ibz = gwr%qbz2ibz(1, iq_bz); isym_q = gwr%qbz2ibz(2, iq_bz)
8631 : 0 : trev_q = gwr%qbz2ibz(6, iq_bz); g0_q = gwr%qbz2ibz(3:5, iq_bz)
8632 : : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
8633 : :
8634 : : ! Find the corresponding irreducible q-point.
8635 : : ! NB: non-zero umklapp G_o is not allowed. There's a check in setup_sigma
8636 : : !call qmesh%get_BZ_item(iq_bz, qbz, iq_ibz, isym_q, itim_q)
8637 : 0 : q_is_gamma = normv(qq_bz, cryst%gmet, "G") < GW_TOLQ0
8638 [ # # ]: 0 : call get_kg(qq_bz, istwfk1, dtset%ecutsigx, cryst%gmet, npwx, gvec_x)
8639 : :
8640 [ # # # # : 0 : ABI_MALLOC(gbound_x, (2*u_mgfft + 8, 2))
# # # # #
# # # # #
# # ]
8641 : 0 : call sphereboundary(gbound_x, istwfk1, gvec_x, u_mgfft, npwx)
8642 : :
8643 [ # # # # : 0 : ABI_MALLOC(rhotwg_ki, (npwx * nspinor, bmin:bmax))
# # # # #
# # # # #
# # ]
8644 [ # # # # : 0 : ABI_MALLOC(rhotwg, (npwx * nspinor))
# # # # #
# # # ]
8645 [ # # # # : 0 : ABI_MALLOC(rhotwgp, (npwx * nspinor))
# # # # ]
8646 [ # # # # : 0 : ABI_MALLOC(vc_sqrt_qbz, (npwx))
# # # # #
# # # ]
8647 [ # # ]: 0 : spinor_padx = reshape([0, 0, npwx, npwx, 0, npwx, npwx, 0], [2, 4])
8648 : :
8649 : : ! Get Fourier components of the Coulomb interaction in the BZ
8650 : : ! In 3D systems, neglecting umklapp, vc(Sq,sG)=vc(q,G)=4pi/|q+G|
8651 : : ! The same relation holds for 0-D systems, but not in 1-D or 2D systems. It depends on S.
8652 [ # # ]: 0 : if (gwr%has_vcgen_sigma) then
8653 : 0 : call gwr%vcgen_sigma%get_vc_sqrt(qq_bz, npwx, gvec_x, gwr%q0, gwr%cryst, vc_sqrt_qbz, gwr%gtau_comm%value)
8654 : : else
8655 : 0 : call gwr%vcgen_eps%get_vc_sqrt(qq_bz, npwx, gvec_x, gwr%q0, gwr%cryst, vc_sqrt_qbz, gwr%gtau_comm%value)
8656 : : end if
8657 : :
8658 : 0 : desc_ki => gwr%green_desc_kibz(ik_ibz)
8659 : :
8660 : : ! Get npw_k and kg_k for this k.
8661 [ # # ]: 0 : if (isirr_k) then
8662 : 0 : istwf_k = desc_ki%istwfk; npw_k = desc_ki%npw
8663 [ # # # # : 0 : ABI_MALLOC(kg_k, (3, npw_k))
# # # # #
# # # #
# ]
8664 [ # # # # ]: 0 : kg_k(:,:) = desc_ki%gvec
8665 : : else
8666 : 0 : istwf_k = 1
8667 [ # # ]: 0 : call get_kg(ksum, istwf_k, dtset%ecutwfn, cryst%gmet, npw_k, kg_k)
8668 : : end if
8669 : :
8670 [ # # # # : 0 : ABI_MALLOC(ug_ksum, (npw_k * nspinor))
# # # # #
# # # ]
8671 [ # # # # : 0 : ABI_MALLOC(ug_ksum_dp, (npw_k * nspinor))
# # # # ]
8672 : : !ABI_MALLOC(ugb_kcalcibz, (npw_k * nspinor))
8673 [ # # # # : 0 : ABI_MALLOC(cg1_ibz, (2, desc_ki%npw * nspinor))
# # # # #
# # # ]
8674 : : !ABI_MALLOC(cg2_bz, (2, npw_k * nspinor))
8675 : :
8676 [ # # # # : 0 : ABI_MALLOC(gbound_ksum, (2*u_mgfft+8, 2))
# # # # ]
8677 : 0 : call sphereboundary(gbound_ksum, istwf_k, kg_k, u_mgfft, npw_k)
8678 : :
8679 : : ! ==========================
8680 : : ! Sum over (occupied) bands
8681 : : ! ==========================
8682 : 0 : ugb_kibz => gwr%ugb(ik_ibz, spin)
8683 : :
8684 [ # # ]: 0 : do il_b=1,ugb_kibz%size_local(2)
8685 : : ! Distribute bands inside tau_comm as wavefunctions are replicated
8686 [ # # ]: 0 : if (gwr%tau_comm%skip(il_b)) cycle
8687 : 0 : band_sum = ugb_kibz%loc2gcol(il_b)
8688 : :
8689 : : ! Skip empty states. MRM: allow negative occ numbers.
8690 [ # # ]: 0 : if (abs(qp_occ(band_sum, ik_ibz, spin)) < tol_empty) CYCLE
8691 : :
8692 : : ! Compute ur_ksum(r) from the symmetrical image.
8693 : : ! I should rotate the g-vectors outside the loop and rotate ug here
8694 : : ! but at present I cannot use cgtk_rotate due to the symrel^T convention.
8695 : :
8696 [ # # ]: 0 : if (isirr_k) then
8697 : : !call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, bra_kq)
8698 [ # # ]: 0 : ug_ksum(:) = ugb_kibz%buffer_cplx(:, il_b)
8699 : : else
8700 : : ! Reconstruct u_kq(G) from the IBZ image.
8701 : :
8702 : : ! FIXME: This is wrong if spc
8703 : 0 : call c_f_pointer(c_loc(ug_ksum_dp), cg2_ptr, shape=[2, npw_k * nspinor])
8704 : :
8705 : : !call c_f_pointer(c_loc(ugb_kibz%buffer_cplx(:, il_b)), cg1_ptr, shape=[2, desc_ki%npw * nspinor])
8706 : : !call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, nspinor, ndat1, &
8707 : : ! desc_ki%npw, desc_ki%gvec, &
8708 : : ! npw_k, kg_k, desc_ki%istwfk, istwf_k, cg1_ptr, cg2_ptr, work_ngfft, work)
8709 : :
8710 [ # # ]: 0 : cg1_ibz(1,:) = real(ugb_kibz%buffer_cplx(:, il_b), kind=dp)
8711 [ # # ]: 0 : cg1_ibz(2,:) = real(aimag(ugb_kibz%buffer_cplx(:, il_b)), kind=dp)
8712 : : call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, nspinor, ndat1, &
8713 : : desc_ki%npw, desc_ki%gvec, &
8714 : 0 : npw_k, kg_k, desc_ki%istwfk, istwf_k, cg1_ibz, cg2_ptr, work_ngfft, work)
8715 [ # # ]: 0 : ug_ksum(:) = ug_ksum_dp(:)
8716 : : end if
8717 : :
8718 : 0 : call fft_ug(npw_k, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwf_k, kg_k, gbound_ksum, ug_ksum, ur_ksum)
8719 : :
8720 [ # # # # : 0 : if (any(g0 /= 0)) ur_ksum = ur_ksum * conjg(eig0r)
# # # # #
# ]
8721 : :
8722 : : ! Get all <k-q,band_sum,s|e^{-i(q+G).r}|s,jb,k>
8723 [ # # ]: 0 : do jb=bmin,bmax
8724 : :
8725 : : ! FIXME: nspinor 2 is wrong as we have a 2x2 matrix
8726 [ # # ]: 0 : ur_prod(:) = conjg(ur_ksum(:)) * ur_bdgw(:,jb)
8727 : 0 : call fft_ur(npwx, u_nfft, nspinor, ndat1, u_mgfft, u_ngfft, istwfk1, gvec_x, gbound_x, ur_prod, rhotwg_ki(:,jb))
8728 : :
8729 : : ! Multiply by the square root of the Coulomb term
8730 : : ! In 3-D systems, the factor sqrt(4pi) is included
8731 [ # # ]: 0 : do ii=1,nspinor
8732 : 0 : spad = (ii-1) * npwx
8733 [ # # ]: 0 : rhotwg_ki(spad+1:spad+npwx,jb) = rhotwg_ki(spad+1:spad + npwx,jb) * vc_sqrt_qbz(1:npwx)
8734 : : end do
8735 : :
8736 [ # # ]: 0 : if (q_is_gamma) then
8737 : : !if (ik_bz == jk_bz) then
8738 : : ! Treat analytically the case q --> 0:
8739 : : !
8740 : : ! * The oscillator is evaluated at q = 0 as it is considered constant in the small cube around Gamma
8741 : : ! while the Colulomb term is integrated out.
8742 : : ! * If nspinor == 1, we have nonzero contribution only if band_sum == jb
8743 : : ! * If nspinor == 2, we evaluate <band_sum,up|jb,up> and <band_sum,dwn|jb,dwn>,
8744 : : ! and impose orthonormalization since npwwfn might be < npwvec.
8745 : : ! * Note the use of i_sz_resid and not i_sz, to account for the possibility
8746 : : ! to have generalized KS basis set from hybrid
8747 : :
8748 : 0 : i_sz = gwr%vcgen_eps%i_sz
8749 [ # # ]: 0 : if (gwr%has_vcgen_sigma) i_sz = gwr%vcgen_sigma%i_sz
8750 : :
8751 [ # # ]: 0 : if (nspinor == 1) then
8752 : 0 : rhotwg_ki(1, jb) = czero_gw
8753 [ # # ]: 0 : if (band_sum == jb) rhotwg_ki(1,jb) = cmplx(sqrt(i_sz), 0.0_gwp)
8754 : : !rhotwg_ki(1,jb) = czero_gw ! DEBUG
8755 : :
8756 : : else
8757 : 0 : rhotwg_ki(1, jb) = zero; rhotwg_ki(npwx+1, jb) = zero
8758 [ # # ]: 0 : if (band_sum == jb) then
8759 : : associate(ugb_kcalcibz => gwr%ugb(ikcalc_ibz, spin)%buffer_cplx(:,il_b))
8760 : 0 : ABI_CHECK(size(ug_ksum) == size(ugb_kcalcibz), "Size mismatch in Sigma_x")
8761 : 0 : ctmp = xdotc(npw_k, ug_ksum(1:), 1, ugb_kcalcibz(1:), 1)
8762 : 0 : rhotwg_ki(1, jb) = cmplx(sqrt(i_sz), 0.0_gwp) * real(ctmp)
8763 : 0 : ctmp = xdotc(npw_k, ug_ksum(npw_k+1:), 1, ugb_kcalcibz(npw_k+1:), 1)
8764 [ # # ]: 0 : rhotwg_ki(npwx+1, jb) = cmplx(sqrt(i_sz), 0.0_gwp) * real(ctmp)
8765 : : end associate
8766 : : end if
8767 : : !!!rhotwg_ki(1, jb) = zero; rhotwg_ki(npwx+1, jb) = zero
8768 : : !!! PAW is missing
8769 : : end if
8770 : : end if
8771 : :
8772 : : end do ! jb Got all matrix elements from bmin up to bmax.
8773 : :
8774 : 0 : theta_mu_minus_esum = fact_spin * qp_occ(band_sum, ik_ibz, spin)
8775 : : theta_mu_minus_esum2 = sqrt(abs(fact_spin * qp_occ(band_sum, ik_ibz, spin))) ! MBB Nat. orb. funct. approx. sqrt(occ)
8776 : :
8777 [ # # ]: 0 : if (abs(theta_mu_minus_esum / fact_spin) >= tol_empty) then ! MRM: allow negative occ numbers
8778 [ # # ]: 0 : do kb=bmin,bmax
8779 : :
8780 : : ! Copy the ket Sigma_x |phi_{k,kb}>.
8781 [ # # ]: 0 : rhotwgp(:) = rhotwg_ki(:, kb)
8782 : :
8783 : : ! Loop over the non-zero row elements of this column.
8784 : : ! If gwcalctyp < 20: only diagonal elements since QP == KS.
8785 : : ! If gwcalctyp >= 20:
8786 : : ! * Only off-diagonal elements connecting states with same character.
8787 : : ! * Only the upper triangle if HF, SEX, or COHSEX.
8788 : :
8789 [ # # ]: 0 : do irow=1,Sigxij_tab(ikcalc, spin)%col(kb)%size1
8790 : 0 : jb = Sigxij_tab(ikcalc, spin)%col(kb)%bidx(irow)
8791 [ # # ]: 0 : rhotwg(:) = rhotwg_ki(:,jb)
8792 : :
8793 : : ! Calculate bare exchange <phi_jb|Sigma_x|phi_kb>.
8794 : : ! Do the scalar product only if band_sum is occupied.
8795 [ # # ]: 0 : do iab=1,gwr%nsig_ab
8796 : 0 : spadx1 = spinor_padx(1, iab); spadx2 = spinor_padx(2, iab)
8797 : 0 : xdot_tmp = -XDOTC(npwx, rhotwg(spadx1+1:), 1, rhotwgp(spadx2+1:), 1)
8798 : 0 : gwpc_sigxme = xdot_tmp * theta_mu_minus_esum
8799 : 0 : gwpc_sigxme2 = xdot_tmp * theta_mu_minus_esum2
8800 : :
8801 : : ! Accumulate and symmetrize Sigma_x matrix elements.
8802 : : ! -wtqm comes from time-reversal (exchange of band indices)
8803 [ # # ]: 0 : is_idx = spin; if (nspinor == 2) is_idx = iab
8804 : : sigxme_tmp(jb, kb, is_idx) = sigxme_tmp(jb, kb, is_idx) + &
8805 : 0 : (wtqp + wtqm) * DBLE(gwpc_sigxme) + (wtqp - wtqm) * j_dpc * AIMAG(gwpc_sigxme)
8806 : :
8807 : 0 : sigx(1, jb, kb, is_idx) = sigx(1, jb, kb, is_idx) + wtqp * gwpc_sigxme
8808 : 0 : sigx(2, jb, kb, is_idx) = sigx(2, jb, kb, is_idx) + wtqm *CONJG(gwpc_sigxme)
8809 : : end do
8810 : : end do ! irow
8811 : :
8812 : : end do ! kb
8813 : : end if
8814 : : end do ! band_sum
8815 : :
8816 [ # # ]: 0 : ABI_FREE(gbound_x)
8817 [ # # ]: 0 : ABI_FREE(kg_k)
8818 [ # # ]: 0 : ABI_FREE(ug_ksum)
8819 [ # # ]: 0 : ABI_FREE(ug_ksum_dp)
8820 : : !ABI_FREE(ugb_kcalcibz)
8821 [ # # ]: 0 : ABI_FREE(cg1_ibz)
8822 : : !ABI_FREE(cg2_bz)
8823 [ # # ]: 0 : ABI_FREE(gbound_ksum)
8824 [ # # ]: 0 : ABI_FREE(gvec_x)
8825 [ # # ]: 0 : ABI_FREE(rhotwg_ki)
8826 [ # # ]: 0 : ABI_FREE(rhotwg)
8827 [ # # ]: 0 : ABI_FREE(rhotwgp)
8828 [ # # ]: 0 : ABI_FREE(vc_sqrt_qbz)
8829 : : end do ! my_ikf Got all diagonal (off-diagonal) matrix elements.
8830 : :
8831 : : ! Gather contributions from all the CPUs.
8832 : 0 : call xmpi_sum(sigxme_tmp, gwr%kgt_comm%value, ierr)
8833 : 0 : call xmpi_sum(sigx, gwr%kgt_comm%value, ierr)
8834 : :
8835 : : ! Multiply by constants. For 3D systems sqrt(4pi) is included in vc_sqrt_qbz.
8836 [ # # # # : 0 : sigxme_tmp = (one / (cryst%ucvol * gwr%nkbz)) * sigxme_tmp ! * Sigp%sigma_mixing
# # ]
8837 [ # # # # : 0 : sigx = (one / (cryst%ucvol * gwr%nkbz)) * sigx ! * Sigp%sigma_mixing
# # # # ]
8838 : :
8839 : : ! If we have summed over the IBZ_q, we have to average over degenerate states.
8840 : : ! Presently only diagonal terms are considered
8841 : : ! Note that here we pass ks_eig to sigx_symmetrize instead of qp_eig.
8842 : : ! The reason is that we use the eigenvalues to detect degeneracies before averaging
8843 : : ! and qp_eig may break degeneracies while ks_eig are much more accurate.
8844 : : ! Most of the breaking comes from the correlated part, likey due to the treatment of q --> 0.
8845 : :
8846 : : ! TODO QP-SCGW required a more involved approach, there is a check in sigma
8847 : : ! TODO it does not work if nspinor == 2.
8848 : :
8849 [ # # ]: 0 : if (gwr%dtset%symsigma == 1) then
8850 : 0 : call sigx_symmetrize(ikcalc_ibz, spin, bmin, bmax, nsppol, nspinor, gwr%nsig_ab, gwr%dtset%symsigma_de, ks_eig, sigx, sigxme_tmp)
8851 : : !do ii=bmin, bmax; print *, "qp_eig:", ii, qp_eig(ii, ikcalc_ibz, spin) * Ha_eV; end do
8852 : : !call sigx_symmetrize(ikcalc_ibz, spin, bmin, bmax, nsppol, nspinor, gwr%nsig_ab, gwr%dtset%symsigma_de, qp_eig, sigx, sigxme_tmp)
8853 : : end if
8854 : :
8855 : : ! Reconstruct the full sigma_x matrix from the upper triangle.
8856 [ # # ]: 0 : if (gwr%nsig_ab == 1) then
8857 : 0 : call hermitianize(sigxme_tmp(:,:,spin), "Upper")
8858 : : else
8859 : 0 : ABI_WARNING("Should hermitianize non-collinear sigma!")
8860 : : end if
8861 : :
8862 : : ! Save exchange matrix in gwr%sigx_mat taking into account sig_diago.
8863 [ # # ]: 0 : if (gwr%nsig_ab == 1) then
8864 [ # # ]: 0 : if (gwr%sig_diago) then
8865 [ # # ]: 0 : do jb=bmin,bmax
8866 : 0 : gwr%sigx_mat(jb, 1, ikcalc, spin) = sigxme_tmp(jb,jb,spin)
8867 : : end do
8868 : : else
8869 [ # # # # ]: 0 : gwr%sigx_mat(bmin:bmax, bmin:bmax, ikcalc, spin) = sigxme_tmp(bmin:bmax, bmin:bmax, spin)
8870 : : end if
8871 : : else
8872 [ # # ]: 0 : if (gwr%sig_diago) then
8873 [ # # ]: 0 : do iab=1,gwr%nsig_ab
8874 [ # # ]: 0 : do jb=bmin,bmax
8875 : 0 : gwr%sigx_mat(jb, 1, ikcalc, iab) = sigxme_tmp(jb,jb,iab)
8876 : : end do
8877 : : end do
8878 : : else
8879 [ # # # # : 0 : gwr%sigx_mat(bmin:bmax, bmin:bmax, ikcalc, :) = sigxme_tmp(bmin:bmax, bmin:bmax, :)
# # ]
8880 : : end if
8881 : : end if
8882 : :
8883 [ # # ]: 0 : ABI_FREE(ur_bdgw)
8884 [ # # ]: 0 : ABI_FREE(ur_prod)
8885 [ # # ]: 0 : ABI_FREE(ur_ksum)
8886 [ # # ]: 0 : ABI_FREE(eig0r)
8887 [ # # ]: 0 : ABI_FREE(sigxme_tmp)
8888 [ # # ]: 0 : ABI_FREE(sigx)
8889 : 0 : call ltg_k%free()
8890 : 0 : call cwtime_report(" Sigx_nk:", cpu_k, wall_k, gflops_k)
8891 : : end do ! ikcalc
8892 : : end do ! my_is
8893 : :
8894 [ # # ]: 0 : if (gwr%spin_comm%nproc > 1) call xmpi_sum(gwr%sigx_mat, gwr%spin_comm%value, ierr)
8895 [ # # # # : 0 : if (gwr%nspinor == 2) gwr%sigx_mat(:,:,:,1) = sum(gwr%sigx_mat(:,:,:,:), dim=4)
# # # # #
# # # # #
# # # # ]
8896 : :
8897 [ # # ]: 0 : ABI_FREE(work)
8898 : 0 : call sigijtab_free(Sigxij_tab)
8899 [ # # # # : 0 : ABI_FREE(Sigxij_tab)
# # # # #
# # # ]
8900 : :
8901 : : ! Compute QP results. Done usually when gwr_task == G0v i.e. Hartree-Fock with KS states.
8902 [ # # ]: 0 : compute_qp__ = .False.; if (present(compute_qp)) compute_qp__ = compute_qp
8903 [ # # # # ]: 0 : if (compute_qp__ .and. gwr%comm%me == 0) then
8904 : 0 : call write_notations(units)
8905 [ # # ]: 0 : do spin=1,gwr%nsppol
8906 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc
8907 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
8908 : 0 : ydoc = yamldoc_open('GWR_SelfEnergy_ee', width=11, real_fmt='(3f8.3)')
8909 : 0 : call ydoc%add_real1d('kpoint', gwr%kcalc(:, ikcalc))
8910 : 0 : call ydoc%add_int('spin', spin, int_fmt="(i1)")
8911 : 0 : call ydoc%add_int('gwr_scf_iteration', gwr%scf_iteration)
8912 : 0 : call ydoc%add_string('gwr_task', gwr%dtset%gwr_task)
8913 : :
8914 : : call ydoc%add_real('KS_gap', &
8915 : : (gwr%ks_ebands%eig(gwr%ks_vbik(ik_ibz, spin)+1, ik_ibz, spin) - &
8916 : 0 : gwr%ks_ebands%eig(gwr%ks_vbik(ik_ibz, spin), ik_ibz, spin)) * Ha_eV)
8917 : 0 : call ydoc%open_tabular('data') !, tag='SigmaeeData')
8918 : 0 : write(msg, "(a5, *(a9))") "Band", "E0", "SigX", "Occ(E)"
8919 : 0 : call ydoc%add_tabular_line(msg)
8920 : :
8921 [ # # ]: 0 : do band=gwr%bstart_ks(ikcalc, spin), gwr%bstop_ks(ikcalc, spin)
8922 : : write(msg,'(i5, *(f9.3))') &
8923 : 0 : band, & ! Band
8924 : 0 : gwr%ks_ebands%eig(band, ik_ibz, spin) * Ha_eV, & ! E0
8925 [ # # ]: 0 : real(gwr%sigx_mat(band, merge(1, band, gwr%sig_diago), ikcalc, spin), kind=dp) * Ha_eV, & ! SigX
8926 : 0 : gwr%qp_ebands%occ(band, ik_ibz, spin) ! Occ(E)
8927 : 0 : call ydoc%add_tabular_line(msg)
8928 : : end do
8929 : :
8930 [ # # ]: 0 : call ydoc%write_units_and_free([std_out, ab_out])
8931 : : end do ! ikcalc
8932 : : end do ! spin
8933 : : end if
8934 : :
8935 : : 10 continue
8936 : 0 : call cwtime_report(" gwr_build_sigxme:", cpu_all, wall_all, gflops_all)
8937 : 0 : call timab(1920, 2, tsec)
8938 : :
8939 [ # # # # : 0 : end subroutine gwr_build_sigxme
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
8940 : : !!***
8941 : :
8942 : : !----------------------------------------------------------------------
8943 : :
8944 : : !!****f* m_gwr/gwr_get_u_ngfft
8945 : : !! NAME
8946 : : !! gwr_get_u_ngfft
8947 : : !!
8948 : : !! FUNCTION
8949 : : !! Compute FFT mesh from boxcutmin.
8950 : : !!
8951 : : !! INPUTS
8952 : : !!
8953 : : !! OUTPUT
8954 : : !!
8955 : : !! SOURCE
8956 : :
8957 : 0 : subroutine gwr_get_u_ngfft(gwr, boxcutmin, u_ngfft, u_nfft, u_mgfft, u_mpw, gmax)
8958 : :
8959 : : !Arguments ------------------------------------
8960 : : class(gwr_t),intent(in) :: gwr
8961 : : real(dp),intent(in) :: boxcutmin
8962 : : integer,intent(out) :: u_ngfft(18), u_nfft, u_mgfft, u_mpw, gmax(3)
8963 : :
8964 : : !Local variables-------------------------------
8965 : : integer :: ik_bz, npw_, ig, ii
8966 : : real(dp) :: kk_bz(3)
8967 : 0 : integer,allocatable :: gvec_(:,:)
8968 : : ! *************************************************************************
8969 : :
8970 : : ! All MPI procs in gwr%comm execute this part.
8971 : : ! Note the loops over the full BZ to compute u_mpw
8972 : : ! FIXME: umklapp, ecutsigx and q-centered G-sphere
8973 : : ! TODO: Write new routine to compute best FFT mesh for ecut1 + ecut1. See set_mesh from GW code.
8974 : :
8975 [ # # ]: 0 : u_ngfft = gwr%dtset%ngfft ! This to allow users to specify fftalg
8976 : :
8977 : 0 : u_mpw = -1; gmax = 0
8978 [ # # ]: 0 : do ik_bz=1,gwr%nkbz
8979 [ # # ]: 0 : kk_bz = gwr%kbz(:, ik_bz)
8980 [ # # ]: 0 : call get_kg(kk_bz, istwfk1, gwr%dtset%ecutwfn, gwr%cryst%gmet, npw_, gvec_)
8981 : 0 : u_mpw = max(u_mpw, npw_)
8982 : : ! TODO: g0 umklapp here can enter into play gmax may not be large enough!
8983 [ # # ]: 0 : do ig=1,npw_
8984 [ # # ]: 0 : do ii=1,3
8985 : 0 : gmax(ii) = max(gmax(ii), abs(gvec_(ii, ig)))
8986 : : end do
8987 : : end do
8988 [ # # ]: 0 : ABI_FREE(gvec_)
8989 : : call getng(boxcutmin, gwr%dtset%chksymtnons, gwr%dtset%ecutwfn, gwr%cryst%gmet, &
8990 : : kk_bz, me_fft0, u_mgfft, u_nfft, u_ngfft, nproc_fft1, gwr%cryst%nsym, paral_fft0, &
8991 : 0 : gwr%cryst%symrel, gwr%cryst%tnons, gpu_option=gwr%dtset%gpu_option, unit=dev_null)
8992 : : end do
8993 : :
8994 [ # # ]: 0 : end subroutine gwr_get_u_ngfft
8995 : : !!***
8996 : :
8997 : : !----------------------------------------------------------------------
8998 : :
8999 : : !!****f* m_gwr/get_1d_sc_phases
9000 : : !! NAME
9001 : : !! get_1d_sc_phases
9002 : : !!
9003 : : !! FUNCTION
9004 : : !! Compute one-dimensional factors in the supercell.
9005 : : !!
9006 : : !! INPUTS
9007 : : !! sc_shape(3)=Supercell shape.
9008 : : !! nkpt=Number of k-points
9009 : : !! kpts(3,nkpt)=K-points in reduced coordinates.
9010 : : !!
9011 : : !! OUTPUT
9012 : : !! ph1d(maxval(sc_shape), 3, nkpt))
9013 : : !!
9014 : : !! SOURCE
9015 : :
9016 : 0 : subroutine get_1d_sc_phases(sc_shape, nkpt, kpts, ph1d)
9017 : :
9018 : : !Arguments ------------------------------------
9019 : : integer,intent(in) :: sc_shape(3), nkpt
9020 : : real(dp),intent(in) :: kpts(3, nkpt)
9021 : : complex(gwp),allocatable,intent(out) :: ph1d(:,:,:)
9022 : :
9023 : : !Local variables-------------------------------
9024 : : integer :: ikpt, ix, iy, iz
9025 : : real(dp) :: arg, fact, kk(3)
9026 : : ! *************************************************************************
9027 : :
9028 [ # # # # : 0 : ABI_MALLOC(ph1d, (maxval(sc_shape), 3, nkpt))
# # # # #
# # # # #
# # # # #
# ]
9029 : :
9030 [ # # ]: 0 : do ikpt=1,nkpt
9031 [ # # ]: 0 : kk = kpts(:, ikpt)
9032 : 0 : fact = two_pi * kk(1)
9033 [ # # ]: 0 : do ix=0,sc_shape(1) - 1
9034 : 0 : arg = fact * ix
9035 : 0 : ph1d(ix + 1, 1, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9036 : : end do
9037 : 0 : fact = two_pi * kk(2)
9038 [ # # ]: 0 : do iy=0,sc_shape(2) - 1
9039 : 0 : arg = fact * iy
9040 : 0 : ph1d(iy + 1, 2, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9041 : : end do
9042 : 0 : fact = two_pi * kk(3)
9043 [ # # ]: 0 : do iz=0,sc_shape(3) - 1
9044 : 0 : arg = fact * iz
9045 : 0 : ph1d(iz + 1, 3, ikpt) = cmplx(cos(arg), sin(arg), kind=gwp)
9046 : : end do
9047 : : end do ! ikpt
9048 : :
9049 : 0 : end subroutine get_1d_sc_phases
9050 : : !!***
9051 : :
9052 : : !!****f* m_gwr/sc_sum
9053 : : !! NAME
9054 : : !! sc_sum
9055 : : !!
9056 : : !! FUNCTION
9057 : : !! Compute matrix elements of the self-energy Sigma_nk in the supercell at fixed rr.
9058 : : !!
9059 : : !! INPUTS
9060 : : !! sc_shape(3)=Supercell shape.
9061 : : !! uc_ngfft(18)=Info on the FFT mesh in the unit cell.
9062 : : !! nspinor=Number of spinor componenets.
9063 : : !! ph1d=1d phase factors in the supercell
9064 : : !! k_is_gamma=Tru if k is gamma.
9065 : : !! alpha=Coeffient
9066 : : !! sc_data=Values in the supercell
9067 : : !! uc_psi=Wavefunction in the unit cell
9068 : : !!
9069 : : !! OUTPUT
9070 : : !! cout=Partial contribution to integral.
9071 : : !!
9072 : : !! SOURCE
9073 : :
9074 [ # # ]: 0 : subroutine sc_sum(sc_shape, uc_ngfft, ph1d, k_is_gamma, alpha, sc_data, uc_psi, cout)
9075 : :
9076 : : !Arguments ------------------------------------
9077 : : integer,intent(in) :: sc_shape(3), uc_ngfft(18)
9078 : : complex(gwp),intent(in) :: ph1d(maxval(sc_shape), 3)
9079 : : logical,intent(in) :: k_is_gamma
9080 : : complex(gwp),target,intent(in) :: alpha, uc_psi(uc_ngfft(1)*uc_ngfft(2)*uc_ngfft(3))
9081 : : complex(gwp),target,intent(in) :: &
9082 : : sc_data(uc_ngfft(1)*sc_shape(1)*uc_ngfft(2)*sc_shape(2)*uc_ngfft(3)*sc_shape(3))
9083 : : complex(gwp),intent(out) :: cout
9084 : :
9085 : : !Local variables-------------------------------
9086 : : integer :: il1, il2, il3, uc_n1, uc_n2, uc_n3, ix, iy, iz !, idat
9087 : : complex(gwp) :: cphase, phl32, phl3
9088 : 0 : complex(gwp),contiguous,pointer :: uc_psi_ptr(:,:,:), sc_data_ptr(:,:,:,:,:,:)
9089 : : ! *************************************************************************
9090 : :
9091 : 0 : uc_n1 = uc_ngfft(1); uc_n2 = uc_ngfft(2); uc_n3 = uc_ngfft(3)
9092 : :
9093 [ # # ]: 0 : call c_f_pointer(c_loc(uc_psi), uc_psi_ptr, shape=[uc_n1, uc_n2, uc_n3])
9094 : : call c_f_pointer(c_loc(sc_data), sc_data_ptr, &
9095 [ # # ]: 0 : shape=[uc_n1, sc_shape(1), uc_n2, sc_shape(2), uc_n3, sc_shape(3)])
9096 : :
9097 : 0 : cout = zero
9098 : :
9099 [ # # ]: 0 : if (k_is_gamma) then
9100 : : ! Don't need to multiply by e^{ik.L}
9101 [ # # ]: 0 : do il3=1,sc_shape(3)
9102 [ # # ]: 0 : do iz=1,uc_n3
9103 [ # # ]: 0 : do il2=1,sc_shape(2)
9104 [ # # ]: 0 : do iy=1,uc_n2
9105 [ # # ]: 0 : do il1=1,sc_shape(1)
9106 [ # # ]: 0 : do ix=1,uc_n1
9107 : 0 : cout = cout + uc_psi_ptr(ix, iy, iz) * sc_data_ptr(ix, il1, iy, il2, iz, il3)
9108 : : end do
9109 : : end do
9110 : : end do
9111 : : end do
9112 : : end do
9113 : : end do
9114 : :
9115 : : else
9116 : : ! Need to multiply by e^{ik.L}
9117 [ # # ]: 0 : do il3=1,sc_shape(3)
9118 : 0 : phl3 = ph1d(il3, 3)
9119 [ # # ]: 0 : do iz=1,uc_n3
9120 [ # # ]: 0 : do il2=1,sc_shape(2)
9121 : 0 : phl32 = phl3 * ph1d(il2, 2)
9122 [ # # ]: 0 : do iy=1,uc_n2
9123 [ # # ]: 0 : do il1=1,sc_shape(1)
9124 : 0 : cphase = phl32 * ph1d(il1, 1) ! e^{ik.L}
9125 [ # # ]: 0 : do ix=1,uc_n1
9126 : 0 : cout = cout + cphase * uc_psi_ptr(ix, iy, iz) * sc_data_ptr(ix, il1, iy, il2, iz, il3)
9127 : : end do
9128 : : end do
9129 : : end do
9130 : : end do
9131 : : end do
9132 : : end do
9133 : : end if
9134 : :
9135 : 0 : cout = alpha * cout
9136 : :
9137 : 0 : end subroutine sc_sum
9138 : : !!***
9139 : :
9140 : : !!****f* m_gwr/memb_limited_step
9141 : : !! NAME
9142 : : !! memb_limited_step
9143 : : !!
9144 : : !! FUNCTION
9145 : : !! Compute the amount of memory needed to process all the data between start and stop,
9146 : : !! and limits the number of steps to avoid exceeding maxmem_mb.
9147 : : !!
9148 : : !! INPUTS
9149 : : !! start, stop: integer range of indices.
9150 : : !! num_items: number of data items processed per index.
9151 : : !! bsize: size in bytes per data item.
9152 : : !! maxmem_mb: maximum allowed memory usage (in megabytes)
9153 : : !!
9154 : : !! OUTPUT
9155 : : !!
9156 : : !! SOURCE
9157 : :
9158 : : integer pure function memb_limited_step(start, stop, num_items, bsize, maxmem_mb) result(step)
9159 : : integer,intent(in) :: start, stop, num_items, bsize
9160 : : real(dp),intent(in) :: maxmem_mb
9161 : :
9162 : : !Local variables-------------------------------
9163 : : real(dp) :: totmem_mb
9164 : : ! *************************************************************************
9165 : :
9166 : : totmem_mb = one * (stop - start + 1) * num_items * bsize
9167 : : step = stop - start + 1
9168 : : if (totmem_mb > maxmem_mb) step = floor(totmem_mb / maxmem_mb)
9169 : :
9170 : : end function memb_limited_step
9171 : : !!***
9172 : :
9173 : : !----------------------------------------------------------------------
9174 : :
9175 : : !!****f* m_gwr/gwr_gamma_gw
9176 : : !! NAME
9177 : : !! gwr_gamma_gw
9178 : : !!
9179 : : !! FUNCTION
9180 : : !!
9181 : : !! INPUTS
9182 : : !! vpsp(nfft)=local psp (Hartree)
9183 : : !!
9184 : : !! OUTPUT
9185 : : !!
9186 : : !! SOURCE
9187 : :
9188 : 0 : subroutine gwr_gamma_gw(gwr, nfftf, ngfftf, vpsp)
9189 : :
9190 : : use m_gwrdm, only : calc_rdmx,calc_rdmc,natoccs,update_hdr_bst,print_tot_occ,get_chkprdm,&
9191 : : print_chkprdm,change_matrix,print_total_energy,print_band_energies
9192 : : use m_spacepar, only : hartre
9193 : :
9194 : : !Arguments ------------------------------------
9195 : : class(gwr_t),target,intent(inout) :: gwr
9196 : : integer,intent(in) :: nfftf
9197 : : !arrays
9198 : : integer,intent(in) :: ngfftf(18)
9199 : : real(dp),intent(in) :: vpsp(nfftf)
9200 : :
9201 : : !Local variables-------------------------------
9202 : : !scalars
9203 : : integer,parameter :: master = 0, cplex1 = 1, tim_fourdp5 = 5
9204 : : integer :: spin, ikcalc, ik_ibz, ib, ib1, ib2, nkibz, nsppol, mband, ierr, b1gw, b2gw
9205 : : !real(dp) :: cpu, wall, gflops
9206 : : real(dp) :: evext_energy,den_int !,coef_hyb,exc_mbb_energy eh_energy, ekin_energy,
9207 : : real(dp) :: gsqcut,boxcut,ecutf
9208 : : character(len=500) :: msg
9209 : 0 : type(hdr_type) :: Hdr_sigma
9210 : : !arrays
9211 : : integer :: units(2)
9212 : : real(dp),parameter :: k0(3) = zero
9213 : : !real(dp) :: kgw(3) ! kk_ibz(3),
9214 : 0 : real(dp),allocatable :: nat_occs(:,:), gw_rhor(:,:), gw_rhog(:,:), gw_vhartr(:)
9215 : 0 : complex(dp),allocatable :: xrdm_k_full(:,:,:), rdm_k(:,:), pot_k(:,:), nateigv(:,:,:,:), old_ks_purex(:,:), new_hartr(:,:)
9216 : 0 : complex(dp) :: omega_i(gwr%ntau)
9217 : 0 : complex(dp),allocatable :: sigcme_k(:,:,:,:)
9218 : : ! *************************************************************************
9219 : :
9220 : 0 : call gwr%run_g0w0(free_ugb=.False.)
9221 : : ! TODO: Might release some PBLAS memory for W at this point
9222 : :
9223 : : ! This section is copied from m_sigma_driver with small changes in order to intergrate it with the gwr% object.
9224 : : associate (dtset => gwr%dtset, qp_ebands => gwr%qp_ebands, ks_me => gwr%ks_me, psps => gwr%psps, &
9225 : : Wfd_nato_master => gwr%kcalc_wfd, dtfil => gwr%dtfil, cryst => gwr%cryst)
9226 : :
9227 [ # # ]: 0 : units = [std_out, ab_out]
9228 : 0 : nkibz = gwr%nkibz; nsppol = gwr%nsppol; b1gw = gwr%b1gw; b2gw = gwr%b2gw
9229 : : ! Don't take mband from ks_ebands but compute it from gwr%bstop_ks
9230 [ # # # # ]: 0 : mband = maxval(gwr%bstop_ks) !; mband = gwr%ks_ebands%mband
9231 : :
9232 : : ! Note: all subroutines of 70_gw/m_gwrdm.F90 are implemented assuming nsppol == 1
9233 [ # # ]: 0 : ABI_CHECK(dtset%nsppol == 1, "1-RDM GW correction only implemented for restricted closed-shell calculations!")
9234 [ # # ]: 0 : ABI_CHECK(.not. gwr%sig_diago, "sig_diago should be false")
9235 : :
9236 [ # # # # : 0 : ABI_CALLOC(nateigv, (mband, mband, nkibz, nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
9237 [ # # # # : 0 : ABI_CALLOC(nat_occs, (mband, nkibz))
# # # # #
# # # # #
# # # # #
# ]
9238 [ # # # # : 0 : ABI_CALLOC(xrdm_k_full, (b1gw:b2gw, b1gw:b2gw, nkibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
9239 : :
9240 : 0 : write(msg,'(a34,2i9)')' Bands used for the GW 1RDM arrays',b1gw,b2gw
9241 : 0 : call wrtout(units, msg)
9242 : :
9243 [ # # ]: 0 : do ik_ibz=1,nkibz
9244 [ # # ]: 0 : do ib=b1gw,b2gw
9245 : 0 : xrdm_k_full(ib,ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
9246 : : end do
9247 [ # # ]: 0 : do ib=1,mband
9248 : : ! Copy initial occ numbers (in principle 2 or 0 from KS-DFT)
9249 : 0 : nat_occs(ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
9250 : : ! Set to identity matrix
9251 : 0 : nateigv(ib,ib,ik_ibz,1) = cone
9252 : : end do
9253 : : end do
9254 : :
9255 [ # # ]: 0 : omega_i = j_dpc * gwr%iw_mesh
9256 : :
9257 [ # # ]: 0 : do spin=1,gwr%nsppol
9258 [ # # ]: 0 : do ikcalc=1,gwr%nkcalc ! TODO: Should be spin dependent!
9259 : : ! Index of the irred k-point
9260 : 0 : ik_ibz = gwr%kcalc2ibz(ikcalc, 1)
9261 : : !kgw = gwr%kcalc(:, ikcalc)
9262 : : ! min and max band indices for GW corrections (for this k-point)
9263 : 0 : ib1 = gwr%bstart_ks(ikcalc, spin); ib2 = gwr%bstop_ks(ikcalc, spin)
9264 : :
9265 : : ! Compute Sigma_x - Vxc or DELTA Sigma_x - Vxc
9266 : : ! where DELTA Sigma_x = Sigma_x - hyb_parameter Vx^exact for hyb Functionals.
9267 : : ! NB: Only restricted closed-shell calcs are implemented here
9268 [ # # # # : 0 : ABI_CALLOC(pot_k, (ib1:ib2, ib1:ib2))
# # # # #
# # # # #
# # # # #
# # # ]
9269 [ # # # # : 0 : ABI_CALLOC(rdm_k, (ib1:ib2, ib1:ib2))
# # # # #
# # # # #
# # # # ]
9270 [ # # # # ]: 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)
9271 : 0 : call calc_rdmx(ib1, ib2, ik_ibz, pot_k, rdm_k, qp_ebands)
9272 : :
9273 : : ! Update the full 1RDM with the exchange corrected one for this k-point
9274 [ # # # # ]: 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)
9275 : :
9276 : : ! Compute NAT ORBS for exchange corrected 1-RDM
9277 : : ! Only restricted closed-shell calcs
9278 [ # # ]: 0 : do ib=ib1,ib2
9279 : 0 : rdm_k(ib,ib) = rdm_k(ib,ib) + qp_ebands%occ(ib,ik_ibz,1)
9280 : : end do
9281 : 0 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=0)
9282 : :
9283 : : ! ================
9284 : : ! Correlation part
9285 : : ! ================
9286 : : ! TODO
9287 : : !ABI_CALLOC(sigcme_k, (gwr%ntau, ib2-ib1+1, ib2-ib1+1, nsppol*gwr%nsig_ab))
9288 : : !gwr%sigc_iw_mat((gwr%ntau, ib1:, ib1:, nsppol*gwr%nsig_ab))
9289 : 0 : call calc_rdmc(ib1, ib2, ik_ibz, omega_i, gwr%iw_wgs, sigcme_k, qp_ebands, rdm_k)
9290 : : !ABI_FREE(sigcme_k)
9291 : :
9292 : : ! Update the full 1RDM with the GW corrected one for this k-point
9293 : : ! Only restricted closed-shell calcs
9294 [ # # # # ]: 0 : rdm_k(ib1:ib2,ib1:ib2) = xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) + rdm_k(ib1:ib2,ib1:ib2)
9295 : : ! Compute nat orbs and occ numbers at k-point ik_ibz
9296 : 0 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=1)
9297 : :
9298 [ # # ]: 0 : ABI_FREE(pot_k)
9299 [ # # ]: 0 : ABI_FREE(rdm_k)
9300 : : end do ! ikcalc
9301 : : end do ! spin
9302 : :
9303 [ # # # # : 0 : ABI_CALLOC(gw_rhor, (nfftf, dtset%nspden))
# # # # #
# # # # #
# # # # #
# ]
9304 : 0 : call gwr%wfk_hdr%copy(hdr_sigma)
9305 : :
9306 : : ! NRM WARNING: only the master has bands on Wfd_nato_master so it prints everything and computes gw_rhor
9307 : : !
9308 : : ! All procs. update the qp_ebands and the Hdr_sigma
9309 : 0 : call update_hdr_bst(Wfd_nato_master, nat_occs, b1gw, b2gw, qp_ebands, Hdr_sigma, Dtset%ngfft(1:3))
9310 : :
9311 : : ! Compute unit cell (averaged) occ = \sum _k weight_k occ_k
9312 : 0 : call print_tot_occ(qp_ebands)
9313 : :
9314 [ # # ]: 0 : if (gwr%comm%me == master) then
9315 : 0 : call Wfd_nato_master%rotate(cryst, nateigv) !, bmask=bdm_mask) ! Let it use bdm_mask and build NOs
9316 : 0 : call Wfd_nato_master%mkrho(cryst, psps, qp_ebands, ngfftf, nfftf, gw_rhor) ! Construct the density
9317 [ # # ]: 0 : if (dtset%prtwf == 1) then
9318 : : ! Print WFK file, here qp_ebands contains nat. orb. occs.
9319 : 0 : call Wfd_nato_master%write_wfk(Hdr_sigma, qp_ebands, dtfil%fnameabo_wfk, wfknocheck=.True.)
9320 : : end if
9321 [ # # ]: 0 : if (dtset%prtden == 1) then
9322 : : ! Print DEN file
9323 : : call fftdatar_write("density",dtfil%fnameabo_den,dtset%iomode,Hdr_sigma,&
9324 : 0 : Cryst,ngfftf,cplex1,nfftf,dtset%nspden,gw_rhor,gwr%mpi_enreg,ebands=qp_ebands)
9325 : : end if
9326 : : end if
9327 : 0 : call xmpi_bcast(gw_rhor, master, gwr%comm%value, ierr)
9328 : 0 : call hdr_sigma%free()
9329 : :
9330 : : ! Compute energies only if all k-points are available
9331 : : ! We need the hole 1-RDM to build Fock[GW.1RDM]!
9332 [ # # # # : 0 : ABI_CALLOC(old_ks_purex, (b1gw:b2gw, gwr%nkcalc))
# # # # #
# # # # #
# # # # #
# ]
9333 [ # # # # : 0 : ABI_CALLOC(new_hartr, (b1gw:b2gw, gwr%nkcalc))
# # # # #
# # # # #
# # ]
9334 [ # # # # : 0 : ABI_CALLOC(gw_rhog, (2, nfftf))
# # # # #
# # # # #
# # ]
9335 [ # # # # : 0 : ABI_CALLOC(gw_vhartr, (nfftf))
# # # # #
# # # #
# ]
9336 : : !
9337 : : ! A) Compute Evext = int rho(r) vext(r) dr -> simply dot product on the FFT grid
9338 : : ! Only restricted closed-shell calcs
9339 : : !
9340 : 0 : den_int = sum(gw_rhor(:,1)) * cryst%ucvol / nfftf
9341 : 0 : evext_energy = sum(gw_rhor(:,1) * vpsp(:)) * cryst%ucvol / nfftf
9342 : : !
9343 : : ! B) Coulomb <KS_i|Vh[NO]|KS_j>
9344 : : !
9345 : : ! FFT to build gw_rhog
9346 : 0 : call fourdp(1, gw_rhog, gw_rhor(:,1), -1, gwr%mpi_enreg, nfftf, ndat1, ngfftf, tim_fourdp5)
9347 : :
9348 : 0 : ecutf = dtset%ecutwfn
9349 [ # # ]: 0 : if (psps%usepaw == 1) then
9350 : 0 : ecutf = dtset%pawecutdg
9351 : 0 : call wrtout(std_out, ch10//' FFT (fine) grid used in PAW GW update:')
9352 : : end if
9353 : :
9354 : 0 : call getcut(boxcut, ecutf, cryst%gmet, gsqcut, dtset%iboxcut, std_out, k0, ngfftf)
9355 : : call hartre(1, gsqcut, dtset%icutcoul, psps%usepaw, gwr%mpi_enreg, nfftf, ngfftf, dtset%nkpt, dtset%rcut, &
9356 : 0 : gw_rhog, cryst%rprimd, dtset%vcutgeo, gw_vhartr)
9357 : :
9358 : : ! TODO
9359 [ # # ]: 0 : ABI_FREE(nateigv)
9360 [ # # ]: 0 : ABI_FREE(nat_occs)
9361 [ # # ]: 0 : ABI_FREE(xrdm_k_full)
9362 [ # # ]: 0 : ABI_FREE(gw_rhor)
9363 [ # # ]: 0 : ABI_FREE(old_ks_purex)
9364 [ # # ]: 0 : ABI_FREE(new_hartr)
9365 [ # # ]: 0 : ABI_FREE(gw_rhog)
9366 [ # # ]: 0 : ABI_FREE(gw_vhartr)
9367 : : end associate
9368 : :
9369 [ # # # # : 0 : end subroutine gwr_gamma_gw
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
9370 : : !!***
9371 : :
9372 [ # # # # : 0 : end module m_gwr
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
9373 : : !!***
|
