Line data Source code
1 : !!****m* ABINIT/m_dvdb
2 : !! NAME
3 : !! m_dvdb
4 : !!
5 : !! FUNCTION
6 : !! Objects and methods to extract data from the DVDB file.
7 : !! The DVDB file is Fortran binary file with a collection of DFPT potentials
8 : !! associated to the different phonon perturbations (idir, ipert, qpt).
9 : !! DVDB files are produced with the `mrgdv` utility and used in the EPH code
10 : !! to compute the matrix elements: <k+q| dvscf_{idir, ipert, qpt} |k>.
11 : !!
12 : !! COPYRIGHT
13 : !! Copyright (C) 2009-2026 ABINIT group (MG, GA)
14 : !! This file is distributed under the terms of the
15 : !! GNU General Public License, see ~abinit/COPYING
16 : !! or http://www.gnu.org/copyleft/gpl.txt .
17 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
18 : !!
19 : !! TODO
20 : !! - Check spin and MPI-parallelism. Can we distribute nsppol?
21 : !!
22 : !! SOURCE
23 :
24 : #if defined HAVE_CONFIG_H
25 : #include "config.h"
26 : #endif
27 :
28 : #include "abi_common.h"
29 :
30 : module m_dvdb
31 :
32 : use defs_basis
33 : use m_abicore
34 : use m_errors
35 : use m_xmpi
36 : use m_nctk
37 : use m_sort
38 : use netcdf
39 : use m_hdr
40 : use m_ddb
41 : use m_ddb_hdr
42 : use m_dtset
43 : use m_krank
44 : use m_xcdata
45 :
46 : use defs_abitypes, only : mpi_type
47 : use m_fstrings, only : strcat, sjoin, itoa, ktoa, ltoa, ftoa, yesno, endswith
48 : use m_time, only : cwtime, cwtime_report, sec2str, timab
49 : use m_io_tools, only : open_file, file_exists, delete_file
50 : use m_numeric_tools, only : wrap2_pmhalf, vdiff_t, l2int
51 : use m_matrix, only : mati3inv, matr3inv
52 : use m_symtk, only : littlegroup_q
53 : use m_geometry, only : littlegroup_pert, irreducible_set_pert, mkradim, xcart2xred
54 : use m_dynmat, only : canat9, get_bigbox_and_weights
55 : use m_copy, only : alloc_copy
56 : use m_mpinfo, only : destroy_mpi_enreg, initmpi_seq
57 : use m_ioarr, only : read_rhor
58 : use m_fftcore, only : ngfft_seq
59 : use m_fft_mesh, only : rotate_fft_mesh, times_eigr, times_eikr, ig2gfft, get_gfft, calc_ceikr, calc_eigr
60 : use m_fft, only : fourdp, zerosym
61 : use m_crystal, only : crystal_t
62 : use m_kpts, only : kpts_ibz_from_kptrlatt, listkk, kpts_map, kpts_timrev_from_kptopt
63 : use m_spacepar, only : symrhg, setsym
64 : use m_fourier_interpol,only : fourier_interpol_seq
65 : use m_pawrhoij, only : pawrhoij_type
66 : use m_dfpt_mkvxc, only : dfpt_mkvxc
67 :
68 : implicit none
69 :
70 : private
71 : !!***
72 :
73 : ! Version 1: header + vscf1(r)
74 : ! Version 2: header + vscf1(r) + record with rhog1(G=0)
75 : integer,public,parameter :: dvdb_last_version = 2
76 :
77 : integer,private,parameter :: DVDB_NOMODE = 0
78 : integer,private,parameter :: DVDB_READMODE = 1
79 : integer,private,parameter :: DVDB_WRITEMODE = 2
80 :
81 : !----------------------------------------------------------------------
82 :
83 : !!****t* m_dvdb/dvdb_t
84 : !! NAME
85 : !! dvdb_t
86 : !!
87 : !! FUNCTION
88 : !! Database of DFPT results. The database contains `numv1` perturbations
89 : !! and the corresponding first order local potentials in real space on the FFT mesh.
90 : !! Provides methods to Fourier interpolate the potentials including the
91 : !! treatment of long-range behaviour in the FT interpolation in polar semiconductors.
92 : !! Note that one can have different FFT meshes for the different perturbations.
93 : !!
94 : !! NOTES
95 : !! natom, nspden, nspinor, and usepaw are global variables in the sense that it is not possible to add
96 : !! new entries to the database if these dimensions differ from the global ones.
97 : !!
98 : !! SOURCE
99 :
100 : type,public :: dvdb_t
101 :
102 : integer :: fh
103 : ! file handle
104 : ! Fortran unit number if iomode==IO_MODE_FORTRAN
105 : ! MPI file handler if iomode==IO_MODE_MPI
106 :
107 : integer :: fform
108 : ! File format
109 :
110 : integer :: comm
111 : ! Global MPI communicator used for IO.
112 :
113 : integer :: gpu_option = 0
114 : ! Input variable
115 :
116 : integer :: comm_rpt = xmpi_comm_self
117 : ! MPI communicator used to distributed R-points.
118 :
119 : integer :: nprocs_rpt = 1
120 : ! Number of cpus for parallelism over R-points.
121 :
122 : integer :: me_rpt = 0
123 : ! My rank in comm_rpt.
124 :
125 : integer :: comm_pert = xmpi_comm_self
126 : ! MPI communicator for parallelism over atomic perturbations.
127 :
128 : integer :: nprocs_pert = 1
129 : ! Number of cpus for parallelism over atomic perturbations.
130 :
131 : integer :: me_pert = 0
132 : ! My rank in comm over atomic perturbations.
133 :
134 : integer :: my_npert
135 : ! Number of atomic perturbations or phonon modes treated by this MPI rank
136 :
137 : integer,allocatable :: my_pinfo(:,:)
138 : ! my_pinfo(3, my_npert)
139 : ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
140 : ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
141 : ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
142 :
143 : integer,allocatable :: pert_table(:,:)
144 : ! pert_table(2, natom3)
145 : ! pert_table(1, npert): rank of the processor treating this atomic perturbation.
146 : ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
147 :
148 : integer :: version
149 : ! File format version read from file.
150 :
151 : integer :: iomode = IO_MODE_FORTRAN
152 : ! Method used to access the DVDB file:
153 : ! IO_MODE_FORTRAN for usual Fortran IO routines
154 : ! IO_MODE_MPI if MPI/IO routines.
155 :
156 : integer :: rw_mode = DVDB_NOMODE
157 : ! (Read|Write) mode
158 :
159 : integer :: current_fpos
160 : ! The current position of the file pointer used for sequential access with Fortran-IO
161 :
162 : integer :: numv1
163 : ! Number of v1 potentials present in file.
164 :
165 : integer :: nqpt
166 : ! Number of q-points (usually the IBZ)
167 :
168 : integer :: natom
169 : ! Number of atoms
170 :
171 : integer :: natom3
172 : ! 3 * natom
173 :
174 : integer :: nspden
175 : ! Number of spin density components
176 :
177 : integer :: nsppol
178 : ! Number of spin polarizations.
179 :
180 : integer :: nspinor
181 : ! Number of spinor components.
182 :
183 : integer :: usepaw
184 : ! 1 if PAW calculation, 0 otherwise
185 :
186 : integer :: mpert
187 : ! Maximum number of perturbations
188 :
189 : integer :: my_nrpt = 0
190 : ! Number of real space points used for Fourier interpolation treated by this MPI rank.
191 :
192 : integer :: nrtot = 0
193 : ! Total Number of real space points used for Fourier interpolation.
194 :
195 : integer :: prtvol = 0
196 : ! Verbosity level
197 :
198 : integer :: brav = 1
199 : ! Option for the sampling of the BZ (input variable, the same option is stored in ifc_t)
200 :
201 : real(dp) :: qdamp = 0.1_dp
202 : ! Exponential damping used in the Fourier transform of the long-range potentials
203 : ! Use negative value to deactivate damping.
204 :
205 : logical :: debug = .False.
206 : ! Debug flag
207 :
208 : logical :: has_dielt = .False.
209 : ! True if the dielectric tensor is available.
210 :
211 : logical :: has_zeff = .False.
212 : ! True if Born effective charges are available.
213 :
214 : logical :: has_quadrupoles = .False.
215 : ! True if quadrupoles are available.
216 :
217 : logical :: has_efield = .False.
218 : ! True if electric field perturbations are available.
219 :
220 : integer :: add_lr = 1
221 : ! Flag defining the treatment of the long range component in the interpolation of the DFPT potentials.
222 : !
223 : ! 0 --> No treatment
224 : ! 1 --> Remove LR model when building W(R,r). Add it back after W(R,r) --> v(q) Fourier interpolation
225 : ! This is the standard approach for polar materials.
226 : ! -1 --> Remove LR model when building W(R,r). DO NOT reintroduce it after Fourier interpolation.
227 : ! This procedure should be used for homopolar materials with (spurious) non-zero BECS
228 : ! in order to remove the long range component from the DFPT potentials.
229 : ! 2 --> Similar to 1 but include only the dipole part. Q* are set to zero even if the DDB file contains them.
230 : ! 4,5,6,7 --> Use model for the LR part only.
231 : ! 4: Use dipole + quadrupole part (if available)
232 : ! 5: Use dipole part only.
233 : ! 6: Use quadrupole part only.
234 : ! 7: Use electric field only.
235 :
236 : integer :: symv1 = 0
237 : ! Flag for the symmetrization of v1 potentials.
238 : ! 0 --> No symmetrization
239 : ! 1 --> Symmetrization in real space
240 : ! 2 --> Call v1phq_complete after interpolation of the potentials in ftinterp_qpt
241 :
242 : integer :: rspace_cell = 0
243 : ! Flag defining the algorithm for generating the list of R-points and the weights used to go from W(r,R) to v1scf(r,q)
244 : ! 0 --> Use unit supercell for R space. All weights set to 1.
245 : ! 1 --> Use Wigner-Seitz super cell and atom dependent weights (same algo as for dynmat)
246 :
247 : character(len=fnlen) :: path = ABI_NOFILE
248 : ! File name of the DVDB file.
249 :
250 : real(dp) :: dielt(3, 3) = zero
251 : ! Dielectric tensor in Cartesian coordinates.
252 : ! Used to deal with the long-range component in the Fourier interpolation.
253 :
254 : integer,allocatable :: pos_dpq(:,:,:)
255 : ! pos_dpq(3, mpert, nqpt)
256 : ! The position of the (idir, ipert, iqpt) potential in the file (in units of POT1 blocks)
257 : ! 0 if the corresponding entry is not available.
258 :
259 : integer,allocatable :: cplex_v1(:)
260 : ! cplex_v1(numv1)
261 : ! The value of cplex for each v1(cplex*nfft, nspden) potential
262 : ! 2 if the potential is complex, 1 if real (q==Gamma)
263 :
264 : integer,allocatable :: symq_table(:,:,:,:)
265 : ! symq(4,2,nsym,nqpt)
266 : ! Table computed by littlegroup_q for all q-points found in the DVDB.
267 : ! three first numbers define the G vector;
268 : ! fourth number is zero if the q-vector is not preserved, is 1 otherwise
269 : ! second index is one without time-reversal symmetry, two with time-reversal symmetry
270 :
271 : integer :: ngfft(18) = -1
272 : ! Info on the FFT to be used for the potentials.
273 :
274 : integer,allocatable :: iv_pinfoq(:,:)
275 : !iv_pinfoq(4, numv1)
276 : ! iv_pinfoq(1, iv1) gives the `idir` index of the iv1 potential
277 : ! iv_pinfoq(2, iv1) gives the `ipert` index of the iv1 potential
278 : ! iv_pinfoq(3, iv1) gives `pertcase`=idir + (ipert-1)*3
279 : ! iv_pinfoq(4, iv1) gives the `iqpt` index of the iv1 potential
280 :
281 : integer,allocatable :: ngfft3_v1(:,:)
282 : ! ngfft3_v1(3, numv1)
283 : ! The FFT mesh used for each v1 potential (the one used to store data in the file).
284 :
285 : integer,allocatable :: my_irpt2tot(:)
286 : ! Mapping my_irpt index to full list of R-points.
287 :
288 : real(dp),allocatable :: qpts(:,:)
289 : ! qpts(3,nqpt)
290 : ! List of q-points in reduced coordinates.
291 :
292 : real(dp),allocatable :: my_rpt(:,:)
293 : ! my_rpt(3, my_nrpt)
294 : ! Real space points for Fourier interpolation (MPI distributed if nprocs_rpt > 1)
295 :
296 : real(kind=sp),allocatable :: wsr(:,:,:,:,:)
297 : ! DFPT potential in the real space supercell representation.
298 : ! wsr(1, my_nrpt, nfft, nspden, my_npert)
299 : ! NOTE kind=sp to save memory as much as possible.
300 : !
301 : ! TODO: Use MPI shared window
302 :
303 : real(dp),allocatable :: my_wratm(:,:)
304 : ! my_wratm(my_nrpt, minatom:maxatom)
305 : ! Weight for the FT associated to the atom and the R vector.
306 :
307 : real(dp),allocatable :: rhog1_g0(:,:)
308 : ! rhog1_g0(2, numv1)
309 : ! G=0 component of rhog1. Used to treat the long range component in (polar) semiconductors.
310 : ! NB: For the time being, this quantity is not used. Long range term is treated with Verdi's model and quadrupoles
311 :
312 : real(dp),allocatable :: zeff(:,:,:)
313 : ! zeff(3, 3, natom)
314 : ! Effective charges on each atom, versus electric field and atomic displacement in Cartesian coordinates.
315 : ! Used to deal with the long-range component in the Fourier interpolation.
316 :
317 : real(dp),allocatable :: zeff_raw(:,:,:)
318 : ! Raw Effective charges i.e. values before enforcing the charge-neutrality condition.
319 :
320 : real(dp),allocatable :: qstar(:,:,:,:)
321 : ! qstar(3, 3, 3, natom)
322 : ! dynamical quadrupole in Cartesian coordinates.
323 : ! First two dimension are associated to the q-point, then atomic perturbation in Cart coords.
324 :
325 : real(dp),allocatable :: v1r_efield(:,:,:)
326 : ! v1r_efield(nfft, 3, nspden)
327 : ! First order potentials due to the three different directions of the electric field perturbation.
328 : ! Potentials are in r-space
329 :
330 : type(crystal_t) :: cryst
331 : ! Crystalline structure read from the the DVDB file.
332 :
333 : type(hdr_type) :: hdr_ref
334 : ! Header associated to the first potential in the DVDB. Used to backspace.
335 : ! Gives the number of Fortran records required to backspace the header
336 : ! Assume all headers with same fform and same basic dimensions e.g. npsp
337 :
338 : type(mpi_type) :: mpi_enreg
339 : ! Internal object used to call fourdp and other GS/DFPT routines
340 :
341 : contains
342 :
343 : procedure :: init => dvdb_init !
344 : ! Create new object.
345 :
346 : procedure :: open_read => dvdb_open_read
347 : ! Open the file in read-only mode.
348 :
349 : procedure :: close => dvdb_close
350 : ! Close the DVDB file.
351 :
352 : procedure :: free => dvdb_free
353 : ! Release the memory allocated and close the file.
354 :
355 : procedure :: has_fields => dvdb_has_fields
356 : ! Check whether the DVDB database stores first-order potentials or first-order densities
357 :
358 : procedure :: print => dvdb_print
359 : ! Print info on object.
360 :
361 : procedure :: findq => dvdb_findq
362 : ! Returns the index of the q-point.
363 :
364 : procedure :: find_qpts => dvdb_find_qpts
365 : ! Returns the index of a list of q-points.
366 :
367 : procedure :: need_ftinterp => dvdb_need_ftinterp
368 : ! Check whether input list of q-points requires Fourier interpolation.
369 :
370 : procedure :: set_pert_distrib => dvdb_set_pert_distrib
371 : ! Activate parallelism over perturbations
372 :
373 : procedure :: read_onev1 => dvdb_read_onev1
374 : ! Read and return the DFPT potential for given (idir, ipert, iqpt).
375 :
376 : procedure :: readsym_allv1 => dvdb_readsym_allv1
377 : ! Read and return all the 3*natom DFPT potentials (either from file or symmetrized)
378 :
379 : procedure :: readsym_qbz => dvdb_readsym_qbz
380 : ! Reconstruct the DFPT potential for a q-point in the BZ from its symmetrical image in the IBZ.
381 :
382 : procedure :: read_vxc1_qbz => dvdb_read_vxc1_qbz
383 : ! Compute the first-order change of exchange-correlation potential
384 : ! for a q-point in the BZ starting from its symmetrical image in the IBZ.
385 :
386 : procedure :: list_perts => dvdb_list_perts
387 : ! Check if all the (phonon) perts are available taking into account symmetries.
388 :
389 : procedure :: ftinterp_setup => dvdb_ftinterp_setup
390 : ! Prepare the internal tables for Fourier interpolation.
391 :
392 : procedure :: get_maxw => dvdb_get_maxw
393 : ! Compute max_r |W(R,r)|
394 :
395 : procedure :: ftinterp_qpt => dvdb_ftinterp_qpt
396 : ! Fourier interpolation of potentials for given q-point
397 :
398 : procedure :: get_ftqbz => dvdb_get_ftqbz
399 : ! Retrieve Fourier interpolated potential for a given q-point in the BZ.
400 : ! Use cache to reduce number of slow FTs.
401 :
402 : procedure :: get_vxc1_ftqbz => dvdb_get_vxc1_ftqbz
403 : ! Retrieve Fourier interpolated first-order change of exchange-correlation
404 : ! potential v1xc for a given q-point in the BZ.
405 :
406 : procedure :: get_v1r_long_range => dvdb_get_v1r_long_range
407 : ! Long-range part of the phonon potential
408 :
409 : procedure :: load_ddb => dvdb_load_ddb
410 : ! Load information about the Born effective charges and dielectric tensor from a DDB file
411 :
412 : procedure :: interpolate_v1scf => dvdb_interpolate_v1scf
413 : ! Fourier interpolation of the phonon potentials
414 :
415 : procedure :: get_v1scf_rpt => dvdb_get_v1scf_rpt
416 : ! Fourier transform of the phonon potential from qpt to R
417 :
418 : procedure :: get_v1scf_qpt => dvdb_get_v1scf_qpt
419 : ! Fourier transform of the phonon potential from R to qpt
420 :
421 : procedure :: load_efield => dvdb_load_efield
422 : ! Load the potential due to the Electric field.
423 :
424 : procedure :: interpolate_and_write => dvdb_interpolate_and_write
425 : ! Interpolate the phonon potentials and write a new DVDB file.
426 :
427 : procedure :: qdownsample => dvdb_qdownsample
428 : ! Downsample the q-mesh. Produce new DVDB file
429 :
430 : procedure :: write_v1qavg => dvdb_write_v1qavg
431 : ! Computes the average over the unit cell of the periodic part of the DFPT potentials
432 : ! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
433 :
434 : end type dvdb_t
435 :
436 : ! Utilities
437 : public :: dvdb_merge_files ! Merge a list of POT1 files.
438 :
439 : ! Debugging tools. These functions are interfaced with mrgdv. Use mrgdv --help to access the documentation
440 : public :: dvdb_test_v1rsym ! Check symmetries in real-space of the DFPT potentials.
441 : public :: dvdb_test_v1complete ! Test the symmetrization of the DFPT potentials.
442 : public :: dvdb_test_ftinterp ! Test the Fourier interpolation of DFPT potentials.
443 : public :: dvdb_test_symcheck ! Test cross-q-point symmetry consistency of the FT interpolation.
444 : public :: dvdb_test_symcheck_native ! Same test but on two literal, non-interpolated q-points.
445 :
446 : !----------------------------------------------------------------------
447 :
448 80 : integer,private,parameter :: pot1_fforms(2) = [109, 111], den1_fforms(1) = [54]
449 :
450 : contains
451 : !!***
452 :
453 : !----------------------------------------------------------------------
454 :
455 : !!****f* m_dvdb/dvdb_init
456 : !! NAME
457 : !! dvdb_init
458 : !!
459 : !! FUNCTION
460 : !! Initialize the object from file. This is a COLLECTIVE procedure that must be called
461 : !! by each process in the MPI communicator comm.
462 : !! We don't pass dtset because in mrgdvd, we need to build an instance and dtset is not available there.
463 : !!
464 : !! INPUTS
465 : !! path=DVDB Filename.
466 : !! comm=MPI communicator.
467 : !!
468 : !! SOURCE
469 :
470 116 : subroutine dvdb_init(new, path, gpu_option, comm)
471 :
472 : !Arguments ------------------------------------
473 : !scalars
474 : class(dvdb_t),intent(out) :: new
475 : character(len=*),intent(in) :: path
476 : integer,intent(in) :: gpu_option, comm
477 :
478 : !Local variables-------------------------------
479 : !scalars
480 : integer,parameter :: master = 0
481 : integer :: iv1,ii,ierr,unt,fform,nqpt,iq,iq_found,cplex,trev_q
482 : integer :: idir,ipert,my_rank, nprocs, iatom, pertcase
483 : real(dp) :: cpu, wall, gflops
484 : character(len=500) :: msg
485 116 : type(hdr_type) :: hdr1
486 : !arrays
487 116 : integer,allocatable :: tmp_pos(:,:,:)
488 : real(dp) :: tsec(2)
489 116 : real(dp),allocatable :: tmp_qpts(:,:)
490 : !************************************************************************
491 :
492 : ! Keep track of total time spent.
493 116 : call timab(1800, 1, tsec)
494 :
495 116 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
496 116 : new%path = path; new%comm = comm; new%iomode = IO_MODE_FORTRAN
497 116 : new%gpu_option = gpu_option
498 :
499 116 : call wrtout(std_out, sjoin("- Analyzing DVDB file: ", path, "..."))
500 116 : call cwtime(cpu, wall, gflops, "start")
501 :
502 : ! Master reads the header and builds useful tables
503 116 : if (my_rank == master) then
504 :
505 116 : if (open_file(path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
506 0 : ABI_ERROR(msg)
507 : end if
508 116 : read(unt, err=10, iomsg=msg) new%version
509 116 : read(unt, err=10, iomsg=msg) new%numv1
510 :
511 : ! Get important dimensions from the first header and rewind the file.
512 116 : call new%hdr_ref%fort_read(unt, new%fform)
513 116 : if (dvdb_check_fform(new%fform, "read_dvdb", msg) /= 0) then
514 0 : ABI_ERROR(sjoin("While reading:", path, ch10, msg))
515 : end if
516 116 : if (new%debug) call new%hdr_ref%echo(new%fform, 4, unit=std_out)
517 :
518 116 : rewind(unt)
519 116 : read(unt, err=10, iomsg=msg)
520 116 : read(unt, err=10, iomsg=msg)
521 :
522 : ! The code below must be executed by the other procs if MPI.
523 116 : new%natom = new%hdr_ref%natom
524 116 : new%natom3 = 3 * new%hdr_ref%natom
525 116 : new%nspden = new%hdr_ref%nspden
526 116 : new%nsppol = new%hdr_ref%nsppol
527 116 : new%nspinor = new%hdr_ref%nspinor
528 116 : new%usepaw = new%hdr_ref%usepaw
529 116 : ABI_CHECK(new%usepaw == 0, "PAW not yet supported")
530 :
531 : ! TODO: Write function to return mpert from natom!
532 116 : new%mpert = new%natom + 6
533 :
534 348 : ABI_MALLOC(tmp_qpts, (3, new%numv1))
535 464 : ABI_MALLOC(tmp_pos, (3, new%mpert, new%numv1))
536 67979 : tmp_pos = 0
537 :
538 348 : ABI_MALLOC(new%cplex_v1, (new%numv1))
539 348 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
540 348 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
541 348 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
542 :
543 116 : nqpt = 0
544 2195 : do iv1=1,new%numv1
545 2079 : call hdr1%fort_read(unt, fform)
546 2079 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
547 0 : ABI_ERROR(sjoin("While reading hdr of v1 potential of index:", itoa(iv1), ch10, msg))
548 : end if
549 :
550 : ! Save cplex and FFT mesh associated to this perturbation.
551 2079 : cplex = 2; if (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14) cplex = 1
552 2079 : new%cplex_v1(iv1) = cplex
553 8316 : new%ngfft3_v1(:, iv1) = hdr1%ngfft(:3)
554 :
555 : ! Skip the records with v1.
556 4158 : do ii=1,hdr1%nspden
557 4158 : read(unt, err=10, iomsg=msg)
558 : end do
559 : ! Read rhog1_g0 (if available)
560 6237 : new%rhog1_g0(:, iv1) = zero
561 2079 : if (new%version > 1) read(unt, err=10, iomsg=msg) new%rhog1_g0(:, iv1)
562 :
563 : ! Check whether this q-point is already in the list.
564 : ! Assume qpoints are grouped so invert the iq loop for better performance.
565 : ! This is gonna be slow if lots of q-points and perturbations are not grouped.
566 2079 : iq_found = 0
567 4629 : do iq=nqpt,1,-1
568 9353 : if (all(abs(hdr1%qptn - tmp_qpts(:,iq)) < tol14)) then
569 : iq_found = iq; exit
570 : end if
571 : end do
572 :
573 : ! pertcase = idir + (ipert-1)*3 where ipert=iatom in the interesting cases
574 2079 : idir = mod(hdr1%pertcase-1, 3) + 1
575 2079 : ipert = (hdr1%pertcase - idir) / 3 + 1
576 :
577 : ! Increment nqpt is new q-points and update tmp_pos
578 2079 : if (iq_found == 0) then
579 682 : nqpt = nqpt + 1
580 2728 : tmp_qpts(:, nqpt) = hdr1%qptn
581 : iq_found = nqpt
582 : end if
583 2079 : tmp_pos(idir, ipert, iq_found) = iv1
584 10395 : new%iv_pinfoq(:,iv1) = [idir, ipert, hdr1%pertcase, iq_found]
585 :
586 2195 : call hdr1%free()
587 : end do
588 :
589 : ! Allocate arrays with correct nqpt dimension
590 116 : new%nqpt = nqpt
591 348 : ABI_MALLOC(new%qpts, (3, nqpt))
592 2960 : new%qpts = tmp_qpts(:,1:nqpt)
593 116 : ABI_FREE(tmp_qpts)
594 :
595 464 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, nqpt))
596 22342 : new%pos_dpq = tmp_pos(:, :, 1:nqpt)
597 116 : ABI_FREE(tmp_pos)
598 :
599 116 : close(unt)
600 : end if
601 :
602 : ! Master broadcasts data.
603 116 : if (xmpi_comm_size(comm) > 1) then
604 0 : call xmpi_bcast(new%version, master, comm, ierr)
605 0 : call xmpi_bcast(new%fform, master, comm, ierr)
606 0 : call xmpi_bcast(new%numv1, master, comm, ierr)
607 0 : call xmpi_bcast(new%nqpt, master, comm, ierr)
608 0 : call new%hdr_ref%bcast(master, my_rank, comm)
609 :
610 0 : new%natom = new%hdr_ref%natom
611 0 : new%natom3 = 3 * new%hdr_ref%natom
612 0 : new%nspden = new%hdr_ref%nspden
613 0 : new%nsppol = new%hdr_ref%nsppol
614 0 : new%nspinor = new%hdr_ref%nspinor
615 0 : new%usepaw = new%hdr_ref%usepaw
616 0 : new%mpert = new%natom + 6
617 :
618 0 : if (my_rank /= master) then
619 0 : ABI_MALLOC(new%cplex_v1, (new%numv1))
620 0 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
621 0 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
622 0 : ABI_MALLOC(new%qpts, (3, new%nqpt))
623 0 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, new%nqpt))
624 0 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
625 : end if
626 :
627 0 : call xmpi_bcast(new%cplex_v1, master, comm, ierr)
628 0 : call xmpi_bcast(new%ngfft3_v1, master, comm, ierr)
629 0 : call xmpi_bcast(new%iv_pinfoq, master, comm, ierr)
630 0 : call xmpi_bcast(new%qpts, master, comm, ierr)
631 0 : call xmpi_bcast(new%pos_dpq, master, comm, ierr)
632 0 : call xmpi_bcast(new%rhog1_g0, master, comm, ierr)
633 : end if
634 :
635 : ! Init crystal_t from the hdr read from file.
636 116 : new%cryst = new%hdr_ref%get_crystal()
637 116 : new%my_npert = new%natom3
638 :
639 : ! Init tables assuming no MPI distribution of perturbations.
640 348 : ABI_MALLOC(new%my_pinfo, (3, new%natom3))
641 348 : ABI_MALLOC(new%pert_table, (2, new%natom3))
642 337 : do iatom=1,new%natom
643 1000 : do idir=1,3
644 663 : pertcase = idir + (iatom-1) * 3
645 2652 : new%my_pinfo(:, pertcase) = [idir, iatom, pertcase]
646 2210 : new%pert_table(:, pertcase) = [xmpi_comm_self, pertcase]
647 : end do
648 : end do
649 :
650 : ! Init Born effective charges
651 3221 : ABI_CALLOC(new%zeff, (3, 3, new%natom))
652 3105 : ABI_CALLOC(new%zeff_raw, (3, 3, new%natom))
653 9188 : ABI_CALLOC(new%qstar, (3, 3, 3, new%natom))
654 :
655 : ! Internal MPI_type needed for calling fourdp!
656 116 : call initmpi_seq(new%mpi_enreg)
657 :
658 : ! Precompute symq_table for all q-points in the DVDB.
659 313282 : ABI_ICALLOC(new%symq_table, (4, 2, new%cryst%nsym, new%nqpt))
660 798 : do iq=1,new%nqpt
661 682 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
662 : call littlegroup_q(new%cryst%nsym, new%qpts(:,iq), new%symq_table(:,:,:,iq), &
663 798 : new%cryst%symrec, new%cryst%symafm, trev_q, prtvol=0)
664 : end do
665 116 : call xmpi_sum(new%symq_table, comm, ierr)
666 :
667 116 : call cwtime_report("- dvdb_init", cpu, wall, gflops)
668 116 : call timab(1800, 2, tsec)
669 :
670 116 : return
671 :
672 : ! Handle Fortran IO error
673 : 10 continue
674 0 : ABI_ERROR(sjoin("Error while reading:", path, ch10, msg))
675 :
676 464 : end subroutine dvdb_init
677 : !!***
678 :
679 : !----------------------------------------------------------------------
680 :
681 : !!****f* m_dvdb/dvdb_open_read
682 : !! NAME
683 : !! dvdb_open_read
684 : !!
685 : !! FUNCTION
686 : !! Open the file in read-only mode.
687 : !!
688 : !! INPUTS
689 : !! ngfft(18)=Info on the FFT mesh used for the DFPT potentials. Note that ngfft
690 : !! is the mesh used by the parent. In principle, it can differ from the one
691 : !! found in the file. In this case a Fourier interpolation is required.
692 : !! comm=MPI communicator
693 : !!
694 : !! SOURCE
695 :
696 95 : subroutine dvdb_open_read(db, ngfft, comm)
697 :
698 : !Arguments ------------------------------------
699 : !scalars
700 : integer,intent(in) :: comm
701 : class(dvdb_t),intent(inout) :: db
702 : !arrays
703 : integer,intent(in) :: ngfft(18)
704 :
705 : !Local variables-------------------------------
706 : !scalars
707 : integer :: nprocs, unt, ii
708 : character(len=500) :: msg
709 : !arrays
710 : character(len=fnlen) :: pot_paths(3)
711 : !************************************************************************
712 :
713 95 : if (db%rw_mode /= DVDB_NOMODE) then
714 0 : ABI_ERROR("DVDB should be in DVDB_NOMODE when open_read is called.")
715 : end if
716 95 : db%rw_mode = DVDB_READMODE
717 :
718 95 : nprocs = xmpi_comm_size(comm)
719 :
720 : ! Initialize tables to call fourdp in sequential
721 1805 : db%ngfft = ngfft
722 95 : call db%mpi_enreg%distribfft%init_seq('c', ngfft(2), ngfft(3), 'all')
723 95 : call db%mpi_enreg%distribfft%init_seq('f', ngfft(2), ngfft(3), 'all')
724 :
725 : ! Open the file.
726 190 : select case (db%iomode)
727 : case (IO_MODE_FORTRAN)
728 95 : if (open_file(db%path, msg, newunit=db%fh, form="unformatted", status="old", action="read") /= 0) then
729 0 : ABI_ERROR(msg)
730 : end if
731 95 : read(db%fh, err=10, iomsg=msg)
732 95 : read(db%fh, err=10, iomsg=msg)
733 95 : db%current_fpos = 1
734 :
735 : case (IO_MODE_MPI)
736 0 : ABI_ERROR("MPI not coded")
737 :
738 : case default
739 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
740 : end select
741 :
742 : ! Read potentials induced by electric fields
743 : ! This requires ngfft so for the time being we call it here.
744 : ! I should try to add efield perturbations to DVDB but then I also have to handle symmetrization wrt idir!
745 95 : if (file_exists("__EFIELD_POTS__")) then
746 0 : call wrtout(std_out, " Reading Efield potentials from EFIELD_POTS")
747 0 : if (open_file("__EFIELD_POTS__", msg, newunit=unt, form="formatted") /= 0) then
748 0 : ABI_ERROR(msg)
749 : end if
750 0 : do ii=1,3
751 0 : read(unt, "(a)") pot_paths(ii)
752 : end do
753 0 : close(unt)
754 0 : call db%load_efield(pot_paths, comm)
755 : end if
756 :
757 95 : return
758 :
759 : ! Handle Fortran IO error
760 : 10 continue
761 0 : ABI_ERROR(sjoin("Error while reading", db%path, ch10, msg))
762 :
763 : end subroutine dvdb_open_read
764 : !!***
765 :
766 : !----------------------------------------------------------------------
767 :
768 : !!****f* m_dvdb/dvdb_close
769 : !! NAME
770 : !! dvdb_close
771 : !!
772 : !! FUNCTION
773 : !! Close the file
774 : !!
775 : !! SOURCE
776 :
777 95 : subroutine dvdb_close(db)
778 :
779 : !Arguments ------------------------------------
780 : class(dvdb_t),intent(inout) :: db
781 : !************************************************************************
782 :
783 190 : select case (db%iomode)
784 : case (IO_MODE_FORTRAN)
785 95 : close(db%fh)
786 : case default
787 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
788 : end select
789 :
790 95 : db%rw_mode = DVDB_NOMODE
791 :
792 95 : end subroutine dvdb_close
793 : !!***
794 :
795 : !----------------------------------------------------------------------
796 :
797 : !!****f* m_dvdb/dvdb_free
798 : !! NAME
799 : !! dvdb_free
800 : !!
801 : !! FUNCTION
802 : !! Close the file and release the memory allocated.
803 : !!
804 : !! SOURCE
805 :
806 235 : subroutine dvdb_free(db)
807 :
808 : !Arguments ------------------------------------
809 : class(dvdb_t),target,intent(inout) :: db
810 :
811 : !Local variables-------------------------------
812 235 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
813 : !************************************************************************
814 :
815 : ! integer arrays
816 116 : ABI_SFREE(db%my_pinfo)
817 235 : ABI_SFREE(db%pert_table)
818 235 : ABI_SFREE(db%pos_dpq)
819 235 : ABI_SFREE(db%cplex_v1)
820 235 : ABI_SFREE(db%symq_table)
821 235 : ABI_SFREE(db%iv_pinfoq)
822 235 : ABI_SFREE(db%ngfft3_v1)
823 235 : ABI_SFREE(db%my_irpt2tot)
824 :
825 : ! real arrays
826 235 : ABI_SFREE(db%qpts)
827 235 : ABI_SFREE(db%my_rpt)
828 :
829 235 : ABI_SFREE(db%my_wratm)
830 235 : ABI_SFREE(db%rhog1_g0)
831 235 : ABI_SFREE(db%zeff)
832 235 : ABI_SFREE(db%zeff_raw)
833 235 : ABI_SFREE(db%qstar)
834 235 : ABI_SFREE(db%v1r_efield)
835 :
836 : ! Deallocate GPU arrays
837 235 : wsr_ptr => db%wsr
838 : #ifdef HAVE_OPENMP_OFFLOAD
839 : !$OMP TARGET EXIT DATA MAP(delete:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
840 : #endif
841 235 : ABI_SFREE(db%wsr)
842 :
843 : ! types
844 235 : call db%hdr_ref%free()
845 235 : call db%cryst%free()
846 235 : call destroy_mpi_enreg(db%mpi_enreg)
847 :
848 : ! Close the file but only if we have performed IO.
849 235 : if (db%rw_mode == DVDB_NOMODE) return
850 95 : call db%close()
851 :
852 235 : end subroutine dvdb_free
853 : !!***
854 :
855 : !!****f* m_dvdb/dvdb_has_fields
856 : !! NAME
857 : !! dvdb_has_fields
858 : !!
859 : !! FUNCTION
860 : !! Check whether the database stores first-order potentials (pot1) or first-order densities (den1)
861 : !!
862 : !! SOURCE
863 :
864 182 : logical function dvdb_has_fields(db, choice, msg) result(ok)
865 :
866 : !Arguments ------------------------------------
867 : class(dvdb_t),intent(in) :: db
868 : character(len=*),intent(in) :: choice
869 : character(len=*),intent(out) :: msg
870 : !************************************************************************
871 :
872 : ! See m_hdr, more specifically all_abifiles for the correspondence between data and fform.
873 182 : msg = ""
874 176 : select case (choice)
875 : case ("pot1")
876 176 : ok = any(db%fform == pot1_fforms)
877 176 : if (.not. ok) msg = sjoin("expecting first order potentials with headform in", ltoa(pot1_fforms), "but got", itoa(db%fform))
878 : case ("den1")
879 6 : ok = any(db%fform == den1_fforms)
880 6 : if (.not. ok) msg = sjoin("expecting first order densities with headform in", ltoa(den1_fforms), "but got", itoa(db%fform))
881 : case default
882 182 : ABI_ERROR(sjoin("Invalid choice:", choice))
883 : end select
884 :
885 182 : end function dvdb_has_fields
886 : !!***
887 :
888 : !----------------------------------------------------------------------
889 :
890 : !!****f* m_dvdb/dvdb_print
891 : !! NAME
892 : !! dvdb_print
893 : !!
894 : !! FUNCTION
895 : !! Print info on the object.
896 : !!
897 : !! INPUTS
898 : !! units=Unit numbers for output.
899 : !! header=Header string
900 : !! prtvol=verbosity level
901 : !!
902 : !! SOURCE
903 :
904 380 : subroutine dvdb_print(db, units, header, prtvol)
905 :
906 : !Arguments ------------------------------------
907 : !scalars
908 : class(dvdb_t),intent(in) :: db
909 : integer,intent(in) :: units(:), prtvol
910 : character(len=*),intent(in) :: header
911 :
912 : !Local variables-------------------------------
913 : integer :: iv1,iq,idir,ipert,iatom
914 : character(len=5000) :: msg
915 : ! *************************************************************************
916 :
917 190 : if (len_trim(header) == 0) then
918 85 : msg = ' ==== Info on the dvdb% object ==== '
919 : else
920 105 : msg = ' ==== '//trim(adjustl(header))//' ==== '
921 : end if
922 190 : call wrtout(units, msg)
923 :
924 190 : call wrtout(units, sjoin(" DVDB version:", itoa(db%version)))
925 190 : call wrtout(units, sjoin(" File path:", db%path))
926 190 : call wrtout(units, sjoin(" Number of v1scf potentials:", itoa(db%numv1)))
927 190 : call wrtout(units, sjoin(" Number of q-points in DVDB: ", itoa(db%nqpt)))
928 190 : call wrtout(units, sjoin("-P Number of CPUs for parallelism over perturbations:", itoa(db%nprocs_pert)))
929 190 : call wrtout(units, sjoin("-P Number of perturbations treated by this CPU:", itoa(db%my_npert)))
930 190 : call wrtout(units, sjoin(" Option for symmetrization of v1scf(r):", itoa(db%symv1)))
931 190 : call wrtout(units, " List of q-points: min(10, nqpt)")
932 1238 : do iq=1,min(db%nqpt, 10)
933 1238 : call wrtout(units, sjoin("[", itoa(iq),"]", ktoa(db%qpts(:,iq))))
934 : end do
935 190 : if (db%nqpt > 10) call wrtout(units, "...")
936 :
937 190 : call wrtout(units, sjoin(" Have dielectric tensor:", yesno(db%has_dielt)))
938 190 : call wrtout(units, sjoin(" Have Born effective charges:", yesno(db%has_zeff)))
939 190 : call wrtout(units, sjoin(" Have quadrupoles:", yesno(db%has_quadrupoles)))
940 190 : call wrtout(units, sjoin(" Have electric field:", yesno(db%has_efield)))
941 190 : call wrtout(units, sjoin(" Treatment of long-range part in V1scf (add_lr):", itoa(db%add_lr)))
942 190 : write(msg,"(a, f6.1)")" Damping factor for Gaussian filter (qdamp):", db%qdamp
943 190 : call wrtout(units, msg)
944 :
945 190 : if (db%has_dielt) then
946 82 : write(msg, '(a,3(a,3es16.6))') ' Dielectric tensor in Cart coords:', ch10, &
947 82 : db%dielt(1,1), db%dielt(1,2), db%dielt(1,3), ch10, &
948 82 : db%dielt(2,1), db%dielt(2,2), db%dielt(2,3), ch10, &
949 164 : db%dielt(3,1), db%dielt(3,2), db%dielt(3,3)
950 82 : call wrtout(units, msg)
951 : end if
952 :
953 190 : if (db%has_zeff) then
954 82 : call print_zeff(units, db%cryst, db%zeff, title=' Born effectives charges in Cart coords:')
955 : !call print_zeff(units, db%zeff_raw, db%cryst, title=' Born effectives charges before chneut: ')
956 : end if
957 :
958 190 : if (db%has_quadrupoles) then
959 2 : call wrtout(units, ' Dynamical Quadrupoles in Cartesian Coordinates:')
960 6 : do iatom=1,db%natom
961 18 : do idir=1,3
962 12 : write(msg,'(2(a,i0), 3(a,3es16.6))')' Q* for iatom: ', iatom, ' idir: ', idir, ch10, &
963 12 : db%qstar(1,1,idir,iatom), db%qstar(1,2,idir,iatom), db%qstar(1,3,idir,iatom), ch10, &
964 12 : db%qstar(2,1,idir,iatom), db%qstar(2,2,idir,iatom), db%qstar(2,3,idir,iatom), ch10, &
965 24 : db%qstar(3,1,idir,iatom), db%qstar(3,2,idir,iatom), db%qstar(3,3,idir,iatom)
966 16 : call wrtout(units, msg)
967 : end do
968 : end do
969 :
970 2 : call wrtout(units, " Dynamical quadrupoles sum rule: \sum_\iatom Q_{beta,gamma}{iatom,idir} = 0 for nonpolar materials")
971 8 : do idir=1,3
972 6 : write(msg,'(a,i0,a,3(a,3es16.6))')" Sum rule for idir: ", idir, ch10, ch10, &
973 42 : sum(db%qstar(1,1,idir,:)), sum(db%qstar(1,2,idir,:)), sum(db%qstar(1,3,idir,:)), ch10, &
974 42 : sum(db%qstar(2,1,idir,:)), sum(db%qstar(2,2,idir,:)), sum(db%qstar(2,3,idir,:)), ch10, &
975 48 : sum(db%qstar(3,1,idir,:)), sum(db%qstar(3,2,idir,:)), sum(db%qstar(3,3,idir,:))
976 8 : call wrtout(units, msg)
977 : end do
978 : end if
979 :
980 380 : if (prtvol > 0) then
981 43 : call db%cryst%print(header="Crystal structure in DVDB file")
982 43 : call wrtout(units, "FFT mesh for potentials on file:")
983 43 : call wrtout(units, "q-point, idir, ipert, ngfft(:3)")
984 517 : do iv1=1,db%numv1
985 474 : idir = db%iv_pinfoq(1, iv1); ipert = db%iv_pinfoq(2, iv1); iq = db%iv_pinfoq(4, iv1)
986 517 : call wrtout(units, sjoin(ktoa(db%qpts(:,iq)), itoa(idir), itoa(ipert), ltoa(db%ngfft3_v1(:,iv1))))
987 : end do
988 : end if
989 :
990 : contains
991 :
992 82 : subroutine print_zeff(units, cryst, zeff, title)
993 :
994 : !Arguments ------------------------------------
995 : !scalars
996 : integer,intent(in) :: units(:)
997 : type(crystal_t),intent(in) :: cryst
998 : real(dp),intent(in) :: zeff(3,3,cryst%natom)
999 : character(len=*),optional,intent(in) :: title
1000 :
1001 : !Local variables-------------------------------
1002 : integer :: iatom
1003 : character(len=5000) :: msg
1004 : ! *************************************************************************
1005 :
1006 82 : if (present(title)) then
1007 82 : call wrtout(units, trim(title))
1008 : else
1009 0 : call wrtout(units, ' Born effectives charges in Cartesian coordinates: ')
1010 : end if
1011 :
1012 246 : do iatom=1,cryst%natom
1013 164 : write(msg, '(a,i0,1x,2a,3(a,3es16.6),a)')' iatom: ', iatom, ", type: ", cryst%symbol_iatom(iatom), ch10, &
1014 164 : zeff(1,1,iatom), zeff(1,2,iatom), zeff(1,3,iatom), ch10, &
1015 164 : zeff(2,1,iatom), zeff(2,2,iatom), zeff(2,3,iatom), ch10, &
1016 328 : zeff(3,1,iatom), zeff(3,2,iatom), zeff(3,3,iatom), ch10
1017 246 : call wrtout(units, msg)
1018 : end do
1019 :
1020 82 : write(msg,'(2a,3(a,3es16.6),a)')ch10,' Fulfillment of charge neutrality, \sum_{atom} Z^*_{ij,atom} = 0', ch10, &
1021 738 : sum(zeff(1,1,:)), sum(zeff(1,2,:)), sum(zeff(1,3,:)), ch10, &
1022 738 : sum(zeff(2,1,:)), sum(zeff(2,2,:)), sum(zeff(2,3,:)), ch10, &
1023 820 : sum(zeff(3,1,:)), sum(zeff(3,2,:)), sum(zeff(3,3,:)), ch10
1024 82 : call wrtout(units, msg)
1025 :
1026 82 : end subroutine print_zeff
1027 :
1028 : end subroutine dvdb_print
1029 : !!***
1030 :
1031 : !----------------------------------------------------------------------
1032 :
1033 : !!****f* m_dvdb/dvdb_get_pinfo
1034 : !! NAME
1035 : !! dvdb_get_pinfo
1036 : !!
1037 : !! FUNCTION
1038 : !! Return information on the perturbations available for a given q-point index.
1039 : !!
1040 : !! INPUTS
1041 : !! iqpt=Index of the q-point
1042 : !!
1043 : !! OUTPUT
1044 : !! nperts=Number of perturbations found.
1045 : !! cplex=2 if potentials are complex, 1 for real
1046 : !! pinfo(3,3*db%mpert)=Array with info on the perturbations present on file
1047 : !! pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
1048 : !! pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
1049 : !! pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
1050 : !!
1051 : !! SOURCE
1052 :
1053 1718 : integer function dvdb_get_pinfo(db, iqpt, cplex, pinfo) result(nperts)
1054 :
1055 : !Arguments ------------------------------------
1056 : !scalars
1057 : type(dvdb_t),intent(in) :: db
1058 : integer,intent(in) :: iqpt
1059 : integer,intent(out) :: cplex
1060 : !arrays
1061 : integer,intent(out) :: pinfo(3,3*db%mpert)
1062 :
1063 : !Local variables-------------------------------
1064 : !scalars
1065 : integer :: idir,ipert,iv1
1066 : ! *************************************************************************
1067 :
1068 : ! Get the number of perturbations computed for this iqpt
1069 165374 : pinfo = 0; cplex = 0; nperts = 0
1070 5048 : do ipert=1,db%natom ! selects atomic perturbations only.
1071 15038 : do idir=1,3
1072 9990 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1073 13320 : if (iv1 /= 0) then
1074 5416 : nperts = nperts + 1
1075 21664 : pinfo(:, nperts) = [idir, ipert, idir + (ipert-1)*3]
1076 5416 : if (cplex == 0) cplex = db%cplex_v1(iv1)
1077 5416 : ABI_CHECK_IEQ(cplex, db%cplex_v1(iv1), "cplex should be constant for given q!")
1078 : end if
1079 : end do
1080 : end do
1081 :
1082 1718 : end function dvdb_get_pinfo
1083 : !!***
1084 :
1085 : !----------------------------------------------------------------------
1086 :
1087 : !!****f* m_dvdb/dvdb_read_onev1
1088 : !! NAME
1089 : !! dvdb_read_onev1
1090 : !!
1091 : !! FUNCTION
1092 : !! Read the DFPT potential for the specified (idir, ipert, iqpt).
1093 : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1094 : !! get the index from the q-point in reduced coordinates.
1095 : !!
1096 : !! INPUTS
1097 : !! idir=Direction of the perturbation
1098 : !! ipert=Perturbation type.
1099 : !! iqpt=Index of the q-point in dvdb%qpts
1100 : !! cplex=1 if real, 2 if complex potentials.
1101 : !! nfft=Number of fft-points treated by this processors
1102 : !! ngfft(18)=contain all needed information about 3D FFT.
1103 : !!
1104 : !! OUTPUT
1105 : !! ierr=Non-zero if error.
1106 : !! v1scf(cplex*nfft, nspden)=DFT potential associated to (idir, ipert, iqpt).
1107 : !! msg=String with error message if ierr /= 0.
1108 : !!
1109 : !! SOURCE
1110 :
1111 5360 : integer function dvdb_read_onev1(db, idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) result(ierr)
1112 :
1113 : !Arguments ------------------------------------
1114 : !scalars
1115 : integer,intent(in) :: idir,ipert,iqpt,cplex,nfft
1116 : character(len=*),intent(out) :: msg
1117 : class(dvdb_t),intent(inout) :: db
1118 : !arrays
1119 : integer,intent(in) :: ngfft(18)
1120 : real(dp),intent(out) :: v1scf(cplex*nfft,db%nspden)
1121 :
1122 : !Local variables-------------------------------
1123 : !scalars
1124 : integer,save :: enough = 0
1125 : integer :: iv1,ispden,nfftot_file,nfftot_out,ifft
1126 : !arrays
1127 : integer :: ngfft_in(18),ngfft_out(18)
1128 5360 : real(dp),allocatable :: v1r_file(:,:)
1129 : ! *************************************************************************
1130 :
1131 : ! Consistency checks
1132 5360 : ierr = 1
1133 5360 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1134 :
1135 5360 : if (iv1 == 0) then
1136 0 : write(msg,"(3(a,i0))")"Cannot find idir: ",idir,", ipert: ",ipert,", iqpt:",iqpt
1137 0 : return
1138 : end if
1139 :
1140 5360 : if (cplex /= db%cplex_v1(iv1)) then
1141 0 : write(msg,"(2(a,i0))")"Wrong cplex. Expecting: ",db%cplex_v1(iv1),", received: ",cplex
1142 0 : return
1143 : end if
1144 :
1145 : ! Find (idir, ipert, iqpt) and skip the header.
1146 5360 : call dvdb_seek(db, idir, ipert, iqpt)
1147 5360 : ierr = my_hdr_skip(db%fh, idir, ipert, db%qpts(:,iqpt), msg)
1148 5360 : if (ierr /= 0) then
1149 0 : msg = sjoin("In my_hdr_skip:", msg)
1150 0 : return
1151 : end if
1152 :
1153 : ! Read v1 from file.
1154 21440 : nfftot_out = product(ngfft(:3)); nfftot_file = product(db%ngfft3_v1(:3, iv1))
1155 :
1156 16244 : if (all(ngfft(:3) == db%ngfft3_v1(:3, iv1))) then
1157 7256 : do ispden=1,db%nspden
1158 7256 : read(db%fh, err=10, iomsg=msg) (v1scf(ifft, ispden), ifft=1,cplex*nfftot_file)
1159 : end do
1160 : else
1161 : ! The FFT mesh used in the caller differ from the one found in the DVDB --> Fourier interpolation
1162 1732 : if (enough == 0) ABI_COMMENT("Performing FFT interpolation of DFPT potentials as input ngfft differs from ngfft_file.")
1163 1732 : enough = enough + 1
1164 6928 : ABI_MALLOC(v1r_file, (cplex*nfftot_file, db%nspden))
1165 3464 : do ispden=1,db%nspden
1166 3464 : read(db%fh, err=10, iomsg=msg) (v1r_file(ifft, ispden), ifft=1,cplex*nfftot_file)
1167 : end do
1168 :
1169 : ! Call fourier_interpol_seq to get v1scf on the ngfft mesh.
1170 1732 : ngfft_in = ngfft; ngfft_out = ngfft
1171 12124 : ngfft_in(1:3) = db%ngfft3_v1(1:3, iv1); ngfft_out(1:3) = ngfft(1:3)
1172 12124 : ngfft_in(4:6) = ngfft_in(1:3); ngfft_out(4:6) = ngfft_out(1:3)
1173 36372 : ngfft_in(9:18) = 0; ngfft_out(9:18) = 0
1174 1732 : ngfft_in(10) = 1; ngfft_out(10) = 1
1175 :
1176 1732 : call fourier_interpol_seq(cplex, db%nspden, nfftot_file, ngfft_in, nfft, ngfft, v1r_file, v1scf)
1177 1732 : ABI_FREE(v1r_file)
1178 : end if
1179 :
1180 : ! Skip record with rhog1_g0 (if present)
1181 5360 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
1182 :
1183 5360 : db%current_fpos = db%current_fpos + 1
1184 : !write(std_out, *)"incr current_fpos", db%current_fpos
1185 :
1186 5360 : return
1187 :
1188 : ! Handle Fortran IO error
1189 : 10 continue
1190 0 : ierr = 1
1191 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
1192 :
1193 10720 : end function dvdb_read_onev1
1194 : !!***
1195 :
1196 : !----------------------------------------------------------------------
1197 :
1198 : !!****f* m_dvdb/dvdb_readsym_allv1
1199 : !! NAME
1200 : !! dvdb_readsym_allv1
1201 : !!
1202 : !! FUNCTION
1203 : !! Read all 3*natom DFPT potentials for the given iqpt (only atomic perturbations).
1204 : !!
1205 : !! The routine will:
1206 : !!
1207 : !! 1) Reconstruct the potentials by symmetry if the DVDB contains less than 3*natom potentials.
1208 : !! 2) interpolate the data if the input FFT mesh defined by `ngfft` differs
1209 : !! from the one used to store data in the file.
1210 : !!
1211 : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1212 : !! get the index from the q-point in reduced coordinates.
1213 : !!
1214 : !! INPUTS
1215 : !! iqpt=Index of the q-point in dvdb%qpts
1216 : !! nfft=Number of fft-points treated by this processors
1217 : !! ngfft(18)=contain all needed information about 3D FFT
1218 : !! comm=MPI communicator
1219 : !!
1220 : !! OUTPUT
1221 : !! cplex=1 if real, 2 if complex.
1222 : !! v1scf(cplex, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
1223 : !!
1224 : !! SOURCE
1225 :
1226 1660 : subroutine dvdb_readsym_allv1(db, iqpt, cplex, nfft, ngfft, v1scf, comm)
1227 :
1228 : !Arguments ------------------------------------
1229 : !scalars
1230 : integer,intent(in) :: iqpt,nfft,comm
1231 : integer,intent(out) :: cplex
1232 : class(dvdb_t),intent(inout) :: db
1233 : !arrays
1234 : integer,intent(in) :: ngfft(18)
1235 : real(dp) ABI_ASYNC ,allocatable,intent(out) :: v1scf(:,:,:,:)
1236 :
1237 : !Local variables-------------------------------
1238 : !scalars
1239 : integer,parameter :: master=0
1240 : integer :: ipc,npc,idir,ipert,pcase,my_rank,nproc,ierr,mu
1241 : character(len=500) :: msg
1242 : !arrays
1243 1660 : integer :: pinfo(3,3*db%mpert),pflag(3, db%natom)
1244 : real(dp) :: tsec(2)
1245 1660 : integer,allocatable :: requests(:)
1246 : ! *************************************************************************
1247 :
1248 : ! Keep track of total time spent.
1249 1660 : call timab(1805, 1, tsec)
1250 :
1251 1660 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
1252 :
1253 : ! Get number of perturbations computed for this iqpt as well as cplex.
1254 1660 : npc = dvdb_get_pinfo(db, iqpt, cplex, pinfo)
1255 1660 : ABI_CHECK(npc /= 0, "npc == 0!")
1256 :
1257 9960 : ABI_MALLOC_OR_DIE(v1scf, (cplex, nfft, db%nspden, 3*db%natom), ierr)
1258 :
1259 : ! Master read all available perturbations and broadcasts data (non-blocking to overlap IO and MPI)
1260 4980 : ABI_MALLOC(requests, (npc))
1261 :
1262 6964 : do ipc=1,npc
1263 5304 : idir = pinfo(1,ipc); ipert = pinfo(2,ipc); pcase = pinfo(3, ipc)
1264 5304 : if (my_rank == master) then
1265 5304 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf(:,:,:,pcase), msg) /= 0) then
1266 0 : ABI_ERROR(msg)
1267 : end if
1268 : end if
1269 6964 : if (nproc > 1) call xmpi_ibcast(v1scf(:,:,:,pcase), master, comm, requests(ipc), ierr)
1270 : end do
1271 :
1272 1660 : if (nproc > 1) call xmpi_waitall(requests, ierr)
1273 1660 : ABI_FREE(requests)
1274 :
1275 : ! Return if all perts are available.
1276 1660 : if (npc == 3*db%natom) then
1277 380 : if (db%symv1==1) then
1278 16 : if (db%debug) write(std_out,*)"Potentials are available but will call v1phq_symmetrize because of symv1"
1279 112 : do mu=1,db%natom3
1280 : !if (mod(mu, nproc) /= my_rank) cycle ! MPI parallelism.
1281 96 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1282 : call v1phq_symmetrize(db%cryst,idir,ipert,db%symq_table(:,:,:,iqpt),ngfft,cplex,nfft,&
1283 112 : db%nspden,db%nsppol,db%mpi_enreg,v1scf(:,:,:,mu))
1284 : !call MPI_Ibcast(void *buffer, int count, MPI_Datatype datatype, int root, MPI_Comm comm, MPI_Request *request)
1285 : end do
1286 : end if
1287 380 : if (db%debug) write(std_out,*)"All perts available. Returning"
1288 380 : call timab(1805, 2, tsec)
1289 : return
1290 : end if
1291 :
1292 : ! Perturbation are missing and we have to reconstruct them by symmetry.
1293 : ! This is the common case when DFPT calculations are done for independent perturbations only.
1294 1280 : if (db%debug) write(std_out,*)sjoin("Will use symmetries to recostruct:", itoa(3*db%natom - npc), "perturbations")
1295 :
1296 : ! 0 if pert is not available.
1297 : ! 1 if pert is on file.
1298 : ! 2 if pert has been reconstructed by symmetry.
1299 11240 : pflag = 0
1300 4364 : do ipc=1,npc
1301 4364 : pflag(pinfo(1,ipc), pinfo(2,ipc)) = 1
1302 : end do
1303 :
1304 1280 : call v1phq_complete(db%cryst,db%qpts(:,iqpt),ngfft,cplex,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,v1scf)
1305 :
1306 1280 : call timab(1805, 2, tsec)
1307 :
1308 : end subroutine dvdb_readsym_allv1
1309 : !!***
1310 :
1311 : !----------------------------------------------------------------------
1312 :
1313 : !!****f* m_dvdb/dvdb_readsym_qbz
1314 : !! NAME
1315 : !! dvdb_readsym_qbz
1316 : !!
1317 : !! FUNCTION
1318 : !! This is the MAIN ENTRY POINT for client code.
1319 : !! Reconstruct the DFPT potential for a q-point in the BZ starting
1320 : !! from its symmetrical image in the IBZ.
1321 : !!
1322 : !! INPUTS
1323 : !! cryst<crystal_t>=crystal structure parameters
1324 : !! qbz(3)=Q-point in BZ.
1325 : !! qbz2db(6)=Symmetry mapping qbz --> DVDB qpoints produced using the SYMREC convention.
1326 : !! Note that qbz2db(1) should give the index in the set of q-points in the DVDB
1327 : !! that is not necessarily ORDERED as the IBZ computed by the Abinit routines.
1328 : !! nfft=Number of fft-points treated by this processors
1329 : !! ngfft(18)=contain all needed information about 3D FFT
1330 : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations.
1331 : !!
1332 : !! OUTPUT
1333 : !! cplex=1 if real, 2 if complex.
1334 : !! v1scf(cplex, nfft, nspden, db%my_npert)= v1scf potentials on the real-space FFT mesh
1335 : !! for the db%my_npert perturbations treated by this MPI rank.
1336 : !!
1337 : !! SOURCE
1338 :
1339 1285 : subroutine dvdb_readsym_qbz(db, cryst, qbz, qbz2db, cplex, nfft, ngfft, v1scf, comm)
1340 :
1341 : !Arguments ------------------------------------
1342 : !scalars
1343 : class(dvdb_t),intent(inout) :: db
1344 : integer,intent(in) :: nfft,comm
1345 : integer,intent(out) :: cplex
1346 : type(crystal_t),intent(in) :: cryst
1347 : !arrays
1348 : real(dp),intent(in) :: qbz(3)
1349 : integer,intent(in) :: ngfft(18), qbz2db(6)
1350 : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
1351 :
1352 : !Local variables-------------------------------
1353 : !scalars
1354 : integer :: db_iqpt, itimrev, isym, imyp
1355 : logical :: isirr_q
1356 : !arrays
1357 : integer :: g0q(3)
1358 : real(dp) :: tsec(2)
1359 1285 : real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:)
1360 : ! *************************************************************************
1361 :
1362 : ABI_UNUSED(qbz(1))
1363 :
1364 : ! Keep track of total time spent.
1365 1285 : call timab(1802, 1, tsec)
1366 :
1367 1285 : db_iqpt = qbz2db(1)
1368 :
1369 : ! IS(q_dvdb) + g0q = q_bz
1370 5140 : isym = qbz2db(2); itimrev = qbz2db(6) + 1; g0q = qbz2db(3:5)
1371 4731 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
1372 :
1373 : ! Read the dvscf potentials in the IBZ for all 3*natom perturbations.
1374 : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
1375 1285 : call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm)
1376 :
1377 1285 : if (.not. isirr_q) then
1378 : ! Must rotate db_iqpt to get potential for qpoint in the BZ.
1379 : ! Be careful with the shape of output v1scf because the routine returns db%my_npert potentials.
1380 :
1381 702 : if (db%my_npert == db%natom3) then
1382 4212 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3))
1383 154012518 : work = v1scf
1384 : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1385 702 : db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert)
1386 702 : ABI_FREE(work)
1387 :
1388 : else
1389 : ! Parallelism over perturbations.
1390 0 : ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3))
1391 :
1392 : ! All 3 natom have been read in v1scf by dvdb_readsym_allv1
1393 : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1394 0 : db%nspden, db%mpi_enreg, v1scf, work2, db%comm_pert)
1395 :
1396 : ! Reallocate v1scf with my_npert and extract data from work2.
1397 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
1398 0 : do imyp=1,db%my_npert
1399 0 : v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp))
1400 : end do
1401 0 : ABI_FREE(work2)
1402 : end if
1403 :
1404 : else
1405 : ! Handle potentials read from file in case of parallelism over perturbations.
1406 583 : if (db%my_npert /= db%natom3) then
1407 0 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%my_npert))
1408 0 : do imyp=1,db%my_npert
1409 0 : work(:,:,:,imyp) = v1scf(:,:,:,db%my_pinfo(3, imyp))
1410 : end do
1411 :
1412 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
1413 0 : v1scf = work
1414 0 : ABI_FREE(work)
1415 : end if
1416 : end if ! not isirr_q
1417 :
1418 1285 : call timab(1802, 2, tsec)
1419 :
1420 1285 : end subroutine dvdb_readsym_qbz
1421 : !!***
1422 :
1423 : !----------------------------------------------------------------------
1424 :
1425 : !!****f* m_dvdb/dvdb_read_vxc1_qbz
1426 : !! NAME
1427 : !! dvdb_read_vxc1_qbz
1428 : !!
1429 : !! FUNCTION
1430 : !! Compute the first-order change of the exchange-correlation potential
1431 : !! for a q-point in the BZ starting from its symmetrical image in the IBZ.
1432 : !!
1433 : !! INPUTS
1434 : !! cryst<crystal_t>=crystal structure parameters
1435 : !! dtset<dataset_type>=All input variables for this dataset
1436 : !! qbz(3)=Q-point in BZ.
1437 : !! mapc_qq2dvdb(6)=Symmetry mapping qbz, see m_kpts.f for a description
1438 : !! nfft=Number of fft-points treated by this processors
1439 : !! ngfft(18)=contain all needed information about 3D FFT
1440 : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
1441 : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
1442 : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
1443 : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
1444 : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
1445 : !!
1446 : !! OUTPUT
1447 : !! drho_cplex=1 if real, 2 if complex.
1448 : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
1449 : !! for the db%my_npert perturbations treated by this MPI rank.
1450 : !!
1451 : !! SOURCE
1452 :
1453 80 : subroutine dvdb_read_vxc1_qbz(db, dtset, cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, nkxc, kxc, &
1454 : vxc1, non_magnetic_xc, usexcnhat, comm)
1455 :
1456 : !Arguments ------------------------------------
1457 : !scalars
1458 : class(dvdb_t),intent(inout) :: db
1459 : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
1460 : integer,intent(out) :: drho_cplex
1461 : real(dp),intent(in) :: qbz(3)
1462 : type(dataset_type),intent(in) :: dtset
1463 : type(crystal_t),intent(in) :: cryst
1464 : logical,intent(in) :: non_magnetic_xc
1465 : !arrays
1466 : integer,intent(in) :: ngfft(18), mapc_qq2dvdb(6)
1467 : real(dp),intent(in) :: kxc(nfft,nkxc)
1468 : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
1469 :
1470 : !Local variables-------------------------------
1471 : !scalars
1472 : integer :: option,imyp
1473 : !arrays
1474 80 : real(dp),allocatable :: rho1(:,:,:,:)
1475 : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
1476 : ! *************************************************************************
1477 :
1478 : ! Get rho1(cplex, nfftf, nspden, my_npert))
1479 80 : call db%readsym_qbz(cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, rho1, comm)
1480 :
1481 80 : option=2 ! if 2, treat only density change
1482 480 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
1483 560 : do imyp=1,db%my_npert
1484 : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
1485 : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp), &
1486 560 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
1487 : end do
1488 80 : ABI_FREE(rho1)
1489 :
1490 80 : end subroutine dvdb_read_vxc1_qbz
1491 : !!***
1492 :
1493 : !----------------------------------------------------------------------
1494 :
1495 : !!****f* m_dvdb/v1phq_complete
1496 : !! NAME
1497 : !! v1phq_complete
1498 : !!
1499 : !! FUNCTION
1500 : !! Use the symmetries of the little group of the q-point to reconstruct
1501 : !! the first order potentials starting from an initial irreducible set.
1502 : !!
1503 : !! INPUTS
1504 : !! cryst<crystal_t>=crystal structure parameters
1505 : !! qpt(3)=q-point in reduced coordinates.
1506 : !! ngfft(18)=Info of FFT grid.
1507 : !! cplex=1 if real potentials (qpt==gamma), 2 if complex
1508 : !! nfft=(effective) number of FFT grid points (for this proc).
1509 : !! nspden=number of spin-density components
1510 : !! nsppol=Number of independent spin polarizations
1511 : !! mpi_enreg=information about MPI parallelization
1512 : !! symv1=If 1, the new potentials are symmetrized using the set of symmetries that leaves the
1513 : !! perturbation invariant.
1514 : !!
1515 : !! SIDE EFFECTS
1516 : !! pflag(3,natom)= For each atomic perturbation:
1517 : !! 0 if pert is not available. 1 if pert is available. 2 if pert has been reconstructed by symmetry.
1518 : !! Initialized by the caller. Changed in output.
1519 : !! v1scf(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials.
1520 : !! in input: filled with the irreducible potentials (corresponding pflag set to 1)
1521 : !! output: Contains full set of perturbations.
1522 : !!
1523 : !! SOURCE
1524 :
1525 1280 : subroutine v1phq_complete(cryst,qpt,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,symv1,pflag,v1scf)
1526 :
1527 : !Arguments ------------------------------------
1528 : !scalars
1529 : integer,intent(in) :: cplex,nfft,nspden,nsppol
1530 : integer,intent(in) :: symv1
1531 : type(crystal_t),intent(in) :: cryst
1532 : type(MPI_type),intent(in) :: mpi_enreg
1533 : !arrays
1534 : integer,intent(in) :: ngfft(18)
1535 : integer,intent(inout) :: pflag(3, cryst%natom)
1536 : real(dp),intent(in) :: qpt(3)
1537 : real(dp),intent(inout) :: v1scf(cplex*nfft,nspden,3*cryst%natom)
1538 :
1539 : !Local variables-------------------------------
1540 : !scalars
1541 : integer,parameter :: syuse0=0,rfmeth2=2,tim_fourdp0=0
1542 : integer :: idir,ipert,tsign,isym_eq,itirev_eq,ipert_eq !,itirev
1543 : integer :: pcase,trev_q,idir_eq,pcase_eq,ispden,cnt
1544 : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot
1545 : real(dp) :: arg
1546 : logical :: has_phase
1547 : logical,parameter :: debug=.False.
1548 : character(len=500) :: msg
1549 : !integer,save :: enough=0
1550 : !arrays
1551 : integer :: symrel_eq(3,3),symrec_eq(3,3),g0_qpt(3),l0(3),tsm1g(3) !symm(3,3),
1552 2560 : integer :: symq(4,2,cryst%nsym)
1553 : real(dp) :: phnon1(2),tnon(3)
1554 1280 : real(dp),allocatable :: workg(:,:), workg_eq(:,:),v1g(:,:,:)
1555 : ! *************************************************************************
1556 :
1557 5120 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
1558 1280 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
1559 1280 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
1560 :
1561 5120 : ABI_MALLOC(v1g, (2,nfft,nspden))
1562 3840 : ABI_MALLOC(workg_eq, (2, nfft))
1563 2560 : ABI_MALLOC(workg, (2, nfft))
1564 :
1565 : ! Examine the symmetries of the q wavevector
1566 1280 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
1567 :
1568 : pcase_loop: &
1569 8750 : do pcase=1,3*cryst%natom
1570 7470 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
1571 7470 : if (pflag(idir, ipert) /= 0) cycle ! This pcase is available
1572 :
1573 : ! Find symmetry which links to the perturbation requested (pcase)
1574 4386 : call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1575 : !if (isym_eq == -1) then
1576 : ! call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1577 : !end if
1578 :
1579 4386 : if (isym_eq == -1) then
1580 : if (debug) write(std_out,*)"Cannot find isym eq for idir, ipert:", idir,ipert
1581 : cycle pcase_loop
1582 : end if
1583 :
1584 : ! set flag since we will reconstruct pcase from isym_eq.
1585 4386 : pflag(idir, ipert) = 2
1586 :
1587 57018 : symrel_eq = cryst%symrel(:,:,isym_eq)
1588 57018 : symrec_eq = cryst%symrec(:,:,isym_eq)
1589 4386 : tsign = 3-2*itirev_eq
1590 :
1591 : ! Phase due to L0 + R^{-1}tau
1592 17544 : l0 = cryst%indsym(1:3,isym_eq,ipert)
1593 :
1594 122808 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym_eq))
1595 10615 : has_phase = any(abs(tnon) > tol12)
1596 : ! FIXME
1597 : !ABI_CHECK(.not. has_phase, "has phase must be tested")
1598 : !if (has_phase) then
1599 : ! enough = enough + 1
1600 : ! if (enough == 1) ABI_WARNING("has phase must be tested")
1601 : !end if
1602 :
1603 156331938 : workg = zero
1604 :
1605 : ! Reconstruct DFPT potential. Final results stored in v1g.
1606 : if (debug) write(std_out,*)"Reconstructing idir:", idir, ", ipert:", ipert
1607 156336324 : v1g = zero; cnt = 0
1608 17544 : do idir_eq=1,3
1609 13158 : if (symrec_eq(idir, idir_eq) == 0) cycle
1610 5792 : cnt = cnt + 1
1611 5792 : pcase_eq = idir_eq + (ipert_eq-1)*3
1612 : if (debug) write(std_out,*) "idir_eq: ", idir_eq, ", ipert_eq: ", ipert_eq, ", tsign: ", tsign
1613 :
1614 5792 : if (pflag(idir_eq, ipert_eq) == 0) then
1615 0 : write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1616 0 : ABI_ERROR(msg)
1617 : end if
1618 :
1619 : !if (pflag(idir_eq, ipert_eq) == 0) then
1620 : ! write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1621 : ! ABI_ERROR(msg)
1622 : !end if
1623 :
1624 15970 : do ispden=1,nspden
1625 : ! Get symmetric perturbation in G-space in workg_eq array.
1626 5792 : call fourdp(cplex,workg_eq,v1scf(:,ispden,pcase_eq),-1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1627 : !call zerosym(workg_eq,cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1628 :
1629 : !call rotate_fqg(itirev_eq,symrec_eq,qpt,tnon,ngfft,nfft,nspden,workg_eq,workg)
1630 5792 : ind1=0
1631 125902 : do i3=1,n3
1632 : ! Get location of G vector (grid point) centered at 0 0 0
1633 120110 : l3 = i3-(i3/id3)*n3-1
1634 2853400 : do i2=1,n2
1635 2727498 : l2 = i2-(i2/id2)*n2-1
1636 71026750 : do i1=1,n1
1637 68179142 : ind1=ind1+1
1638 :
1639 68179142 : l1 = i1-(i1/id1)*n1-1
1640 :
1641 : ! Get rotated G vector Gj for each symmetry element
1642 : ! -- here we use the TRANSPOSE of symrel_eq; assuming symrel_eq expresses
1643 : ! the rotation in real space, the transpose is then appropriate
1644 : ! for G space symmetrization (p. 1172d,e of notes, 2 June 1995).
1645 68179142 : j1 = tsign * (symrel_eq(1,1)*l1+symrel_eq(2,1)*l2+symrel_eq(3,1)*l3)
1646 68179142 : j2 = tsign * (symrel_eq(1,2)*l1+symrel_eq(2,2)*l2+symrel_eq(3,2)*l3)
1647 68179142 : j3 = tsign * (symrel_eq(1,3)*l1+symrel_eq(2,3)*l2+symrel_eq(3,3)*l3)
1648 :
1649 : ! FIXME :TO BE CLARIFIED:
1650 : ! We are not working on the G-sphere thus SG may be outside
1651 : ! of the box. This check is not done in irrzg!!!
1652 : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
1653 68179142 : (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. &
1654 : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
1655 : !write(std_out,*)"got it"
1656 50844369 : workg(:, ind1) = zero; cycle
1657 : end if
1658 :
1659 204924076 : tsm1g = [j1,j2,j3] ! +- S^{-1} G
1660 :
1661 : ! Map into [0,n-1] and then add 1 for array index in [1,n]
1662 51231019 : k1=1+mod(n1+mod(j1,n1),n1)
1663 51231019 : k2=1+mod(n2+mod(j2,n2),n2)
1664 51231019 : k3=1+mod(n3+mod(j3,n3),n3)
1665 :
1666 : ! Get linear index of rotated point Gj
1667 51231019 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
1668 :
1669 51231019 : if (has_phase) then
1670 : ! compute exp(-2*Pi*I*G dot tau) using original G
1671 : ! NB: this phase is same as that in irrzg and phnons1, and corresponds
1672 : ! to complex conjugate of phase from G to Gj;
1673 : ! we use it immediately below, to go _to_ workg_eq(ind1)
1674 114836952 : arg = two_pi * dot_product(qpt + tsm1g, tnon)
1675 28709238 : phnon1(1) = cos(arg); phnon1(2) = -sin(arg)
1676 :
1677 : ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G)
1678 28709238 : workg(1, ind1) = phnon1(1) * workg_eq(1, ind2) - phnon1(2) * workg_eq(2, ind2)
1679 28709238 : workg(2, ind1) = phnon1(1) * workg_eq(2, ind2) + phnon1(2) * workg_eq(1, ind2)
1680 : else
1681 22521781 : workg(1, ind1) = workg_eq(1, ind2)
1682 22521781 : workg(2, ind1) = workg_eq(2, ind2)
1683 : end if
1684 :
1685 : ! Take complex conjugate if time-reversal is used.
1686 53958517 : if (tsign == -1) workg(2, ind1) = -workg(2, ind1)
1687 : end do
1688 : end do
1689 : end do
1690 :
1691 204556376 : v1g(:,:,ispden) = v1g(:,:,ispden) + workg * symrec_eq(idir, idir_eq)
1692 : end do ! ispden
1693 : end do ! idir_eq
1694 : !if (debug) write(std_out,*)"Used ",cnt," equivalent perturbations"
1695 :
1696 : ! Get potential in real space (results in v1scf)
1697 8772 : do ispden=1,nspden
1698 : !call zerosym(v1g(:,:,ispden),cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1699 4386 : call fourdp(cplex,v1g(:,:,ispden),v1scf(:,ispden,pcase),+1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1700 :
1701 : ! IS(q) = q + G0
1702 : ! we want q so we have to multiply by exp(iG0r) in real space.
1703 16731 : if (any(g0_qpt /= 0)) then
1704 1802 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1705 : if (debug) write(std_out,*)"Found not zero g0_qpt", g0_qpt ! for idir: ", idir, ", ipert: ", ipert
1706 1802 : call times_eigr(g0_qpt, ngfft, nfft, 1, v1scf(:,ispden,pcase))
1707 : end if
1708 : end do
1709 :
1710 5666 : if (symv1 == 1) then
1711 : if (debug) write(std_out,*)" Calling v1phq_symmetrize"
1712 376 : call v1phq_symmetrize(cryst,idir,ipert,symq,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,v1scf(:,:,pcase))
1713 : end if
1714 : end do pcase_loop
1715 :
1716 1280 : ABI_FREE(v1g)
1717 1280 : ABI_FREE(workg)
1718 1280 : ABI_FREE(workg_eq)
1719 :
1720 : ! Handle possible error.
1721 11240 : if (any(pflag == 0)) then
1722 0 : write(std_out,"(2a)")"The following perturbations cannot be recostructed by symmetry for q-point: ",trim(ktoa(qpt))
1723 0 : do ipert=1,cryst%natom
1724 0 : do idir=1,3
1725 0 : if (pflag(idir, ipert) == 0) write(std_out,"(2(a,i0))")"idir= ",idir,", ipert= ",ipert
1726 : end do
1727 : end do
1728 : write(msg,"(5a)")&
1729 0 : "Cannot recostruct all 3*natom atomic perturbations from file",ch10,&
1730 0 : "This usually happens when the DVDB does not contain all the independent perturbations for this q-point",ch10,&
1731 0 : "See above message for further information."
1732 0 : ABI_ERROR(msg)
1733 : end if
1734 :
1735 1280 : end subroutine v1phq_complete
1736 : !!***
1737 :
1738 : !----------------------------------------------------------------------
1739 :
1740 : !!****f* m_dvdb/find_symeq
1741 : !! NAME
1742 : !! find_symeq
1743 : !!
1744 : !! FUNCTION
1745 : !! Find symmetry which links to the perturbation specified by (idir, ipert)
1746 : !!
1747 : !! INPUTS
1748 : !! cryst<crystal_t>=crystal structure parameters
1749 : !! idir=Direction of the perturbation
1750 : !! ipert=Perturbation type.
1751 : !! symq(4,2,nsym)=Table produced by littlegroup_q for this q-point.
1752 : !! pflag(3,natom)= For each atomic perturbation:
1753 : !! 0 if pert is not available. 1 if pert is available. 2 if pert can been reconstructed by symmetry.
1754 : !!
1755 : !! OUTPUT
1756 : !! ipert_eq
1757 : !! isym_eq
1758 : !! itirev_eq
1759 : !! g0_qpt(3)
1760 : !!
1761 : !! SOURCE
1762 :
1763 4386 : subroutine find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0)
1764 :
1765 : !Arguments ------------------------------------
1766 : !scalars
1767 : integer,intent(in) :: idir,ipert
1768 : integer,intent(out) :: ipert_eq,isym_eq,itirev_eq
1769 : type(crystal_t),intent(in) :: cryst
1770 : logical,optional :: allow_g0
1771 : !arrays
1772 : integer,intent(in) :: symq(4,2,cryst%nsym),pflag(3,cryst%natom)
1773 : integer,intent(out) :: g0_qpt(3)
1774 :
1775 : !Local variables-------------------------------
1776 : !scalars
1777 : logical :: do_allow_g0
1778 : integer :: isym,idir_eq,ip,itirev
1779 : ! *************************************************************************
1780 :
1781 4386 : isym_eq = -1; ipert_eq = -1
1782 4386 : do_allow_g0 = .true.; if (present(allow_g0)) do_allow_g0 = allow_g0
1783 :
1784 : symloop: &
1785 4687 : do itirev=1,2
1786 4687 : itirev_eq = itirev
1787 54562 : do isym=1,cryst%nsym
1788 :
1789 : ! Check that isym preserves the q-point
1790 : ! The condition is
1791 : !
1792 : ! $q = O S(q) - G$
1793 : !
1794 : ! with O being either the identity or the time reversal symmetry (= inversion in reciprocal space)
1795 : ! and G being a primitive vector of the reciprocal lattice.
1796 :
1797 : !if (symq(4,itirev,isym) /= 1 .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1798 49875 : if (symq(4,itirev,isym) /= 1) cycle ! .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1799 60918 : if (any(symq(1:3,itirev,isym) /= 0) .and. .not. do_allow_g0) cycle
1800 72440 : g0_qpt = symq(1:3,itirev,isym)
1801 :
1802 : ! indsym map is computed in symatm.
1803 46354 : do ip=1,cryst%natom
1804 : !if (.not. cryst%indsym(4,isym,ip) == ipert) cycle
1805 32329 : if (.not. cryst%indsym(4,isym,ipert) == ip) cycle
1806 18110 : isym_eq = isym; ipert_eq = ip
1807 72440 : do idir_eq=1,3
1808 54330 : if (idir_eq == idir .and. ip == ipert .and. cryst%symrec(idir,idir_eq,isym) /= 0) isym_eq = -1
1809 72440 : if (cryst%symrec(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1810 : !if (cryst%symrel(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1811 : !if (idir_eq == idir .and. ip == ipert) cycle
1812 16209 : isym_eq = -1
1813 : end if
1814 : end do
1815 63599 : if (isym_eq /= -1) exit symloop
1816 : end do
1817 : end do
1818 : end do symloop
1819 :
1820 4386 : if (isym_eq == -1) then
1821 0 : ipert_eq = -1; itirev_eq = -1
1822 : end if
1823 :
1824 4386 : end subroutine find_symeq
1825 : !!***
1826 :
1827 : !----------------------------------------------------------------------
1828 :
1829 : !!****f* m_dvdb/v1phq_rotate
1830 : !! NAME
1831 : !! v1phq_rotate
1832 : !!
1833 : !! FUNCTION
1834 : !! Reconstruct all the DFPT potential for a q-point in the BZ (qpt_bz) starting from its symmetrical image in the IBZ (q_ibz)
1835 : !!
1836 : !! INPUTS
1837 : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1838 : !! cryst<crystal_t>=crystal structure parameters
1839 : !! isym, itimrev, g0q: Symmetry indices and umklapp. The q-point in the BZ is given by:
1840 : !!
1841 : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
1842 : !!
1843 : !! where S is symrec(:,:,isym)
1844 : !! ngfft=array of dimensions for different FFT grids
1845 : !! ngfft(18)=contain all needed information about 3D FFT.
1846 : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
1847 : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
1848 : !! nspden=number of spin-density components
1849 : !! mpi_enreg=information about MPI parallelization
1850 : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
1851 : !! for the irreducible q-point `qpt_ibz`
1852 : !! comm: MPI communicator to distribute natom3 * nspden FFT calls
1853 : !!
1854 : !! OUTPUT
1855 : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
1856 : !!
1857 : !! SOURCE
1858 :
1859 2050 : subroutine v1phq_rotate(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
1860 2050 : mpi_enreg, v1r_qibz, v1r_qbz, comm)
1861 :
1862 : !Arguments ------------------------------------
1863 : !scalars
1864 : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, comm
1865 : type(crystal_t),intent(in) :: cryst
1866 : type(MPI_type),intent(in) :: mpi_enreg
1867 : !arrays
1868 : integer,intent(in) :: g0q(3),ngfft(18)
1869 : real(dp),intent(in) :: qpt_ibz(3)
1870 : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
1871 : real(dp) ABI_ASYNC, intent(out) :: v1r_qbz(cplex*nfft,nspden,3*cryst%natom)
1872 :
1873 : !Local variables-------------------------------
1874 : !scalars
1875 : integer,parameter :: tim_fourdp0 = 0
1876 : !integer,save :: enough = 0
1877 : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,my_rank,nproc,ierr,root
1878 : !arrays
1879 : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
1880 : real(dp) :: tnon(3), tsec(2)
1881 2050 : real(dp) ABI_ASYNC, allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
1882 4100 : integer :: requests(nspden, 3*cryst%natom), requests_v1r_qbz(3*cryst%natom)
1883 4100 : logical :: requests_v1g_qibz_done(nspden, 3*cryst%natom)
1884 : ! *************************************************************************
1885 :
1886 : ! Keep track of total time spent.
1887 2050 : call timab(1804, 1, tsec)
1888 :
1889 2050 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1890 :
1891 2050 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1892 2050 : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
1893 :
1894 : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
1895 10250 : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
1896 25612 : requests_v1g_qibz_done = .False.
1897 : cnt = 0
1898 13831 : do mu=1,natom3
1899 25612 : do ispden=1,nspden
1900 11781 : cnt = cnt + 1; root = mod(cnt, nproc)
1901 11781 : if (root == my_rank) then ! Non-blocking
1902 11781 : call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1903 : end if
1904 23562 : call xmpi_ibcast(v1g_qibz(:,ispden,mu), root, comm, requests(ispden, mu), ierr)
1905 : end do
1906 : end do
1907 :
1908 8200 : ABI_MALLOC(workg, (2*nfft, nspden))
1909 6150 : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
1910 :
1911 26650 : symrec_eq = cryst%symrec(:,:,isym)
1912 : ! Compute sm1 = symrec_eq^{-1}
1913 51250 : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
1914 :
1915 : ! For each perturbation (idir, ipert, qpt_bz), rotate the symmetrical potentials at (idir_eq, ipert_eq, q_ibz)
1916 : ! computed in g-space and take linear combinations using symrec_eq(idir, idir_eq).
1917 : ! Finally, perform g -- >r FFTs of the potentials at qpt_bz and multiply by e^{-ig0.r} to account for umklapp.
1918 :
1919 : ! See Eq C2 in [[cite:Brunin2020b]] 10.1103/PhysRevB.102.094308
1920 13831 : do mu=1,natom3
1921 11781 : root = mod(mu, nproc)
1922 : ! MPI parallelism.
1923 11781 : if (root == my_rank) then
1924 11781 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1925 :
1926 : ! Phase due to L0 + R^{-1} tau where R is a symrel operation hence R^{-1} = symrec_eq^T
1927 47124 : l0 = cryst%indsym(1:3,isym,ipert)
1928 329868 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
1929 : !if (.not. all(abs(tnon) < tol12)) then
1930 : ! enough = enough + 1
1931 : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
1932 : !end if
1933 :
1934 11781 : ipert_eq = cryst%indsym(4, isym, ipert)
1935 :
1936 236947674 : v1g_mu = zero; cnt = 0
1937 47124 : do idir_eq=1,3
1938 35343 : if (symrec_eq(idir, idir_eq) == 0) cycle
1939 18377 : mu_eq = idir_eq + (ipert_eq - 1) * 3
1940 18377 : cnt = cnt + 1
1941 :
1942 : ! Wait for request before operating on v1g_qibz
1943 24973 : if (.not. all(requests_v1g_qibz_done(:, mu_eq))) then
1944 23562 : do ispden=1,nspden
1945 11781 : call xmpi_wait(requests(ispden, mu_eq), ierr)
1946 23562 : requests_v1g_qibz_done(ispden, mu_eq) = .True.
1947 : end do
1948 : end if
1949 :
1950 : ! Rotate in G-space: output in workg
1951 18377 : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
1952 : ! And accumulate in v1g_mu
1953 367576854 : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
1954 : end do ! idir_eq
1955 :
1956 11781 : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
1957 :
1958 : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
1959 23562 : do ispden=1,nspden
1960 11781 : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, mu), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1961 58905 : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, mu))
1962 : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,mu))
1963 : end do
1964 :
1965 : end if ! root == myrank
1966 :
1967 13831 : call xmpi_ibcast(v1r_qbz(:,:,mu), root, comm, requests_v1r_qbz(mu), ierr)
1968 : end do ! mu
1969 :
1970 : ! Release all requests
1971 2050 : call xmpi_waitall(requests, ierr)
1972 2050 : call xmpi_waitall(requests_v1r_qbz, ierr)
1973 :
1974 2050 : ABI_FREE(workg)
1975 2050 : ABI_FREE(v1g_mu)
1976 2050 : ABI_FREE(v1g_qibz)
1977 :
1978 2050 : call timab(1804, 2, tsec)
1979 :
1980 2050 : end subroutine v1phq_rotate
1981 : !!***
1982 :
1983 : !----------------------------------------------------------------------
1984 :
1985 : !!****f* m_dvdb/v1phq_rotate_myperts
1986 : !! NAME
1987 : !! v1phq_rotate_myperts
1988 : !!
1989 : !! FUNCTION
1990 : !! Reconstruct all the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ.
1991 : !!
1992 : !! INPUTS
1993 : !! cryst<crystal_t>=crystal structure parameters
1994 : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1995 : !! ngfft=array of dimensions for different FFT grids
1996 : !! isym, itimrev, g0q:
1997 : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
1998 : !! ngfft(18)=contain all needed information about 3D FFT.
1999 : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2000 : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2001 : !! nspden=number of spin-density components
2002 : !! mpi_enreg=information about MPI parallelization
2003 : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
2004 : !! for the irreducible q-point `qpt_ibz`
2005 : !!
2006 : !! OUTPUT
2007 : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
2008 : !!
2009 : !! SOURCE
2010 :
2011 : subroutine v1phq_rotate_myperts(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
2012 : mpi_enreg, my_npert, my_pinfo, v1r_qibz, v1r_qbz)
2013 :
2014 : !Arguments ------------------------------------
2015 : !scalars
2016 : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, my_npert
2017 : type(crystal_t),intent(in) :: cryst
2018 : type(MPI_type),intent(in) :: mpi_enreg
2019 : !arrays
2020 : integer,intent(in) :: g0q(3), ngfft(18), my_pinfo(3, my_npert)
2021 : real(dp),intent(in) :: qpt_ibz(3)
2022 : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
2023 : real(dp),intent(out) :: v1r_qbz(cplex*nfft,nspden,my_npert)
2024 :
2025 : !Local variables-------------------------------
2026 : !scalars
2027 : integer,parameter :: tim_fourdp0 = 0
2028 : !integer,save :: enough = 0
2029 : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,imyp !ierr,
2030 : !arrays
2031 : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
2032 : logical :: fourdp_done(3*cryst%natom)
2033 : real(dp) :: tnon(3), tsec(2)
2034 : real(dp), allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
2035 : ! *************************************************************************
2036 :
2037 : ! Keep track of total time spent.
2038 : call timab(1804, 1, tsec)
2039 :
2040 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
2041 :
2042 : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
2043 :
2044 : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
2045 : fourdp_done = .False.
2046 : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
2047 : !do mu=1,natom3
2048 : ! do ispden=1,nspden
2049 : ! call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2050 : ! end do
2051 : !end do
2052 :
2053 : ABI_MALLOC(workg, (2*nfft, nspden))
2054 : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
2055 :
2056 : symrec_eq = cryst%symrec(:,:,isym)
2057 : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
2058 :
2059 : ! For each perturbation treated by this MPI proc
2060 : do imyp=1,my_npert
2061 : idir = my_pinfo(1, imyp); ipert = my_pinfo(2, imyp); mu = my_pinfo(3, imyp)
2062 :
2063 : ! Phase due to L0 + R^{-1}tau
2064 : l0 = cryst%indsym(1:3,isym,ipert)
2065 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
2066 : !if (.not. all(abs(tnon) < tol12)) then
2067 : ! enough = enough + 1
2068 : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
2069 : !end if
2070 :
2071 : ipert_eq = cryst%indsym(4, isym, ipert)
2072 :
2073 : v1g_mu = zero; cnt = 0
2074 : do idir_eq=1,3
2075 : if (symrec_eq(idir, idir_eq) == 0) cycle
2076 : mu_eq = idir_eq + (ipert_eq - 1) * 3
2077 : cnt = cnt + 1
2078 :
2079 : if (.not. fourdp_done(mu_eq)) then
2080 : do ispden=1,nspden
2081 : call fourdp(cplex, v1g_qibz(:,ispden,mu_eq), v1r_qibz(:,ispden,mu_eq), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2082 : end do
2083 : fourdp_done(mu_eq) = .True.
2084 : end if
2085 :
2086 : ! Rotate in G-space and accumulate in workg
2087 : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
2088 : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
2089 : end do ! idir_eq
2090 :
2091 : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
2092 :
2093 : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
2094 : do ispden=1,nspden
2095 : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, imyp), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2096 : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, imyp))
2097 : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,imyp))
2098 : end do
2099 :
2100 : end do ! imyp
2101 :
2102 : ABI_FREE(workg)
2103 : ABI_FREE(v1g_mu)
2104 : ABI_FREE(v1g_qibz)
2105 :
2106 : call timab(1804, 2, tsec)
2107 :
2108 : end subroutine v1phq_rotate_myperts
2109 : !!***
2110 :
2111 : !!****f* m_dvdb/v1phq_symmetrize
2112 : !! NAME
2113 : !! v1phq_symmetrize
2114 : !!
2115 : !! FUNCTION
2116 : !! Enforce spatial-symmetry on the DFPT potential.
2117 : !!
2118 : !! INPUTS
2119 : !! cryst<crystal_t>=crystal structure parameters
2120 : !! idir=Direction of the perturbation
2121 : !! ipert=Perturbation type.
2122 : !! symq(4,2,nsym)= Table computed by littlegroup_q.
2123 : !! three first numbers define the G vector;
2124 : !! fourth number is zero if the q-vector is not preserved, is 1 otherwise
2125 : !! second index is one without time-reversal symmetry, two with time-reversal symmetry
2126 : !! ngfft=array of dimensions for different FFT grids
2127 : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2128 : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2129 : !! nspden=number of spin-density components
2130 : !! mpi_enreg=information about MPI parallelization
2131 : !!
2132 : !! SIDE EFFECTS
2133 : !! v1r(cplex*nfft,nspden)=Array with first order potentials in real space. Symmetrized in output.
2134 : !!
2135 : !! SOURCE
2136 :
2137 1718 : subroutine v1phq_symmetrize(cryst, idir, ipert, symq, ngfft, cplex, nfft, nspden, nsppol, mpi_enreg, v1r)
2138 :
2139 : !Arguments ------------------------------------
2140 : !scalars
2141 : integer,intent(in) :: idir, ipert, cplex, nfft, nspden, nsppol
2142 : type(crystal_t),intent(in) :: cryst
2143 : type(MPI_type),intent(in) :: mpi_enreg
2144 : !arrays
2145 : integer,intent(in) :: symq(4,2,cryst%nsym),ngfft(18)
2146 : real(dp),intent(inout) :: v1r(cplex*nfft,nspden)
2147 :
2148 : !Local variables-------------------------------
2149 : integer,parameter :: syuse0 = 0, rfmeth2 = 2, iscf1 = 1
2150 : integer :: nsym1, nfftot
2151 : !arrays
2152 3436 : integer :: symafm1(cryst%nsym),symrel1(3,3,cryst%nsym),symrc1(3,3,cryst%nsym)
2153 1718 : integer,allocatable :: irrzon1(:,:,:),indsy1(:,:,:)
2154 0 : real(dp) :: tnons1(3,cryst%nsym)
2155 1718 : real(dp),allocatable :: phnons1(:,:,:),v1g(:,:)
2156 : ! *************************************************************************
2157 :
2158 1718 : if (cryst%nsym == 1) return
2159 :
2160 6872 : nfftot = product(ngfft(1:3))
2161 1718 : ABI_CHECK(nfft == nfftot, "MPI-FFT not coded")
2162 :
2163 : ! Symmetrize (copied from dfpt_looppert)
2164 : ! Determines the set of symmetries that leaves the perturbation invariant.
2165 : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
2166 1718 : cryst%symafm,symafm1,symq,cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,tnons1,unit=dev_null)
2167 :
2168 : ! Set up corresponding symmetry data
2169 6872 : ABI_MALLOC(irrzon1, (nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4)))
2170 6872 : ABI_MALLOC(phnons1, (2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4)))
2171 6872 : ABI_MALLOC(indsy1,(4,nsym1,cryst%natom))
2172 :
2173 : call setsym(indsy1,irrzon1,iscf1,cryst%natom,nfft,ngfft,nspden,nsppol,&
2174 1718 : nsym1,phnons1,symafm1,symrc1,symrel1,tnons1,cryst%typat,cryst%xred)
2175 :
2176 : !if (psps%usepaw==1) then
2177 : ! ! Allocate/initialize only zarot in pawang1 datastructure
2178 : ! call pawang_init(pawang1,0,0,pawang%l_max-1,0,0,nsym1,0,0,0,0)
2179 : ! call setsym_ylm(gprimd,pawang1%l_max-1,pawang1%nsym,0,rprimd,symrc1,pawang1%zarot)
2180 : !end if
2181 :
2182 : ! FIXME Be careful here because symrhg was written for densities!
2183 1718 : ABI_CHECK(nsppol == 1 .and. nspden == 1, "symrhg was written for densities, not for potentials")
2184 :
2185 5154 : ABI_MALLOC(v1g, (2,nfft))
2186 : call symrhg(cplex,cryst%gprimd,irrzon1,mpi_enreg,nfft,nfftot,ngfft,nspden,nsppol,nsym1,&
2187 1718 : phnons1,v1g,v1r,cryst%rprimd,symafm1,symrel1,tnons1)
2188 :
2189 1718 : ABI_FREE(irrzon1)
2190 1718 : ABI_FREE(phnons1)
2191 1718 : ABI_FREE(indsy1)
2192 1718 : ABI_FREE(v1g)
2193 :
2194 : end subroutine v1phq_symmetrize
2195 : !!***
2196 :
2197 : !----------------------------------------------------------------------
2198 :
2199 : !!****f* m_dvdb/rotate_fqg
2200 : !! NAME
2201 : !! rotate_fqg
2202 : !!
2203 : !! FUNCTION
2204 : !! Rotate density/potential infg_q(g) in g-space to obtain outfg_{ISq}(g)
2205 : !!
2206 : !! INPUTS
2207 : !! itirev=2 if time-reversal symmetry should be used, 1 otherwise.
2208 : !! symm(3,3)=Symmetry operation S in reciprocal space.
2209 : !! NB: symm usually corresponds to the inverso of one of the symrec operations.
2210 : !! qpt(3)=q-point in the IBZ (this is the q-point associated to infg)
2211 : !! tnon(3)=Fractional translation associate the the symmetry operation.
2212 : !! ngfft(18)=contain all needed information about 3D FFT.
2213 : !! nfft=Number of fft-points treated by this processors
2214 : !! nspden=number of spin-density components
2215 : !! infg(2,nfft,nspden)=Input array in g-space on the FFT box.
2216 : !!
2217 : !! OUTPUTS
2218 : !! outfg(2,nfft,nspden)= Input array in g-space on the FFT box. In pseudo-equation:
2219 : !!
2220 : !! outfg(g) = infg(IS G) e^{-i(IS^{-1} G)} exp(2*pi*I*(G) dot tau_S) rho(IS^{-1} G)
2221 : !!
2222 : !! SOURCE
2223 :
2224 18377 : subroutine rotate_fqg(itirev, symm, qpt, tnon, ngfft, nfft, nspden, infg, outfg)
2225 :
2226 : !Arguments ------------------------------------
2227 : !scalars
2228 : integer,intent(in) :: itirev,nfft,nspden
2229 : !arrays
2230 : integer,intent(in) :: symm(3,3),ngfft(18)
2231 : real(dp),intent(in) :: qpt(3),tnon(3)
2232 : real(dp),intent(in) :: infg(2,nfft,nspden)
2233 : real(dp),intent(out) :: outfg(2,nfft,nspden)
2234 :
2235 : !Local variables-------------------------------
2236 : !scalars
2237 : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot,isp,tsign
2238 : real(dp) :: arg
2239 : logical :: has_phase
2240 : !arrays
2241 : integer :: tsg(3)
2242 : real(dp) :: phnon1(2), tsec(2)
2243 : ! *************************************************************************
2244 :
2245 : ! Keep track of total time spent.
2246 18377 : call timab(1803, 1, tsec)
2247 :
2248 73508 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
2249 18377 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
2250 18377 : id1 = n1/2+2; id2 = n2/2+2; id3=n3/2+2
2251 :
2252 18377 : ABI_CHECK(any(itirev == [1, 2]), "Wrong itirev")
2253 53619 : tsign = 3-2*itirev; has_phase = any(abs(tnon) > tol12)
2254 :
2255 : !outfg = zero
2256 :
2257 36754 : do isp=1,nspden
2258 : ind1 = 0
2259 376070 : do i3=1,n3
2260 : ! Get location of G vector (grid point) centered at 0 0 0
2261 339316 : l3 = i3-(i3/id3)*n3-1
2262 7781485 : do i2=1,n2
2263 7423792 : l2 = i2-(i2/id2)*n2-1
2264 191509596 : do i1=1,n1
2265 183746488 : ind1 = ind1 + 1
2266 : !ind1 = 1 + i1 + (i2-1)*n1 + (i3-1)*n1*n2
2267 : !if (mod(ind1, nprocs) /= my_rank) cycle
2268 :
2269 183746488 : l1 = i1-(i1/id1)*n1-1
2270 :
2271 : ! Get rotated G vector: IS(G)
2272 183746488 : j1 = tsign * (symm(1,1)*l1+symm(1,2)*l2+symm(1,3)*l3)
2273 183746488 : j2 = tsign * (symm(2,1)*l1+symm(2,2)*l2+symm(2,3)*l3)
2274 183746488 : j3 = tsign * (symm(3,1)*l1+symm(3,2)*l2+symm(3,3)*l3)
2275 :
2276 : ! FIXME :TO BE CLARIFIED:
2277 : ! We are not working on the G-sphere thus SG may be outside
2278 : ! of the box. This check is not done in irrzg!!!
2279 : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
2280 183746488 : (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. &
2281 : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
2282 : !write(std_out,*)"outsize box!"
2283 176108448 : outfg(:,ind1,isp) = zero
2284 : cycle
2285 : end if
2286 :
2287 500174688 : tsg = [j1,j2,j3] ! IS^{-1} G
2288 :
2289 : ! Map into [0,n-1] and then add 1 for array index in [1, n]
2290 125043672 : k1=1+mod(n1+mod(j1,n1),n1)
2291 125043672 : k2=1+mod(n2+mod(j2,n2),n2)
2292 125043672 : k3=1+mod(n3+mod(j3,n3),n3)
2293 :
2294 : ! Get linear index of rotated point Gj
2295 125043672 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
2296 :
2297 : ! TODO: Here I believe there are lots of cache misses, should perform low-level profiling
2298 : ! OMP perhaps can accelerate this part but mind false sharing...
2299 125043672 : if (has_phase) then
2300 : ! compute exp(-2*pi*I*G dot tau_S) using original G
2301 240549132 : arg = two_pi * dot_product(qpt + tsg, tnon)
2302 60137283 : phnon1(1) = cos(arg); phnon1(2) =-sin(arg)
2303 :
2304 : ! rho(Strans*G)=exp(2*pi*IG dot tau_S) rho(G)
2305 60137283 : outfg(1, ind1, isp) = phnon1(1) * infg(1, ind2, isp) - phnon1(2) * infg(2, ind2, isp)
2306 60137283 : outfg(2, ind1, isp) = phnon1(1) * infg(2, ind2, isp) + phnon1(2) * infg(1, ind2, isp)
2307 : else
2308 64906389 : outfg(1, ind1, isp) = infg(1, ind2, isp)
2309 64906389 : outfg(2, ind1, isp) = infg(2, ind2, isp)
2310 : end if
2311 :
2312 : ! Take complex conjugate if time-reversal is used.
2313 132467464 : if (tsign == -1) outfg(2, ind1, isp) = -outfg(2, ind1, isp)
2314 : end do
2315 : end do
2316 : end do
2317 : end do ! isp
2318 :
2319 : !call xmpi_sum(comm, outfg, ierr)
2320 18377 : call timab(1803, 2, tsec)
2321 :
2322 18377 : end subroutine rotate_fqg
2323 : !!***
2324 :
2325 : !----------------------------------------------------------------------
2326 :
2327 : !!****f* m_dvdb/dvdb_ftinterp_setup
2328 : !! NAME
2329 : !! dvdb_ftinterp_setup
2330 : !!
2331 : !! FUNCTION
2332 : !! Precompute the wsr array with the DFPT potential in the supercell
2333 : !! required for the Fourier interpolation.
2334 : !! This is a collective routine that should be called by all procs inside db%comm.
2335 : !!
2336 : !! \begin{equation}
2337 : !! \label{eq:dfpt_pot_realspace}
2338 : !! W_{\kappa\alpha}(\rr,\RR) = \dfrac{1}{N_\qq} \sum_\qq e^{-i\qq\cdot(\RR - \rr)}\,
2339 : !! \partial_{\kappa\alpha\qq}{v^{\text{scf}}}(\rr)
2340 : !! \end{equation}
2341 : !!
2342 : !! INPUTS
2343 : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
2344 : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
2345 : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
2346 : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
2347 : !! nfft=Number of fft-points treated by this processors
2348 : !! ngfft(18)=contain all needed information about 3D FFT
2349 : !! comm_rpt = MPI communicator used to distribute R-lattice points.
2350 : !!
2351 : !! SOURCE
2352 :
2353 36 : subroutine dvdb_ftinterp_setup(db, ngqpt, qptopt, nqshift, qshift, nfft, ngfft, comm_rpt)
2354 :
2355 : !Arguments ------------------------------------
2356 : !scalars
2357 : class(dvdb_t),target,intent(inout) :: db
2358 : integer,intent(in) :: qptopt,nqshift,nfft,comm_rpt
2359 : !arrays
2360 : integer,intent(in) :: ngqpt(3), ngfft(18)
2361 : real(dp),intent(in) :: qshift(3,nqshift)
2362 :
2363 : !Local variables-------------------------------
2364 : !scalars
2365 : integer,parameter :: master=0
2366 : integer :: iq_ibz,nqibz,iq_bz,nqbz !, timerev_q
2367 : integer :: ii,jj,cplex_qibz,ispden,imyp,irpt,idir,ipert,ipc, iqst, itimrev, isym
2368 : integer :: ifft, ierr, my_rstart, my_rstop, iatom
2369 : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
2370 : logical :: isirr_q
2371 : character(len=500) :: msg
2372 : !arrays
2373 : integer :: g0q(3)
2374 : !integer :: symq(4,2,db%cryst%nsym)
2375 36 : integer,allocatable :: indqq(:,:), iperm(:), nqsts(:), iqs_dvdb(:), all_cell(:,:)
2376 : real(dp) :: qpt_bz(3)
2377 36 : real(dp),allocatable :: qibz(:,:), qbz(:,:), emiqr(:,:), all_rpt(:,:), all_wghatm(:,:,:)
2378 36 : real(dp),allocatable :: v1r_qibz(:,:,:,:), v1r_qbz(:,:,:,:), v1r_lr(:,:,:)
2379 36 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
2380 : logical,parameter :: DEBUG_WSR_IMAG = .False.
2381 36 : real(dp),allocatable :: wsi_diag(:,:,:,:)
2382 : ! *************************************************************************
2383 :
2384 : ! Set communicator for R-point parallelism.
2385 : ! Note that client code is responsible for calling the interpolation routine dvdb_get_ftqbz (R -> q)
2386 : ! with all procs inside comm_rpt to avoid MPI deadlocks.
2387 36 : db%comm_rpt = comm_rpt; db%nprocs_rpt = xmpi_comm_size(db%comm_rpt); db%me_rpt = xmpi_comm_rank(db%comm_rpt)
2388 :
2389 36 : if (db%add_lr >= 4) then
2390 0 : call wrtout(std_out, " Skipping construction of W(R,r) because add_lr >= 4. Will use LR part only!")
2391 0 : return
2392 : end if
2393 :
2394 36 : call cwtime(cpu_all, wall_all, gflops_all, "start")
2395 :
2396 : call wrtout(std_out, sjoin(ch10, "Building W(R,r) using q-mesh ngqpt: ", ltoa(ngqpt), &
2397 36 : ", with nprocs_rpt:", itoa(db%nprocs_rpt)), do_flush=.True.)
2398 36 : call wrtout(std_out, sjoin(" Using Gaussian filter with qdamp: ", ftoa(db%qdamp, fmt="(f6.1)")))
2399 36 : call wrtout(std_out, "")
2400 36 : call wrtout(std_out, " Note: this part may take some time depending on the number of MPI procs, ngqpt and nfft points.")
2401 36 : call wrtout(std_out, " Use boxcutmin < 2.0 (> 1.1) to decrease nfft, reduce memory requirements and speedup the calculation.")
2402 : !call wrtout(std_out, " Q-mesh shifts:")
2403 : !do ii=1,nqshift
2404 : ! call wrtout(std_out, ltoa(qshift(:, ii)))
2405 : !end do
2406 :
2407 : call prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2408 36 : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm, db%comm)
2409 :
2410 36 : nqibz = size(qibz, dim=2); nqbz = size(qbz, dim=2); db%nrtot = size(all_rpt, dim=2)
2411 :
2412 : ! Distribute R-points inside comm_rpt.
2413 36 : call xmpi_split_work(db%nrtot, db%comm_rpt, my_rstart, my_rstop)
2414 :
2415 : ! Select my_rpoints.
2416 : ! Use REMALLOC so that we can call this routine multiple times i.e. for changing add_lr
2417 36 : db%my_nrpt = my_rstop - my_rstart + 1
2418 36 : ABI_CHECK(db%my_nrpt /= 0, "my_nrpt == 0!")
2419 :
2420 108 : ABI_REMALLOC(db%my_rpt, (3, db%my_nrpt))
2421 5036 : db%my_rpt = all_rpt(:, my_rstart:my_rstop)
2422 108 : ABI_REMALLOC(db%my_irpt2tot, (db%my_nrpt))
2423 1277 : do irpt=1,db%my_nrpt
2424 1277 : db%my_irpt2tot(irpt) = my_rstart + (irpt - 1)
2425 : end do
2426 :
2427 : ! Copy weights for the atoms treated by this proc.
2428 462 : ii = minval(db%my_pinfo(2,:)); jj = maxval(db%my_pinfo(2,:))
2429 144 : ABI_REMALLOC(db%my_wratm, (db%my_nrpt, ii:jj))
2430 2581 : db%my_wratm = one
2431 36 : if (db%rspace_cell == 1) then
2432 0 : do iatom=1,db%cryst%natom
2433 0 : if (iatom >= ii .and. iatom <= jj) db%my_wratm(:, iatom) = all_wghatm(iatom, iatom, my_rstart:my_rstop)
2434 : end do
2435 : end if
2436 :
2437 36 : write(std_out, "(a, i0)")" Using rspace_cell method for integration weights: ", db%rspace_cell
2438 36 : write(std_out, "(a, i0)")" Total number of R-points in real-space big box: ", db%nrtot
2439 36 : write(std_out, "(a, i0)")" Number of R-points treated by this MPI rank: ", db%my_nrpt
2440 36 : write(std_out, "(a, 3(i0, 1x))")" ngfft: ", ngfft(1:3)
2441 36 : write(std_out, "(a, i0)")" dvdb_add_lr: ", db%add_lr
2442 :
2443 : ! Allocate potential in the supercell. Memory is MPI-distributed over my_nrpt and my_npert
2444 : call wrtout(std_out, sjoin(" Memory required for W(R,r): ", &
2445 36 : ftoa(two * db%my_nrpt * nfft * db%nspden * db%my_npert * sp * b2Mb, fmt="f8.1"), "[Mb] <<< MEM"))
2446 :
2447 : ABI_SFREE(all_cell)
2448 36 : ABI_SFREE(all_wghatm)
2449 36 : ABI_FREE(all_rpt)
2450 :
2451 108 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
2452 180 : ABI_MALLOC(v1r_qbz, (2, nfft, db%nspden, db%natom3))
2453 8410533 : ABI_CALLOC(v1r_lr, (2, nfft, db%my_npert))
2454 :
2455 36 : ABI_SFREE(db%wsr)
2456 216 : ABI_MALLOC_OR_DIE(db%wsr, (1, db%my_nrpt, nfft, db%nspden, db%my_npert), ierr)
2457 138868110 : db%wsr = zero
2458 :
2459 : if (DEBUG_WSR_IMAG) then
2460 : ABI_MALLOC(wsi_diag, (db%my_nrpt, nfft, db%nspden, db%my_npert))
2461 : wsi_diag = zero
2462 : end if
2463 :
2464 : ! TODO: Parallelize this part over q-points using comm_rpt. For the time being only pert parallelism.
2465 36 : iqst = 0
2466 237 : do iq_ibz=1,nqibz
2467 201 : call cwtime(cpu, wall, gflops, "start")
2468 : !
2469 : ! Here all procs get all potentials for this IBZ q-point on the real-space FFT mesh.
2470 : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
2471 : ! Note that here we need all 3*natom perturbations because of v1phq_rotate.
2472 201 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, db%comm)
2473 :
2474 : ! Reconstruct by symmetry the potentials for the star of this q-point,
2475 : ! perform slow FT and accumulate in wsr. Be careful with the gamma point.
2476 1442 : do ii=1,nqsts(iq_ibz)
2477 1241 : iqst = iqst + 1
2478 : !if (mod(ii, nproc) /= my_rank) cycle ! MPI parallelism.
2479 1241 : iq_bz = iperm(iqst)
2480 1241 : ABI_CHECK(iq_ibz == indqq(1, iq_bz), "iq_ibz !/ indqq(1)")
2481 4964 : qpt_bz = qbz(:, iq_bz)
2482 : !if (all(abs(qpt_bz) < tol12)) cycle
2483 : ! IS(q_ibz) + g0q = q_bz
2484 4964 : isym = indqq(2, iq_bz); itimrev = indqq(6, iq_bz) + 1; g0q = indqq(3:5, iq_bz)
2485 4182 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
2486 : !write(std_out, *)"qbz", trim(ktoa(qpt_bz)), " --> qibz ", trim(ktoa(qibz(:,iq_ibz)))
2487 : !write(std_out, *)"via isym, itimrev, g0q:", isym, itimrev, g0q
2488 :
2489 : ! Compute long-range part of the coupling potential at qpt_bz.
2490 1241 : if (db%add_lr /= 0) then
2491 7959 : do imyp=1,db%my_npert
2492 6822 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2493 7959 : call db%get_v1r_long_range(qpt_bz, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
2494 : end do
2495 : end if
2496 :
2497 1442 : if (cplex_qibz == 1) then
2498 : ! Gamma point.
2499 36 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
2500 144 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
2501 :
2502 36 : if (db%add_lr /= 0) then
2503 : ! Subtract the long-range part of the potential.
2504 161 : do imyp=1,db%my_npert
2505 138 : ipc = db%my_pinfo(3, imyp)
2506 299 : do ispden=1,db%nspden
2507 961668 : v1r_qibz(1, :, ispden, ipc) = v1r_qibz(1, :, ispden, ipc) - v1r_lr(1, :, imyp)
2508 : end do
2509 : end do
2510 : end if
2511 :
2512 : ! Slow FT.
2513 249 : do imyp=1,db%my_npert
2514 213 : ipc = db%my_pinfo(3, imyp)
2515 462 : do ispden=1,db%nspden
2516 2803818 : do ifft=1,nfft
2517 70835733 : do irpt=1,db%my_nrpt
2518 : db%wsr(1, irpt, ifft, ispden, imyp) = db%wsr(1, irpt, ifft, ispden, imyp) + &
2519 70835520 : v1r_qibz(1, ifft, ispden, ipc)
2520 : end do
2521 : end do
2522 : end do
2523 : end do
2524 :
2525 : else
2526 : ! q /= Gamma. Get the periodic part of the potential in BZ (v1r_qbz)
2527 1205 : if (isirr_q) then
2528 33744234 : v1r_qbz = v1r_qibz
2529 : else
2530 : call v1phq_rotate(db%cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
2531 1040 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
2532 : end if
2533 :
2534 : ! Multiply by e^{iqpt_bz.r}
2535 1205 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden * db%natom3, v1r_qbz)
2536 :
2537 1205 : if (db%add_lr /= 0) then
2538 : ! Subtract the long-range part of the potential.
2539 7798 : do imyp=1,db%my_npert
2540 6684 : ipc = db%my_pinfo(3, imyp)
2541 14482 : do ispden=1,db%nspden
2542 157017576 : v1r_qbz(:, :, ispden, ipc) = v1r_qbz(:, :, ispden, ipc) - v1r_lr(:, :, imyp)
2543 : end do
2544 : end do
2545 : end if
2546 :
2547 : ! Compute FT phases for this qpt_bz.
2548 4820 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
2549 :
2550 : ! Slow FT.
2551 8414 : do imyp=1,db%my_npert
2552 7209 : ipc = db%my_pinfo(3, imyp)
2553 15623 : do ispden=1,db%nspden
2554 65243154 : do ifft=1,nfft
2555 : db%wsr(1, :, ifft, ispden, imyp) = db%wsr(1, :, ifft, ispden, imyp) &
2556 : + emiqr(1, :) * v1r_qbz(1, ifft, ispden, ipc) &
2557 3408342336 : - emiqr(2, :) * v1r_qbz(2, ifft, ispden, ipc)
2558 :
2559 7209 : if (DEBUG_WSR_IMAG) then
2560 : wsi_diag(:, ifft, ispden, imyp) = wsi_diag(:, ifft, ispden, imyp) &
2561 : + emiqr(1, :) * v1r_qbz(2, ifft, ispden, ipc) &
2562 : + emiqr(2, :) * v1r_qbz(1, ifft, ispden, ipc)
2563 : end if
2564 : end do
2565 :
2566 : !call zgerc(db%my_nrpt, nfft, cone, emiqr, 1, v1r_qbz(:,:,ispden,ipc), 1, &
2567 : ! db%wsr(:,:,:,ispden,imyp), db%my_nrpt)
2568 :
2569 : end do ! ispden
2570 : end do ! imyp
2571 : end if
2572 :
2573 : end do ! iqst
2574 :
2575 201 : write(msg,'(2(a,i0),a)') " IBZ q-point [", iq_ibz, "/", nqibz, "]"
2576 201 : call cwtime_report(msg, cpu, wall, gflops)
2577 438 : ABI_FREE(v1r_qibz)
2578 : end do ! iq_ibz
2579 :
2580 36 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
2581 36 : call wrtout(std_out, ch10//ch10)
2582 :
2583 36 : ABI_FREE(iperm)
2584 36 : ABI_FREE(emiqr)
2585 36 : ABI_FREE(qibz)
2586 36 : ABI_FREE(qbz)
2587 36 : ABI_FREE(indqq)
2588 36 : ABI_FREE(iqs_dvdb)
2589 36 : ABI_FREE(nqsts)
2590 36 : ABI_FREE(v1r_qbz)
2591 36 : ABI_FREE(v1r_lr)
2592 :
2593 : !call xmpi_sum(db%wsr, db%comm, ierr)
2594 138868110 : db%wsr = db%wsr / nqbz
2595 :
2596 : if (DEBUG_WSR_IMAG) then
2597 : wsi_diag = wsi_diag / nqbz
2598 : write(std_out, "(a)")" --- DEBUG_WSR_IMAG: discarded Im[W(R,r)] vs kept Re[W(R,r)], per perturbation (imyp) ---"
2599 : do imyp=1,db%my_npert
2600 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2601 : write(std_out, "(a,i0,a,i0,a,i0,a,es12.4,a,es12.4)") &
2602 : " imyp=", imyp, " idir=", idir, " ipert=", ipert, &
2603 : " max|Im[wsr]|=", maxval(abs(wsi_diag(:,:,:,imyp))), &
2604 : " max|Re[wsr]|=", maxval(abs(real(db%wsr(1,:,:,:,imyp), kind=dp)))
2605 : end do
2606 : ABI_FREE(wsi_diag)
2607 : end if
2608 :
2609 36 : wsr_ptr => db%wsr
2610 : #ifdef HAVE_OPENMP_OFFLOAD
2611 : ! Upload wsr array to GPU
2612 : !$OMP TARGET ENTER DATA MAP(to:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
2613 : #endif
2614 :
2615 36 : call cwtime_report(" Construction of W(R,r)", cpu_all, wall_all, gflops_all)
2616 :
2617 144 : end subroutine dvdb_ftinterp_setup
2618 : !!***
2619 :
2620 : !----------------------------------------------------------------------
2621 :
2622 : !!****f* m_dvdb/dvdb_get_maxw
2623 : !! NAME
2624 : !! dvdb_get_maxw
2625 : !!
2626 : !! FUNCTION
2627 : !! Compute max_r |W(R,r)|
2628 : !!
2629 : !! INPUTS
2630 : !!
2631 : !! FUNCTION
2632 :
2633 1 : subroutine dvdb_get_maxw(db, ngqpt, all_rpt, all_rmod, maxw)
2634 :
2635 : !Arguments ------------------------------------
2636 : !scalars
2637 : class(dvdb_t),intent(in) :: db
2638 : integer,intent(in) :: ngqpt(3)
2639 : real(dp),allocatable,intent(out) :: maxw(:,:), all_rpt(:,:), all_rmod(:)
2640 :
2641 : !Local variables-------------------------------
2642 : !scalars
2643 : integer :: imyp, ipc, irpt, irpt_tot, ifft, nfft, ispden, ierr, ii
2644 : real(dp) :: phre
2645 : !arrays
2646 1 : integer,allocatable :: iperm_irpt(:)
2647 : real(dp) :: sc_rprimd(3,3)
2648 : ! *************************************************************************
2649 :
2650 1 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
2651 :
2652 1 : nfft = size(db%wsr, dim=3)
2653 58 : ABI_CALLOC(maxw, (db%nrtot, db%natom3))
2654 :
2655 : ! Need all RPTs to sort output.
2656 35 : ABI_CALLOC(all_rpt, (3, db%nrtot))
2657 9 : do irpt=1,db%my_nrpt
2658 8 : irpt_tot = db%my_irpt2tot(irpt)
2659 33 : all_rpt(:, irpt_tot) = db%my_rpt(:, irpt)
2660 : end do
2661 1 : call xmpi_sum(all_rpt, db%comm_rpt, ierr)
2662 :
2663 7 : do imyp=1,db%my_npert
2664 6 : ipc = db%my_pinfo(3, imyp)
2665 55 : do irpt=1,db%my_nrpt
2666 48 : irpt_tot = db%my_irpt2tot(irpt)
2667 48 : phre = zero
2668 96 : do ispden=1,db%nspden
2669 196704 : do ifft=1,nfft
2670 196656 : phre = max(phre, real(db%wsr(1,irpt,ifft,ispden,imyp), kind=dp) ** 2) ! + db%wsr(2,irpt,ifft,ispden,imyp) ** 2)
2671 : end do
2672 : end do
2673 54 : maxw(irpt_tot, ipc) = sqrt(phre)
2674 : end do
2675 : end do
2676 :
2677 : ! Handle parallelism
2678 1 : if (db%nprocs_rpt /= 1) call xmpi_sum(maxw, db%comm_rpt, ierr)
2679 1 : if (db%nprocs_pert /= 1) call xmpi_sum(maxw, db%comm_pert, ierr)
2680 :
2681 1 : sc_rprimd(:, 1) = ngqpt(1) * db%cryst%rprimd(:, 1)
2682 : sc_rprimd(:, 2) = ngqpt(2) * db%cryst%rprimd(:, 2)
2683 : sc_rprimd(:, 3) = ngqpt(3) * db%cryst%rprimd(:, 3)
2684 1 : call sort_rpts(db%nrtot, all_rpt, db%cryst%rmet, iperm_irpt, rmod=all_rmod)
2685 :
2686 : ! Sort output results by |R|.
2687 66 : all_rpt = all_rpt(:, iperm_irpt(:))
2688 7 : do ii=1,db%natom3
2689 103 : maxw(:, ii) = maxw(iperm_irpt(:), ii)
2690 : end do
2691 :
2692 1 : ABI_FREE(iperm_irpt)
2693 :
2694 1 : end subroutine dvdb_get_maxw
2695 : !!***
2696 :
2697 : !----------------------------------------------------------------------
2698 :
2699 : !!****f* m_dvdb/prepare_ftinterp
2700 : !! NAME
2701 : !! prepare_ftinterp
2702 : !!
2703 : !! FUNCTION
2704 : !! Helper function used to prepare the Fourier interpolation of the DFPT potentials.
2705 :
2706 36 : subroutine prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2707 : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm, comm)
2708 :
2709 : !Arguments ------------------------------------
2710 : !scalars
2711 : integer,intent(in) :: nqshift, qptopt, comm
2712 : class(dvdb_t),target,intent(in) :: db
2713 : !arrays
2714 : integer,intent(in) :: ngqpt(3)
2715 : real(dp),intent(in) :: qshift(3,nqshift)
2716 : integer,allocatable,intent(out) :: indqq(:,:), nqsts(:), iqs_dvdb(:), iperm(:)
2717 : real(dp),allocatable,intent(out) :: all_rpt(:,:), all_wghatm(:,:,:)
2718 : real(dp),allocatable,intent(out) :: qibz(:,:),qbz(:,:)
2719 :
2720 : !Local variables-------------------------------
2721 : !scalars
2722 : integer,parameter :: cutmode2 = 2
2723 : integer :: iq_ibz,nqibz,iq_bz,nqbz,ii,iq_dvdb
2724 : integer :: iqst,nqst,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3, nrtot
2725 : real(dp) :: r_inscribed_sphere
2726 : logical :: found
2727 : character(len=500) :: msg
2728 : type(crystal_t),pointer :: cryst
2729 36 : type(krank_t) :: qrank
2730 : !arrays
2731 : integer :: qptrlatt(3,3)
2732 36 : integer,allocatable :: bz2ibz_sort(:),all_cell(:,:)
2733 72 : real(dp) :: shift(3), rcan(3, db%cryst%natom), trans(3, db%cryst%natom), acell(3), rprim(3,3), gprim(3,3)
2734 36 : real(dp),allocatable :: wtq(:),all_rcart(:,:)
2735 : ! *************************************************************************
2736 :
2737 36 : cryst => db%cryst
2738 :
2739 : ! Generate q-mesh: find BZ, IBZ and the corresponding weights from ngqpt.
2740 36 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3)
2741 36 : qptrlatt = 0; qptrlatt(1, 1) = ngqpt(1); qptrlatt(2, 2) = ngqpt(2); qptrlatt(3, 3) = ngqpt(3)
2742 :
2743 36 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
2744 144 : ABI_CHECK(all(qshift(:, 1) == zero), "qshift != 0 not supported")
2745 :
2746 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nqshift, qshift, &
2747 36 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
2748 :
2749 144 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
2750 :
2751 72 : select case (db%rspace_cell)
2752 : case (0)
2753 : ! Generate q-mesh
2754 : #if 1
2755 36 : ABI_FREE(qbz)
2756 108 : ABI_MALLOC(qbz, (3, nqbz))
2757 36 : ii = 0
2758 143 : do iz=0,nq3-1
2759 494 : do iy=0,nq2-1
2760 1699 : do ix=0,nq1-1
2761 1241 : ii = ii + 1
2762 4964 : qbz(:, ii) = [ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)]
2763 5315 : call wrap2_pmhalf([ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)], qbz(:,ii), shift)
2764 : end do
2765 : end do
2766 : end do
2767 : #endif
2768 :
2769 : ! Compute real-space points in the supercell
2770 : ! Use the following indexing (N means ngfft on the adequate direction)
2771 : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
2772 : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
2773 36 : nrtot = nqbz
2774 5036 : ABI_CALLOC(all_rpt, (3, nrtot))
2775 36 : ii = 0
2776 143 : do iz=1,nq3
2777 107 : r3 = ig2gfft(iz, nq3)
2778 494 : do iy=1,nq2
2779 351 : r2 = ig2gfft(iy, nq2)
2780 1699 : do ix=1,nq1
2781 1241 : r1 = ig2gfft(ix, nq1)
2782 1241 : ii = ii + 1
2783 5315 : all_rpt(:, ii) = [r1, r2, r3]
2784 : end do
2785 : end do
2786 : end do
2787 :
2788 : case (1)
2789 : ! Use Wigner-Seitz cell.
2790 : !
2791 : ! Compute rprim, and gprim
2792 0 : call mkradim(acell, rprim, cryst%rprimd)
2793 0 : call canat9(db%brav, cryst%natom, rcan, rprim, trans, cryst%xred)
2794 0 : call matr3inv(rprim, gprim)
2795 :
2796 : ! In principle one may have N_R that depends on iatom to minimize memory.
2797 : call get_bigbox_and_weights(db%brav, cryst%natom, nqbz, ngqpt, nqshift, qshift, rprim, cryst%rprimd, gprim, rcan, &
2798 0 : cutmode2, nrtot, all_rcart, all_cell, all_wghatm, r_inscribed_sphere, comm)
2799 0 : ABI_FREE(all_cell)
2800 0 : do ii=1,nrtot
2801 0 : all_rcart(:,ii) = all_rcart(:,ii) * acell(:)
2802 : end do
2803 0 : ABI_MALLOC(all_rpt, (3, nrtot))
2804 0 : call xcart2xred(nrtot, cryst%rprimd, all_rcart, all_rpt)
2805 0 : ABI_FREE(all_rcart)
2806 :
2807 : case default
2808 36 : ABI_ERROR(sjoin("Wrong rspace_cell:", itoa(db%rspace_cell)))
2809 : end select
2810 :
2811 : ! Find correspondence BZ --> IBZ. Note:
2812 : ! - q --> -q symmetry is always used for phonons.
2813 : ! - we use symrec instead of symrel
2814 :
2815 108 : ABI_MALLOC(indqq, (6, nqbz))
2816 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2817 :
2818 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2819 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2820 : end if
2821 :
2822 36 : call qrank%free()
2823 :
2824 : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
2825 108 : ABI_MALLOC(iperm, (nqbz))
2826 72 : ABI_MALLOC(bz2ibz_sort, (nqbz))
2827 3795 : iperm = [(ii, ii=1,nqbz)]
2828 1313 : bz2ibz_sort = indqq(1, :)
2829 36 : call sort_int(nqbz, bz2ibz_sort, iperm)
2830 :
2831 : ! Reconstruct the IBZ according to what is present in the DVDB.
2832 108 : ABI_MALLOC(nqsts, (nqibz))
2833 72 : ABI_MALLOC(iqs_dvdb, (nqibz))
2834 237 : iqs_dvdb = -1
2835 :
2836 : iqst = 0
2837 237 : do iq_ibz=1,nqibz
2838 : ! In each q-point star, count the number of q-points and find the one present in the DVDB.
2839 201 : nqst = 0
2840 201 : found = .false.
2841 1442 : do ii=iqst+1,nqbz
2842 1406 : if (bz2ibz_sort(ii) /= iq_ibz) exit
2843 1241 : nqst = nqst + 1
2844 1241 : iq_bz = iperm(ii)
2845 1442 : if (.not. found) then
2846 671 : iq_dvdb = db%findq(qbz(:,iq_bz))
2847 671 : if (iq_dvdb /= -1) then
2848 804 : qibz(:,iq_ibz) = qbz(:,iq_bz)
2849 201 : iqs_dvdb(iq_ibz) = iq_dvdb
2850 201 : found = .true.
2851 : end if
2852 : end if
2853 : end do
2854 :
2855 : ! Check that nqst has been counted properly.
2856 201 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst + 1) == iq_ibz, "Wrong iqst")
2857 201 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
2858 0 : write(msg, "(a,i0,a,f5.2)")"Error in q-point star or q-weights. nqst:", nqst, "wtq * nqbz = ", wtq(iq_ibz) * nqbz
2859 0 : ABI_ERROR(msg)
2860 : end if
2861 :
2862 : ! Check that the q-point has been found in DVDB.
2863 201 : ABI_CHECK(found, sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
2864 :
2865 201 : iqst = iqst + nqst
2866 237 : nqsts(iq_ibz) = nqst
2867 : end do
2868 :
2869 36 : ABI_FREE(wtq)
2870 36 : ABI_FREE(bz2ibz_sort)
2871 :
2872 : ! Redo the mapping with the new IBZ
2873 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2874 :
2875 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2876 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2877 : end if
2878 36 : call qrank%free()
2879 :
2880 36 : end subroutine prepare_ftinterp
2881 : !!***
2882 :
2883 : !----------------------------------------------------------------------
2884 :
2885 : !!****f* m_dvdb/dvdb_ftinterp_qpt
2886 : !! NAME
2887 : !! dvdb_ftinterp_qpt
2888 : !!
2889 : !! FUNCTION
2890 : !! Fourier interpolation of potentials for a given q-point
2891 : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
2892 : !!
2893 : !! \begin{equation}
2894 : !! \partial v^{scf}_{\tilde\qq\kappa\alpha}(\rr) \approx \sum_\RR e^{+i\tilde{\qq}\cdot(\RR - \rr)} W_{\kappa\alpha}(\rr,\RR).
2895 : !! \end{equation
2896 : !!
2897 : !! INPUTS
2898 : !! qpt(3)=q-point in reduced coordinates (arbitrary point in the BZ).
2899 : !! nfft=Number of FFT-points treated by this processors.
2900 : !! ngfft(18)=contain all needed information about 3D FFT.
2901 : !! comm=MPI communicator for R-points.
2902 : !! [add_lr]= If present, use this value for the LR treatment instead of dv%add_lr
2903 : !!
2904 : !! OUTPUT
2905 : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point (periodic part)
2906 : !!
2907 : !! SOURCE
2908 :
2909 3762 : subroutine dvdb_ftinterp_qpt(db, qpt, nfft, ngfft, ov1r, comm_rpt, add_lr)
2910 :
2911 : !Arguments ------------------------------------
2912 : !scalars
2913 : integer,intent(in) :: nfft, comm_rpt
2914 : integer,optional,intent(in) :: add_lr
2915 : class(dvdb_t),intent(inout) :: db
2916 : !arrays
2917 : integer,intent(in) :: ngfft(18)
2918 : real(dp),intent(in) :: qpt(3)
2919 : real(dp),intent(out) :: ov1r(2, nfft, db%nspden, db%my_npert)
2920 :
2921 : !Local variables-------------------------------
2922 : !scalars
2923 : integer,parameter :: cplex2 = 2
2924 : integer :: ispden, imyp, idir, ipert, timerev_q, ierr, my_add_lr !, ifft, ir
2925 : !real(dp) :: qmod
2926 : !real(sp) :: beta_sp !, wr !,wi
2927 : logical :: prev_has_zeff, prev_has_quadrupoles, prev_has_efield
2928 : !arrays
2929 3762 : integer :: symq(4,2,db%cryst%nsym), rfdir(3)
2930 3762 : integer,allocatable :: pertsy(:,:), rfpert(:), pflag(:,:)
2931 : !real(dp) :: qcart(3)
2932 3762 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:,:)
2933 3762 : real(sp),allocatable :: weiqr_sp(:,:), ov1r_sp(:, :), eiqr_sp(:,:)
2934 : ! *************************************************************************
2935 :
2936 3762 : my_add_lr = db%add_lr; if (present(add_lr)) my_add_lr = add_lr
2937 :
2938 : !qcart = two_pi * matmul(db%cryst%gprimd, qpt)
2939 : !qmod = sqrt(dot_product(qcart, qcart))
2940 :
2941 3762 : if (my_add_lr >= 4) then
2942 : ! Use LR part only and return immediately.
2943 0 : if (my_add_lr > 4) then
2944 0 : prev_has_zeff = db%has_zeff
2945 0 : prev_has_quadrupoles = db%has_quadrupoles
2946 0 : prev_has_efield = db%has_efield
2947 0 : db%has_zeff = .False.
2948 0 : db%has_quadrupoles = .False.
2949 0 : db%has_efield = .False.
2950 0 : if (my_add_lr == 5 .and. prev_has_zeff) db%has_zeff = .True.
2951 0 : if (my_add_lr == 6 .and. prev_has_quadrupoles) db%has_quadrupoles = .True.
2952 0 : if (my_add_lr == 7 .and. prev_has_efield) db%has_efield = .True.
2953 : end if
2954 :
2955 0 : ov1r = zero
2956 0 : do imyp=1,db%my_npert
2957 0 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2958 0 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, ov1r(:, :, 1, imyp))
2959 : ! Remove the phase to get the lattice-periodic part.
2960 0 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, 1, imyp))
2961 0 : if (db%nspden /= 1) ov1r(:, :, 2, imyp) = ov1r(:, :, 1, imyp)
2962 : end do
2963 :
2964 0 : if (my_add_lr > 4) then
2965 : ! Restore input flags.
2966 0 : db%has_zeff = prev_has_zeff
2967 0 : db%has_quadrupoles = prev_has_quadrupoles
2968 0 : db%has_efield = prev_has_efield
2969 : end if
2970 :
2971 0 : return
2972 : end if
2973 :
2974 3762 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
2975 :
2976 : ! Examine the symmetries of the q-wavevector
2977 3762 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
2978 :
2979 : ! Compute long-range part of the coupling potential.
2980 3762 : if (my_add_lr > 0) then
2981 : !call wrtout(std_out, "dvdb_ftinterp_qpt: Computing long-range part of the coupling potential.")
2982 10056 : ABI_MALLOC(v1r_lr, (2, nfft, db%my_npert))
2983 17598 : do imyp=1,db%my_npert
2984 15084 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2985 17598 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
2986 : end do
2987 : end if
2988 :
2989 : ! Compute e^{iq.R} FT phases for this q-point.
2990 11286 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
2991 3762 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
2992 :
2993 : ! Interpolate potentials (results in ov1r)
2994 3762 : if (db%nprocs_rpt > 1) ov1r = zero
2995 11286 : ABI_MALLOC(ov1r_sp, (2, nfft))
2996 :
2997 11286 : ABI_MALLOC(weiqr_sp, (db%my_nrpt, 2))
2998 7524 : ABI_MALLOC(eiqr_sp, (db%my_nrpt, 2))
2999 275908 : eiqr_sp = transpose(eiqr)
3000 :
3001 23778 : do imyp=1,db%my_npert
3002 20016 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
3003 :
3004 782148 : weiqr_sp(:, 1) = db%my_wratm(:, ipert) * eiqr_sp(:, 1)
3005 782148 : weiqr_sp(:, 2) = db%my_wratm(:, ipert) * eiqr_sp(:, 2)
3006 :
3007 40032 : do ispden=1,db%nspden
3008 :
3009 : ! We need to compute: sum_R W(R, r) e^{iq.R} with W real matrix.
3010 : ! Use BLAS2 to compute ov1r = W (x + iy) but need to handle kind conversion as ov1r is double-precision
3011 : ! NB: Can use MKL BLAS-like extensions to perform 2 matrix-vector operations:
3012 : ! call dgem2vu(m, n, alpha, a, lda, x1, incx1, x2, incx2, beta, y1, incy1, y2, incy2)
3013 : ! unfortunately the API does not support transa so one has to transport db%wsr.
3014 : ! Alternatively, compute all my_npert with ZGEMM (more memory but it should be more efficient).
3015 :
3016 : !select case (db%gpu_option)
3017 : !case (ABI_GPU_DISABLED)
3018 : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,1), 1, &
3019 20016 : zero_sp, ov1r_sp(1,1), 2)
3020 : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,2), 1, &
3021 20016 : zero_sp, ov1r_sp(2,1), 2)
3022 : !case (ABI_GPU_OPENMP)
3023 : ! TODO
3024 : !case default
3025 : ! ABI_ERROR(sjoin("ftinterp_qpt: unsupported gpu_option:", itoa(db%gpu_option)))
3026 : !end select
3027 :
3028 406968624 : ov1r(:, :, ispden, imyp) = ov1r_sp(:, :)
3029 :
3030 : ! Add the long-range part of the potential
3031 20016 : if (my_add_lr > 0) then
3032 : !call wrtout(std_out, "Adding the long-range part of the potential")
3033 164629692 : ov1r(:, :, ispden, imyp) = ov1r(:, :, ispden, imyp) + v1r_lr(:, :, imyp)
3034 : end if
3035 :
3036 : ! Remove the phase to get the lattice-periodic part.
3037 80064 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, ispden, imyp))
3038 :
3039 : ! Need to collect results if R-points are distributed (TODO Non-blocking API?)
3040 40032 : if (db%nprocs_rpt > 1) call xmpi_sum(ov1r(:,:,ispden,imyp), comm_rpt, ierr)
3041 : end do ! ispden
3042 :
3043 : ! Be careful with Gamma-point and cplex!
3044 23778 : if (db%symv1 == 1) then !(.and. receiver == -1 .or. receiver == db%comm_rpt%my_rank)
3045 : call v1phq_symmetrize(db%cryst, idir, ipert, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, &
3046 1218 : db%mpi_enreg, ov1r(:,:,:,imyp))
3047 : end if
3048 : end do ! imyp
3049 :
3050 3762 : ABI_FREE(ov1r_sp)
3051 :
3052 3762 : if (db%symv1 == 2) then
3053 : ! Symmetrize potentials (this part is seldom executed)
3054 : ! Initialize the list of perturbations rfpert and rdfir
3055 : ! WARNING: Only phonon perturbations are considered for the time being.
3056 0 : ABI_MALLOC(rfpert, (db%mpert))
3057 0 : rfpert = 0; rfpert(1:db%cryst%natom) = 1; rfdir = 1
3058 0 : ABI_MALLOC(pertsy, (3, db%mpert))
3059 0 : ABI_MALLOC(pflag, (3, db%natom))
3060 :
3061 : ! Determine the symmetrical perturbations. Meaning of pertsy:
3062 : ! 0 for non-target perturbations
3063 : ! 1 for basis perturbations
3064 : ! -1 for perturbations that can be found from basis perturbations
3065 : call irreducible_set_pert(db%cryst%indsym,db%mpert,db%cryst%natom,db%cryst%nsym,&
3066 0 : pertsy,rfdir,rfpert,symq,db%cryst%symrec,db%cryst%symrel)
3067 :
3068 0 : pflag = 0
3069 0 : do imyp=1,3*db%cryst%natom
3070 0 : idir = mod(imyp-1, 3) + 1; ipert = (imyp - idir) / 3 + 1
3071 0 : if (pertsy(idir, ipert) == 1) pflag(idir,ipert) = 1
3072 : end do
3073 :
3074 : ! Complete potentials
3075 0 : call v1phq_complete(db%cryst,qpt,ngfft,cplex2,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,ov1r)
3076 :
3077 0 : ABI_FREE(pertsy)
3078 0 : ABI_FREE(rfpert)
3079 0 : ABI_FREE(pflag)
3080 : endif
3081 :
3082 : ! Set imaginary part to zero if gamma point.
3083 6133032 : if (sum(qpt**2) < tol14) ov1r(2, :, :, :) = zero
3084 :
3085 3762 : ABI_FREE(eiqr)
3086 3762 : ABI_FREE(weiqr_sp)
3087 3762 : ABI_SFREE(v1r_lr)
3088 3762 : ABI_SFREE(eiqr_sp)
3089 :
3090 3762 : end subroutine dvdb_ftinterp_qpt
3091 : !!***
3092 :
3093 : !----------------------------------------------------------------------
3094 :
3095 : !!****f* m_dvdb/dvdb_get_ftqbz
3096 : !! NAME
3097 : !! dvdb_get_ftqbz
3098 : !!
3099 : !! FUNCTION
3100 : !! Fourier interpolation of potentials for a given q-point in the BZ (qbz).
3101 : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
3102 : !!
3103 : !! INPUTS
3104 : !! qbz(3)= q-point in the BZ in reduced coordinates.
3105 : !! nfft=Number of fft-points treated by this processors
3106 : !! ngfft(18)=contain all needed information about 3D FFT
3107 : !!
3108 : !! OUTPUT
3109 : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point.
3110 : !!
3111 : !! SOURCE
3112 :
3113 3757 : subroutine dvdb_get_ftqbz(db, qbz, cplex, nfft, ngfft, v1scf, comm)
3114 :
3115 : !Arguments ------------------------------------
3116 : !scalars
3117 : class(dvdb_t),intent(inout) :: db
3118 : integer,intent(in) :: nfft, comm
3119 : integer,intent(out) :: cplex
3120 : !arrays
3121 : integer,intent(in) :: ngfft(18)
3122 : real(dp),intent(in) :: qbz(3)
3123 : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3124 :
3125 : !Local variables-------------------------------
3126 : real(dp) :: tsec(2)
3127 : ! *************************************************************************
3128 :
3129 : ABI_UNUSED(comm)
3130 :
3131 : ! Keep track of total time spent.
3132 3757 : call timab(1809, 1, tsec)
3133 :
3134 : ! Interpolate the dvscf potentials directly in the **BZ** for my_npert perturbations.
3135 : ! This is possible only if all procs inside comm_rpt call this routine else deadlock
3136 : ! Note that cplex is always set to 2 here
3137 3757 : cplex = 2
3138 18785 : ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
3139 3757 : call db%ftinterp_qpt(qbz, nfft, ngfft, v1scf, db%comm_rpt)
3140 3757 : call timab(1809, 2, tsec)
3141 :
3142 3757 : end subroutine dvdb_get_ftqbz
3143 : !!***
3144 :
3145 : !----------------------------------------------------------------------
3146 :
3147 : !!****f* m_dvdb/dvdb_get_vxc1_ftqbz
3148 : !! NAME
3149 : !! dvdb_get_vxc1_ftqbz
3150 : !!
3151 : !! FUNCTION
3152 : !! Fourier interpolation of the first-order change of exchange-correlation potential
3153 : !! for a given q-point in the BZ (qbz).
3154 : !!
3155 : !! INPUTS
3156 : !! cryst<crystal_t>=crystal structure parameters
3157 : !! dtset<dataset_type>=All input variables for this dataset
3158 : !! qbz(3)=Q-point in BZ
3159 : !! nfft=Number of fft-points treated by this processors
3160 : !! ngfft(18)=contain all needed information about 3D FFT
3161 : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
3162 : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
3163 : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
3164 : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
3165 : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
3166 : !!
3167 : !! OUTPUT
3168 : !! drho_cplex=1 if real, 2 if complex.
3169 : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
3170 : !! for the db%my_npert perturbations treated by this MPI rank.
3171 : !!
3172 : !! SOURCE
3173 :
3174 0 : subroutine dvdb_get_vxc1_ftqbz(db, dtset, cryst, qbz, drho_cplex, nfft, ngfft, nkxc, kxc, &
3175 : vxc1, non_magnetic_xc, usexcnhat, comm)
3176 :
3177 : !Arguments ------------------------------------
3178 : !scalars
3179 : class(dvdb_t),intent(inout) :: db
3180 : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
3181 : integer,intent(out) :: drho_cplex
3182 : real(dp),intent(in) :: qbz(3)
3183 : type(dataset_type),intent(in) :: dtset
3184 : type(crystal_t),intent(in) :: cryst
3185 : logical,intent(in) :: non_magnetic_xc
3186 : !arrays
3187 : integer,intent(in) :: ngfft(18)
3188 : real(dp),intent(in) :: kxc(nfft,nkxc)
3189 : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
3190 :
3191 : !Local variables-------------------------------
3192 : !scalars
3193 : integer :: option,imyp
3194 : !arrays
3195 0 : real(dp),allocatable :: rho1(:,:,:,:)
3196 : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
3197 : ! *************************************************************************
3198 :
3199 : ! Get rho1(cplex, nfftf, nspden, my_npert))
3200 0 : call db%get_ftqbz(qbz, drho_cplex, nfft, ngfft, rho1, comm)
3201 :
3202 0 : option = 2 ! if 2, treat only density change
3203 : !option = 1 ! if 1, treat both density change and XC core correction
3204 0 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
3205 :
3206 0 : do imyp=1,db%my_npert
3207 : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
3208 : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp),&
3209 0 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
3210 : end do
3211 :
3212 0 : ABI_FREE(rho1)
3213 :
3214 0 : end subroutine dvdb_get_vxc1_ftqbz
3215 : !!***
3216 :
3217 : !----------------------------------------------------------------------
3218 :
3219 : !!****f* m_dvdb/dvdb_get_v1scf_rpt
3220 : !! NAME
3221 : !! dvdb_get_v1scf_rpt
3222 : !!
3223 : !! FUNCTION
3224 : !! Compute the phonon perturbation potential in real space lattice representation.
3225 : !! This routine is meant to replace dvdb_ftinterp_setup
3226 : !! and performs the potential interpolation one perturbation at a time.
3227 : !!
3228 : !! INPUTS
3229 : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3230 : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3231 : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3232 : !! nfft=Number of fft-points treated by this processors
3233 : !! ngfft(18)=contain all needed information about 3D FFT
3234 : !! nrpt=Number of R-points = number of q-points in the full BZ
3235 : !! nspden=Number of spin densities.
3236 : !! ipert=index of the perturbation to be treated [1,natom3]
3237 : !! comm=MPI communicator
3238 : !!
3239 : !! OUTPUT
3240 : !! v1scf_rpt(2,nrpt,nfft,nspden)
3241 : !!
3242 : !! SOURCE
3243 :
3244 31 : subroutine dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3245 31 : nrpt, nspden, ipert, v1scf_rpt, comm)
3246 :
3247 : !Arguments ------------------------------------
3248 : !scalars
3249 : integer,intent(in) :: nqshift,nfft,nrpt,nspden,ipert,comm
3250 : class(dvdb_t),target,intent(inout) :: db
3251 : !arrays
3252 : integer,intent(in) :: ngqpt(3),ngfft(18)
3253 : real(dp),intent(in) :: qshift(3,nqshift)
3254 : real(dp),intent(out) :: v1scf_rpt(2,nrpt,nfft,nspden)
3255 : type(crystal_t),intent(in) :: cryst
3256 :
3257 : !Local variables-------------------------------
3258 : !scalars
3259 : integer,parameter :: sppoldbl1=1, timrev1=1
3260 : integer :: my_qptopt,iq_ibz,nqibz,iq_bz,nqbz
3261 : integer :: ii,iq_dvdb,cplex_qibz,ispden,irpt,idir,iat
3262 : integer :: iqst,nqst,itimrev,tsign,isym,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3
3263 : integer :: nproc,my_rank,ifft,cnt,ierr
3264 : character(len=500) :: msg
3265 : real(dp) :: dksqmax, cpu, wall, gflops
3266 : logical :: isirr_q, found
3267 : !arrays
3268 : integer :: qptrlatt(3,3),g0q(3)
3269 31 : integer,allocatable :: indqq(:,:),iperm(:),bz2ibz_sort(:),nqsts(:),iqs_dvdb(:)
3270 : real(dp) :: qpt_bz(3),shift(3)
3271 31 : real(dp),allocatable :: qibz(:,:),qbz(:,:),wtq(:),emiqr(:,:)
3272 31 : real(dp),allocatable :: v1r_qibz(:,:,:,:),v1r_qbz(:,:,:,:), v1r_lr(:,:)
3273 : ! *************************************************************************
3274 :
3275 : !ABI_ERROR("Legacy code!")
3276 :
3277 31 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3278 :
3279 31 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3); my_qptopt = 1 !; if (present(qptopt)) my_qptopt = qptopt
3280 :
3281 : ! Generate the q-mesh by finding the IBZ and the corresponding weights.
3282 31 : qptrlatt = 0
3283 124 : do ii=1,3
3284 124 : qptrlatt(ii,ii) = ngqpt(ii)
3285 : end do
3286 :
3287 : ! Get IBZ and BZ.
3288 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, &
3289 31 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
3290 :
3291 : !write(std_out,*)"Irreducible q-points:"
3292 : !do iq_ibz=1,nqibz; write(std_out,*)trim(ktoa(qibz(:,iq_ibz))),wtq(iq_ibz)*nqbz; end do
3293 124 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
3294 31 : ABI_CHECK(nqbz == nrpt, "nqbz /= nrpt")
3295 :
3296 31 : db%my_nrpt = nqbz
3297 :
3298 31 : ABI_CHECK(nspden == db%nspden, "nspden /= db%nspden")
3299 :
3300 : ! We want a gamma centered q-mesh for FFT.
3301 31 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
3302 124 : ABI_CHECK(all(qshift(:,1) == zero), "qshift != 0 not supported")
3303 :
3304 31 : ABI_FREE(qbz)
3305 93 : ABI_MALLOC(qbz, (3, nqbz))
3306 31 : ii = 0
3307 99 : do iz=0,nq3-1
3308 259 : do iy=0,nq2-1
3309 644 : do ix=0,nq1-1
3310 416 : ii = ii + 1
3311 1664 : qbz(:, ii) = [ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)]
3312 1824 : call wrap2_pmhalf([ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)], qbz(:,ii), shift)
3313 : end do
3314 : end do
3315 : end do
3316 :
3317 : ! Compute real-space points.
3318 : ! Use the following indexing (N means ngfft of the adequate direction)
3319 : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
3320 : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
3321 93 : ABI_MALLOC(db%my_rpt, (3, db%my_nrpt))
3322 31 : ii = 0
3323 99 : do iz=1,nq3
3324 68 : r3 = ig2gfft(iz,nq3)
3325 259 : do iy=1,nq2
3326 160 : r2 = ig2gfft(iy,nq2)
3327 644 : do ix=1,nq1
3328 416 : r1 = ig2gfft(ix,nq1)
3329 416 : ii = ii + 1
3330 1824 : db%my_rpt(:,ii) = [r1, r2, r3]
3331 : end do
3332 : end do
3333 : end do
3334 :
3335 : ! Find correspondence BZ --> IBZ. Note:
3336 : ! q --> -q symmetry is always used for phonons.
3337 : ! we use symrec instead of symrel
3338 93 : ABI_MALLOC(indqq, (nqbz*sppoldbl1,6))
3339 : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,&
3340 31 : sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.)
3341 :
3342 : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3343 : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3344 : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3345 : !call qrank%free()
3346 :
3347 31 : if (dksqmax > tol12) then
3348 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3349 : end if
3350 :
3351 : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
3352 93 : ABI_MALLOC(iperm, (nqbz))
3353 62 : ABI_MALLOC(bz2ibz_sort, (nqbz))
3354 1310 : iperm = [(ii, ii=1,nqbz)]
3355 478 : bz2ibz_sort = indqq(:,1)
3356 31 : call sort_int(nqbz, bz2ibz_sort, iperm)
3357 :
3358 : ! Reconstruct the IBZ according to what is present in the DVDB.
3359 93 : ABI_MALLOC(nqsts, (nqibz))
3360 62 : ABI_MALLOC(iqs_dvdb, (nqibz))
3361 93 : ABI_MALLOC(v1r_lr, (2,nfft))
3362 :
3363 31 : iqst = 0
3364 139 : do iq_ibz=1,nqibz
3365 : ! In each q-point star, count the number of q-points and find the one present in DVDB.
3366 108 : nqst = 0
3367 108 : found = .false.
3368 524 : do ii=iqst+1,nqbz
3369 493 : if (bz2ibz_sort(ii) /= iq_ibz) exit
3370 416 : nqst = nqst + 1
3371 :
3372 416 : iq_bz = iperm(ii)
3373 524 : if (.not. found) then
3374 317 : iq_dvdb = db%findq(qbz(:,iq_bz))
3375 317 : if (iq_dvdb /= -1) then
3376 432 : qibz(:,iq_ibz) = qbz(:,iq_bz)
3377 108 : iqs_dvdb(iq_ibz) = iq_dvdb
3378 108 : found = .true.
3379 : end if
3380 : end if
3381 : end do
3382 :
3383 : ! Check that nqst has been counted properly.
3384 108 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst+1) == iq_ibz, "Wrong iqst")
3385 108 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
3386 0 : write(std_out,*)nqst, wtq(iq_ibz) * nqbz
3387 0 : ABI_ERROR("Error in counting q-point star or in the weights.")
3388 : end if
3389 :
3390 : ! Check that the q-point has been found in DVDB.
3391 108 : if (.not. found) then
3392 0 : ABI_ERROR(sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
3393 : end if
3394 : !write(std_out,*)sjoin("qpt irred:",ktoa(qibz(:,iq_ibz)))
3395 :
3396 108 : iqst = iqst + nqst
3397 139 : nqsts(iq_ibz) = nqst
3398 : end do
3399 :
3400 : ! Redo the mapping with the new IBZ
3401 : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,&
3402 31 : sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.)
3403 :
3404 : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3405 : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3406 : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3407 : !call qrank%free()
3408 :
3409 31 : if (dksqmax > tol12) then
3410 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3411 : end if
3412 :
3413 93 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
3414 11230149 : v1scf_rpt = zero
3415 :
3416 155 : ABI_MALLOC_OR_DIE(v1r_qbz, (2, nfft, db%nspden, db%natom3), ierr)
3417 : !v1r_qbz = huge(one)
3418 :
3419 31 : iqst = 0
3420 31 : call cwtime(cpu, wall, gflops, "start")
3421 139 : do iq_ibz=1,nqibz
3422 :
3423 : ! Get potentials for this IBZ q-point on the real-space FFT mesh.
3424 : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
3425 108 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, comm)
3426 :
3427 : ! Reconstruct by symmetry the potentials for the star of this q-point, perform FT and accumulate
3428 : ! Be careful with the gamma point.
3429 524 : do ii=1,nqsts(iq_ibz)
3430 416 : iqst = iqst + 1
3431 416 : iq_bz = iperm(iqst)
3432 416 : ABI_CHECK(iq_ibz == indqq(iq_bz,1), "iq_ibz !/ ind qq(1)")
3433 1664 : isym = indqq(iq_bz,2); itimrev = indqq(iq_bz,6) + 1; g0q = indqq(iq_bz,3:5) ! IS(q_ibz) + g0q = q_bz
3434 416 : tsign = 3-2*itimrev
3435 :
3436 1664 : qpt_bz = qbz(:, iq_bz)
3437 : !write(std_out,*)" treating:",trim(ktoa(qpt_bz))
3438 1681 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
3439 : !ABI_CHECK(all(g0q == 0), "g0q /= 0")
3440 :
3441 : ! Compute long-range part of the coupling potential
3442 : !call cwtime(cpu, wall, gflops, "start")
3443 10816136 : v1r_lr = zero; cnt = 0
3444 416 : if (db%add_lr /= 0) then
3445 128 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3446 128 : call db%get_v1r_long_range(qpt_bz, idir, iat, nfft, ngfft, v1r_lr)
3447 : end if
3448 : !call cwtime_report(" dvdb_get_v1r_long_range", cpu, wall, gflops)
3449 :
3450 524 : if (cplex_qibz == 1) then
3451 : ! Gamma point.
3452 31 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
3453 124 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
3454 :
3455 : ! Subtract the long-range part of the potential
3456 31 : if (db%add_lr /= 0) then
3457 32 : do ispden=1,db%nspden
3458 159090 : v1r_qibz(1,:,ispden,ipert) = v1r_qibz(1,:,ispden,ipert) - v1r_lr(1,:)
3459 : end do
3460 : end if
3461 :
3462 : ! SLOW FT.
3463 : !call cwtime(cpu, wall, gflops, "start")
3464 31 : cnt = 0
3465 62 : do ispden=1,db%nspden
3466 478 : do irpt=1,db%my_nrpt
3467 : ! MPI-parallelism
3468 416 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
3469 3605687 : do ifft=1,nfft
3470 : v1scf_rpt(1,irpt,ifft,ispden) = v1scf_rpt(1,irpt,ifft,ispden) + &
3471 3605656 : v1r_qibz(1, ifft, ispden, ipert)
3472 : end do
3473 : end do
3474 : end do
3475 : !call cwtime_report(" slow fft", cpu, wall, gflops)
3476 :
3477 : else
3478 : ! q /= Gamma
3479 : ! Get the periodic part of the potential in BZ (v1r_qbz)
3480 385 : if (isirr_q) then
3481 : !write(std_out,*)sjoin("qpt irred:",ktoa(qpt_bz))
3482 15058132 : v1r_qbz = v1r_qibz
3483 : else
3484 : !call cwtime(cpu, wall, gflops, "start")
3485 : call v1phq_rotate(cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
3486 308 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
3487 : end if
3488 :
3489 : ! Multiply by e^{iqpt_bz.r}
3490 385 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden*db%natom3, v1r_qbz)
3491 :
3492 : ! Subtract the long-range part of the potential
3493 385 : if (db%add_lr /= 0) then
3494 224 : do ispden=1,db%nspden
3495 1113518 : v1r_qbz(1,:,ispden,ipert) = v1r_qbz(1,:,ispden,ipert) - v1r_lr(1,:)
3496 1113630 : v1r_qbz(2,:,ispden,ipert) = v1r_qbz(2,:,ispden,ipert) - v1r_lr(2,:)
3497 : end do
3498 : end if
3499 :
3500 : ! Compute FT phases for this qpt_bz.
3501 1540 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
3502 :
3503 : ! SLOW FT.
3504 : !call cwtime_report(" phases", cpu, wall, gflops)
3505 385 : cnt = 0
3506 770 : do ispden=1,db%nspden
3507 3191643 : do ifft=1,nfft
3508 3190873 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
3509 :
3510 : v1scf_rpt(1,:,ifft,ispden) = v1scf_rpt(1,:,ifft,ispden) &
3511 : + emiqr(1,:) * v1r_qbz(1, ifft, ispden, ipert) &
3512 47007009 : - emiqr(2,:) * v1r_qbz(2, ifft, ispden, ipert)
3513 :
3514 : v1scf_rpt(2,:,ifft,ispden) = v1scf_rpt(2,:,ifft,ispden) &
3515 : + emiqr(1,:) * v1r_qbz(2, ifft, ispden, ipert) &
3516 47007394 : + emiqr(2,:) * v1r_qbz(1, ifft, ispden, ipert)
3517 : end do
3518 : end do
3519 : !call cwtime_report(" slow fft", cpu, wall, gflops)
3520 : end if
3521 :
3522 : end do ! iqst
3523 :
3524 108 : write(msg,'(2(a,i0),a)') " q-point [",iq_ibz,"/",nqibz,"]"
3525 108 : call cwtime_report(msg, cpu, wall, gflops)
3526 :
3527 139 : ABI_FREE(v1r_qibz)
3528 : end do ! iq_ibz
3529 31 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
3530 :
3531 11230149 : v1scf_rpt = v1scf_rpt / nqbz
3532 31 : call xmpi_sum(v1scf_rpt, comm, ierr)
3533 :
3534 31 : ABI_FREE(emiqr)
3535 31 : ABI_FREE(qibz)
3536 31 : ABI_FREE(wtq)
3537 31 : ABI_FREE(qbz)
3538 31 : ABI_FREE(indqq)
3539 31 : ABI_FREE(iperm)
3540 31 : ABI_FREE(bz2ibz_sort)
3541 31 : ABI_FREE(iqs_dvdb)
3542 31 : ABI_FREE(nqsts)
3543 31 : ABI_FREE(v1r_qbz)
3544 31 : ABI_FREE(v1r_lr)
3545 :
3546 62 : end subroutine dvdb_get_v1scf_rpt
3547 : !!***
3548 :
3549 : !----------------------------------------------------------------------
3550 :
3551 : !!****f* m_dvdb/dvdb_get_v1scf_qpt
3552 : !! NAME
3553 : !! dvdb_get_v1scf_qpt
3554 : !!
3555 : !! FUNCTION
3556 : !! Fourier interpolation of potentials for a given q-point
3557 : !! This routine is meant to replace dvdb_ftinterp_qpt
3558 : !! by performing the interpolation one perturbation at a time.
3559 : !!
3560 : !! INPUTS
3561 : !! qpt(3)=q-point in reduced coordinates.
3562 : !! nfft=Number of fft-points treated by this processors
3563 : !! ngfft(18)=contain all needed information about 3D FFT
3564 : !! nrpt=Number of R-points = number of q-points in the full BZ
3565 : !! nspden=Number of spin densities.
3566 : !! ipert=index of the perturbation to be treated [1,natom3]
3567 : !! v1scf_rpt(2,nrpt,nfft,nspden)=phonon perturbation potential in real space lattice representation.
3568 : !! comm=MPI communicator
3569 : !!
3570 : !! OUTPUT
3571 : !! v1scf_qpt(2*nfft, nspden)=Interpolated DFPT potentials at the given q-point.
3572 : !!
3573 : !! SOURCE
3574 :
3575 244 : subroutine dvdb_get_v1scf_qpt(db, cryst, qpt, nfft, ngfft, nrpt, nspden, &
3576 244 : ipert, v1scf_rpt, v1scf_qpt, comm)
3577 :
3578 : !Arguments ------------------------------------
3579 : !scalars
3580 : integer,intent(in) :: nfft,nrpt,nspden,ipert,comm
3581 : class(dvdb_t),intent(in) :: db
3582 : type(crystal_t),intent(in) :: cryst
3583 : !arrays
3584 : integer,intent(in) :: ngfft(18)
3585 : real(dp),intent(in) :: qpt(3)
3586 : real(dp),intent(in) :: v1scf_rpt(2,nrpt,nfft,db%nspden)
3587 : real(dp),intent(out) :: v1scf_qpt(2,nfft,db%nspden)
3588 :
3589 : !Local variables-------------------------------
3590 : !scalars
3591 : integer,parameter :: cplex2=2
3592 : integer :: ir,ispden,ifft,idir,iat,timerev_q,nproc,my_rank,cnt,ierr
3593 : real(dp) :: wr,wi
3594 : !arrays
3595 488 : integer :: symq(4,2,db%cryst%nsym)
3596 244 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:)
3597 : ! *************************************************************************
3598 :
3599 : !ABI_ERROR("Legacy code!")
3600 :
3601 : ABI_UNUSED(cryst%natom)
3602 : ABI_UNUSED(nspden)
3603 :
3604 244 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3605 :
3606 732 : ABI_MALLOC(v1r_lr, (2,nfft))
3607 :
3608 : ! Examine the symmetries of the q wavevector
3609 244 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
3610 :
3611 : ! Compute FT phases for this q-point.
3612 732 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
3613 244 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
3614 :
3615 244 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3616 :
3617 : ! Compute long-range part of the coupling potential
3618 10437202 : v1r_lr = zero; cnt = 0
3619 244 : if (db%add_lr > 0) call db%get_v1r_long_range(qpt, idir, iat, nfft, ngfft, v1r_lr)
3620 :
3621 : ! TODO: If high-symmetry q-points, one could save flops by FFT interpolating the independent
3622 : ! TODO: Use ZGEMM with MPI
3623 : ! perturbations and then rotate ...
3624 10437446 : v1scf_qpt = zero; cnt = 0
3625 488 : do ispden=1,db%nspden
3626 3479230 : do ifft=1,nfft
3627 3478986 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI-parallelism
3628 :
3629 36342810 : do ir=1,db%my_nrpt
3630 32863824 : wr = v1scf_rpt(1, ir,ifft,ispden)
3631 32863824 : wi = v1scf_rpt(2, ir,ifft,ispden)
3632 32863824 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + wr*eiqr(1,ir) - wi * eiqr(2,ir)
3633 36342810 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + wr*eiqr(2,ir) + wi * eiqr(1,ir)
3634 : end do
3635 :
3636 : ! Add the long-range part of the potential
3637 3478986 : if (db%add_lr > 0) then
3638 2555380 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + v1r_lr(1,ifft)
3639 2555380 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + v1r_lr(2,ifft)
3640 : end if
3641 3479230 : if (db%add_lr == 4) then
3642 0 : v1scf_qpt(1,ifft,ispden) = v1r_lr(1,ifft)
3643 0 : v1scf_qpt(2,ifft,ispden) = v1r_lr(2,ifft)
3644 : end if
3645 : end do ! ifft
3646 :
3647 244 : call xmpi_sum(v1scf_qpt(:,:,ispden), comm, ierr)
3648 :
3649 : ! Remove the phase.
3650 1220 : call times_eikr(-qpt, ngfft, nfft, 1, v1scf_qpt(:,:,ispden))
3651 : end do
3652 :
3653 : ! Be careful with gamma and cplex!
3654 244 : if (db%symv1 == 1) then
3655 28 : call v1phq_symmetrize(db%cryst, idir, iat, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, db%mpi_enreg, v1scf_qpt)
3656 : end if
3657 :
3658 244 : ABI_FREE(eiqr)
3659 244 : ABI_FREE(v1r_lr)
3660 :
3661 244 : end subroutine dvdb_get_v1scf_qpt
3662 : !!***
3663 :
3664 : !----------------------------------------------------------------------
3665 :
3666 : !!****f* m_dvdb/dvdb_interpolate_v1scf
3667 : !! NAME
3668 : !! dvdb_interpolate_v1scf
3669 : !!
3670 : !! FUNCTION
3671 : !! Interpolate the phonon perturbation potential.
3672 : !! This routine is meant to replace dvdb_ftinterp_setup and dvdb_ftinterp_qpt.
3673 : !! It performs the interpolation one perturbation at a time.
3674 : !!
3675 : !! INPUTS
3676 : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3677 : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3678 : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3679 : !! nfft=Number of fft-points treated by this processors
3680 : !! ngfft(18)=contain all needed information about 3D FFT
3681 : !! nfftf=Number of fft-points on the fine grid for interpolated potential
3682 : !! ngfftf(18)=information on 3D FFT for interpolated potential
3683 : !! comm=MPI communicator
3684 : !!
3685 : !! OUTPUT
3686 : !! v1scf(2, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
3687 : !!
3688 : !! SOURCE
3689 :
3690 0 : subroutine dvdb_interpolate_v1scf(db, cryst, qpt, ngqpt, nqshift, qshift, &
3691 : nfft, ngfft, nfftf, ngfftf, v1scf, comm)
3692 :
3693 : !Arguments ------------------------------------
3694 : !scalars
3695 : integer,intent(in) :: nqshift,nfft,nfftf,comm
3696 : class(dvdb_t),target,intent(inout) :: db
3697 : !arrays
3698 : real(dp),intent(in) :: qpt(3)
3699 : integer,intent(in) :: ngqpt(3),ngfft(18),ngfftf(18)
3700 : real(dp),intent(in) :: qshift(3,nqshift)
3701 : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3702 : type(crystal_t),intent(in) :: cryst
3703 :
3704 : !Local variables-------------------------------
3705 : !scalars
3706 : integer :: ipert, nqbz, ierr, nproc, my_rank
3707 : !real(dp) :: work_size
3708 : !arrays
3709 0 : real(dp),allocatable :: v1scf_rpt(:,:,:,:)
3710 : ! *************************************************************************
3711 :
3712 0 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3713 :
3714 0 : nqbz = product(ngqpt) * nqshift
3715 0 : db%my_nrpt = nqbz
3716 :
3717 0 : ABI_MALLOC_OR_DIE(v1scf, (2,nfftf,db%nspden,db%natom3), ierr)
3718 0 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2,db%my_nrpt,nfft,db%nspden), ierr)
3719 :
3720 0 : do ipert=1,db%natom3
3721 0 : write(std_out, "(a,i4,a,i4,a)") " Interpolating potential for perturbation ", ipert, " / ", db%natom3, ch10
3722 :
3723 : ! FIXME I think this should be ngfftf and not ngfft
3724 : ! Also, other calls to dvdb_ftinterp_setup should use ngfftf.
3725 : call dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3726 0 : db%my_nrpt, db%nspden, ipert, v1scf_rpt, comm)
3727 :
3728 : call dvdb_get_v1scf_qpt(db, cryst, qpt, nfftf, ngfftf, db%my_nrpt, db%nspden, &
3729 0 : ipert, v1scf_rpt, v1scf(:,:,:,ipert), comm)
3730 :
3731 0 : ABI_FREE(db%my_rpt)
3732 : end do
3733 :
3734 0 : ABI_FREE(v1scf_rpt)
3735 :
3736 0 : end subroutine dvdb_interpolate_v1scf
3737 : !!***
3738 :
3739 : !----------------------------------------------------------------------
3740 :
3741 : !!****f* m_dvdb/dvdb_findq
3742 : !! NAME
3743 : !! dvdb_findq
3744 : !!
3745 : !! FUNCTION
3746 : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3747 : !! Returns -1 if not found.
3748 : !!
3749 : !! INPUTS
3750 : !! qpt(3)=q-point in reduced coordinates.
3751 : !! [qtol]=Optional tolerance for q-point comparison.
3752 : !! For each reduced direction the absolute difference between the coordinates must be less that qtol
3753 : !!
3754 : !! SOURCE
3755 :
3756 6172 : integer pure function dvdb_findq(db, qpt, qtol) result(iqpt)
3757 :
3758 : !Arguments ------------------------------------
3759 : !scalars
3760 : real(dp),optional,intent(in) :: qtol
3761 : class(dvdb_t),intent(in) :: db
3762 : !arrays
3763 : real(dp),intent(in) :: qpt(3)
3764 :
3765 : !Local variables-------------------------------
3766 : !scalars
3767 : integer :: iq
3768 : real(dp) :: my_qtol
3769 : ! *************************************************************************
3770 :
3771 6172 : my_qtol = tol6; if (present(qtol)) my_qtol = qtol
3772 6172 : iqpt = -1
3773 45711 : do iq=1,db%nqpt
3774 55309 : if (all(abs(db%qpts(:, iq) - qpt) < my_qtol)) then
3775 : iqpt = iq; exit
3776 : end if
3777 : end do
3778 :
3779 6172 : end function dvdb_findq
3780 : !!***
3781 :
3782 : !----------------------------------------------------------------------
3783 :
3784 : !!****f* m_dvdb/dvdb_find_qpts
3785 : !! NAME
3786 : !! dvdb_find_qpts
3787 : !!
3788 : !! FUNCTION
3789 : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3790 : !! Returns -1 if not found.
3791 : !!
3792 : !! INPUTS
3793 : !! nqpt: Number of q-points
3794 : !! qpt(3,nqpt): q-point in reduced coordinates.
3795 : !! comm: MPI communicator
3796 : !!
3797 : !! OUTPUT
3798 : !! iq2dvdb(nqpt): index of q-points in dvdb%qpts. Set to -1 if not found
3799 : !! ierr= Number of points **not** found
3800 : !!
3801 : !! SOURCE
3802 :
3803 61 : integer function dvdb_find_qpts(db, nqpt, qpts, iq2dvdb, comm) result(notfound)
3804 :
3805 : !Arguments ------------------------------------
3806 : !scalars
3807 : class(dvdb_t),intent(in) :: db
3808 : integer,intent(in) :: nqpt, comm
3809 : !arrays
3810 : real(dp),intent(in) :: qpts(3, nqpt)
3811 : integer,intent(out) :: iq2dvdb(nqpt)
3812 :
3813 : !Local variables-------------------------------
3814 : !scalars
3815 : integer :: iq, my_rank, nprocs, ierr
3816 : ! *************************************************************************
3817 :
3818 61 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
3819 :
3820 4070 : iq2dvdb = 0
3821 4070 : do iq=1,nqpt
3822 4009 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
3823 4070 : iq2dvdb(iq) = db%findq(qpts(:, iq))
3824 : end do
3825 :
3826 61 : call xmpi_sum(iq2dvdb, comm, ierr)
3827 4070 : notfound = count(iq2dvdb == -1)
3828 :
3829 61 : end function dvdb_find_qpts
3830 : !!***
3831 :
3832 : !----------------------------------------------------------------------
3833 :
3834 : !!****f* m_dvdb/dvdb_need_ftinterp
3835 : !! NAME
3836 : !! dvdb_need_ftinterp
3837 : !!
3838 : !! FUNCTION
3839 : !! Check whether input list of q-points requires Fourier interpolation.
3840 : !!
3841 : !! INPUTS
3842 : !! nqpt: Number of q-points
3843 : !! qpt(3,nqpt): q-point in reduced coordinates.
3844 : !!
3845 : !! OUTPUT
3846 : !! qmap_symrec(6, nqpt)
3847 : !! need_ftinterp
3848 : !!
3849 : !! SOURCE
3850 :
3851 7 : subroutine dvdb_need_ftinterp(db, nqpt, qpts, qptopt, qmap_symrec, need_ftinterp)
3852 :
3853 : !Arguments ------------------------------------
3854 : !scalars
3855 : class(dvdb_t),intent(in) :: db
3856 : integer,intent(in) :: nqpt, qptopt
3857 : logical,intent(out) :: need_ftinterp
3858 : !arrays
3859 : real(dp),intent(in) :: qpts(3, nqpt)
3860 : integer,allocatable,intent(out) :: qmap_symrec(:,:)
3861 :
3862 : !Local variables-------------------------------
3863 : !scalars
3864 : integer :: iq, iq_ibz, db_iqpt, qtimrev
3865 7 : type(krank_t) :: qrank
3866 : !arrays
3867 : real(dp) :: qq_ibz(3)
3868 : ! *************************************************************************
3869 :
3870 7 : need_ftinterp = .False.
3871 7 : call qrank%init(db%nqpt, db%qpts, compute_invrank=.False.)
3872 :
3873 7 : qtimrev = kpts_timrev_from_kptopt(qptopt)
3874 21 : ABI_MALLOC(qmap_symrec, (6, nqpt))
3875 :
3876 7 : if (kpts_map("symrec", qtimrev, db%cryst, qrank, nqpt, qpts, qmap_symrec) /= 0) then
3877 : ! There's at least on-qpoint in qpts that is not the IBZ image of db%qpts.
3878 5 : need_ftinterp = .True.; call qrank%free()
3879 5 : return
3880 : end if
3881 :
3882 : ! All the IBZ images must be in the DVDB
3883 14 : do iq=1,nqpt
3884 12 : iq_ibz = qmap_symrec(1, iq)
3885 48 : qq_ibz = db%qpts(:, iq_ibz)
3886 12 : db_iqpt = db%findq(qq_ibz)
3887 14 : if (db_iqpt == -1) then
3888 0 : need_ftinterp = .True.; exit
3889 : end if
3890 : end do
3891 :
3892 2 : call qrank%free()
3893 :
3894 7 : end subroutine dvdb_need_ftinterp
3895 : !!***
3896 :
3897 : !!****f* m_dvdb/dvdb_set_pert_distrib
3898 : !! NAME
3899 : !! dvdb_set_pert_distrib
3900 : !!
3901 : !! FUNCTION
3902 : !! Activate MPI distribution of the 3*natom perturbations.
3903 : !!
3904 : !! INPUTS
3905 : !! my_npert=Number of perturbations treated by this rank
3906 : !! natom3= 3 * natom
3907 : !! my_pinfo(3, my_npert)
3908 : !! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
3909 : !! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
3910 : !! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
3911 : !! pert_table(2, natom3)
3912 : !! pert_table(1, npert): rank of the processor treating this atomic perturbation.
3913 : !! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
3914 : !! comm_pert=MPI communicator used to distribute the 3*natom perturbations
3915 : !!
3916 : !! SOURCE
3917 :
3918 0 : subroutine dvdb_set_pert_distrib(self, my_npert, natom3, my_pinfo, pert_table, comm_pert)
3919 :
3920 : !Arguments ------------------------------------
3921 : !scalars
3922 : class(dvdb_t),intent(inout) :: self
3923 : integer,intent(in) :: my_npert, natom3, comm_pert
3924 : !arrays
3925 : integer,intent(in) :: my_pinfo(3,my_npert), pert_table(2,natom3)
3926 : ! *************************************************************************
3927 :
3928 0 : self%comm_pert = comm_pert
3929 0 : self%nprocs_pert = xmpi_comm_size(comm_pert)
3930 0 : self%me_pert = xmpi_comm_rank(comm_pert)
3931 0 : self%my_npert = my_npert
3932 :
3933 0 : ABI_SFREE(self%my_pinfo)
3934 0 : ABI_SFREE(self%pert_table)
3935 0 : call alloc_copy(my_pinfo, self%my_pinfo)
3936 0 : call alloc_copy(pert_table, self%pert_table)
3937 :
3938 0 : if (self%debug) then
3939 0 : write(std_out, *)"Activating perturbation over perturbations:"
3940 0 : write(std_out, *)"nprocs_pert: ", self%nprocs_pert
3941 0 : write(std_out, *)"my_pinfo: ",self%my_pinfo
3942 0 : write(std_out, *)"pert_table: ",self%pert_table
3943 : end if
3944 :
3945 0 : end subroutine dvdb_set_pert_distrib
3946 : !!***
3947 :
3948 : !!****f* m_dvdb/dvdb_seek
3949 : !! NAME
3950 : !! dvdb_seek
3951 : !!
3952 : !! FUNCTION
3953 : !! Move the internal file pointer so that it points to the
3954 : !! block with (idir, ipert, iqpt). Needed only if dvdb%iomode==IO_MODE_FORTRAN
3955 : !!
3956 : !! INPUTS
3957 : !! idir,ipert,iqpt = (direction, perturbation, q-point) indices
3958 : !!
3959 : !! SIDE EFFECTS
3960 : !! db<type(dvdb_t)>: modifies db%current_fpos.
3961 : !!
3962 : !! SOURCE
3963 :
3964 5360 : subroutine dvdb_seek(db, idir, ipert, iqpt)
3965 :
3966 : !Arguments ------------------------------------
3967 : integer,intent(in) :: idir, ipert, iqpt
3968 : type(dvdb_t),intent(inout) :: db
3969 :
3970 : !Local variables-------------------------------
3971 : integer :: pos_now,pos_wanted,ii,ispden,nn,ierr
3972 : real(dp),parameter :: fake_qpt(3)=zero
3973 : character(len=500) :: msg
3974 : ! *************************************************************************
3975 :
3976 5360 : if (db%iomode == IO_MODE_FORTRAN) then
3977 5360 : pos_now = db%current_fpos
3978 5360 : pos_wanted = db%pos_dpq(idir,ipert,iqpt)
3979 5360 : ABI_CHECK(pos_wanted /= 0, "pos_wanted cannot be zero!")
3980 :
3981 : ! Optimal access.
3982 6416 : if (pos_now == pos_wanted) return
3983 :
3984 1056 : if (pos_wanted < pos_now) then
3985 : ! Backspace previous records and header
3986 : ! but only if nn <= pos_wanted else rewind file and skip pos_wanted potentials (should be faster)
3987 850 : nn = pos_now - pos_wanted
3988 850 : if (nn <= pos_wanted) then
3989 3594 : do ii=1,nn
3990 : !write(std_out, *)"backspacing"
3991 2974 : if (db%version > 1) backspace(unit=db%fh, err=10, iomsg=msg)
3992 5948 : do ispden=1,db%nspden
3993 5948 : backspace(unit=db%fh, err=10, iomsg=msg)
3994 : end do
3995 2974 : ierr = db%hdr_ref%backspace(db%fh, msg)
3996 3594 : if (ierr /= 0) goto 10
3997 : end do
3998 620 : db%current_fpos = pos_wanted; return
3999 : else
4000 : ! rewind the file and read it from the beginning
4001 230 : if (dvdb_rewind(db, msg) /= 0) then
4002 0 : ABI_ERROR(msg)
4003 : end if
4004 : nn = pos_wanted
4005 : end if
4006 :
4007 : else
4008 206 : nn = pos_wanted - pos_now + 1
4009 : end if
4010 :
4011 4943 : do ii=1,nn-1
4012 : !write(std_out,*)"in seek with ii: ",ii,"pos_wanted: ",pos_wanted
4013 4507 : if (my_hdr_skip(db%fh, -1, -1, fake_qpt, msg) /= 0) then
4014 0 : ABI_ERROR(msg)
4015 : end if
4016 : ! Skip the records with v1.
4017 9014 : do ispden=1,db%nspden
4018 9014 : read(db%fh, err=10, iomsg=msg)
4019 : end do
4020 : ! Skip record with rhog1_g0 (if present)
4021 4943 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
4022 : end do
4023 :
4024 436 : db%current_fpos = pos_wanted
4025 :
4026 : else
4027 0 : ABI_ERROR("Should not be called when iomode /= IO_MODE_FORTRAN")
4028 : end if
4029 :
4030 0 : return
4031 :
4032 : ! Handle Fortran IO error
4033 : 10 continue
4034 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4035 :
4036 : end subroutine dvdb_seek
4037 : !!***
4038 :
4039 : !----------------------------------------------------------------------
4040 :
4041 : !!****f* m_dvdb/dvdb_rewind
4042 : !! NAME
4043 : !! dvdb_rewind
4044 : !!
4045 : !! FUNCTION
4046 : !! Rewind the file and move to the first header. Needed only if dvdb%iomode==IO_MODE_FORTRAN
4047 : !! Return exit code and error message in msg if ierr != 0.
4048 : !!
4049 : !! SOURCE
4050 :
4051 230 : integer function dvdb_rewind(db, msg) result(ierr)
4052 :
4053 : !Arguments ------------------------------------
4054 : type(dvdb_t),intent(inout) :: db
4055 : character(len=*),intent(out) :: msg
4056 : ! *************************************************************************
4057 :
4058 230 : ierr = 0
4059 230 : if (db%iomode == IO_MODE_FORTRAN) then
4060 230 : rewind(db%fh, err=10, iomsg=msg)
4061 230 : read(db%fh, err=10, iomsg=msg) ! version
4062 230 : read(db%fh, err=10, iomsg=msg) ! numv1
4063 230 : db%current_fpos = 1
4064 :
4065 : else
4066 0 : ierr = -1
4067 0 : msg = "should not be called when iomode /= IO_MODE_FORTRAN"
4068 : end if
4069 :
4070 : return
4071 :
4072 : ! Handle Fortran IO error
4073 : 10 continue
4074 0 : ierr = 1
4075 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4076 :
4077 230 : end function dvdb_rewind
4078 : !!***
4079 :
4080 : !----------------------------------------------------------------------
4081 :
4082 : !!****f* m_dvdb/my_hdr_skip
4083 : !! NAME
4084 : !! my_hdr_skip
4085 : !!
4086 : !! FUNCTION
4087 : !! Skip the header without rewinding the file. Return exit code.
4088 : !!
4089 : !! NOTES
4090 : !! Because hdr_skip rewinds the file and I'm not gonna change that ugly code.
4091 : !!
4092 : !! SOURCE
4093 :
4094 9867 : integer function my_hdr_skip(unit, idir, ipert, qpt, msg) result(ierr)
4095 :
4096 : !Arguments ------------------------------------
4097 : !scalars
4098 : integer,intent(in) :: unit,idir,ipert
4099 : real(dp),intent(in) :: qpt(3)
4100 : character(len=500),intent(out) :: msg
4101 :
4102 : !Local variables-------------------------------
4103 : integer :: fform
4104 9867 : type(hdr_type) :: tmp_hdr
4105 : !************************************************************************
4106 :
4107 9867 : ierr = 0; msg = ""
4108 9867 : call tmp_hdr%fort_read(unit, fform)
4109 9867 : ierr = dvdb_check_fform(fform, "read_dvdb", msg)
4110 9867 : if (ierr /= 0) return
4111 :
4112 9867 : if (idir /= -1 .and. ipert /= -1) then
4113 : if (idir /= mod(tmp_hdr%pertcase-1, 3) + 1 .or. &
4114 21440 : ipert /= (tmp_hdr%pertcase - idir) / 3 + 1 .or. &
4115 : any(abs(qpt - tmp_hdr%qptn) > tol14)) then
4116 0 : msg = "Perturbation index on file does not match the one expected by the caller"
4117 0 : ierr = -1
4118 : end if
4119 : end if
4120 :
4121 9867 : call tmp_hdr%free()
4122 :
4123 9867 : end function my_hdr_skip
4124 : !!***
4125 :
4126 : !----------------------------------------------------------------------
4127 :
4128 : !!****f* m_dvdb/dvdb_list_perts
4129 : !! NAME
4130 : !! dvdb_list_perts
4131 : !!
4132 : !! FUNCTION
4133 : !! Given a q-point mesh, this routine checks if all the (phonon) perturbations
4134 : !! are available taking into account symmetries.
4135 : !!
4136 : !! INPUTS
4137 : !! ngqpt(3)=Q-mesh divisions. If all(ngqpt == -1), the list of q-points in the DVDB
4138 : !! (i.e. db%qpts) is analyzed instead of the q-points generated from ngqpt.
4139 : !! [unit]=Unit number for output. Default `std_out`.
4140 : !!
4141 : !! OUTPUT
4142 : !! npert_miss = Number of missing perturbations.
4143 : !!
4144 : !! SOURCE
4145 :
4146 116 : subroutine dvdb_list_perts(db, ngqpt, npert_miss, unit)
4147 :
4148 : !Arguments ------------------------------------
4149 : class(dvdb_t),target,intent(in) :: db
4150 : integer,intent(out) :: npert_miss
4151 : integer,optional,intent(in) :: unit
4152 : !arrays
4153 : integer,intent(in) :: ngqpt(3)
4154 :
4155 : !Local variables-------------------------------
4156 : !scalars
4157 : integer :: npert_redund,miss_q,idir,ipert,iv1,psy,weird_q,enough
4158 : integer :: iq_ibz,nqibz,iq_file,qptopt,nshiftq,ii,timerev_q,unt,nqbz
4159 : character(len=500) :: msg,ptype,found
4160 : type(crystal_t),pointer :: cryst
4161 : !arrays
4162 : integer :: rfdir(3),qptrlatt(3,3)
4163 116 : integer,allocatable :: pertsy(:,:),symq(:,:,:),rfpert(:)
4164 : real(dp) :: qq(3),shiftq(3,1)
4165 116 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:)
4166 : ! *************************************************************************
4167 :
4168 116 : unt = std_out; if (present(unit)) unt = unit
4169 116 : cryst => db%cryst
4170 :
4171 464 : if (all(ngqpt == -1)) then
4172 : ! Will test the q-points in db
4173 116 : call alloc_copy(db%qpts, qibz)
4174 116 : nqibz = db%nqpt
4175 : else
4176 : ! Will test the q-points in the IBZ associated to ngqpt hence build IBZ and BZ from ngqpt.
4177 0 : qptopt = 1; shiftq = zero; nshiftq = 1; qptrlatt = 0
4178 0 : do ii=1,3
4179 0 : qptrlatt(ii, ii) = ngqpt(ii)
4180 : end do
4181 :
4182 0 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nshiftq, shiftq, nqibz, qibz, wtq, nqbz, qbz)
4183 :
4184 0 : ABI_FREE(qbz)
4185 0 : ABI_FREE(wtq)
4186 : end if
4187 :
4188 : ! Initialize the list of perturbations rfpert and rdfir
4189 : ! WARNING: Only phonon perturbations are considered for the time being.
4190 348 : ABI_MALLOC(rfpert,(db%mpert))
4191 1602 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
4192 :
4193 348 : ABI_MALLOC(symq, (4,2,cryst%nsym))
4194 348 : ABI_MALLOC(pertsy, (3,db%mpert))
4195 :
4196 : ! Loop over the q-points in the IBZ and test whether the q-point is present
4197 : ! and if all the independent perturbations are available.
4198 : ! `npert_miss` is the number of irreducible perturbations not found in the DVDB (critical)
4199 : ! `npert_redund` is the number of redundant perturbations found in the DVDB (not critical)
4200 : !
4201 116 : enough = 5; if (db%prtvol > 0) enough = nqibz + 1
4202 116 : npert_miss = 0; npert_redund = 0
4203 798 : do iq_ibz=1,nqibz
4204 682 : if (iq_ibz == enough) then
4205 45 : call wrtout(unt,' More than 20 q-points with prtvol == 0. Only important messages will be printed...')
4206 : end if
4207 2728 : qq = qibz(:,iq_ibz)
4208 682 : iq_file = db%findq(qq)
4209 :
4210 : ! Examine the symmetries of the q wavevector
4211 682 : call littlegroup_q(cryst%nsym,qq,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=db%prtvol)
4212 :
4213 : ! Determine the symmetrical perturbations. Meaning of pertsy:
4214 : ! 0 for non-target perturbations
4215 : ! 1 for basis perturbations
4216 : ! -1 for perturbations that can be found from basis perturbations
4217 : call irreducible_set_pert(cryst%indsym,db%mpert,cryst%natom,cryst%nsym,&
4218 682 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4219 :
4220 682 : if (iq_file /= -1) then
4221 : ! This q-point is in the DVDB. Test if all the independent perturbations are available.
4222 682 : if (iq_ibz <= enough) then
4223 526 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is present in the DVDB file"))
4224 526 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4225 : end if
4226 682 : ii = 0; weird_q = 0; miss_q = 0
4227 6039 : do ipert=1,db%mpert
4228 22110 : do idir=1,3
4229 16071 : psy = pertsy(idir,ipert)
4230 16071 : if (psy == 0) cycle
4231 3795 : iv1 = db%pos_dpq(idir,ipert,iq_file)
4232 3795 : ptype = "independent"; if (psy == -1) ptype = "symmetric"
4233 3795 : found = "Yes"; if (iv1 == 0) found = "No"
4234 :
4235 3795 : if (psy == 1 .and. iv1 == 0) miss_q = miss_q + 1
4236 3795 : if (psy == -1 .and. iv1 /= 0) weird_q = weird_q + 1
4237 :
4238 3795 : ii=ii+1
4239 9152 : if (iq_ibz <= enough) then
4240 2886 : write(msg,'(i5,a,i2,a,i4,4a)')ii,') idir=',idir,', ipert=',ipert,", type=",trim(ptype),", found=",trim(found)
4241 2886 : call wrtout(unt, msg)
4242 : end if
4243 : end do
4244 : end do
4245 :
4246 682 : if (weird_q /= 0) then
4247 0 : write(msg,"(a,i0,a)")" DVDB is overcomplete. ",weird_q, " perturbation(s) can be reconstructed by symmetry."
4248 0 : call wrtout(unt, msg)
4249 : end if
4250 :
4251 682 : npert_redund = npert_redund + weird_q
4252 682 : npert_miss = npert_miss + miss_q
4253 682 : if (miss_q /=0) then
4254 0 : call wrtout(unt, sjoin(" WARNING:", itoa(miss_q), "independent perturbation(s) are missing!."))
4255 : end if
4256 :
4257 : else
4258 : ! This q-point is not present in dvdb. Print the list of independent perturbations.
4259 0 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is NOT present in the DVDB file"))
4260 0 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4261 0 : ii = 0
4262 0 : do ipert=1,db%mpert
4263 0 : do idir=1,3
4264 0 : if (pertsy(idir,ipert) == 1) then
4265 0 : ii=ii+1
4266 0 : write(msg,'(i5,a,i2,a,i4,a)')ii,') idir=',idir,', ipert=',ipert,", type=independent, found=No"
4267 0 : call wrtout(unt, msg)
4268 0 : npert_miss = npert_miss + 1
4269 : end if
4270 : end do
4271 : end do
4272 : end if
4273 :
4274 1480 : if (iq_ibz <= enough) call wrtout(unt," ")
4275 : end do ! iq_ibz
4276 :
4277 116 : if (npert_miss /= 0) then
4278 0 : call wrtout(unt, sjoin(ch10, " There are ",itoa(npert_miss), "independent perturbations missing!"))
4279 : else
4280 116 : call wrtout(unt, " All the independent perturbations are available")
4281 116 : if (npert_redund /= 0) then
4282 0 : call wrtout(unt, " Note however that the DVDB is overcomplete as symmetric perturbations are present.")
4283 : end if
4284 : end if
4285 :
4286 116 : ABI_FREE(qibz)
4287 116 : ABI_FREE(rfpert)
4288 116 : ABI_FREE(symq)
4289 116 : ABI_FREE(pertsy)
4290 :
4291 116 : end subroutine dvdb_list_perts
4292 : !!***
4293 :
4294 : !----------------------------------------------------------------------
4295 :
4296 : !!****f* m_dvdb/dvdb_merge_files
4297 : !! NAME
4298 : !! dvdb_merge_files
4299 : !!
4300 : !! FUNCTION
4301 : !! Merge a list of POT1 or DEN1 files.
4302 : !!
4303 : !! INPUT
4304 : !! nfiles=Number of files to be merged.
4305 : !! dvdb_filepath=Name of output DVDB file.
4306 : !! prtvol=Verbosity level.
4307 : !!
4308 : !! SIDE EFFECTS
4309 : !! v1files=List of file names to merge. This list could be changed if POT1 files in netcdf format are found.
4310 : !!
4311 : !! SOURCE
4312 :
4313 17 : subroutine dvdb_merge_files(nfiles, v1files, dvdb_filepath, prtvol)
4314 :
4315 : !Arguments ------------------------------------
4316 : !scalars
4317 : integer,intent(in) :: nfiles,prtvol
4318 : character(len=*),intent(in) :: dvdb_filepath
4319 : character(len=*),intent(inout) :: v1files(nfiles)
4320 :
4321 : !Local variables-------------------------------
4322 : !scalars
4323 : ! Here I made a mistake because 102 corresponds to GS potentials
4324 : ! as a consequence DVDB files generated with version <= 8.1.6
4325 : ! contain list of potentials with fform = 102.
4326 : !integer :: fform_pot=102
4327 : integer :: fform_pot = 111, gpu_option0 = 0
4328 : integer :: ii,jj,fform,ount,cplex,nfft,ifft,ispden,nperts
4329 : integer :: n1,n2,n3,v1_varid,ierr, npert_miss, first_fform
4330 : logical :: qeq0
4331 : character(len=500) :: msg
4332 : type(hdr_type),pointer :: hdr1
4333 1394 : type(dvdb_t) :: dvdb
4334 : !arrays
4335 34 : integer :: units(nfiles)
4336 : real(dp) :: rhog1_g0(2)
4337 17 : real(dp),allocatable :: v1(:)
4338 34 : logical :: has_rhog1_g0(nfiles)
4339 17 : type(hdr_type),target,allocatable :: hdr1_list(:)
4340 : !************************************************************************
4341 :
4342 17 : if (file_exists(dvdb_filepath)) then
4343 0 : ABI_ERROR(sjoin("Cannot overwrite existing file:", dvdb_filepath))
4344 : end if
4345 :
4346 : ! If a file is not found, try the netcdf version and change v1files accordingly.
4347 296 : do ii=1,nfiles
4348 296 : if (nctk_try_fort_or_ncfile(v1files(ii), msg) /= 0) then
4349 0 : ABI_ERROR(msg)
4350 : end if
4351 : end do
4352 :
4353 : ! Read the headers
4354 330 : ABI_MALLOC(hdr1_list, (nfiles))
4355 17 : nperts = size(hdr1_list)
4356 :
4357 : ! Write dvdb file (we only support fortran binary format)
4358 17 : if (open_file(dvdb_filepath, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
4359 0 : ABI_ERROR(msg)
4360 : end if
4361 17 : write(ount, err=10, iomsg=msg) dvdb_last_version
4362 17 : write(ount, err=10, iomsg=msg) nperts
4363 :
4364 : ! Validate headers.
4365 : ! TODO: Should perform consistency check on the headers
4366 : ! rearrange them in blocks of q-points for efficiency reason.
4367 : ! ignore POT1 files that do not correspond to atomic perturbations.
4368 : ! Add POT file from GS run to support Sternheimer in eph_task = 4
4369 :
4370 296 : do ii=1,nfiles
4371 279 : write(std_out,"(a,i0,2a)")"- Reading header of file [",ii,"]: ",trim(v1files(ii))
4372 :
4373 279 : if (endswith(v1files(ii), ".nc")) then
4374 279 : NCF_CHECK(nctk_open_read(units(ii), v1files(ii), xmpi_comm_self))
4375 279 : call hdr1_list(ii)%ncread(units(ii), fform)
4376 : else
4377 0 : if (open_file(v1files(ii), msg, newunit=units(ii), form="unformatted", action="read", status="old") /= 0) then
4378 0 : ABI_ERROR(msg)
4379 : end if
4380 0 : call hdr1_list(ii)%fort_read(units(ii), fform)
4381 : end if
4382 :
4383 279 : if (dvdb_check_fform(fform, "merge_dvdb", msg) /= 0) then
4384 0 : ABI_ERROR(sjoin("While reading:", v1files(ii), msg))
4385 : end if
4386 279 : if (prtvol > 0) call hdr1_list(ii)%echo(fform, 3, unit=std_out)
4387 279 : if (hdr1_list(ii)%pertcase == 0) then
4388 0 : ABI_ERROR(sjoin("Found GS potential:", v1files(ii)))
4389 : end if
4390 : !write(std_out,*)"done", trim(v1files(ii))
4391 :
4392 279 : if (ii == 1) then
4393 17 : first_fform = fform
4394 : else
4395 262 : ABI_CHECK_IEQ(fform, first_fform, "Trying to merge files with different quantities")
4396 : end if
4397 :
4398 : ! Supported fform:
4399 : ! 109 POT1 files without vh1(G=0)
4400 : ! 111 POT1 files with extra record with vh1(G=0) after FFT data.
4401 : ! 54 RHO1 files (treating DRHODB as DVDB)
4402 :
4403 279 : has_rhog1_g0(ii) = .True.
4404 279 : if (any(fform == [54, 109])) has_rhog1_g0(ii) = .False.
4405 :
4406 279 : write(std_out,"(a,i0,2a)")"- Merging file [",ii,"]: ",trim(v1files(ii))
4407 279 : jj = ii
4408 279 : hdr1 => hdr1_list(jj)
4409 279 : if (any(fform == pot1_fforms)) then
4410 199 : call hdr1%fort_write(ount, fform_pot, ierr)
4411 : else
4412 80 : call hdr1%fort_write(ount, den1_fforms(1), ierr)
4413 : end if
4414 279 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
4415 :
4416 279 : qeq0 = (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14)
4417 279 : cplex = 2; if (qeq0) cplex = 1
4418 1116 : nfft = product(hdr1%ngfft(1:3))
4419 279 : n1 = hdr1%ngfft(1); n2 = hdr1%ngfft(2); n3 = hdr1%ngfft(3)
4420 :
4421 837 : ABI_MALLOC(v1, (cplex*nfft))
4422 :
4423 279 : if (.not. endswith(v1files(ii), ".nc")) then
4424 : ! Fortran IO
4425 0 : do ispden=1,hdr1%nspden
4426 0 : read(units(jj), err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4427 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4428 : end do
4429 : ! Add rhog1(G=0)
4430 0 : rhog1_g0 = zero
4431 0 : if (has_rhog1_g0(jj)) read(units(jj), err=10, iomsg=msg) rhog1_g0
4432 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4433 : else
4434 : ! Netcdf IO
4435 : ! netcdf array has shape [cplex, n1, n2, n3, nspden]
4436 279 : if (any(fform == pot1_fforms)) then
4437 199 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_potential", v1_varid))
4438 398 : do ispden=1,hdr1%nspden
4439 2189 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
4440 398 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4441 : end do
4442 : ! Add rhog1(G=0)
4443 199 : rhog1_g0 = zero
4444 199 : if (has_rhog1_g0(jj)) then
4445 199 : NCF_CHECK(nf90_get_var(units(ii), nctk_idname(units(ii), "rhog1_g0"), rhog1_g0))
4446 : end if
4447 80 : else if (any(fform == den1_fforms)) then
4448 : ! v below should read as rho
4449 80 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_density", v1_varid))
4450 160 : do ispden=1,hdr1%nspden
4451 880 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
4452 160 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4453 : end do
4454 : else
4455 0 : ABI_ERROR(sjoin("Don't know how to handle fform:", itoa(fform)))
4456 : end if
4457 279 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4458 : end if
4459 :
4460 279 : if (.not. endswith(v1files(ii), ".nc")) then
4461 0 : close(units(ii))
4462 : else
4463 279 : NCF_CHECK(nf90_close(units(ii)))
4464 : end if
4465 :
4466 296 : ABI_FREE(v1)
4467 : end do ! nperts
4468 :
4469 17 : close(ount)
4470 :
4471 296 : do ii=1,size(hdr1_list)
4472 296 : call hdr1_list(ii)%free()
4473 : end do
4474 296 : ABI_FREE(hdr1_list)
4475 :
4476 17 : write(std_out,"(a,i0,a)")" Merged successfully ", nfiles, " files"
4477 :
4478 : ! List available perturbations.
4479 17 : call dvdb%init(dvdb_filepath, gpu_option0, xmpi_comm_self)
4480 34 : call dvdb%print([std_out], "", 0)
4481 17 : call dvdb%list_perts([-1, -1, -1], npert_miss)
4482 17 : call dvdb%free()
4483 :
4484 17 : return
4485 :
4486 : ! Handle Fortran IO error
4487 : 10 continue
4488 0 : ABI_ERROR(sjoin("Error while merging files", ch10, msg))
4489 :
4490 17 : end subroutine dvdb_merge_files
4491 : !!***
4492 :
4493 : !!****f* m_dvdb/calc_eiqr
4494 : !! NAME
4495 : !! calc_eiqr
4496 : !!
4497 : !! FUNCTION
4498 : !! Compute e^{iq.r} for nrpt R-points.
4499 : !!
4500 : !! INPUTS
4501 : !!
4502 : !! OUTPUT
4503 : !!
4504 : !! SOURCE
4505 :
4506 5596 : subroutine calc_eiqr(qpt, nrpt, rpt, eiqr)
4507 :
4508 : !Arguments -------------------------------
4509 : !scalars
4510 : integer,intent(in) :: nrpt
4511 : !arrays
4512 : real(dp),intent(in) :: qpt(3), rpt(3, nrpt)
4513 : real(dp),intent(out) :: eiqr(2, nrpt)
4514 :
4515 : !Local variables -------------------------
4516 : !scalars
4517 : integer :: ir
4518 : real(dp) :: qr
4519 : ! *********************************************************************
4520 :
4521 : !$OMP PARALLEL DO PRIVATE(qr)
4522 222124 : do ir=1,nrpt
4523 866112 : qr = two_pi * dot_product(qpt, rpt(:,ir))
4524 222124 : eiqr(1, ir) = cos(qr); eiqr(2, ir) = sin(qr)
4525 : end do
4526 :
4527 5596 : end subroutine calc_eiqr
4528 : !!***
4529 :
4530 : !----------------------------------------------------------------------
4531 :
4532 : !!****f* m_dvdb/dvdb_check_fform
4533 : !! NAME
4534 : !! dvdb_check_fform
4535 : !!
4536 : !! FUNCTION
4537 : !! Check the value of fform. Return exit status and error message.
4538 : !!
4539 : !! INPUTS
4540 : !! fform=Value read from the header
4541 : !! mode="merge_dvdb" to check the value of fform when we are merging POT1 files
4542 : !! "read_dvdb" when we are reading POT1 files from a DVDB file.
4543 : !!
4544 : !! OUTPUT
4545 : !! errmsg=String with error message if ierr /= 0
4546 : !!
4547 : !! SOURCE
4548 :
4549 12349 : integer function dvdb_check_fform(fform, mode, errmsg) result(ierr)
4550 :
4551 : !Arguments ------------------------------------
4552 : integer,intent(in) :: fform
4553 : character(len=*),intent(in) :: mode
4554 : character(len=*),intent(out) :: errmsg
4555 : ! *************************************************************************
4556 :
4557 12349 : ierr = 0
4558 :
4559 : ! Here I made a mistake because 102 corresponds to GS potentials
4560 : ! as a consequence DVDB files generated with version <= 8.1.6
4561 : ! contain list of potentials with fform = 102.
4562 : !
4563 : ! In GWPT, one may want to use DRHODB as DVDB. For this, here I
4564 : ! also allow merging and reading first order density with fform = 54.
4565 : !
4566 : !integer :: fform_rho=54
4567 : !integer :: fform_pot=102
4568 : !integer :: fform_pot=109
4569 : !integer :: fform_pot=111
4570 :
4571 12349 : if (fform == 0) then
4572 0 : errmsg = "fform == 0! Either corrupted/nonexistent file or IO error"
4573 0 : ierr = 42; return
4574 : end if
4575 :
4576 279 : select case (mode)
4577 : case ("merge_dvdb")
4578 279 : if (all(fform /= [54, 109, 111])) then
4579 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `merge_dvdb` mode")
4580 0 : ierr = 1; return
4581 : end if
4582 :
4583 : case ("read_dvdb")
4584 12070 : if (all(fform /= [54, 102, 109, 111])) then
4585 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `read_dvdb` mode")
4586 0 : ierr = 1; return
4587 : end if
4588 :
4589 : case default
4590 0 : errmsg = sjoin("Invalid mode:", mode)
4591 12349 : ierr = -1; return
4592 : end select
4593 :
4594 12349 : end function dvdb_check_fform
4595 : !!***
4596 :
4597 : !!****f* m_dvdb/dvdb_test_v1rsym
4598 : !! NAME
4599 : !! dvdb_test_v1rsym
4600 : !!
4601 : !! FUNCTION
4602 : !! Debugging tool used to check whether the DFPT potentials in real space fulfill
4603 : !! the correct symmetries on the real space FFT mesh.
4604 : !!
4605 : !! INPUTS
4606 : !! db_path=Filename
4607 : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 to disable it.
4608 : !! comm=MPI communicator.
4609 : !!
4610 : !! OUTPUT
4611 : !! Only writing.
4612 : !!
4613 : !! SOURCE
4614 :
4615 0 : subroutine dvdb_test_v1rsym(db_path, symv1scf, comm)
4616 :
4617 : !Arguments ------------------------------------
4618 : character(len=*),intent(in) :: db_path
4619 : integer,intent(in) :: symv1scf, comm
4620 :
4621 : !Local variables-------------------------------
4622 : !scalars
4623 : integer,parameter :: rfmeth2=2, syuse0=0, gpu_option0 = 0
4624 : integer :: iqpt,idir,ipert,nsym1,cplex,v1pos, isym,nfft,ifft,ifft_rot,ispden
4625 : real(dp) :: max_err,re,im,vre,vim !,pre,pim
4626 : character(len=500) :: msg
4627 : logical :: isok
4628 0 : type(dvdb_t),target :: db
4629 : type(crystal_t),pointer :: cryst
4630 : !arrays
4631 : integer :: ngfft(18)
4632 0 : integer,allocatable :: symafm1(:),symrel1(:,:,:),irottb(:,:)
4633 : real(dp) :: qpt(3)
4634 0 : real(dp),allocatable :: tnons1(:,:),v1scf(:,:)
4635 : ! *************************************************************************
4636 :
4637 0 : call db%init(db_path, gpu_option0, comm)
4638 0 : db%debug = .True.
4639 0 : db%symv1 = symv1scf
4640 0 : call db%print([std_out], "", 0)
4641 : !call db%list_perts([-1,-1,-1], npert_miss)
4642 :
4643 0 : call ngfft_seq(ngfft, db%ngfft3_v1(:,1))
4644 0 : nfft = product(ngfft(1:3))
4645 0 : call db%open_read(ngfft, comm)
4646 :
4647 0 : cryst => db%cryst
4648 0 : ABI_MALLOC(symafm1, (cryst%nsym))
4649 0 : ABI_MALLOC(symrel1, (3,3,cryst%nsym))
4650 0 : ABI_MALLOC(tnons1, (3,cryst%nsym))
4651 :
4652 0 : do iqpt=1,db%nqpt
4653 0 : qpt = db%qpts(:, iqpt)
4654 0 : do ipert=1,db%natom
4655 0 : do idir=1,3
4656 0 : v1pos = db%pos_dpq(idir, ipert, iqpt); if (v1pos == 0) cycle
4657 :
4658 : ! Determines the set of symmetries that leaves the perturbation invariant.
4659 : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
4660 : cryst%symafm,symafm1,db%symq_table(:,:,:,iqpt),cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,&
4661 0 : tnons1,unit=dev_null)
4662 :
4663 0 : cplex = db%cplex_v1(v1pos)
4664 0 : ngfft(1:3) = db%ngfft3_v1(:, v1pos)
4665 0 : nfft = product(ngfft(:3))
4666 0 : ABI_MALLOC(v1scf, (cplex*nfft, db%nspden))
4667 :
4668 0 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) /= 0) then
4669 0 : ABI_ERROR(msg)
4670 : end if
4671 :
4672 0 : ABI_MALLOC(irottb, (nfft,nsym1))
4673 0 : call rotate_fft_mesh(nsym1,symrel1,tnons1,ngfft,irottb,isok)
4674 0 : if (.not. isok) then
4675 0 : ABI_WARNING("Real space FFT mesh is not compatible with symmetries!")
4676 : end if
4677 :
4678 0 : max_err = zero
4679 0 : do isym=1,nsym1
4680 0 : do ispden=1,db%nspden
4681 0 : do ifft=1,nfft
4682 0 : ifft_rot = irottb(ifft, isym)
4683 : !pre = cos(two_pi * dot_product(qpt, tnons1(:,isym)))
4684 : !pim = -sin(two_pi * dot_product(qpt, tnons1(:,isym)))
4685 0 : if (cplex == 2) then
4686 0 : re = v1scf(2*ifft_rot-1, ispden)
4687 0 : im = v1scf(2*ifft_rot , ispden)
4688 : !vre = re * pre - im * pim
4689 : !vim = re * pim + im * pre
4690 0 : vre = re; vim = im
4691 :
4692 0 : re = v1scf(2*ifft-1, ispden) - vre
4693 0 : im = v1scf(2*ifft , ispden) - vim
4694 : else
4695 0 : re = v1scf(ifft, ispden) - v1scf(ifft_rot, ispden)
4696 0 : im = zero
4697 : end if
4698 : !if (sqrt(re**2 + im**2) > tol6) write(std_out,*)"ifft,isym,err: ",ifft,isym,sqrt(re**2 + im**2)
4699 0 : max_err = max(max_err, sqrt(re**2 + im**2))
4700 : end do
4701 : end do
4702 : end do
4703 0 : if (nsym1>1) then
4704 0 : write(std_out,"(3(a,i2),a,i2,a,es16.8)")"For iqpt= ",iqpt,&
4705 0 : ", idir= ",idir,", ipert= ",ipert,", nsym= ",nsym1,", max_err= ",max_err
4706 : end if
4707 :
4708 0 : ABI_FREE(irottb)
4709 0 : ABI_FREE(v1scf)
4710 : end do
4711 : end do
4712 :
4713 : end do ! iqpt
4714 :
4715 0 : ABI_FREE(symafm1)
4716 0 : ABI_FREE(symrel1)
4717 0 : ABI_FREE(tnons1)
4718 :
4719 0 : call db%free()
4720 :
4721 0 : end subroutine dvdb_test_v1rsym
4722 : !!***
4723 :
4724 : !----------------------------------------------------------------------
4725 :
4726 : !!****f* m_dvdb/dvdb_test_v1complete
4727 : !! NAME
4728 : !! dvdb_test_v1complete
4729 : !!
4730 : !! FUNCTION
4731 : !! Debugging tool used to test the symmetrization of the DFPT potentials.
4732 : !! Assumes DVDB file containing all 3*natom perturbations (either generated with nsym == 1 or
4733 : !! via other specialized variables e.g. prepgkk)
4734 : !!
4735 : !! INPUTS
4736 : !! db_path=Filename of the DVDB file.
4737 : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 ti disable it.
4738 : !! dump_path=File used to dump potentials (empty string to disable output)
4739 : !! comm=MPI communicator.
4740 : !!
4741 : !! OUTPUT
4742 : !! Only writing.
4743 : !!
4744 : !! SOURCE
4745 :
4746 0 : subroutine dvdb_test_v1complete(dvdb_filepath, symv1scf, dump_path, comm)
4747 :
4748 : !Arguments ------------------------------------
4749 : character(len=*),intent(in) :: dvdb_filepath,dump_path
4750 : integer,intent(in) :: symv1scf, comm
4751 :
4752 : !Local variables-------------------------------
4753 : !scalars
4754 : integer,parameter :: master = 0, gpu_option0 = 0
4755 : integer :: iqpt,pcase,idir,ipert,cplex,nfft,ispden,timerev_q,ifft,unt,my_rank, ncid
4756 : integer :: i1,i2,i3,n1,n2,n3,id1,id2,id3,cnt, npert_miss
4757 : integer :: ncerr
4758 : character(len=500) :: msg
4759 : type(crystal_t),pointer :: cryst
4760 0 : type(dvdb_t),target :: dvdb
4761 : type(vdiff_t) :: vd
4762 : !arrays
4763 : integer :: ngfft(18), rfdir(3)
4764 0 : integer,allocatable :: pflag(:,:), pertsy(:,:),rfpert(:),symq(:,:,:)
4765 : real(dp) :: qpt(3)
4766 0 : real(dp),allocatable :: file_v1scf(:,:,:,:),symm_v1scf(:,:,:,:), work2(:,:,:,:)
4767 : ! *************************************************************************
4768 :
4769 0 : my_rank = xmpi_comm_rank(comm)
4770 :
4771 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
4772 0 : dvdb%debug = .false.
4773 0 : dvdb%symv1 = symv1scf
4774 0 : call dvdb%print([std_out], "", 0)
4775 0 : call dvdb%list_perts([-1,-1,-1], npert_miss)
4776 :
4777 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
4778 0 : nfft = product(ngfft(1:3))
4779 0 : call dvdb%open_read(ngfft, comm)
4780 :
4781 0 : cryst => dvdb%cryst
4782 :
4783 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
4784 0 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
4785 :
4786 0 : ABI_MALLOC(pflag, (3, dvdb%natom))
4787 :
4788 : ! Initialize the list of perturbations rfpert and rdfir
4789 : ! WARNING: Only phonon perturbations are considered for the time being.
4790 0 : ABI_MALLOC(rfpert,(dvdb%mpert))
4791 0 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
4792 0 : ABI_MALLOC(symq, (4,2,cryst%nsym))
4793 0 : ABI_MALLOC(pertsy, (3,dvdb%mpert))
4794 :
4795 0 : unt = -1; ncid = nctk_noid
4796 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
4797 0 : write(std_out,"(a)")sjoin("Will write potentials to:", dump_path)
4798 0 : if (endswith(dump_path, ".nc")) then
4799 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
4800 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
4801 : ncerr = nctk_def_dims(ncid, [&
4802 : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
4803 : nctkdim_t("natom3", cryst%natom * 3), nctkdim_t("mpert", dvdb%mpert), nctkdim_t("nqpt", dvdb%nqpt)], &
4804 0 : defmode=.True.)
4805 0 : NCF_CHECK(ncerr)
4806 0 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "symv1scf"]))
4807 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
4808 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("origin_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4809 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("recons_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4810 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("pertsy_qpt", "int", "three, mpert, nqpt")))
4811 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
4812 0 : NCF_CHECK(nctk_set_datamode(ncid))
4813 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
4814 0 : "symv1scf"], [symv1scf])
4815 0 : NCF_CHECK(ncerr)
4816 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
4817 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
4818 : else
4819 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
4820 0 : ABI_ERROR(msg)
4821 : end if
4822 : end if
4823 : end if
4824 :
4825 0 : ABI_CALLOC(work2, (2, nfft, dvdb%nspden, dvdb%natom3))
4826 :
4827 : ! loop over the q-points available in the dvdb (likely qpts in the IBZ)
4828 : ! For each q-point, use symmetries to reconstruct all 3*natom perts for the independent ones
4829 : ! and compare with the corresponding results available in the DVDB file
4830 :
4831 0 : do iqpt=1,dvdb%nqpt
4832 0 : qpt = dvdb%qpts(:,iqpt)
4833 :
4834 : ! Examine the symmetries of the q wavevector
4835 0 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=dvdb%prtvol)
4836 :
4837 : ! Determine the symmetrical perturbations. Meaning of pertsy:
4838 : ! 0 for non-target perturbations
4839 : ! 1 for basis perturbations
4840 : ! -1 for perturbations that can be found from basis perturbations
4841 : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
4842 0 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4843 :
4844 : ! Read all potentials (here we assume that all perturbations are available in the DVDB)
4845 0 : call dvdb%readsym_allv1(iqpt, cplex, nfft, ngfft, file_v1scf, dvdb%comm)
4846 :
4847 : ! Copy basis perturbations in symm_v1scf and set pflag
4848 0 : ABI_MALLOC(symm_v1scf, (cplex, nfft, dvdb%nspden, dvdb%natom3))
4849 0 : symm_v1scf = huge(one); pflag = 0
4850 0 : do pcase=1,3*dvdb%cryst%natom
4851 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4852 0 : if (pertsy(idir, ipert) == 1) then
4853 0 : symm_v1scf(:,:,:,pcase) = file_v1scf(:,:,:,pcase)
4854 0 : pflag(idir,ipert) = 1
4855 : end if
4856 : end do
4857 :
4858 : ! Complete potentials by symmetry.
4859 0 : call v1phq_complete(cryst,qpt,ngfft,cplex,nfft,dvdb%nspden,dvdb%nsppol,dvdb%mpi_enreg,dvdb%symv1,pflag,symm_v1scf)
4860 :
4861 0 : if (ncid /= nctk_noid) then
4862 0 : work2 = zero
4863 0 : if (cplex == 1) work2(1,:,:,:) = file_v1scf(1,:,:,:)
4864 0 : if (cplex == 2) work2 = file_v1scf
4865 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "origin_v1scf"), work2, start=[1,1,1,1,iqpt])
4866 0 : NCF_CHECK(ncerr)
4867 0 : if (cplex == 1) work2(1,:,:,:) = symm_v1scf(1,:,:,:)
4868 0 : if (cplex == 2) work2 = symm_v1scf
4869 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "recons_v1scf"), work2, start=[1,1,1,1,iqpt])
4870 0 : NCF_CHECK(ncerr)
4871 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "pertsy_qpt"), pertsy, start=[1,1,iqpt]))
4872 : end if
4873 :
4874 : ! Compare potentials.
4875 0 : do pcase=1,3*cryst%natom
4876 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4877 0 : if (pflag(idir,ipert) /= 2) cycle
4878 0 : cnt = cnt+1
4879 :
4880 0 : do ispden=1,dvdb%nspden
4881 : !write(std_out,"(5(a,i0),3a,es12.4)")"For cnt: ",cnt ,", iqpt: ", iqpt, ", idir: ", idir, &
4882 : ! ", ipert: ", ipert, ", ispden: ", ispden, ", qpt: ", trim(ktoa(qpt)) ,", max_err: ", &
4883 : ! maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4884 : !write(std_out,"(a,es10.3)")" max(abs(f1-f2))", maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4885 0 : call vd%eval(cplex,nfft,file_v1scf(:,:,ispden,pcase),symm_v1scf(:,:,ispden,pcase),cryst%ucvol, unit=std_out)
4886 :
4887 : ! Debug: write potentials to file.
4888 0 : if (unt /= -1) then
4889 0 : write(unt,*)"# count:", cnt
4890 0 : write(unt,*)"# q-point:", trim(ktoa(qpt)), ", iqpt: ", trim(itoa(iqpt))
4891 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
4892 0 : write(unt,*)"# file_v1scf, symmetrized_v1scf, diff"
4893 0 : if (cplex == 1) then
4894 0 : do i3=1,n3
4895 0 : do i2=1,n2
4896 0 : do i1=1,n1
4897 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4898 : write(unt,"(3i3,3(es12.4,2x))") &
4899 0 : i1,i2,i3, &
4900 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4901 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase)
4902 : end do
4903 : end do
4904 : end do
4905 : else
4906 0 : do i3=1,n3
4907 0 : do i2=1,n2
4908 0 : do i1=1,n1
4909 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4910 : write(unt, "(3i3,6(es12.4,2x))") &
4911 0 : i1,i2,i3, &
4912 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4913 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase), &
4914 0 : file_v1scf(2,ifft,ispden,pcase), symm_v1scf(2,ifft,ispden,pcase), &
4915 0 : file_v1scf(2,ifft,ispden,pcase) - symm_v1scf(2,ifft,ispden,pcase)
4916 : end do
4917 : end do
4918 : end do
4919 : end if
4920 0 : write(unt,*)
4921 0 : write(unt,*)
4922 : end if
4923 :
4924 : end do
4925 : !write(std_out,*)""
4926 : end do
4927 :
4928 0 : ABI_FREE(symm_v1scf)
4929 0 : ABI_FREE(file_v1scf)
4930 : end do
4931 :
4932 0 : ABI_FREE(work2)
4933 0 : ABI_FREE(pflag)
4934 0 : ABI_FREE(rfpert)
4935 0 : ABI_FREE(symq)
4936 0 : ABI_FREE(pertsy)
4937 :
4938 0 : call dvdb%free()
4939 :
4940 0 : if (unt /= -1) close(unt)
4941 0 : if (ncid /= nctk_noid) then
4942 0 : NCF_CHECK(nf90_close(ncid))
4943 : end if
4944 :
4945 0 : end subroutine dvdb_test_v1complete
4946 : !!***
4947 :
4948 : !----------------------------------------------------------------------
4949 :
4950 : !!****f* m_dvdb/dvdb_write_v1qavg
4951 : !! NAME
4952 : !! dvdb_write_v1qavg
4953 : !!
4954 : !! FUNCTION
4955 : !! Computes the average over the unit cell of the periodic part of the DFPT potentials
4956 : !! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
4957 : !! Results are stored in the V1QAVG netcdf file. Two options are available:
4958 : !!
4959 : !! eph_task = -15 --> Use list of q-points found in the DVDB file. Mainly used to plot the average
4960 : !! along a q-path. The procedure required to generate a DVDB with a q-path is rather lengthy
4961 : !! as it requires several phonon calculations with WKQ followed by a merge of the POT files.
4962 : !!
4963 : !! eph_task = +15 --> Assume DVDB file with q-mesh (dvdb_ngqpt), use Fourier interpolation
4964 : !! to interpolate potentials along the path specified by ph_qpath and ph_nqpath.
4965 : !!
4966 : !! INPUTS
4967 : !! dtset<dataset_type>= Input variables.
4968 : !! out_ncpath=Filename for output netcdf file.
4969 : !!
4970 : !! OUTPUT
4971 : !! Only writing.
4972 : !!
4973 : !! SOURCE
4974 :
4975 2 : subroutine dvdb_write_v1qavg(dvdb, dtset, out_ncpath)
4976 :
4977 : !Arguments ------------------------------------
4978 : class(dvdb_t),target,intent(inout) :: dvdb
4979 : type(dataset_type),target,intent(in) :: dtset
4980 : character(len=*),intent(in) :: out_ncpath
4981 :
4982 : !Local variables-------------------------------
4983 : !scalars
4984 : integer,parameter :: master = 0
4985 : integer :: nfft, iq, cplex, ispden, comm_rpt, my_rank, idir, ipert, ipc, imyp
4986 : integer :: n1, n2, n3, unt, this_nqpt, interpolated
4987 : integer :: i1, i2, i3, ifft, ig, ngsmall, ii, qptopt
4988 : integer :: ncid, ncerr
4989 : real(dp) :: gsq_max, g2
4990 : !type(vdiff_t) :: vd_max
4991 : logical :: write_v1r
4992 : character(len=500) :: msg
4993 : character(len=fnlen) :: dump_path
4994 : !arrays
4995 : integer :: ngfft(18), units(2)
4996 2 : integer, allocatable :: gfft(:,:),ig2ifft(:), gsmall(:,:)
4997 : real(dp) :: dvdb_qdamp(1)
4998 : real(dp) :: vals2(2)
4999 2 : real(dp),pointer :: this_qpts(:,:)
5000 2 : real(dp),allocatable :: file_v1r(:,:,:,:),long_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5001 2 : real(dp),allocatable :: maxw(:,:), all_rpt(:,:), all_rmod(:), workg(:,:), work_gsmall(:,:)
5002 : ! *************************************************************************
5003 :
5004 4 : my_rank = xmpi_comm_rank(dvdb%comm)
5005 6 : units = [std_out, ab_out]
5006 :
5007 2 : call wrtout(units, " Computing average over the unit cell of the periodic part of the DFPT potentials", newlines=2)
5008 4 : call dvdb%print([std_out], "", 0)
5009 :
5010 : ! Define FFT mesh
5011 38 : ngfft = dvdb%ngfft
5012 8 : nfft = product(ngfft(1:3))
5013 2 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
5014 :
5015 : ! Get list of G-vectors in FFT mesh.
5016 6 : ABI_MALLOC(gfft, (3, nfft))
5017 2 : call get_gfft(ngfft, [zero, zero, zero], dvdb%cryst%gmet, gsq_max, gfft)
5018 6 : ABI_MALLOC(workg, (2, nfft))
5019 :
5020 : ! Select G-vectors in small sphere (ratio of gsq_max)
5021 6 : do ii=1,2
5022 4 : if (ii == 2) then
5023 6 : ABI_MALLOC(ig2ifft, (ngsmall))
5024 : end if
5025 4 : ngsmall = 0
5026 16390 : do ig=1,nfft
5027 : ! Don't include (2pi)**2 to be consistent with get_gfft
5028 327680 : g2 = dot_product(gfft(:,ig), matmul(dvdb%cryst%gmet, gfft(:, ig)))
5029 16384 : if (g2 <= gsq_max * 0.01_dp) ngsmall = ngsmall + 1
5030 16388 : if (ii == 2) ig2ifft(ngsmall) = ig
5031 : end do
5032 : end do
5033 2 : write(std_out, *)"Found ngsmall", ngsmall
5034 :
5035 : !call ig2fft_sphere(dvdb%cryst%gmet, gfft, ig2ifft)
5036 6 : ABI_MALLOC(gsmall, (3, ngsmall))
5037 56 : do ig=1,ngsmall
5038 218 : gsmall(:, ig) = gfft(:, ig2ifft(ig))
5039 : end do
5040 6 : ABI_MALLOC(work_gsmall, (2, ngsmall))
5041 :
5042 10 : ABI_MALLOC(long_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
5043 8 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
5044 :
5045 2 : unt = -1; dump_path = ""
5046 : !dump_path = "V1QAVG.dat"
5047 2 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5048 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
5049 0 : ABI_ERROR(msg)
5050 : end if
5051 0 : write(std_out,"(a)")sjoin(" Will write potentials in text format to:", dump_path)
5052 : end if
5053 :
5054 : ! Select list of q-points depending on eph_task (either from DVDB file or interpolated)
5055 2 : write_v1r = .False.
5056 2 : if (dtset%eph_task == -15) then
5057 1 : call wrtout(units, " Using list of q-points found in the DVDB file")
5058 1 : this_nqpt = dvdb%nqpt
5059 1 : this_qpts => dvdb%qpts
5060 1 : interpolated = 0
5061 :
5062 1 : else if (dtset%eph_task == +15) then
5063 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
5064 1 : call wrtout(units, msg)
5065 1 : ABI_CHECK(dtset%ph_nqpath > 0, "When eph_task = +15, ph_qpath must be given in input.")
5066 1 : this_nqpt = dtset%ph_nqpath
5067 1 : this_qpts => dtset%ph_qpath(:, 1:this_nqpt)
5068 1 : comm_rpt = xmpi_comm_self
5069 1 : qptopt = dtset%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5070 1 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfft, ngfft, comm_rpt)
5071 1 : interpolated = 1
5072 1 : write_v1r = dtset%prtpot > 0
5073 : else
5074 0 : ABI_ERROR(sjoin("Invalid value for eph_task:", itoa(dtset%eph_task)))
5075 : end if
5076 :
5077 2 : call wrtout(units, sjoin(ch10, "- Results stored in: ", out_ncpath))
5078 2 : call wrtout(units, " Use `abiopen.py out_V1QAVG.nc -e` to visualize results")
5079 :
5080 2 : if (my_rank == master) then
5081 2 : NCF_CHECK(nctk_open_create(ncid, out_ncpath, xmpi_comm_self))
5082 2 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5083 : ncerr = nctk_def_dims(ncid, [ &
5084 : nctkdim_t("nspden", dvdb%nspden), nctkdim_t("natom", dvdb%natom3 / 3), nctkdim_t("nqpt", this_nqpt), &
5085 12 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("ngsmall", ngsmall)], defmode=.True.)
5086 2 : NCF_CHECK(ncerr)
5087 :
5088 2 : if (interpolated == 1) then
5089 : ! Define arrays for Max_r |W(R, r)|
5090 3 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nrpt", dvdb%nrtot), nctkdim_t("nfft", nfft)]))
5091 : ncerr = nctk_def_arrays(ncid, [ &
5092 : nctkarr_t("ngqpt", "int", "three"), nctkarr_t("rpt", "dp", "three, nrpt"), nctkarr_t("rmod", "dp", "nrpt"), &
5093 : nctkarr_t("ngfft", "int", "three"), &
5094 : nctkarr_t("maxw", "dp", "nrpt, natom3") &
5095 6 : ])
5096 1 : NCF_CHECK(ncerr)
5097 : end if
5098 :
5099 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5100 10 : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"])
5101 2 : NCF_CHECK(ncerr)
5102 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5103 12 : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield", "dvdb_add_lr"])
5104 2 : NCF_CHECK(ncerr)
5105 4 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"]))
5106 : ncerr = nctk_def_arrays(ncid, [ &
5107 : nctkarr_t("v1scf_avg", "dp", "two, nspden, three, natom, nqpt"), &
5108 : nctkarr_t("v1lr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5109 : nctkarr_t("v1scfmlr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5110 : nctkarr_t("v1scfmlr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5111 : nctkarr_t("v1scf_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5112 : nctkarr_t("v1lr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5113 : nctkarr_t("gsmall", "int", "three, ngsmall"), &
5114 : nctkarr_t("v1scf_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5115 : nctkarr_t("v1lr_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5116 : nctkarr_t("qpoints", "dp", "three, nqpt") &
5117 22 : ])
5118 2 : NCF_CHECK(ncerr)
5119 :
5120 2 : if (write_v1r) then
5121 : ncerr = nctk_def_arrays(ncid, [ &
5122 : nctkarr_t("v1r_interpolated", "dp", "two, nfft, nspden, natom3"), &
5123 : nctkarr_t("v1r_lrmodel", "dp", "two, nfft, nspden, natom3") &
5124 0 : ])
5125 0 : NCF_CHECK(ncerr)
5126 : end if
5127 :
5128 2 : NCF_CHECK(nctk_set_datamode(ncid))
5129 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpoints"), this_qpts))
5130 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5131 : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"], &
5132 18 : [dtset%symdynmat, dvdb%symv1, dtset%dvdb_add_lr, interpolated])
5133 2 : NCF_CHECK(ncerr)
5134 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5135 : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield"], &
5136 18 : l2int([dvdb%has_dielt, dvdb%has_zeff, dvdb%has_quadrupoles, dvdb%has_efield]))
5137 2 : NCF_CHECK(ncerr)
5138 4 : dvdb_qdamp = dvdb%qdamp
5139 4 : NCF_CHECK(nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"], dvdb_qdamp))
5140 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "gsmall"), gsmall))
5141 : end if
5142 :
5143 10 : do iq=1,this_nqpt
5144 :
5145 8 : if (interpolated == 0) then
5146 3 : call wrtout(std_out, sjoin(" Treating qpt:", ktoa(this_qpts(:,iq))))
5147 :
5148 : ! Read data from DVDB file, reconstruct all 3*natom perturbations in tmp_v1r.
5149 3 : call dvdb%readsym_allv1(dvdb%findq(this_qpts(:, iq)), cplex, nfft, ngfft, tmp_v1r, xmpi_comm_self)
5150 :
5151 : ! Transfer data to file_v1r taking into account my_npert
5152 21 : do imyp=1,dvdb%my_npert
5153 18 : ipc = dvdb%my_pinfo(3, imyp)
5154 21 : if (cplex == 1) then
5155 24588 : file_v1r(1,:,:,imyp) = tmp_v1r(1,:,:,ipc)
5156 24588 : file_v1r(2,:,:,imyp) = zero
5157 : else
5158 147480 : file_v1r(:,:,:,imyp) = tmp_v1r(:,:,:,ipc)
5159 : end if
5160 : end do
5161 3 : ABI_FREE(tmp_v1r)
5162 :
5163 : else
5164 : ! Interpolate my_npert potentials for this q-point.
5165 5 : call wrtout(std_out, sjoin(" Interpolating qpt:", ktoa(this_qpts(:,iq))))
5166 5 : call dvdb%ftinterp_qpt(this_qpts(:, iq), nfft, ngfft, file_v1r, comm_rpt) !, add_lr=?)
5167 5 : cplex = 2
5168 : end if
5169 :
5170 : ! Compute the periodic part of the LR term (note add_qphase = 0 because we want the periodic part)
5171 56 : do imyp=1,dvdb%my_npert
5172 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5173 104 : do ispden=1,min(dvdb%nspden, 2)
5174 96 : call dvdb%get_v1r_long_range(this_qpts(:,iq), idir, ipert, nfft, ngfft, long_v1r(:,:,ispden,imyp), add_qphase=0)
5175 : end do
5176 : end do
5177 :
5178 : ! Compute average and write to file.
5179 8 : if (my_rank /= master) cycle
5180 :
5181 8 : if (write_v1r .and. iq == 1) then
5182 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_interpolated"), file_v1r))
5183 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_lrmodel"), long_v1r))
5184 : end if
5185 :
5186 58 : do imyp=1,dvdb%my_npert
5187 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5188 104 : do ispden=1,dvdb%nspden
5189 :
5190 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp), dim=2) / nfft
5191 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_avg"), vals2, &
5192 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5193 48 : NCF_CHECK(ncerr)
5194 :
5195 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp)), dim=2) / nfft
5196 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_abs_avg"), vals2, &
5197 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5198 48 : NCF_CHECK(ncerr)
5199 :
5200 393360 : vals2 = sum(long_v1r(:,:,ispden,imyp), dim=2) / nfft
5201 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_avg"), vals2, &
5202 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5203 48 : NCF_CHECK(ncerr)
5204 393360 : vals2 = sum(abs(long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5205 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_abs_avg"), vals2, &
5206 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5207 48 : NCF_CHECK(ncerr)
5208 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp), dim=2) / nfft
5209 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_avg"), vals2, &
5210 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5211 48 : NCF_CHECK(ncerr)
5212 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5213 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_abs_avg"), vals2, &
5214 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5215 48 : NCF_CHECK(ncerr)
5216 :
5217 : ! Compute G-components of DFPT potentials and LR model for G in small-sphere and save results to disk
5218 48 : call fourdp(2, workg, file_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5219 1344 : do ig=1,ngsmall
5220 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5221 : end do
5222 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_gsmall"), work_gsmall, &
5223 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5224 48 : NCF_CHECK(ncerr)
5225 :
5226 48 : call fourdp(2, workg, long_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5227 1344 : do ig=1,ngsmall
5228 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5229 : end do
5230 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_gsmall"), work_gsmall, &
5231 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5232 48 : NCF_CHECK(ncerr)
5233 :
5234 : ! Debugging section.
5235 : !write(std_out, "(a)")"--- !DVDB_LONGRANGE_DIFF"
5236 : !write(std_out,"(3a)")" qpoint: ", trim(ktoa(this_qpts(:,iq))), ","
5237 : !write(std_out,"(a,i0,a)")" iq: ", iq, ","
5238 : !write(std_out,"(2(a,i0))")" idir: ", idir, ", ipert:", ipert
5239 : !write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5240 : !call call vd%eval(2, nfft, file_v1r(:,:,ispden,imyp), long_v1r(:,:,ispden,imyp), &
5241 : ! dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out))
5242 : !write(std_out,"(a)")"..."
5243 :
5244 : ! Debug: write potentials to file.
5245 96 : if (unt /= -1) then
5246 0 : write(unt,*)"# q-point:", trim(ktoa(this_qpts(:,iq))), ", iq: ", trim(itoa(iq))
5247 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
5248 0 : write(unt,*)"# file_v1r, long_v1r, diff"
5249 :
5250 0 : if (cplex == 1) then
5251 0 : do i3=1,n3
5252 0 : do i2=1,n2
5253 0 : do i1=1,n1
5254 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5255 : write(unt,"(3(i0,1x),3(es12.4,2x))") &
5256 0 : i1,i2,i3, &
5257 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5258 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp)
5259 : end do
5260 : end do
5261 : end do
5262 : else
5263 0 : do i3=1,n3
5264 0 : do i2=1,n2
5265 0 : do i1=1,n1
5266 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5267 : write(unt, "(3(i0,1x),6(es12.4,2x))") &
5268 0 : i1,i2,i3, &
5269 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5270 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp), &
5271 0 : file_v1r(2,ifft,ispden,imyp), long_v1r(2,ifft,ispden,imyp), &
5272 0 : file_v1r(2,ifft,ispden,imyp) - long_v1r(2,ifft,ispden,imyp)
5273 : end do
5274 : end do
5275 : end do
5276 : end if
5277 0 : write(unt,*)
5278 0 : write(unt,*)
5279 : end if
5280 :
5281 : end do
5282 : end do
5283 : !write(std_out,*)" "
5284 : end do ! iq
5285 :
5286 2 : ABI_FREE(long_v1r)
5287 2 : ABI_FREE(file_v1r)
5288 2 : ABI_FREE(workg)
5289 2 : ABI_FREE(gfft)
5290 2 : ABI_FREE(ig2ifft)
5291 2 : ABI_FREE(gsmall)
5292 2 : ABI_FREE(work_gsmall)
5293 :
5294 2 : if (interpolated == 1) then
5295 : ! Compute max_r |W(R,r)| and write data to file.
5296 1 : call dvdb%get_maxw(dtset%ddb_ngqpt, all_rpt, all_rmod, maxw)
5297 1 : if (my_rank == master) then
5298 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), dtset%ddb_ngqpt))
5299 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rpt"), all_rpt))
5300 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rmod"), all_rmod))
5301 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5302 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "maxw"), maxw))
5303 : end if
5304 1 : ABI_FREE(all_rpt)
5305 1 : ABI_FREE(all_rmod)
5306 1 : ABI_FREE(maxw)
5307 : end if
5308 :
5309 2 : if (my_rank == master) then
5310 2 : NCF_CHECK(nf90_close(ncid))
5311 : end if
5312 :
5313 4 : end subroutine dvdb_write_v1qavg
5314 : !!***
5315 :
5316 : !----------------------------------------------------------------------
5317 :
5318 : !!****f* m_dvdb/dvdb_test_ftinterp
5319 : !! NAME
5320 : !! dvdb_test_ftinterp
5321 : !!
5322 : !! FUNCTION
5323 : !! Debugging tool used to test the Fourier interpolation of the DFPT potentials.
5324 : !!
5325 : !! INPUTS
5326 : !! dvdb_filepath=Filename
5327 : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equat to ddb_ngqpt)
5328 : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5329 : !! qdamp=Defines exponential damping in LR potential
5330 : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5331 : !! prtvol=Verbosity level.
5332 : !! coarse_ngqpt(3)= Coarse q-mesh used to analyze the accuracy of the FT interpolation
5333 : !! Must be divisor of dvdb_ngqpt. Use 0 to disable the test.
5334 : !! comm=MPI communicator.
5335 : !!
5336 : !! OUTPUT
5337 : !! Only writing.
5338 : !!
5339 : !! SOURCE
5340 :
5341 0 : subroutine dvdb_test_ftinterp(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5342 : ddb_filepath, prtvol, coarse_ngqpt, dump_path, comm)
5343 :
5344 : !Arguments ------------------------------------
5345 : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5346 : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5347 : real(dp),intent(in) :: dvdb_qdamp
5348 : integer,intent(in) :: dvdb_ngqpt(3), coarse_ngqpt(3)
5349 :
5350 : !Local variables-------------------------------
5351 : !scalars
5352 : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0
5353 : integer :: nfft, iq, cplex, mu, ispden, comm_rpt, iblock_dielt, iblock_dielt_zeff, my_rank, ierr
5354 : integer :: ncid, ncerr
5355 : logical :: autotest
5356 0 : type(dvdb_t) :: dvdb, coarse_dvdb
5357 : type(vdiff_t) :: vd_max, vd
5358 0 : type(ddb_type) :: ddb
5359 : character(len=fnlen) :: coarse_fname
5360 : !arrays
5361 : integer :: ngfft(18)
5362 0 : real(dp),allocatable :: file_v1r(:,:,:,:),intp_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5363 : ! *************************************************************************
5364 :
5365 0 : my_rank = xmpi_comm_rank(comm)
5366 :
5367 0 : write(std_out,"(a)")sjoin(" Testing Fourier interpolation of V1(r) with ngqpt:", ltoa(dvdb_ngqpt))
5368 0 : if (len_trim(ddb_filepath) > 0) then
5369 0 : write(std_out,"(a)")sjoin(" Reading Zeff and eps_inf from DDB file:", ddb_filepath)
5370 0 : write(std_out,"(a)")sjoin(" dvdb_add_lr set to:", itoa(dvdb_add_lr))
5371 : end if
5372 :
5373 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5374 0 : dvdb%debug = .False.
5375 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5376 0 : dvdb%symv1 = symv1
5377 0 : dvdb%add_lr = dvdb_add_lr
5378 0 : dvdb%qdamp = dvdb_qdamp
5379 0 : dvdb%rspace_cell = rspace_cell
5380 :
5381 : !call dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5382 :
5383 0 : iblock_dielt = 0; iblock_dielt_zeff = 0
5384 0 : if (len_trim(ddb_filepath) > 0) then
5385 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5386 : else
5387 0 : dvdb%add_lr = 0
5388 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5389 : end if
5390 :
5391 0 : call dvdb%print([std_out], "", 0)
5392 :
5393 : ! Define FFT mesh for real space representation.
5394 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5395 0 : nfft = product(ngfft(1:3))
5396 0 : call dvdb%open_read(ngfft, comm)
5397 :
5398 0 : ABI_MALLOC(intp_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
5399 0 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
5400 :
5401 : ! Prepare FT interpolation.
5402 0 : comm_rpt = xmpi_comm_self
5403 :
5404 : ! Optionally dump ab-initio and interpolated V1(r) to a netcdf file for post-processing in python.
5405 0 : ncid = nctk_noid
5406 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5407 0 : write(std_out,"(a)")sjoin(" Will write ab-initio and interpolated potentials to:", dump_path)
5408 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5409 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5410 : ncerr = nctk_def_dims(ncid, [ &
5411 : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5412 0 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nqpt", dvdb%nqpt)], defmode=.True.)
5413 0 : NCF_CHECK(ncerr)
5414 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
5415 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
5416 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5417 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5418 0 : if (all(coarse_ngqpt /= 0)) then
5419 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_ngqpt", "int", "three")))
5420 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5421 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5422 : end if
5423 0 : NCF_CHECK(nctk_set_datamode(ncid))
5424 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
5425 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5426 0 : if (all(coarse_ngqpt /= 0)) then
5427 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_ngqpt"), coarse_ngqpt))
5428 : end if
5429 : end if
5430 :
5431 0 : autotest = .True.
5432 : if (autotest) then
5433 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5434 :
5435 : ! First step: Use FT interpolation to get q-points in the initial ab-initio mesh.
5436 : ! We should get the same result...
5437 0 : do iq=1,dvdb%nqpt
5438 : ! Read data from DVDB file and store it in file_v1r
5439 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5440 :
5441 0 : if (cplex == 1) then
5442 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
5443 0 : file_v1r(2,:,:,:) = zero
5444 : else
5445 0 : file_v1r = tmp_v1r
5446 : end if
5447 0 : ABI_FREE(tmp_v1r)
5448 :
5449 : ! Interpolate data at the same q-point.
5450 0 : call dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5451 :
5452 0 : write(std_out,"(a)")sjoin("=== For q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5453 0 : do mu=1,dvdb%natom3
5454 0 : do ispden=1,dvdb%nspden
5455 0 : write(std_out, "(a)")"--- !DVDB_SELF_DIFF"
5456 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5457 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5458 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5459 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5460 : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5461 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5462 0 : write(std_out,"(a)")"..."
5463 : !do ifft=1,nfft
5464 : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5465 : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5466 : !end do
5467 : end do
5468 : end do
5469 :
5470 0 : if (ncid /= nctk_noid) then
5471 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
5472 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
5473 : end if
5474 :
5475 0 : write(std_out,*)" "
5476 : end do ! iq
5477 :
5478 0 : write(std_out, "(/, a)")" Max values over q-points and perturbations"
5479 0 : call vd_max%print()
5480 0 : ABI_FREE(dvdb%wsr)
5481 : end if
5482 :
5483 : ! Now downsample the q-mesh, build real-space representation with coarse q-mesh and
5484 : ! compare with ab-intio values in the initial dvdb.
5485 0 : if (all(coarse_ngqpt /= 0)) then
5486 0 : write(std_out, "(/, 2a)")" Downsampling Q-mesh using coarse_ngqpt:", trim(ltoa(coarse_ngqpt))
5487 :
5488 0 : coarse_fname = strcat(dvdb_filepath, "_COARSE")
5489 0 : call dvdb%qdownsample(coarse_fname, qptopt1, coarse_ngqpt, comm)
5490 :
5491 0 : call coarse_dvdb%init(coarse_fname, gpu_option0, comm)
5492 0 : call coarse_dvdb%open_read(ngfft, comm)
5493 : !call coarse_dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5494 :
5495 0 : coarse_dvdb%debug = dvdb%debug
5496 0 : coarse_dvdb%symv1 = dvdb%symv1
5497 0 : coarse_dvdb%add_lr = dvdb%add_lr
5498 0 : coarse_dvdb%has_dielt = dvdb%has_dielt
5499 0 : coarse_dvdb%has_zeff = dvdb%has_zeff
5500 0 : coarse_dvdb%has_quadrupoles = dvdb%has_quadrupoles
5501 0 : coarse_dvdb%has_efield = dvdb%has_efield
5502 0 : coarse_dvdb%dielt = dvdb%dielt
5503 0 : coarse_dvdb%zeff = dvdb%zeff
5504 0 : coarse_dvdb%zeff_raw = dvdb%zeff_raw
5505 0 : coarse_dvdb%qstar = dvdb%qstar
5506 0 : coarse_dvdb%qdamp = dvdb%qdamp
5507 : !call coarse_dvdb%print()
5508 :
5509 : ! Prepare FT interpolation using coarse q-mesh.
5510 0 : call coarse_dvdb%ftinterp_setup(coarse_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5511 :
5512 0 : do iq=1,dvdb%nqpt
5513 : ! Read data from DVDB file and store it in file_v1r
5514 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5515 :
5516 0 : if (cplex == 1) then
5517 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
5518 0 : file_v1r(2,:,:,:) = zero
5519 : else
5520 0 : file_v1r = tmp_v1r
5521 : end if
5522 0 : ABI_FREE(tmp_v1r)
5523 :
5524 : ! Interpolate data at the same q-point using the coarse Q-mesh
5525 0 : call coarse_dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5526 :
5527 0 : write(std_out,"(a)")sjoin("=== For COARSE q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5528 0 : do mu=1,dvdb%natom3
5529 0 : do ispden=1,dvdb%nspden
5530 0 : write(std_out, "(a)")"--- !DVDB_COARSE_DIFF"
5531 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5532 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5533 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5534 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5535 : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5536 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5537 0 : write(std_out,"(a)")"..."
5538 : !do ifft=1,nfft
5539 : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5540 : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5541 : !end do
5542 : end do
5543 : end do
5544 :
5545 0 : if (ncid /= nctk_noid) then
5546 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
5547 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
5548 : end if
5549 :
5550 0 : write(std_out,*)" "
5551 : end do ! iq
5552 :
5553 0 : write(std_out, "(/, a)")" COARSE DVDB: Max values over q-points and perturbations"
5554 0 : call vd_max%print()
5555 0 : call coarse_dvdb%free()
5556 0 : if (my_rank == master) call delete_file(coarse_fname, ierr)
5557 : end if
5558 :
5559 0 : ABI_FREE(intp_v1r)
5560 0 : ABI_FREE(file_v1r)
5561 :
5562 0 : if (ncid /= nctk_noid) then
5563 0 : NCF_CHECK(nf90_close(ncid))
5564 : end if
5565 :
5566 0 : call dvdb%free()
5567 0 : call ddb%free()
5568 :
5569 0 : end subroutine dvdb_test_ftinterp
5570 : !!***
5571 :
5572 : !----------------------------------------------------------------------
5573 :
5574 : !!****f* m_dvdb/dvdb_test_symcheck
5575 : !! NAME
5576 : !! dvdb_test_symcheck
5577 : !!
5578 : !! FUNCTION
5579 : !! Debugging tool: checks whether Fourier-interpolating the DFPT potential independently
5580 : !! at q_source and at q_target = I(itimrev) S(isym) q_source (for every symmetry of the
5581 : !! crystal) gives results consistent with each other via the exact rotation formula
5582 : !! implemented in v1phq_rotate. This isolates the Fourier-interpolation machinery
5583 : !! (dvdb_ftinterp_qpt) from gstore_symmetrize: no e-ph coupling / m_gstore.F90 code is
5584 : !! involved at all. q_source need not be on the native ab-initio q-mesh.
5585 : !!
5586 : !! INPUTS
5587 : !! dvdb_filepath=Filename
5588 : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equal to ddb_ngqpt)
5589 : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5590 : !! qdamp=Defines exponential damping in LR potential
5591 : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5592 : !! prtvol=Verbosity level.
5593 : !! qpt_source(3)=Source q-point (reduced coordinates, arbitrary, need not be on the ab-initio mesh).
5594 : !! comm=MPI communicator.
5595 : !!
5596 : !! OUTPUT
5597 : !! Only writing.
5598 : !!
5599 : !! SOURCE
5600 :
5601 0 : subroutine dvdb_test_symcheck(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5602 : ddb_filepath, prtvol, qpt_source, dump_path, comm)
5603 :
5604 : !Arguments ------------------------------------
5605 : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5606 : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5607 : real(dp),intent(in) :: dvdb_qdamp
5608 : integer,intent(in) :: dvdb_ngqpt(3)
5609 : real(dp),intent(in) :: qpt_source(3)
5610 :
5611 : !Local variables-------------------------------
5612 : !scalars
5613 : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0, cplex2 = 2
5614 : integer :: nfft, isym, itimrev, tsign, mu, ispden, comm_rpt, iat, my_rank, ncid, ncerr
5615 0 : type(dvdb_t) :: dvdb
5616 : type(vdiff_t) :: vd_max, vd
5617 : !arrays
5618 : integer :: ngfft(18), g0q(3)
5619 : real(dp) :: qpt_target(3)
5620 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5621 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5622 : ! *************************************************************************
5623 :
5624 0 : my_rank = xmpi_comm_rank(comm)
5625 :
5626 0 : write(std_out,"(2a)")" Testing cross-q-point symmetry consistency of the FT interpolation of V1(r)", ch10
5627 0 : write(std_out,"(a)")sjoin(" q_source: ", ktoa(qpt_source))
5628 :
5629 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5630 0 : dvdb%debug = .False.
5631 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5632 0 : dvdb%symv1 = symv1
5633 0 : dvdb%add_lr = dvdb_add_lr
5634 0 : dvdb%qdamp = dvdb_qdamp
5635 0 : dvdb%rspace_cell = rspace_cell
5636 :
5637 0 : if (len_trim(ddb_filepath) > 0) then
5638 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5639 : else
5640 0 : dvdb%add_lr = 0
5641 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5642 : end if
5643 :
5644 0 : call dvdb%print([std_out], "", 0)
5645 :
5646 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5647 0 : nfft = product(ngfft(1:3))
5648 0 : call dvdb%open_read(ngfft, comm)
5649 :
5650 0 : comm_rpt = xmpi_comm_self
5651 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5652 :
5653 0 : ABI_MALLOC(v1r_source, (2, nfft, dvdb%nspden, dvdb%natom3))
5654 0 : ABI_MALLOC(v1r_target, (2, nfft, dvdb%nspden, dvdb%natom3))
5655 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
5656 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
5657 :
5658 : ! Interpolate once at q_source (this itself is a genuine off-grid interpolation if q_source
5659 : ! is not on the coarse ab-initio mesh).
5660 0 : call dvdb%ftinterp_qpt(qpt_source, nfft, ngfft, v1r_source, dvdb%comm_rpt)
5661 :
5662 : ! Optionally dump v1r_target (independent re-interpolation at q_target) and v1r_predicted
5663 : ! (rotated prediction from q_source) to a netcdf file for post-processing in python.
5664 0 : ncid = nctk_noid
5665 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5666 0 : write(std_out,"(a)")sjoin(" Will write target and predicted potentials to:", dump_path)
5667 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5668 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5669 : ncerr = nctk_def_dims(ncid, [ &
5670 : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5671 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nsym", dvdb%cryst%nsym), nctkdim_t("ntimrev", 2)], &
5672 0 : defmode=.True.)
5673 0 : NCF_CHECK(ncerr)
5674 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_source", "dp", "three")))
5675 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_target", "dp", "three, ntimrev, nsym")))
5676 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_target", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5677 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_predicted", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5678 0 : NCF_CHECK(nctk_set_datamode(ncid))
5679 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_source"), qpt_source))
5680 : end if
5681 :
5682 0 : g0q = 0
5683 0 : do isym=1,dvdb%cryst%nsym
5684 0 : do itimrev=1,2
5685 0 : tsign = 3 - 2*itimrev
5686 0 : qpt_target = tsign * matmul(dvdb%cryst%symrec(:,:,isym), qpt_source)
5687 :
5688 : ! Independent, direct interpolation at the target q (no symmetry involved at all).
5689 0 : call dvdb%ftinterp_qpt(qpt_target, nfft, ngfft, v1r_target, dvdb%comm_rpt)
5690 :
5691 : ! Predicted potential at q_target obtained by ROTATING the q_source interpolation
5692 : ! with the exact same formula gstore_symmetrize/v1phq_rotate uses to expand IBZ->BZ.
5693 : call v1phq_rotate(dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5694 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5695 :
5696 0 : if (ncid /= nctk_noid) then
5697 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_target"), qpt_target, start=[1,itimrev,isym]))
5698 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_target"), v1r_target, start=[1,1,1,1,itimrev,isym]))
5699 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_predicted"), v1r_predicted, start=[1,1,1,1,itimrev,isym]))
5700 : end if
5701 :
5702 0 : do mu=1,dvdb%natom3
5703 0 : iat = (mu - 1) / 3 + 1
5704 0 : do ispden=1,dvdb%nspden
5705 : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5706 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5707 : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5708 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5709 : end do
5710 : end do
5711 :
5712 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK"
5713 0 : write(std_out,"(a,i0,a)")" isym: ", isym, ","
5714 0 : write(std_out,"(a,i0,a)")" itimrev: ", itimrev, ","
5715 0 : write(std_out,"(3a)")" qpt_target: ", trim(ktoa(qpt_target)), ","
5716 0 : call vd_max%print()
5717 0 : do iat=1,dvdb%cryst%natom
5718 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5719 : end do
5720 0 : write(std_out,"(a)")"..."
5721 : end do ! itimrev
5722 : end do ! isym
5723 :
5724 0 : ABI_FREE(v1r_source)
5725 0 : ABI_FREE(v1r_target)
5726 0 : ABI_FREE(v1r_predicted)
5727 0 : ABI_FREE(vd_max_atom)
5728 :
5729 0 : if (ncid /= nctk_noid) then
5730 0 : NCF_CHECK(nf90_close(ncid))
5731 : end if
5732 :
5733 0 : call dvdb%free()
5734 :
5735 0 : end subroutine dvdb_test_symcheck
5736 : !!***
5737 :
5738 : !----------------------------------------------------------------------
5739 :
5740 : !!****f* m_dvdb/dvdb_test_symcheck_native
5741 : !! NAME
5742 : !! dvdb_test_symcheck_native
5743 : !!
5744 : !! FUNCTION
5745 : !! Debugging tool: like dvdb_test_symcheck but operates on TWO LITERAL, independently
5746 : !! DFPT-computed q-points already present in the DVDB (no Fourier interpolation involved
5747 : !! at all -- no ftinterp_setup/ftinterp_qpt call anywhere). Reads q_source and q_target
5748 : !! directly via readsym_allv1, predicts q_target from q_source via v1phq_rotate, and
5749 : !! compares against q_target's own literal data. Isolates v1phq_rotate/rotate_fqg
5750 : !! completely from the W(R,r) real-space Fourier-interpolation machinery.
5751 : !!
5752 : !! INPUTS
5753 : !! dvdb_filepath=Filename (must contain BOTH q_source and q_target as literal,
5754 : !! fully-available (3*natom perturbations) q-points, e.g. produced with nsym 1).
5755 : !! sym_dvdb_filepath=Filename of a DIFFERENT DVDB (or any file crystal_from_file can read) that
5756 : !! carries the crystal's TRUE, full symmetry table (dvdb_filepath's own nsym is typically 1,
5757 : !! since that's what forces every requested perturbation/q to be explicitly, independently
5758 : !! computed in the first place -- so its own %cryst cannot be used to look up isym > 1).
5759 : !! qpt_source(3), qpt_target(3)=The two q-points (reduced coordinates), assumed related by
5760 : !! the given isym/itimrev/g0q.
5761 : !! isym, itimrev, g0q(3)=Symmetry indices such that qpt_target = I(itimrev) S(isym) qpt_source + g0q.
5762 : !! comm=MPI communicator.
5763 : !!
5764 : !! OUTPUT
5765 : !! Only writing.
5766 : !!
5767 : !! SOURCE
5768 :
5769 0 : subroutine dvdb_test_symcheck_native(dvdb_filepath, sym_dvdb_filepath, qpt_source, qpt_target, &
5770 : isym, itimrev, g0q, comm)
5771 :
5772 : !Arguments ------------------------------------
5773 : character(len=*),intent(in) :: dvdb_filepath, sym_dvdb_filepath
5774 : integer,intent(in) :: comm, isym, itimrev
5775 : integer,intent(in) :: g0q(3)
5776 : real(dp),intent(in) :: qpt_source(3), qpt_target(3)
5777 :
5778 : !Local variables-------------------------------
5779 : !scalars
5780 : integer,parameter :: gpu_option0 = 0, cplex2 = 2
5781 : integer :: nfft, mu, ispden, iq_source, iq_target, iat
5782 0 : type(dvdb_t) :: dvdb, sym_dvdb
5783 : type(vdiff_t) :: vd_max, vd
5784 : !arrays
5785 : integer :: ngfft(18)
5786 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5787 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5788 : ! *************************************************************************
5789 :
5790 0 : write(std_out,"(2a)")" Testing v1phq_rotate against TWO LITERAL, non-interpolated q-points", ch10
5791 0 : write(std_out,"(2a)")" q_source: ", trim(ktoa(qpt_source))
5792 0 : write(std_out,"(2a)")" q_target: ", trim(ktoa(qpt_target))
5793 :
5794 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5795 0 : dvdb%debug = .False.
5796 0 : call dvdb%print([std_out], "", 0)
5797 :
5798 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5799 0 : nfft = product(ngfft(1:3))
5800 0 : call dvdb%open_read(ngfft, comm)
5801 :
5802 : ! Load a SEPARATE dvdb just to get the crystal's true, full symmetry table (dvdb_filepath's
5803 : ! own %cryst normally has nsym=1, see docstring above).
5804 0 : call sym_dvdb%init(sym_dvdb_filepath, gpu_option0, comm)
5805 0 : write(std_out,"(a,i0,a,i0)")" sym_dvdb nsym: ", sym_dvdb%cryst%nsym, " dvdb (literal) nsym: ", dvdb%cryst%nsym
5806 :
5807 0 : iq_source = dvdb%findq(qpt_source)
5808 0 : iq_target = dvdb%findq(qpt_target)
5809 0 : ABI_CHECK(iq_source /= -1, "qpt_source not found in DVDB!")
5810 0 : ABI_CHECK(iq_target /= -1, "qpt_target not found in DVDB!")
5811 :
5812 0 : call dvdb%readsym_allv1(iq_source, mu, nfft, ngfft, v1r_source, comm) ! mu reused as cplex out-arg
5813 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_source")
5814 0 : call dvdb%readsym_allv1(iq_target, mu, nfft, ngfft, v1r_target, comm)
5815 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_target")
5816 :
5817 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
5818 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
5819 :
5820 : call v1phq_rotate(sym_dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5821 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5822 :
5823 0 : call sym_dvdb%free()
5824 :
5825 0 : do mu=1,dvdb%natom3
5826 0 : iat = (mu - 1) / 3 + 1
5827 0 : do ispden=1,dvdb%nspden
5828 : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5829 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5830 : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5831 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5832 : end do
5833 : end do
5834 :
5835 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK_NATIVE"
5836 0 : call vd_max%print()
5837 0 : do iat=1,dvdb%cryst%natom
5838 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5839 : end do
5840 0 : write(std_out,"(a)")"..."
5841 :
5842 0 : ABI_FREE(v1r_source)
5843 0 : ABI_FREE(v1r_target)
5844 0 : ABI_FREE(v1r_predicted)
5845 0 : ABI_FREE(vd_max_atom)
5846 :
5847 0 : call dvdb%free()
5848 :
5849 0 : end subroutine dvdb_test_symcheck_native
5850 : !!***
5851 :
5852 : !----------------------------------------------------------------------
5853 :
5854 : !!****f* m_dvdb/dvdb_get_v1r_long_range
5855 : !! NAME
5856 : !! dvdb_get_v1r_long_range
5857 : !!
5858 : !! FUNCTION
5859 : !! Compute the long-range part of the phonon potential
5860 : !! due to the Born effective charges, PRL 115, 176401 (2015) [[cite:Verdi2015]].
5861 : !!
5862 : !! V^L_{iatom,idir}(r) = i (4pi/vol) sum_G (q+G) . Zeff_{iatom,idir}
5863 : !! e^{i (q+G).(r - tau_{iatom})} / ((q+G) . dielt . (q+G))
5864 : !!
5865 : !! where Zeff and dielt are the Born effective charge tensor and the dielectric tensor in cart coords,
5866 : !! tau is the atom position, and vol is the volume of the unit cell.
5867 : !! Note that internally the tensors are stored in Cartesian coordinates while in output we need
5868 : !! the contribution due to the displacement of the iatom-sublattice along the reduced direction idir
5869 : !! hence we need to perform some tensor gymnastics to go from Cart to reduced.
5870 : !!
5871 : !! INPUTS
5872 : !! db = the DVDB object.
5873 : !! qpt = the q-point in reduced coordinates.
5874 : !! idir = direction index.
5875 : !! iatom = atom index.
5876 : !! nfft = number of fft points.
5877 : !! ngfft(18) = FFT mesh.
5878 : !! [add_qphase]=By default, the routine returns the LR potential with the e^{iqr} phase.
5879 : !! Use add_qphase = 0 to get the lattice-periodic part.
5880 : !!
5881 : !! OUTPUT
5882 : !! v1r_lr = dipole potential
5883 : !!
5884 : !! SOURCE
5885 :
5886 22234 : subroutine dvdb_get_v1r_long_range(db, qpt, idir, iatom, nfft, ngfft, v1r_lr, add_qphase)
5887 :
5888 : !Arguments ------------------------------------
5889 : !scalars
5890 : class(dvdb_t),intent(in) :: db
5891 : integer,intent(in) :: idir, iatom, nfft
5892 : integer,optional,intent(in) :: add_qphase
5893 : !arrays
5894 : integer,intent(in) :: ngfft(18)
5895 : real(dp),intent(in) :: qpt(3)
5896 : real(dp),intent(out) :: v1r_lr(2,nfft)
5897 :
5898 : !Local variables-------------------------------
5899 : !scalars
5900 : integer :: n1, n2, n3, nfftot, ig, iphase, ii, jj, kk, ll, mm, ifft, ispden
5901 : real(dp) :: fac, qGZ, qGS, denom, denom_inv, qtau, re, im, phre, phim, qg_mod, gsq_max
5902 : real(dp),parameter :: tol_denom = tol8
5903 : !arrays
5904 22234 : integer, allocatable :: gfft(:,:)
5905 : real(dp) :: gprimd(3,3), rprimd(3,3), dielt_red(3,3)
5906 : real(dp) :: qG_red(3), qG_cart(3), Zstar(3), Sstar(3,3), tau_red(3)
5907 22234 : real(dp), allocatable :: v1G_lr(:,:), v1G_lr33(:,:,:,:), workr(:,:)
5908 : ! *************************************************************************
5909 :
5910 : ! Return immediately if metals by
5911 : !if (db%has_zeff .or. db%has_quadrupoles) then
5912 :
5913 22234 : iphase = 1; if (present(add_qphase)) iphase = add_qphase
5914 :
5915 : ! Make sure FFT parallelism is not used
5916 88936 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
5917 22234 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
5918 :
5919 : ! Allocate memory
5920 66702 : ABI_MALLOC(gfft, (3, nfft))
5921 66702 : ABI_MALLOC(v1G_lr, (2, nfft))
5922 :
5923 : ! Reciprocal and real space primitive vectors
5924 555850 : gprimd = db%cryst%gprimd; rprimd = db%cryst%rprimd
5925 :
5926 : ! Prefactor
5927 22234 : fac = four_pi / db%cryst%ucvol
5928 :
5929 : ! Transform the Born effective charge tensor from Cartesian to reduced coordinates
5930 : ! and select the relevant direction.
5931 689254 : Zstar = matmul(transpose(gprimd), matmul(db%zeff(:,:,iatom), rprimd(:,idir))) * two_pi
5932 :
5933 22234 : if (db%has_quadrupoles) then
5934 : ! Transform Qstar from Cartesian to reduced coordinates and select the relevant direction.
5935 0 : Sstar = zero
5936 0 : do ii=1,3
5937 0 : do jj=1,3
5938 0 : do kk=1,3
5939 0 : do ll=1,3
5940 0 : do mm=1,3
5941 : Sstar(ii,jj) = Sstar(ii,jj) + &
5942 0 : gprimd(mm,jj) * gprimd(ll,ii) * db%qstar(mm,ll,kk,iatom) * rprimd(kk,idir) * two_pi ** 2
5943 : end do
5944 : end do
5945 : end do
5946 : end do
5947 : end do
5948 : end if
5949 :
5950 : ! Transform the dielectric tensor from Cartesian to reduced coordinates.
5951 : ! q_cart e_cart q_cart = q_red (G^t e_cart G) q_red
5952 2023294 : dielt_red = matmul(transpose(gprimd), matmul(db%dielt, gprimd)) * two_pi ** 2
5953 :
5954 : ! Atom position
5955 88936 : tau_red = db%cryst%xred(:,iatom)
5956 :
5957 : ! Get the set of G vectors
5958 : ! TODO: May use zero-padded FFT with small G-sphere
5959 22234 : call get_gfft(ngfft, qpt, db%cryst%gmet, gsq_max, gfft)
5960 :
5961 : ! Compute the long-range potential in G-space due to Z* and Q* (if present)
5962 336598582 : v1G_lr = zero
5963 22234 : if (db%has_zeff .or. db%has_quadrupoles) then
5964 :
5965 112214350 : do ig=1,nfft
5966 : ! (q + G)
5967 448768464 : qG_red = qpt + gfft(:,ig)
5968 1795073856 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
5969 448768464 : qG_mod = sqrt(sum(qG_cart ** 2))
5970 : ! (q + G) . Zeff(:,idir,iatom)
5971 448768464 : qGZ = dot_product(qG_red, Zstar)
5972 : ! (q + G) . dielt . (q + G)
5973 1795073856 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
5974 : ! Avoid (q + G) = 0
5975 112192116 : if (denom < tol_denom) cycle
5976 112191608 : denom_inv = one / denom
5977 : ! HM hard cutoff, in this case qdamp takes the meaning of an energy cutoff in Hartree (hardcoded to 1 for the moment)
5978 : !if (half*qG_mod**2 > 1) cycle
5979 112191608 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
5980 112191608 : qGS = zero
5981 112191608 : if (db%has_quadrupoles) then
5982 0 : do ii=1,3
5983 0 : do jj=1,3
5984 0 : qGS = qGS + qG_red(ii) * qG_red(jj) * Sstar(ii,jj) / two
5985 : end do
5986 : end do
5987 : end if
5988 :
5989 : ! Phase factor exp(-i (q+G) . tau)
5990 448766432 : qtau = - two_pi * dot_product(qG_red, tau_red)
5991 112191608 : phre = cos(qtau); phim = sin(qtau)
5992 : !phre = one; phim = zero
5993 :
5994 112191608 : re = +fac * qGS * denom_inv !re = zero
5995 112191608 : im = fac * qGZ * denom_inv
5996 112191608 : v1G_lr(1,ig) = phre * re - phim * im
5997 112213842 : v1G_lr(2,ig) = phim * re + phre * im
5998 : end do
5999 : end if
6000 :
6001 : ! FFT to get the long-range potential in r-space
6002 22234 : call fourdp(2, v1G_lr, v1r_lr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6003 :
6004 22234 : if (db%has_efield) then
6005 : ! Add term due to Electric field.
6006 : ! TODO: Change API to account for ispden/isppol. return nspden LR part
6007 : ! although only the electric field part depends on nsppden.
6008 : !v1r_lr = zero ! Comment this line to have only efield contribution
6009 0 : ABI_CHECK(db%nspden == 1, "nspden != 1 not coded")
6010 0 : ispden = 1
6011 0 : ABI_CALLOC(v1G_lr33, (3, 3, 2, nfft))
6012 0 : do ig=1,nfft
6013 : !if (ig > 1) cycle
6014 : ! (q + G)
6015 0 : qG_red = qpt + gfft(:,ig)
6016 0 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
6017 0 : qG_mod = sqrt(sum(qG_cart ** 2))
6018 : ! (q + G) . Zeff(:,idir,iatom)
6019 : !qGZ = dot_product(qG_red, Zstar)
6020 : ! (q + G) . dielt . (q + G)
6021 0 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
6022 : ! Avoid (q + G) = 0
6023 0 : if (denom < tol_denom) cycle
6024 0 : denom_inv = one / denom
6025 0 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6026 0 : fac = (four_pi / db%cryst%ucvol) * denom_inv !* qGZ
6027 : ! Phase factor exp(-i (q+G) . tau)
6028 0 : qtau = - two_pi * dot_product(qG_red, tau_red)
6029 0 : phre = cos(qtau); phim = sin(qtau)
6030 : !phre = one; phim = zero
6031 :
6032 0 : do ii=1,3
6033 0 : do jj=1,3
6034 0 : v1G_lr33(ii, jj, 1, ig) = fac * phre * qG_red(ii) * qG_red(jj)
6035 0 : v1G_lr33(ii, jj, 2, ig) = fac * phim * qG_red(ii) * qG_red(jj)
6036 : end do
6037 : end do
6038 : end do ! ig
6039 :
6040 0 : ABI_MALLOC(workr, (2, nfft))
6041 0 : do ii=1,3
6042 0 : do jj=1,3
6043 0 : v1G_lr = v1G_lr33(ii, jj, :, :)
6044 0 : call fourdp(2, v1G_lr, workr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6045 : ! Two pi comes for qpt but we should check whether the gradient wrt E-field is in gprimd or 2pi gprimd coordinates.
6046 : ! MG: Remove two_pi factor because jump discontinuity in the real part for G != 0 are overestimated.
6047 0 : do ifft=1,nfft
6048 : !v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) * two_pi
6049 0 : v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) ! * two_pi
6050 : end do
6051 : end do
6052 : end do
6053 :
6054 0 : ABI_FREE(workr)
6055 0 : ABI_FREE(v1G_lr33)
6056 : end if
6057 :
6058 : ! Multiply by exp(i q.r)
6059 22234 : if (iphase == 1) call times_eikr(qpt, ngfft, nfft, 1, v1r_lr)
6060 :
6061 22234 : ABI_FREE(gfft)
6062 22234 : ABI_FREE(v1G_lr)
6063 :
6064 22234 : end subroutine dvdb_get_v1r_long_range
6065 : !!***
6066 :
6067 : !----------------------------------------------------------------------
6068 :
6069 : !!****f* m_dvdb/dvdb_load_ddb
6070 : !! NAME
6071 : !! dvdb_load_ddb
6072 : !!
6073 : !! FUNCTION
6074 : !! Load information about the Born effective charges and dielectric tensor from a DDB file
6075 : !!
6076 : !! TODO
6077 : !! Use this function in eph driver
6078 :
6079 0 : subroutine dvdb_load_ddb(dvdb, chneut, prtvol, comm, ddb_filepath, ddb)
6080 :
6081 : !Arguments ------------------------------------
6082 : !scalars
6083 : class(dvdb_t),intent(inout) :: dvdb
6084 : integer,intent(in) :: chneut, prtvol, comm
6085 : character(len=*),optional,intent(in) :: ddb_filepath
6086 : type(ddb_type),optional,target,intent(in) :: ddb
6087 :
6088 : !Local variables ------------------------------
6089 : integer,parameter :: master = 0, rfmeth1 = 1, selectz0 = 0
6090 : integer :: my_rank, iblock_dielt, iblock_dielt_zeff, iblock_quadrupoles
6091 : logical :: free_ddb
6092 0 : type(crystal_t) :: cryst_ddb
6093 : type(ddb_type),pointer :: ddb_ptr
6094 0 : type(ddb_type),target :: this_ddb
6095 0 : type(ddb_hdr_type) :: ddb_hdr
6096 : !arrays
6097 : real(dp) :: dielt(3,3)
6098 0 : real(dp),allocatable :: zeff(:,:,:), zeff_raw(:,:,:)
6099 : ! *************************************************************************
6100 :
6101 0 : my_rank = xmpi_comm_rank(comm)
6102 :
6103 0 : if (present(ddb_filepath)) then
6104 : ! Build ddb object from file. Will release memory before returning.
6105 0 : ABI_CHECK(.not. present(ddb), "ddb argument cannot be present when ddb_filepath is used")
6106 0 : call this_ddb%from_file(ddb_filepath, ddb_hdr, cryst_ddb, comm, prtvol=prtvol)
6107 0 : call this_ddb%set_brav(dvdb%brav)
6108 0 : call cryst_ddb%free()
6109 0 : ddb_ptr => this_ddb
6110 0 : free_ddb = .True.
6111 : else
6112 : ! Point input ddb, won't release memory.
6113 : free_ddb = .False.
6114 : ddb_ptr => ddb
6115 : end if
6116 :
6117 : ! Get dielectric Tensor
6118 0 : iblock_dielt = ddb_ptr%get_dielt(rfmeth1, dielt)
6119 0 : dvdb%dielt = dielt
6120 :
6121 : ! Get Dielectric Tensor and Effective Charges
6122 : ! (initialized to one_3D and zero if the derivatives are not available in the DDB file)
6123 0 : ABI_MALLOC(zeff, (3, 3, dvdb%natom))
6124 0 : ABI_MALLOC(zeff_raw, (3, 3, dvdb%natom))
6125 0 : iblock_dielt_zeff = ddb_ptr%get_dielt_zeff(dvdb%cryst, rfmeth1, chneut, selectz0, dielt, zeff, zeff_raw=zeff_raw)
6126 :
6127 0 : if (my_rank == master) then
6128 0 : if (iblock_dielt_zeff == 0) then
6129 0 : call wrtout(ab_out, sjoin("- Cannot find dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6130 0 : call wrtout(ab_out, "Values initialized with zeros")
6131 : else
6132 0 : call wrtout(ab_out, sjoin("- Found dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6133 : end if
6134 : end if
6135 :
6136 0 : if (iblock_dielt /= 0) then
6137 0 : dvdb%has_dielt = .True.
6138 0 : dvdb%dielt = dielt
6139 : end if
6140 0 : if (iblock_dielt_zeff /= 0) then
6141 0 : dvdb%has_zeff = .True.; dvdb%zeff = zeff; dvdb%zeff_raw = zeff_raw
6142 : end if
6143 0 : if (dvdb%has_dielt .and. (dvdb%has_zeff .or. dvdb%has_quadrupoles)) then
6144 0 : if (dvdb%add_lr == 0) then
6145 : call wrtout([std_out, ab_out], &
6146 0 : " WARNING: dvdb_add_lr set to 0. Long-range term won't be subtracted in Fourier interpolation.")
6147 : end if
6148 : end if
6149 :
6150 : ! Read the quadrupoles
6151 0 : iblock_quadrupoles = ddb_ptr%get_quadrupoles(ddb_hdr%ddb_version,1,BLKTYP_d3E_xx,dvdb%qstar)
6152 0 : if (iblock_quadrupoles /=0) dvdb%has_quadrupoles = .True.
6153 :
6154 0 : if (present(ddb_filepath)) call ddb_hdr%free()
6155 :
6156 0 : ABI_FREE(zeff)
6157 0 : ABI_FREE(zeff_raw)
6158 0 : if (free_ddb) call ddb_ptr%free()
6159 :
6160 0 : end subroutine dvdb_load_ddb
6161 : !!***
6162 :
6163 : !!****f* m_dvdb/dvdb_load_efield
6164 : !! NAME
6165 : !! dvdb_load_efield
6166 : !!
6167 : !! FUNCTION
6168 : !! Load first order derivatives wrt the electric file from files
6169 : !!
6170 : !! INPUTS
6171 : !! pot_paths=List of strings with paths to POT1 files.
6172 : !! comm=MPI communicator.
6173 :
6174 0 : subroutine dvdb_load_efield(dvdb, pot_paths, comm)
6175 :
6176 : !Arguments ------------------------------------
6177 : !scalars
6178 : class(dvdb_t),intent(inout) :: dvdb
6179 : integer,intent(in) :: comm
6180 : character(len=*),intent(in) :: pot_paths(3)
6181 :
6182 : !Local variables-------------------------------
6183 : !scalars
6184 : integer,parameter :: pawread0 = 0, cplex1 = 1
6185 : integer :: ii, idir, ipert, nfft
6186 0 : type(hdr_type) :: hdr
6187 : !arrays
6188 0 : real(dp),allocatable :: v1e_red(:,:,:)
6189 0 : type(pawrhoij_type),allocatable :: pawrhoij(:)
6190 : ! *************************************************************************
6191 :
6192 0 : ABI_CHECK(all(dvdb%ngfft /= -1), "dbvd%ngfft must be defined!")
6193 :
6194 0 : nfft = product(dvdb%ngfft(1:3))
6195 0 : ABI_CALLOC(v1e_red, (nfft, dvdb%nspden, 3))
6196 :
6197 0 : do ii=1,3
6198 : ! Read DFPT potentials due to E-field.
6199 : ! TODO: Should implement symmetries so that only the irred pots are needed.
6200 0 : call wrtout(std_out, sjoin("Loading Efield DFPT potential from:", pot_paths(ii)))
6201 : call read_rhor(pot_paths(ii), cplex1, dvdb%nspden, nfft, dvdb%ngfft, pawread0, &
6202 0 : dvdb%mpi_enreg, v1e_red(:,:,ii), hdr, pawrhoij, comm, allow_interp=.True., want_varname="first_order_potential")
6203 :
6204 : ! Consistency check: expecting E-field perturbation.
6205 0 : idir = mod(hdr%pertcase - 1, 3) + 1; ipert = (hdr%pertcase - idir) / 3 + 1
6206 0 : ABI_CHECK(all(abs(hdr%qptn) < tol12), sjoin("Expecting Gamma point in E-field pert, got qpt:", ktoa(hdr%qptn)))
6207 0 : ABI_CHECK(ipert == hdr%natom + 2, sjoin("Expecting E-field perturbation, got ipert:", itoa(ipert)))
6208 0 : ABI_CHECK(idir == ii, sjoin("Expecting E-field perturbation along idir:", itoa(ii), " got idir:", itoa(idir)))
6209 0 : call hdr%free()
6210 : end do
6211 :
6212 : ! Transfer data.
6213 0 : ABI_MALLOC(dvdb%v1r_efield, (nfft, 3, dvdb%nspden))
6214 0 : do ii=1,3
6215 0 : dvdb%v1r_efield(:,ii,:) = v1e_red(:,:,ii)
6216 : end do
6217 0 : ABI_FREE(v1e_red)
6218 :
6219 0 : dvdb%has_efield = .True.
6220 :
6221 0 : end subroutine dvdb_load_efield
6222 : !!***
6223 :
6224 : !----------------------------------------------------------------------
6225 :
6226 : !!****f* m_dvdb/dvdb_interpolate_and_write
6227 : !! NAME
6228 : !! dvdb_interpolate_and_write
6229 : !!
6230 : !! FUNCTION
6231 : !! Interpolate the phonon potential onto a fine q-point grid
6232 : !! and write the data in a new DVDB file.
6233 : !!
6234 : !! INPUTS
6235 : !!
6236 : !! OUTPUT
6237 : !!
6238 : !! SOURCE
6239 :
6240 8 : subroutine dvdb_interpolate_and_write(dvdb, dtset, new_dvdb_fname, ngfft, ngfftf, cryst, &
6241 8 : ngqpt_coarse, nqshift_coarse, qshift_coarse, comm, custom_qpt)
6242 :
6243 : !Arguments ------------------------------------
6244 : !scalars
6245 : integer,intent(in) :: nqshift_coarse, comm
6246 : character(len=*),intent(in) :: new_dvdb_fname
6247 : type(crystal_t),intent(in) :: cryst
6248 : class(dvdb_t),intent(inout) :: dvdb
6249 : type(dataset_type),intent(in) :: dtset
6250 : !arrays
6251 : integer,intent(in) :: ngfft(18), ngfftf(18)
6252 : integer,intent(in) :: ngqpt_coarse(3)
6253 : real(dp),intent(in) :: qshift_coarse(3,nqshift_coarse)
6254 : real(dp),optional,intent(in) :: custom_qpt(:,:)
6255 :
6256 : !Local variables ------------------------------
6257 : !scalars
6258 : integer,parameter :: master=0, fform_pot=111
6259 : integer :: my_rank,nproc,idir,ipert,iat,ipc,ispden, ierr
6260 : integer :: cplex,db_iqpt,natom,natom3,npc,trev_q,nspden
6261 : integer :: nqbz, nqibz, iq, ifft, nqbz_coarse
6262 : integer :: nperts_read, nperts_interpolate, nperts
6263 : integer :: nqpt_read, nqpt_interpolate, qptopt
6264 : integer :: nfft,nfftf, dimv1, ount, unt, fform, ncid, ncerr
6265 : logical :: use_netcdf
6266 : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
6267 : character(len=500) :: msg
6268 : character(len=fnlen) :: tmp_fname
6269 8 : type(hdr_type) :: hdr_ref
6270 : !arrays
6271 16 : integer :: qptrlatt(3,3), rfdir(3), symq(4,2,cryst%nsym)
6272 8 : integer,allocatable :: pinfo(:,:),rfpert(:),pertsy(:,:,:),iq_read(:),this_pertsy(:,:)
6273 : real(dp) :: qpt(3), rhog1_g0(2)
6274 8 : real(dp),allocatable :: v1scf(:,:,:), v1scf_rpt(:,:,:,:),v1(:)
6275 8 : real(dp),allocatable :: wtq(:),qibz(:,:),qbz(:,:),q_interp(:,:),q_read(:,:)
6276 : !************************************************************************
6277 :
6278 8 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6279 :
6280 8 : write(msg, '(2a)') " Interpolation of the electron-phonon coupling potential", ch10
6281 8 : call wrtout(ab_out, msg, do_flush=.True.); call wrtout(std_out, msg, do_flush=.True.)
6282 :
6283 8 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6284 :
6285 8 : if (dtset%eph_task == 5 .or. present(custom_qpt)) then
6286 7 : msg = sjoin(" From coarse q-mesh:", ltoa(ngqpt_coarse), "to:", ltoa(dtset%eph_ngqpt_fine))
6287 21 : call wrtout([std_out, ab_out], msg)
6288 : ! Setup fine q-point grid in the IBZ
6289 : ! Generate the list of irreducible q-points in the grid
6290 7 : qptrlatt = 0
6291 7 : qptrlatt(1,1) = dtset%eph_ngqpt_fine(1); qptrlatt(2,2) = dtset%eph_ngqpt_fine(2); qptrlatt(3,3) = dtset%eph_ngqpt_fine(3)
6292 7 : qptopt = 1; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
6293 7 : call wrtout(std_out, sjoin(" Generating q-IBZ for DVDB with qptopt:", itoa(qptopt)))
6294 7 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
6295 :
6296 1 : else if (dtset%eph_task == -5) then
6297 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
6298 3 : call wrtout([std_out, ab_out], msg)
6299 1 : ABI_CHECK(dtset%ph_nqpath > 0, "ph_nqpath must be specified when eph_task == -5")
6300 1 : nqibz = dtset%ph_nqpath
6301 3 : ABI_MALLOC(qibz, (3, nqibz))
6302 22 : qibz = dtset%ph_qpath(:, 1:nqibz)
6303 8 : ABI_CALLOC(wtq, (nqibz))
6304 1 : nqbz = nqibz
6305 2 : ABI_MALLOC(qbz, (3, nqbz))
6306 22 : qbz = qibz
6307 :
6308 : else
6309 0 : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
6310 : end if
6311 :
6312 8 : if (present(custom_qpt)) then
6313 0 : ABI_SFREE(qibz)
6314 0 : ABI_SFREE(wtq)
6315 0 : ABI_SFREE(qbz)
6316 0 : nqibz = size(custom_qpt,dim=2)
6317 0 : ABI_MALLOC(qibz, (3, nqibz))
6318 0 : qibz = custom_qpt
6319 0 : ABI_CALLOC(wtq, (nqibz))
6320 0 : nqbz = nqibz
6321 0 : ABI_MALLOC(qbz, (3, nqbz))
6322 0 : qbz = qibz
6323 : end if
6324 :
6325 32 : nfft = product(ngfft(1:3)); nfftf = product(ngfftf(1:3))
6326 :
6327 : ! check that ngqpt_coarse is in DVDB.
6328 32 : nqbz_coarse = product(ngqpt_coarse) * nqshift_coarse
6329 :
6330 : ! ==========================================
6331 : ! Prepare the header to write the potentials
6332 : ! ==========================================
6333 :
6334 : ! Read the first header
6335 8 : if (my_rank == master) then
6336 8 : if (open_file(dvdb%path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
6337 0 : ABI_ERROR(msg)
6338 : end if
6339 8 : read(unt, err=10, iomsg=msg) dvdb%version
6340 8 : read(unt, err=10, iomsg=msg) dvdb%numv1
6341 :
6342 8 : call hdr_ref%fort_read(unt, fform)
6343 8 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
6344 0 : ABI_ERROR(sjoin("While reading:", dvdb%path, ch10, msg))
6345 : end if
6346 8 : close(unt)
6347 : end if
6348 :
6349 : ! Reset the symmetries of the header
6350 : ! One might have disable the symmetries in the response function calculation
6351 : ! that produced the initial set of potentials present in the DVDB.
6352 : ! This is because the symmetry features are not used in all parts
6353 : ! of the response function driver.
6354 : !write(std_out,*)hdr_ref%nsym, cryst%nsym
6355 : !ABI_CHECK(hdr_ref%nsym == cryst%nsym, "Diff nsym")
6356 8 : ABI_SFREE(hdr_ref%symrel)
6357 8 : ABI_SFREE(hdr_ref%tnons)
6358 8 : ABI_SFREE(hdr_ref%symafm)
6359 8 : hdr_ref%nsym = cryst%nsym
6360 24 : ABI_MALLOC(hdr_ref%symrel, (3,3,hdr_ref%nsym))
6361 24 : ABI_MALLOC(hdr_ref%tnons, (3,hdr_ref%nsym))
6362 24 : ABI_MALLOC(hdr_ref%symafm, (hdr_ref%nsym))
6363 :
6364 5000 : hdr_ref%symrel(:,:,:) = cryst%symrel(:,:,:)
6365 1544 : hdr_ref%tnons(:,:) = cryst%tnons(:,:)
6366 392 : hdr_ref%symafm(:) = cryst%symafm(:)
6367 32 : hdr_ref%ngfft = ngfftf(1:3)
6368 :
6369 : ! =======================================
6370 : ! Open DVDB and copy important dimensions
6371 : ! =======================================
6372 :
6373 8 : call dvdb%open_read(ngfftf, xmpi_comm_self)
6374 :
6375 : ! Besides perturbations with same q-points won't be contiguous on file --> IO is gonna be inefficient.
6376 16 : call dvdb%print([std_out], "", dtset%prtvol)
6377 :
6378 8 : natom = cryst%natom
6379 8 : natom3 = 3 * natom
6380 8 : nspden = dvdb%nspden
6381 :
6382 : ! ==================================================
6383 : ! Sort the q-points to read and those to interpolate
6384 : ! and find the irreducible perturbations
6385 : ! ==================================================
6386 24 : ABI_MALLOC(iq_read, (nqibz))
6387 24 : ABI_MALLOC(q_read, (3,nqibz))
6388 16 : ABI_MALLOC(q_interp, (3,nqibz))
6389 32 : ABI_MALLOC(pertsy, (nqibz,3,dvdb%mpert))
6390 24 : ABI_MALLOC(this_pertsy, (3,dvdb%mpert))
6391 24 : ABI_MALLOC(rfpert, (dvdb%mpert))
6392 24 : ABI_MALLOC(pinfo, (3,3*dvdb%mpert))
6393 110 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
6394 :
6395 2645 : pertsy = 0
6396 8 : nqpt_read = 0
6397 8 : nperts_read = 0
6398 8 : nqpt_interpolate = 0
6399 8 : nperts_interpolate = 0
6400 :
6401 111 : do iq=1,nqibz
6402 412 : qpt = qibz(:,iq)
6403 :
6404 : ! Find the index of the q-point in the DVDB.
6405 103 : db_iqpt = dvdb%findq(qpt)
6406 : !if (db_iqpt /= 1) db_iqpt = -1
6407 :
6408 111 : if (db_iqpt /= -1) then
6409 29 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt)," found in DVDB with index ",itoa(db_iqpt)))
6410 29 : nqpt_read = nqpt_read + 1
6411 116 : q_read(:,nqpt_read) = qpt(:)
6412 29 : iq_read(nqpt_read) = db_iqpt
6413 :
6414 : ! Count the perturbations
6415 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6416 85 : do ipc=1,npc
6417 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6418 85 : if (iat .le. natom) nperts_read = nperts_read + 1
6419 : end do
6420 :
6421 : else
6422 74 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt), "not found in DVDB. Will interpolate."))
6423 74 : nqpt_interpolate = nqpt_interpolate + 1
6424 296 : q_interp(:,nqpt_interpolate) = qpt(:)
6425 :
6426 : ! Examine the symmetries of the q wavevector
6427 74 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
6428 :
6429 : ! Find the list of irreducible perturbations for this q-point.
6430 : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
6431 74 : this_pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
6432 2358 : pertsy(nqpt_interpolate,:,:) = this_pertsy
6433 : !pertsy = 1
6434 :
6435 201 : do iat=1,natom
6436 582 : do idir=1,3
6437 381 : ipert = (iat-1) * 3 + idir
6438 508 : if (pertsy(nqpt_interpolate,idir,iat) == 1) nperts_interpolate = nperts_interpolate + 1
6439 : end do
6440 : end do
6441 :
6442 : end if
6443 : end do
6444 :
6445 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points found in input DVDB:", itoa(nqpt_read)))
6446 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points requiring Fourier interpolation", itoa(nqpt_interpolate)))
6447 :
6448 : ! =================================================
6449 : ! Open the new DVDB file and write preliminary info
6450 : ! =================================================
6451 8 : nperts = nperts_read + nperts_interpolate
6452 :
6453 8 : if (my_rank == master) then
6454 8 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6455 0 : ABI_ERROR(msg)
6456 : end if
6457 8 : write(ount, err=10, iomsg=msg) dvdb_last_version
6458 8 : write(ount, err=10, iomsg=msg) nperts
6459 : end if
6460 :
6461 : ! =================================================================
6462 : ! Master reads all available perturbations and copy in the new DVDB
6463 : ! =================================================================
6464 :
6465 0 : rhog1_g0 = zero
6466 :
6467 : if (my_rank == master) then
6468 37 : do iq=1,nqpt_read
6469 116 : qpt = q_read(:,iq)
6470 29 : db_iqpt = iq_read(iq)
6471 :
6472 : ! Read each irreducible perturbation potentials
6473 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6474 29 : ABI_CHECK(npc /= 0, "npc == 0!")
6475 :
6476 : ! These arrays depend on cplex.
6477 145 : ABI_MALLOC(v1scf, (cplex, nfftf, nspden))
6478 87 : ABI_MALLOC(v1, (cplex*nfftf))
6479 :
6480 85 : do ipc=1,npc
6481 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6482 56 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfftf, ngfftf, v1scf, msg) /= 0) then
6483 0 : ABI_ERROR(msg)
6484 : end if
6485 :
6486 : ! Write header
6487 224 : hdr_ref%qptn = qpt
6488 56 : hdr_ref%pertcase = ipert
6489 56 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6490 56 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6491 :
6492 112 : do ispden=1,nspden
6493 112 : v1 = reshape(v1scf(:,:,ispden), (/cplex*nfftf/))
6494 112 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6495 : end do
6496 85 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6497 : end do
6498 :
6499 29 : ABI_FREE(v1scf)
6500 37 : ABI_FREE(v1)
6501 : end do
6502 : end if ! master
6503 :
6504 8 : call xmpi_barrier(comm)
6505 :
6506 : ! ================================================================
6507 : ! Interpolate the potential for q-points not in the original DVDB
6508 : ! ================================================================
6509 :
6510 8 : dvdb%my_nrpt = nqbz_coarse
6511 40 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2, dvdb%my_nrpt, nfftf, dvdb%nspden), ierr)
6512 :
6513 8 : cplex = 2
6514 32 : ABI_MALLOC(v1scf, (cplex,nfftf,nspden))
6515 24 : ABI_MALLOC(v1, (cplex*nfftf))
6516 :
6517 : use_netcdf = .False.
6518 : ! Create temporary netcdf file used to write Fortran file with contiguous perturbations.
6519 8 : use_netcdf = .True.
6520 8 : if (my_rank == master) then
6521 8 : tmp_fname = strcat(new_dvdb_fname, "_TEMPORARY_TRANSFER_FILE.nc")
6522 8 : dimv1 = cplex * nfftf
6523 8 : NCF_CHECK(nctk_open_create(ncid, tmp_fname, xmpi_comm_self))
6524 : ncerr = nctk_def_dims(ncid, [&
6525 : nctkdim_t("dimv1", dimv1), nctkdim_t("nspden", nspden), &
6526 : nctkdim_t("natom", natom), nctkdim_t("nqpt_intp", nqpt_interpolate), &
6527 : nctkdim_t("nrpt", dvdb%my_nrpt), nctkdim_t("nfft", nfftf), nctkdim_t("natom3", natom * 3) &
6528 64 : ])
6529 8 : NCF_CHECK(ncerr)
6530 8 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1", "dp", "dimv1, nspden, three, natom, nqpt_intp")))
6531 : !NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1scf_rpt", "dp", "two, nrpt, nfft, nspden, natom3")))
6532 8 : NCF_CHECK(nctk_set_datamode(ncid))
6533 : end if
6534 :
6535 23 : do iat=1,natom
6536 68 : do idir=1,3
6537 45 : ipert = (iat-1) * 3 + idir
6538 :
6539 : ! Entry set to -1 for perturbations that can be found from basis perturbations.
6540 576 : if (sum(pertsy(:,idir,iat)) == -nqpt_interpolate) cycle
6541 :
6542 31 : call wrtout(std_out, sjoin(" Interpolating perturbation iat, idir = ",itoa(iat), itoa(idir)), do_flush=.True.)
6543 31 : call cwtime(cpu, wall, gflops, "start")
6544 :
6545 : ! TODO: This part is slow.
6546 : ! Compute phonon potential in real space lattice representation.
6547 : call dvdb_get_v1scf_rpt(dvdb, cryst, ngqpt_coarse, nqshift_coarse, &
6548 : qshift_coarse, nfftf, ngfftf, &
6549 31 : dvdb%my_nrpt, dvdb%nspden, ipert, v1scf_rpt, comm)
6550 :
6551 : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1scf_rpt"), v1scf_rpt, start=[1,1,1,1,ipert]))
6552 31 : call cwtime_report(" v1scf_rpt built", cpu, wall, gflops)
6553 :
6554 348 : do iq=1,nqpt_interpolate
6555 317 : if (pertsy(iq,idir,iat) == -1) cycle
6556 976 : qpt = q_interp(:,iq)
6557 :
6558 : ! Interpolate the phonon potential
6559 : call dvdb_get_v1scf_qpt(dvdb, cryst, qpt, nfftf, ngfftf, dvdb%my_nrpt, &
6560 244 : dvdb%nspden, ipert, v1scf_rpt, v1scf, comm)
6561 :
6562 : !call wrtout(std_out, sjoin("Writing q-point", itoa(iq)))
6563 275 : if (my_rank == master) then
6564 : if (use_netcdf) then
6565 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6566 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6567 244 : NCF_CHECK(ncerr)
6568 : else
6569 : ! Master writes the file (change also qpt and ipert in hdr%)
6570 : hdr_ref%qptn = qpt
6571 : hdr_ref%pertcase = ipert
6572 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6573 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6574 :
6575 : do ispden=1,nspden
6576 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6577 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6578 : end do
6579 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6580 : end if
6581 : end if
6582 : end do
6583 :
6584 31 : call cwtime_report(" q-points interpolated and written to new DVDB file.", cpu, wall, gflops)
6585 122 : ABI_FREE(dvdb%my_rpt)
6586 : end do
6587 : end do
6588 :
6589 8 : if (use_netcdf .and. my_rank == master) then
6590 82 : do iq=1,nqpt_interpolate
6591 296 : qpt = q_interp(:,iq)
6592 209 : do iat=1,natom
6593 582 : do idir=1,3
6594 381 : if (pertsy(iq,idir,iat) == -1) cycle
6595 244 : ipert = (iat-1) * 3 + idir
6596 976 : hdr_ref%qptn = qpt
6597 244 : hdr_ref%pertcase = ipert
6598 244 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6599 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6600 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6601 244 : NCF_CHECK(ncerr)
6602 488 : do ispden=1,nspden
6603 488 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6604 488 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6605 : end do
6606 371 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6607 : end do
6608 : end do
6609 : end do
6610 8 : NCF_CHECK(nf90_close(ncid))
6611 8 : call delete_file(tmp_fname, ierr)
6612 : end if
6613 :
6614 8 : if (my_rank == master) close(ount)
6615 :
6616 : ! Free memory
6617 8 : ABI_FREE(v1scf)
6618 8 : ABI_FREE(v1)
6619 8 : ABI_FREE(v1scf_rpt)
6620 8 : ABI_FREE(qbz)
6621 8 : ABI_FREE(qibz)
6622 8 : ABI_FREE(q_interp)
6623 8 : ABI_FREE(q_read)
6624 8 : ABI_FREE(wtq)
6625 8 : ABI_FREE(iq_read)
6626 8 : ABI_FREE(pertsy)
6627 8 : ABI_FREE(this_pertsy)
6628 8 : ABI_FREE(rfpert)
6629 8 : ABI_FREE(pinfo)
6630 :
6631 8 : call hdr_ref%free()
6632 :
6633 8 : write(msg, '(2a)') "Interpolation of the electron-phonon coupling potential completed", ch10
6634 24 : call wrtout([std_out, ab_out], msg, do_flush=.True.)
6635 :
6636 8 : call cwtime_report(" Overall time:", cpu_all, wall_all, gflops_all)
6637 :
6638 8 : return
6639 :
6640 : ! Handle Fortran IO error
6641 : 10 continue
6642 0 : ABI_ERROR(msg)
6643 :
6644 24 : end subroutine dvdb_interpolate_and_write
6645 : !!***
6646 :
6647 : !----------------------------------------------------------------------
6648 :
6649 : !!****f* m_dvdb/dvdb_qdownsample
6650 : !! NAME
6651 : !! dvdb_qdownsample
6652 : !!
6653 : !! FUNCTION
6654 : !! Downsample the q-mesh. Produce new DVDB file
6655 : !!
6656 : !! INPUTS
6657 : !! new_dvdb_fname=Path of output DVDB
6658 : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
6659 : !! ngqpt(3)=Division of coarse Q-mesh
6660 : !! comm=MPI communicator.
6661 : !!
6662 : !! OUTPUT
6663 : !! Only writing
6664 : !!
6665 : !! SOURCE
6666 :
6667 0 : subroutine dvdb_qdownsample(dvdb, new_dvdb_fname, qptopt, ngqpt, comm)
6668 :
6669 : !Arguments ------------------------------------
6670 : !scalars
6671 : integer,intent(in) :: comm
6672 : class(dvdb_t),intent(inout) :: dvdb
6673 : character(len=*),intent(in) :: new_dvdb_fname
6674 : !arrays
6675 : integer,intent(in) :: qptopt, ngqpt(3)
6676 :
6677 : !Local variables ------------------------------
6678 : !scalars
6679 : integer,parameter :: master=0, fform_pot=111
6680 : integer :: ierr,my_rank,nproc,idir,ipert,iat,ipc,ispden
6681 : integer :: cplex, db_iqpt, npc, nqbz, nqibz, iq, ifft, nperts_read, nfft, ount
6682 : character(len=500) :: msg
6683 : !arrays
6684 : integer :: qptrlatt(3,3)
6685 0 : integer,allocatable :: iq_read(:), pinfo(:,:)
6686 : real(dp) :: rhog1_g0(2)
6687 0 : real(dp),allocatable :: v1scf(:,:,:), v1(:), wtq(:), qibz(:,:), qbz(:,:)
6688 : !************************************************************************
6689 :
6690 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6691 0 : if (my_rank /= master) goto 20
6692 :
6693 0 : nfft = product(dvdb%ngfft(1:3))
6694 :
6695 : ! =======================
6696 : ! Setup fine q-point grid
6697 : ! =======================
6698 : ! Generate the list of irreducible q-points in the coarse grid
6699 0 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
6700 0 : call kpts_ibz_from_kptrlatt(dvdb%cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
6701 :
6702 : ! =======================================
6703 : ! Open DVDB and copy important dimensions
6704 : ! =======================================
6705 :
6706 0 : ABI_MALLOC(iq_read, (nqibz))
6707 0 : ABI_MALLOC(pinfo, (3, 3*dvdb%mpert))
6708 0 : nperts_read = 0
6709 :
6710 0 : do iq=1,nqibz
6711 : ! Find the index of the q-point in the DVDB.
6712 0 : db_iqpt = dvdb%findq(qibz(:, iq))
6713 0 : ABI_CHECK(db_iqpt /= -1, sjoin("Q-point:", ktoa(qibz(:, iq)), "not found in DVDB!"))
6714 0 : iq_read(iq) = db_iqpt
6715 :
6716 : ! Count the number of perturbations.
6717 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6718 0 : do ipc=1,npc
6719 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6720 0 : if (iat <= dvdb%cryst%natom) nperts_read = nperts_read + 1
6721 : end do
6722 : end do
6723 :
6724 : ! =================================================
6725 : ! Open the new DVDB file and write preliminary info
6726 : ! =================================================
6727 : !nperts = nperts_read + nperts_interpolate
6728 0 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6729 0 : ABI_ERROR(msg)
6730 : end if
6731 0 : write(ount, err=10, iomsg=msg) dvdb_last_version
6732 0 : write(ount, err=10, iomsg=msg) nperts_read
6733 :
6734 : ! Read all perturbations on the coarse Q-mesh and write them to the new DVDB
6735 0 : rhog1_g0 = zero
6736 :
6737 0 : do iq=1,nqibz
6738 0 : db_iqpt = iq_read(iq)
6739 :
6740 : ! Read each irreducible perturbation potentials
6741 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6742 0 : ABI_CHECK(npc /= 0, "npc == 0!")
6743 :
6744 0 : ABI_MALLOC(v1scf, (cplex, nfft, dvdb%nspden))
6745 0 : ABI_MALLOC(v1, (cplex*nfft))
6746 :
6747 0 : do ipc=1,npc
6748 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6749 0 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfft, dvdb%ngfft, v1scf, msg) /= 0) then
6750 0 : ABI_ERROR(msg)
6751 : end if
6752 :
6753 : ! Change the header.
6754 0 : dvdb%hdr_ref%qptn = qibz(:, iq)
6755 0 : dvdb%hdr_ref%pertcase = ipert
6756 :
6757 : ! Write header
6758 0 : call dvdb%hdr_ref%fort_write(ount, fform_pot, ierr)
6759 0 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6760 :
6761 0 : do ispden=1,dvdb%nspden
6762 0 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfft])
6763 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
6764 : end do
6765 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6766 : end do
6767 :
6768 0 : ABI_FREE(v1scf)
6769 0 : ABI_FREE(v1)
6770 : end do
6771 :
6772 0 : close(ount)
6773 :
6774 : ! Free memory
6775 0 : ABI_FREE(qbz)
6776 0 : ABI_FREE(qibz)
6777 0 : ABI_FREE(wtq)
6778 0 : ABI_FREE(iq_read)
6779 0 : ABI_FREE(pinfo)
6780 :
6781 0 : write(msg, '(2a)') " Downsampling of the e-ph coupling potential completed", ch10
6782 0 : call wrtout(std_out, msg, do_flush=.True.)
6783 :
6784 : 20 continue
6785 0 : call xmpi_barrier(comm)
6786 :
6787 0 : return
6788 :
6789 : ! Handle Fortran IO error
6790 : 10 continue
6791 0 : ABI_ERROR(msg)
6792 :
6793 0 : end subroutine dvdb_qdownsample
6794 : !!***
6795 :
6796 38966 : end module m_dvdb
6797 : !!***
|
