Branch data 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
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 : 1598 : 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 [ + + + + ]: 153734 : pinfo = 0; cplex = 0; nperts = 0
1070 [ + + ]: 4688 : do ipert=1,db%natom ! selects atomic perturbations only.
1071 [ + + ]: 13958 : do idir=1,3
1072 : 9270 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1073 [ + + ]: 12360 : if (iv1 /= 0) then
1074 : 4890 : nperts = nperts + 1
1075 [ + + ]: 19560 : pinfo(:, nperts) = [idir, ipert, idir + (ipert-1)*3]
1076 [ + + ]: 4890 : if (cplex == 0) cplex = db%cplex_v1(iv1)
1077 [ - + ]: 4890 : 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 : 1598 : 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 : 4834 : 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 : 4834 : real(dp),allocatable :: v1r_file(:,:)
1129 : : ! *************************************************************************
1130 : :
1131 : : ! Consistency checks
1132 : 4834 : ierr = 1
1133 : 4834 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1134 : :
1135 : 4834 : 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 [ - + ]: 4834 : 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 : 4834 : call dvdb_seek(db, idir, ipert, iqpt)
1147 : 4834 : ierr = my_hdr_skip(db%fh, idir, ipert, db%qpts(:,iqpt), msg)
1148 [ - + ]: 4834 : 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 [ + + ]: 19336 : nfftot_out = product(ngfft(:3)); nfftot_file = product(db%ngfft3_v1(:3, iv1))
1155 : :
1156 [ + + + + : 15718 : 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 [ + + ]: 1206 : if (enough == 0) ABI_COMMENT("Performing FFT interpolation of DFPT potentials as input ngfft differs from ngfft_file.")
1163 : 1206 : enough = enough + 1
1164 [ - + + - : 4824 : ABI_MALLOC(v1r_file, (cplex*nfftot_file, db%nspden))
- + + - +
- + - - +
- + ]
1165 [ + + ]: 2412 : do ispden=1,db%nspden
1166 [ + - ]: 2412 : 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 : 1206 : ngfft_in = ngfft; ngfft_out = ngfft
1171 [ + + + + ]: 8442 : ngfft_in(1:3) = db%ngfft3_v1(1:3, iv1); ngfft_out(1:3) = ngfft(1:3)
1172 [ + + + + ]: 8442 : ngfft_in(4:6) = ngfft_in(1:3); ngfft_out(4:6) = ngfft_out(1:3)
1173 [ + + + + ]: 25326 : ngfft_in(9:18) = 0; ngfft_out(9:18) = 0
1174 : 1206 : ngfft_in(10) = 1; ngfft_out(10) = 1
1175 : :
1176 : 1206 : call fourier_interpol_seq(cplex, db%nspden, nfftot_file, ngfft_in, nfft, ngfft, v1r_file, v1scf)
1177 [ - + ]: 1206 : ABI_FREE(v1r_file)
1178 : : end if
1179 : :
1180 : : ! Skip record with rhog1_g0 (if present)
1181 [ + - + - ]: 4834 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
1182 : :
1183 : 4834 : db%current_fpos = db%current_fpos + 1
1184 : : !write(std_out, *)"incr current_fpos", db%current_fpos
1185 : :
1186 : 4834 : 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 [ - + - + ]: 9668 : 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 : 1540 : 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 : 1540 : integer :: pinfo(3,3*db%mpert),pflag(3, db%natom)
1244 : : real(dp) :: tsec(2)
1245 : 1540 : integer,allocatable :: requests(:)
1246 : : ! *************************************************************************
1247 : :
1248 : : ! Keep track of total time spent.
1249 : 1540 : call timab(1805, 1, tsec)
1250 : :
1251 : 1540 : 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 : 1540 : npc = dvdb_get_pinfo(db, iqpt, cplex, pinfo)
1255 [ - + ]: 1540 : ABI_CHECK(npc /= 0, "npc == 0!")
1256 : :
1257 [ - + + - : 9240 : 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 [ - + + - : 4620 : ABI_MALLOC(requests, (npc))
+ - + - -
+ - + ]
1261 : :
1262 [ + + ]: 6318 : do ipc=1,npc
1263 : 4778 : idir = pinfo(1,ipc); ipert = pinfo(2,ipc); pcase = pinfo(3, ipc)
1264 [ + - ]: 4778 : if (my_rank == master) then
1265 [ - + ]: 4778 : 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 [ - + ]: 6318 : if (nproc > 1) call xmpi_ibcast(v1scf(:,:,:,pcase), master, comm, requests(ipc), ierr)
1270 : : end do
1271 : :
1272 [ - + ]: 1540 : if (nproc > 1) call xmpi_waitall(requests, ierr)
1273 [ - + ]: 1540 : ABI_FREE(requests)
1274 : :
1275 : : ! Return if all perts are available.
1276 [ + + ]: 1540 : if (npc == 3*db%natom) then
1277 [ + + ]: 334 : 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 [ - + ]: 334 : if (db%debug) write(std_out,*)"All perts available. Returning"
1288 : 334 : 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 [ - + ]: 1206 : 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 [ + + + + ]: 10574 : pflag = 0
1300 [ + + ]: 4040 : do ipc=1,npc
1301 : 4040 : pflag(pinfo(1,ipc), pinfo(2,ipc)) = 1
1302 : : end do
1303 : :
1304 : 1206 : call v1phq_complete(db%cryst,db%qpts(:,iqpt),ngfft,cplex,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,v1scf)
1305 : :
1306 : 1206 : 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 : 1165 : 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 : 1165 : real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:)
1360 : : ! *************************************************************************
1361 : :
1362 : : ABI_UNUSED(qbz(1))
1363 : :
1364 : : ! Keep track of total time spent.
1365 : 1165 : call timab(1802, 1, tsec)
1366 : :
1367 : 1165 : db_iqpt = qbz2db(1)
1368 : :
1369 : : ! IS(q_dvdb) + g0q = q_bz
1370 [ + + ]: 4660 : isym = qbz2db(2); itimrev = qbz2db(6) + 1; g0q = qbz2db(3:5)
1371 [ + + + + : 4339 : 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 [ - + ]: 1165 : call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm)
1376 : :
1377 [ + + ]: 1165 : 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 [ + - ]: 582 : if (db%my_npert == db%natom3) then
1382 [ - + + - : 3492 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1383 [ + - + - : 141663702 : work = v1scf
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
1384 : : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1385 : 582 : db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert)
1386 [ - + ]: 582 : 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 : 1165 : call timab(1802, 2, tsec)
1419 : :
1420 [ - + - + ]: 1165 : 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 : 20 : 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 : 20 : real(dp),allocatable :: rho1(:,:,:,:)
1475 : : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
1476 : : ! *************************************************************************
1477 : :
1478 : : ! Get rho1(cplex, nfftf, nspden, my_npert))
1479 : 20 : call db%readsym_qbz(cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, rho1, comm)
1480 : :
1481 : 20 : option=2 ! if 2, treat only density change
1482 [ - + + - : 120 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1483 [ + + ]: 140 : 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 : 140 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
1487 : : end do
1488 [ - + ]: 20 : ABI_FREE(rho1)
1489 : :
1490 : 20 : 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 : 1206 : 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 : 2412 : integer :: symq(4,2,cryst%nsym)
1553 : : real(dp) :: phnon1(2),tnon(3)
1554 : 1206 : real(dp),allocatable :: workg(:,:), workg_eq(:,:),v1g(:,:,:)
1555 : : ! *************************************************************************
1556 : :
1557 [ + + ]: 4824 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
1558 [ - + ]: 1206 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
1559 : 1206 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
1560 : :
1561 [ - + + - : 4824 : ABI_MALLOC(v1g, (2,nfft,nspden))
- + + - +
- + - - +
- + ]
1562 [ - + + - : 3618 : ABI_MALLOC(workg_eq, (2, nfft))
+ - + - -
+ - + ]
1563 [ - + + - : 2412 : ABI_MALLOC(workg, (2, nfft))
- + - + ]
1564 : :
1565 : : ! Examine the symmetries of the q wavevector
1566 : 1206 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
1567 : :
1568 : : pcase_loop: &
1569 [ + + ]: 8232 : do pcase=1,3*cryst%natom
1570 : 7026 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
1571 [ + + ]: 7026 : if (pflag(idir, ipert) /= 0) cycle ! This pcase is available
1572 : :
1573 : : ! Find symmetry which links to the perturbation requested (pcase)
1574 : 4192 : 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 [ + - ]: 4192 : 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 : 4192 : pflag(idir, ipert) = 2
1586 : :
1587 [ + + + + ]: 54496 : symrel_eq = cryst%symrel(:,:,isym_eq)
1588 [ + + + + ]: 54496 : symrec_eq = cryst%symrec(:,:,isym_eq)
1589 : 4192 : tsign = 3-2*itirev_eq
1590 : :
1591 : : ! Phase due to L0 + R^{-1}tau
1592 [ + + ]: 16768 : l0 = cryst%indsym(1:3,isym_eq,ipert)
1593 : :
1594 [ + + + + : 117376 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym_eq))
+ + + + +
- + + ]
1595 [ + + + + ]: 10077 : 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 [ + + + + ]: 153114592 : workg = zero
1604 : :
1605 : : ! Reconstruct DFPT potential. Final results stored in v1g.
1606 : : if (debug) write(std_out,*)"Reconstructing idir:", idir, ", ipert:", ipert
1607 [ + + + + : 153118784 : v1g = zero; cnt = 0
+ + ]
1608 [ + + ]: 16768 : do idir_eq=1,3
1609 [ + + ]: 12576 : if (symrec_eq(idir, idir_eq) == 0) cycle
1610 : 5504 : cnt = cnt + 1
1611 : 5504 : 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 [ - + ]: 5504 : 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 [ + + ]: 15200 : do ispden=1,nspden
1625 : : ! Get symmetric perturbation in G-space in workg_eq array.
1626 : 5504 : 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 : 5504 : ind1=0
1631 [ + + ]: 120502 : do i3=1,n3
1632 : : ! Get location of G vector (grid point) centered at 0 0 0
1633 : 114998 : l3 = i3-(i3/id3)*n3-1
1634 [ + + ]: 2757136 : do i2=1,n2
1635 : 2636634 : l2 = i2-(i2/id2)*n2-1
1636 [ + + ]: 69313654 : do i1=1,n1
1637 : 66562022 : ind1=ind1+1
1638 : :
1639 : 66562022 : 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 : 66562022 : j1 = tsign * (symrel_eq(1,1)*l1+symrel_eq(2,1)*l2+symrel_eq(3,1)*l3)
1646 : 66562022 : j2 = tsign * (symrel_eq(1,2)*l1+symrel_eq(2,2)*l2+symrel_eq(3,2)*l3)
1647 : 66562022 : 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 [ + + + + : 66562022 : (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 [ + + ]: 49414689 : workg(:, ind1) = zero; cycle
1657 : : end if
1658 : :
1659 [ + + ]: 200361836 : 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 : 50090459 : k1=1+mod(n1+mod(j1,n1),n1)
1663 : 50090459 : k2=1+mod(n2+mod(j2,n2),n2)
1664 : 50090459 : k3=1+mod(n3+mod(j3,n3),n3)
1665 : :
1666 : : ! Get linear index of rotated point Gj
1667 : 50090459 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
1668 : :
1669 [ + + ]: 50090459 : 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 [ + + ]: 112928424 : arg = two_pi * dot_product(qpt + tsm1g, tnon)
1675 : 28232106 : phnon1(1) = cos(arg); phnon1(2) = -sin(arg)
1676 : :
1677 : : ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G)
1678 : 28232106 : workg(1, ind1) = phnon1(1) * workg_eq(1, ind2) - phnon1(2) * workg_eq(2, ind2)
1679 : 28232106 : workg(2, ind1) = phnon1(1) * workg_eq(2, ind2) + phnon1(2) * workg_eq(1, ind2)
1680 : : else
1681 : 21858353 : workg(1, ind1) = workg_eq(1, ind2)
1682 : 21858353 : workg(2, ind1) = workg_eq(2, ind2)
1683 : : end if
1684 : :
1685 : : ! Take complex conjugate if time-reversal is used.
1686 [ + + ]: 52727093 : if (tsign == -1) workg(2, ind1) = -workg(2, ind1)
1687 : : end do
1688 : : end do
1689 : : end do
1690 : :
1691 [ + + + + ]: 199704146 : 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 [ + + ]: 8384 : do ispden=1,nspden
1698 : : !call zerosym(v1g(:,:,ispden),cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1699 : 4192 : 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 [ + + + + : 15933 : if (any(g0_qpt /= 0)) then
+ + ]
1704 [ - + ]: 1738 : 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 : 1738 : call times_eigr(g0_qpt, ngfft, nfft, 1, v1scf(:,ispden,pcase))
1707 : : end if
1708 : : end do
1709 : :
1710 [ + + ]: 5398 : 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 [ - + ]: 1206 : ABI_FREE(v1g)
1717 [ - + ]: 1206 : ABI_FREE(workg)
1718 [ - + ]: 1206 : ABI_FREE(workg_eq)
1719 : :
1720 : : ! Handle possible error.
1721 [ + + + + : 10574 : 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 : 1206 : 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 : 4192 : 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 : 4192 : isym_eq = -1; ipert_eq = -1
1782 [ + - ]: 4192 : do_allow_g0 = .true.; if (present(allow_g0)) do_allow_g0 = allow_g0
1783 : :
1784 : : symloop: &
1785 [ + - ]: 4493 : do itirev=1,2
1786 : 4493 : itirev_eq = itirev
1787 [ + + ]: 52370 : 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 [ + + ]: 47877 : if (symq(4,itirev,isym) /= 1) cycle ! .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1799 [ + + + + : 58980 : if (any(symq(1:3,itirev,isym) /= 0) .and. .not. do_allow_g0) cycle
- + ]
1800 [ + + ]: 70096 : g0_qpt = symq(1:3,itirev,isym)
1801 : :
1802 : : ! indsym map is computed in symatm.
1803 [ + + ]: 44904 : do ip=1,cryst%natom
1804 : : !if (.not. cryst%indsym(4,isym,ip) == ipert) cycle
1805 [ + + ]: 31271 : if (.not. cryst%indsym(4,isym,ipert) == ip) cycle
1806 : 17524 : isym_eq = isym; ipert_eq = ip
1807 [ + + ]: 70096 : do idir_eq=1,3
1808 [ + + + + : 52572 : if (idir_eq == idir .and. ip == ipert .and. cryst%symrec(idir,idir_eq,isym) /= 0) isym_eq = -1
+ + ]
1809 [ + + + + ]: 70096 : 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 : 15773 : isym_eq = -1
1813 : : end if
1814 : : end do
1815 [ + + ]: 61209 : if (isym_eq /= -1) exit symloop
1816 : : end do
1817 : : end do
1818 : : end do symloop
1819 : :
1820 [ - + ]: 4192 : if (isym_eq == -1) then
1821 : 0 : ipert_eq = -1; itirev_eq = -1
1822 : : end if
1823 : :
1824 : 4192 : 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 : 1930 : subroutine v1phq_rotate(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
1860 : 1930 : 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 : 1930 : real(dp) ABI_ASYNC, allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
1882 : 3860 : integer :: requests(nspden, 3*cryst%natom), requests_v1r_qbz(3*cryst%natom)
1883 : 3860 : logical :: requests_v1g_qibz_done(nspden, 3*cryst%natom)
1884 : : ! *************************************************************************
1885 : :
1886 : : ! Keep track of total time spent.
1887 : 1930 : call timab(1804, 1, tsec)
1888 : :
1889 [ - + ]: 1930 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1890 : :
1891 : 1930 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1892 : 1930 : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
1893 : :
1894 : : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
1895 [ + - - + : 9650 : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
1896 [ + + + + ]: 24052 : requests_v1g_qibz_done = .False.
1897 : : cnt = 0
1898 [ + + ]: 12991 : do mu=1,natom3
1899 [ + + ]: 24052 : do ispden=1,nspden
1900 : 11061 : cnt = cnt + 1; root = mod(cnt, nproc)
1901 [ + - ]: 11061 : if (root == my_rank) then ! Non-blocking
1902 : 11061 : call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1903 : : end if
1904 : 22122 : call xmpi_ibcast(v1g_qibz(:,ispden,mu), root, comm, requests(ispden, mu), ierr)
1905 : : end do
1906 : : end do
1907 : :
1908 [ - + + - : 7720 : ABI_MALLOC(workg, (2*nfft, nspden))
- + + - +
- + - - +
- + - + ]
1909 [ - + + - : 5790 : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
- + + - -
+ - + -
+ ]
1910 : :
1911 [ + + + + ]: 25090 : symrec_eq = cryst%symrec(:,:,isym)
1912 : : ! Compute sm1 = symrec_eq^{-1}
1913 [ + + + + : 48250 : 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 [ + + ]: 12991 : do mu=1,natom3
1921 : 11061 : root = mod(mu, nproc)
1922 : : ! MPI parallelism.
1923 [ + - ]: 11061 : if (root == my_rank) then
1924 : 11061 : 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 [ + + ]: 44244 : l0 = cryst%indsym(1:3,isym,ipert)
1928 [ + + + + : 309708 : 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 : 11061 : ipert_eq = cryst%indsym(4, isym, ipert)
1935 : :
1936 [ + + + + ]: 228714810 : v1g_mu = zero; cnt = 0
1937 [ + + ]: 44244 : do idir_eq=1,3
1938 [ + + ]: 33183 : if (symrec_eq(idir, idir_eq) == 0) cycle
1939 : 17249 : mu_eq = idir_eq + (ipert_eq - 1) * 3
1940 : 17249 : cnt = cnt + 1
1941 : :
1942 : : ! Wait for request before operating on v1g_qibz
1943 [ + + + + : 23437 : if (.not. all(requests_v1g_qibz_done(:, mu_eq))) then
+ + ]
1944 [ + + ]: 22122 : do ispden=1,nspden
1945 : 11061 : call xmpi_wait(requests(ispden, mu_eq), ierr)
1946 : 22122 : requests_v1g_qibz_done(ispden, mu_eq) = .True.
1947 : : end do
1948 : : end if
1949 : :
1950 : : ! Rotate in G-space: output in workg
1951 : 17249 : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
1952 : : ! And accumulate in v1g_mu
1953 [ + - + - : 354692486 : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
- + - - +
+ + + ]
1954 : : end do ! idir_eq
1955 : :
1956 [ - + ]: 11061 : 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 [ + + ]: 22122 : do ispden=1,nspden
1960 : 11061 : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, mu), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1961 [ + + ]: 55305 : 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 : 12991 : call xmpi_ibcast(v1r_qbz(:,:,mu), root, comm, requests_v1r_qbz(mu), ierr)
1968 : : end do ! mu
1969 : :
1970 : : ! Release all requests
1971 : 1930 : call xmpi_waitall(requests, ierr)
1972 : 1930 : call xmpi_waitall(requests_v1r_qbz, ierr)
1973 : :
1974 [ - + ]: 1930 : ABI_FREE(workg)
1975 [ - + ]: 1930 : ABI_FREE(v1g_mu)
1976 [ - + ]: 1930 : ABI_FREE(v1g_qibz)
1977 : :
1978 : 1930 : call timab(1804, 2, tsec)
1979 : :
1980 [ - + - + : 1930 : 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 : 17249 : 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 : 17249 : call timab(1803, 1, tsec)
2247 : :
2248 [ + + ]: 68996 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
2249 [ - + ]: 17249 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
2250 : 17249 : id1 = n1/2+2; id2 = n2/2+2; id3=n3/2+2
2251 : :
2252 [ - + ]: 17249 : ABI_CHECK(any(itirev == [1, 2]), "Wrong itirev")
2253 [ + + + + ]: 50453 : tsign = 3-2*itirev; has_phase = any(abs(tnon) > tol12)
2254 : :
2255 : : !outfg = zero
2256 : :
2257 [ + + ]: 34498 : do isp=1,nspden
2258 : : ind1 = 0
2259 [ + + ]: 353670 : do i3=1,n3
2260 : : ! Get location of G vector (grid point) centered at 0 0 0
2261 : 319172 : l3 = i3-(i3/id3)*n3-1
2262 [ + + ]: 7400181 : do i2=1,n2
2263 : 7063760 : l2 = i2-(i2/id2)*n2-1
2264 [ + + ]: 184689804 : do i1=1,n1
2265 : 177306872 : ind1 = ind1 + 1
2266 : : !ind1 = 1 + i1 + (i2-1)*n1 + (i3-1)*n1*n2
2267 : : !if (mod(ind1, nprocs) /= my_rank) cycle
2268 : :
2269 : 177306872 : l1 = i1-(i1/id1)*n1-1
2270 : :
2271 : : ! Get rotated G vector: IS(G)
2272 : 177306872 : j1 = tsign * (symm(1,1)*l1+symm(1,2)*l2+symm(1,3)*l3)
2273 : 177306872 : j2 = tsign * (symm(2,1)*l1+symm(2,2)*l2+symm(2,3)*l3)
2274 : 177306872 : 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 [ + + + + : 177306872 : (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 [ + + ]: 169680108 : outfg(:,ind1,isp) = zero
2284 : : cycle
2285 : : end if
2286 : :
2287 [ + + ]: 482987344 : 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 : 120746836 : k1=1+mod(n1+mod(j1,n1),n1)
2291 : 120746836 : k2=1+mod(n2+mod(j2,n2),n2)
2292 : 120746836 : k3=1+mod(n3+mod(j3,n3),n3)
2293 : :
2294 : : ! Get linear index of rotated point Gj
2295 : 120746836 : 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 [ + + ]: 120746836 : if (has_phase) then
2300 : : ! compute exp(-2*pi*I*G dot tau_S) using original G
2301 [ + + ]: 232235396 : arg = two_pi * dot_product(qpt + tsg, tnon)
2302 : 58058849 : phnon1(1) = cos(arg); phnon1(2) =-sin(arg)
2303 : :
2304 : : ! rho(Strans*G)=exp(2*pi*IG dot tau_S) rho(G)
2305 : 58058849 : outfg(1, ind1, isp) = phnon1(1) * infg(1, ind2, isp) - phnon1(2) * infg(2, ind2, isp)
2306 : 58058849 : outfg(2, ind1, isp) = phnon1(1) * infg(2, ind2, isp) + phnon1(2) * infg(1, ind2, isp)
2307 : : else
2308 : 62687987 : outfg(1, ind1, isp) = infg(1, ind2, isp)
2309 : 62687987 : outfg(2, ind1, isp) = infg(2, ind2, isp)
2310 : : end if
2311 : :
2312 : : ! Take complex conjugate if time-reversal is used.
2313 [ + + ]: 127810596 : 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 : 17249 : call timab(1803, 2, tsec)
2321 : :
2322 : 17249 : 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(one * 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 : 6052 : 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 [ - + ]: 6052 : my_qtol = tol6; if (present(qtol)) my_qtol = qtol
3772 : 6052 : iqpt = -1
3773 [ + + ]: 45137 : do iq=1,db%nqpt
3774 [ + + + + : 54299 : if (all(abs(db%qpts(:, iq) - qpt) < my_qtol)) then
+ + ]
3775 : : iqpt = iq; exit
3776 : : end if
3777 : : end do
3778 : :
3779 : 6052 : 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
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 [ - + + - : 21 : ABI_MALLOC(qmap_symrec, (6, nqpt))
+ - + - -
+ - + -
+ ]
3874 : :
3875 [ + + ]: 7 : if (kpts_map("symrec", qptopt, db%cryst, qrank, nqpt, qpts, qmap_symrec) /= 0) then
3876 : : ! There's at least on-qpoint in qpts that is not the IBZ image of db%qpts.
3877 : 5 : need_ftinterp = .True.; call qrank%free()
3878 : 5 : return
3879 : : end if
3880 : :
3881 : : ! All the IBZ images must be in the DVDB
3882 [ + + ]: 14 : do iq=1,nqpt
3883 : 12 : iq_ibz = qmap_symrec(1, iq)
3884 [ + + ]: 48 : qq_ibz = db%qpts(:, iq_ibz)
3885 : 12 : db_iqpt = db%findq(qq_ibz)
3886 [ - + ]: 14 : if (db_iqpt == -1) then
3887 : 0 : need_ftinterp = .True.; exit
3888 : : end if
3889 : : end do
3890 : :
3891 : 2 : call qrank%free()
3892 : :
3893 [ - + - + : 7 : end subroutine dvdb_need_ftinterp
- + - + -
+ - + ]
3894 : : !!***
3895 : :
3896 : : !!****f* m_dvdb/dvdb_set_pert_distrib
3897 : : !! NAME
3898 : : !! dvdb_set_pert_distrib
3899 : : !!
3900 : : !! FUNCTION
3901 : : !! Activate MPI distribution of the 3*natom perturbations.
3902 : : !!
3903 : : !! INPUTS
3904 : : !! my_npert=Number of perturbations treated by this rank
3905 : : !! natom3= 3 * natom
3906 : : !! my_pinfo(3, my_npert)
3907 : : !! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
3908 : : !! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
3909 : : !! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
3910 : : !! pert_table(2, natom3)
3911 : : !! pert_table(1, npert): rank of the processor treating this atomic perturbation.
3912 : : !! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
3913 : : !! comm_pert=MPI communicator used to distribute the 3*natom perturbations
3914 : : !!
3915 : : !! SOURCE
3916 : :
3917 : 0 : subroutine dvdb_set_pert_distrib(self, my_npert, natom3, my_pinfo, pert_table, comm_pert)
3918 : :
3919 : : !Arguments ------------------------------------
3920 : : !scalars
3921 : : class(dvdb_t),intent(inout) :: self
3922 : : integer,intent(in) :: my_npert, natom3, comm_pert
3923 : : !arrays
3924 : : integer,intent(in) :: my_pinfo(3,my_npert), pert_table(2,natom3)
3925 : : ! *************************************************************************
3926 : :
3927 : 0 : self%comm_pert = comm_pert
3928 : 0 : self%nprocs_pert = xmpi_comm_size(comm_pert)
3929 : 0 : self%me_pert = xmpi_comm_rank(comm_pert)
3930 : 0 : self%my_npert = my_npert
3931 : :
3932 [ # # ]: 0 : ABI_SFREE(self%my_pinfo)
3933 [ # # ]: 0 : ABI_SFREE(self%pert_table)
3934 [ # # ]: 0 : call alloc_copy(my_pinfo, self%my_pinfo)
3935 [ # # ]: 0 : call alloc_copy(pert_table, self%pert_table)
3936 : :
3937 [ # # ]: 0 : if (self%debug) then
3938 : 0 : write(std_out, *)"Activating perturbation over perturbations:"
3939 : 0 : write(std_out, *)"nprocs_pert: ", self%nprocs_pert
3940 : 0 : write(std_out, *)"my_pinfo: ",self%my_pinfo
3941 : 0 : write(std_out, *)"pert_table: ",self%pert_table
3942 : : end if
3943 : :
3944 : 0 : end subroutine dvdb_set_pert_distrib
3945 : : !!***
3946 : :
3947 : : !!****f* m_dvdb/dvdb_seek
3948 : : !! NAME
3949 : : !! dvdb_seek
3950 : : !!
3951 : : !! FUNCTION
3952 : : !! Move the internal file pointer so that it points to the
3953 : : !! block with (idir, ipert, iqpt). Needed only if dvdb%iomode==IO_MODE_FORTRAN
3954 : : !!
3955 : : !! INPUTS
3956 : : !! idir,ipert,iqpt = (direction, perturbation, q-point) indices
3957 : : !!
3958 : : !! SIDE EFFECTS
3959 : : !! db<type(dvdb_t)>: modifies db%current_fpos.
3960 : : !!
3961 : : !! SOURCE
3962 : :
3963 : 4834 : subroutine dvdb_seek(db, idir, ipert, iqpt)
3964 : :
3965 : : !Arguments ------------------------------------
3966 : : integer,intent(in) :: idir, ipert, iqpt
3967 : : type(dvdb_t),intent(inout) :: db
3968 : :
3969 : : !Local variables-------------------------------
3970 : : integer :: pos_now,pos_wanted,ii,ispden,nn,ierr
3971 : : real(dp),parameter :: fake_qpt(3)=zero
3972 : : character(len=500) :: msg
3973 : : ! *************************************************************************
3974 : :
3975 [ + - ]: 4834 : if (db%iomode == IO_MODE_FORTRAN) then
3976 : 4834 : pos_now = db%current_fpos
3977 : 4834 : pos_wanted = db%pos_dpq(idir,ipert,iqpt)
3978 [ - + ]: 4834 : ABI_CHECK(pos_wanted /= 0, "pos_wanted cannot be zero!")
3979 : :
3980 : : ! Optimal access.
3981 [ + + ]: 5770 : if (pos_now == pos_wanted) return
3982 : :
3983 [ + + ]: 936 : if (pos_wanted < pos_now) then
3984 : : ! Backspace previous records and header
3985 : : ! but only if nn <= pos_wanted else rewind file and skip pos_wanted potentials (should be faster)
3986 : 730 : nn = pos_now - pos_wanted
3987 [ + + ]: 730 : if (nn <= pos_wanted) then
3988 [ + + ]: 3018 : do ii=1,nn
3989 : : !write(std_out, *)"backspacing"
3990 [ + - + - ]: 2504 : if (db%version > 1) backspace(unit=db%fh, err=10, iomsg=msg)
3991 [ + + ]: 5008 : do ispden=1,db%nspden
3992 [ + - ]: 5008 : backspace(unit=db%fh, err=10, iomsg=msg)
3993 : : end do
3994 : 2504 : ierr = db%hdr_ref%backspace(db%fh, msg)
3995 [ + - ]: 3018 : if (ierr /= 0) goto 10
3996 : : end do
3997 : 514 : db%current_fpos = pos_wanted; return
3998 : : else
3999 : : ! rewind the file and read it from the beginning
4000 [ - + ]: 216 : if (dvdb_rewind(db, msg) /= 0) then
4001 : 0 : ABI_ERROR(msg)
4002 : : end if
4003 : : nn = pos_wanted
4004 : : end if
4005 : :
4006 : : else
4007 : 206 : nn = pos_wanted - pos_now + 1
4008 : : end if
4009 : :
4010 [ + + ]: 4901 : do ii=1,nn-1
4011 : : !write(std_out,*)"in seek with ii: ",ii,"pos_wanted: ",pos_wanted
4012 [ - + ]: 4479 : if (my_hdr_skip(db%fh, -1, -1, fake_qpt, msg) /= 0) then
4013 : 0 : ABI_ERROR(msg)
4014 : : end if
4015 : : ! Skip the records with v1.
4016 [ + + ]: 8958 : do ispden=1,db%nspden
4017 [ + - ]: 8958 : read(db%fh, err=10, iomsg=msg)
4018 : : end do
4019 : : ! Skip record with rhog1_g0 (if present)
4020 [ + - + - ]: 4901 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
4021 : : end do
4022 : :
4023 : 422 : db%current_fpos = pos_wanted
4024 : :
4025 : : else
4026 : 0 : ABI_ERROR("Should not be called when iomode /= IO_MODE_FORTRAN")
4027 : : end if
4028 : :
4029 : 0 : return
4030 : :
4031 : : ! Handle Fortran IO error
4032 : : 10 continue
4033 : 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4034 : :
4035 : : end subroutine dvdb_seek
4036 : : !!***
4037 : :
4038 : : !----------------------------------------------------------------------
4039 : :
4040 : : !!****f* m_dvdb/dvdb_rewind
4041 : : !! NAME
4042 : : !! dvdb_rewind
4043 : : !!
4044 : : !! FUNCTION
4045 : : !! Rewind the file and move to the first header. Needed only if dvdb%iomode==IO_MODE_FORTRAN
4046 : : !! Return exit code and error message in msg if ierr != 0.
4047 : : !!
4048 : : !! SOURCE
4049 : :
4050 : 216 : integer function dvdb_rewind(db, msg) result(ierr)
4051 : :
4052 : : !Arguments ------------------------------------
4053 : : type(dvdb_t),intent(inout) :: db
4054 : : character(len=*),intent(out) :: msg
4055 : : ! *************************************************************************
4056 : :
4057 : 216 : ierr = 0
4058 : 216 : if (db%iomode == IO_MODE_FORTRAN) then
4059 [ + - ]: 216 : rewind(db%fh, err=10, iomsg=msg)
4060 [ + - ]: 216 : read(db%fh, err=10, iomsg=msg) ! version
4061 [ + - ]: 216 : read(db%fh, err=10, iomsg=msg) ! numv1
4062 : 216 : db%current_fpos = 1
4063 : :
4064 : : else
4065 : 0 : ierr = -1
4066 [ # # # # ]: 0 : msg = "should not be called when iomode /= IO_MODE_FORTRAN"
4067 : : end if
4068 : :
4069 : : return
4070 : :
4071 : : ! Handle Fortran IO error
4072 : : 10 continue
4073 : 0 : ierr = 1
4074 [ # # # # ]: 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4075 : :
4076 [ + - ]: 216 : end function dvdb_rewind
4077 : : !!***
4078 : :
4079 : : !----------------------------------------------------------------------
4080 : :
4081 : : !!****f* m_dvdb/my_hdr_skip
4082 : : !! NAME
4083 : : !! my_hdr_skip
4084 : : !!
4085 : : !! FUNCTION
4086 : : !! Skip the header without rewinding the file. Return exit code.
4087 : : !!
4088 : : !! NOTES
4089 : : !! Because hdr_skip rewinds the file and I'm not gonna change that ugly code.
4090 : : !!
4091 : : !! SOURCE
4092 : :
4093 : 9313 : integer function my_hdr_skip(unit, idir, ipert, qpt, msg) result(ierr)
4094 : :
4095 : : !Arguments ------------------------------------
4096 : : !scalars
4097 : : integer,intent(in) :: unit,idir,ipert
4098 : : real(dp),intent(in) :: qpt(3)
4099 : : character(len=500),intent(out) :: msg
4100 : :
4101 : : !Local variables-------------------------------
4102 : : integer :: fform
4103 : 9313 : type(hdr_type) :: tmp_hdr
4104 : : !************************************************************************
4105 : :
4106 : 9313 : ierr = 0; msg = ""
4107 : 9313 : call tmp_hdr%fort_read(unit, fform)
4108 : 9313 : ierr = dvdb_check_fform(fform, "read_dvdb", msg)
4109 [ + - ]: 9313 : if (ierr /= 0) return
4110 : :
4111 [ + + + - ]: 9313 : if (idir /= -1 .and. ipert /= -1) then
4112 : : if (idir /= mod(tmp_hdr%pertcase-1, 3) + 1 .or. &
4113 [ + + + - : 19336 : ipert /= (tmp_hdr%pertcase - idir) / 3 + 1 .or. &
+ - + - -
+ ]
4114 : : any(abs(qpt - tmp_hdr%qptn) > tol14)) then
4115 : 0 : msg = "Perturbation index on file does not match the one expected by the caller"
4116 : 0 : ierr = -1
4117 : : end if
4118 : : end if
4119 : :
4120 : 9313 : call tmp_hdr%free()
4121 : :
4122 [ - + - + : 9313 : end function my_hdr_skip
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - ]
4123 : : !!***
4124 : :
4125 : : !----------------------------------------------------------------------
4126 : :
4127 : : !!****f* m_dvdb/dvdb_list_perts
4128 : : !! NAME
4129 : : !! dvdb_list_perts
4130 : : !!
4131 : : !! FUNCTION
4132 : : !! Given a q-point mesh, this routine checks if all the (phonon) perturbations
4133 : : !! are available taking into account symmetries.
4134 : : !!
4135 : : !! INPUTS
4136 : : !! ngqpt(3)=Q-mesh divisions. If all(ngqpt == -1), the list of q-points in the DVDB
4137 : : !! (i.e. db%qpts) is analyzed instead of the q-points generated from ngqpt.
4138 : : !! [unit]=Unit number for output. Default `std_out`.
4139 : : !!
4140 : : !! OUTPUT
4141 : : !! npert_miss = Number of missing perturbations.
4142 : : !!
4143 : : !! SOURCE
4144 : :
4145 : 116 : subroutine dvdb_list_perts(db, ngqpt, npert_miss, unit)
4146 : :
4147 : : !Arguments ------------------------------------
4148 : : class(dvdb_t),target,intent(in) :: db
4149 : : integer,intent(out) :: npert_miss
4150 : : integer,optional,intent(in) :: unit
4151 : : !arrays
4152 : : integer,intent(in) :: ngqpt(3)
4153 : :
4154 : : !Local variables-------------------------------
4155 : : !scalars
4156 : : integer :: npert_redund,miss_q,idir,ipert,iv1,psy,weird_q,enough
4157 : : integer :: iq_ibz,nqibz,iq_file,qptopt,nshiftq,ii,timerev_q,unt,nqbz
4158 : : character(len=500) :: msg,ptype,found
4159 : : type(crystal_t),pointer :: cryst
4160 : : !arrays
4161 : : integer :: rfdir(3),qptrlatt(3,3)
4162 : 116 : integer,allocatable :: pertsy(:,:),symq(:,:,:),rfpert(:)
4163 : : real(dp) :: qq(3),shiftq(3,1)
4164 : 116 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:)
4165 : : ! *************************************************************************
4166 : :
4167 [ - + ]: 116 : unt = std_out; if (present(unit)) unt = unit
4168 : 116 : cryst => db%cryst
4169 : :
4170 [ + + + - : 464 : if (all(ngqpt == -1)) then
+ - ]
4171 : : ! Will test the q-points in db
4172 : 116 : call alloc_copy(db%qpts, qibz)
4173 : 116 : nqibz = db%nqpt
4174 : : else
4175 : : ! Will test the q-points in the IBZ associated to ngqpt hence build IBZ and BZ from ngqpt.
4176 : 0 : qptopt = 1; shiftq = zero; nshiftq = 1; qptrlatt = 0
4177 [ # # ]: 0 : do ii=1,3
4178 : 0 : qptrlatt(ii, ii) = ngqpt(ii)
4179 : : end do
4180 : :
4181 : 0 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nshiftq, shiftq, nqibz, qibz, wtq, nqbz, qbz)
4182 : :
4183 [ # # ]: 0 : ABI_FREE(qbz)
4184 [ # # ]: 0 : ABI_FREE(wtq)
4185 : : end if
4186 : :
4187 : : ! Initialize the list of perturbations rfpert and rdfir
4188 : : ! WARNING: Only phonon perturbations are considered for the time being.
4189 [ - + + - : 348 : ABI_MALLOC(rfpert,(db%mpert))
+ - + - -
+ - + ]
4190 [ + + + + : 1602 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
4191 : :
4192 [ - + + - : 348 : ABI_MALLOC(symq, (4,2,cryst%nsym))
+ - + - -
+ - + ]
4193 [ - + + - : 348 : ABI_MALLOC(pertsy, (3,db%mpert))
+ - + - -
+ - + ]
4194 : :
4195 : : ! Loop over the q-points in the IBZ and test whether the q-point is present
4196 : : ! and if all the independent perturbations are available.
4197 : : ! `npert_miss` is the number of irreducible perturbations not found in the DVDB (critical)
4198 : : ! `npert_redund` is the number of redundant perturbations found in the DVDB (not critical)
4199 : : !
4200 [ + + ]: 116 : enough = 5; if (db%prtvol > 0) enough = nqibz + 1
4201 : 116 : npert_miss = 0; npert_redund = 0
4202 [ + + ]: 798 : do iq_ibz=1,nqibz
4203 [ + + ]: 682 : if (iq_ibz == enough) then
4204 : 45 : call wrtout(unt,' More than 20 q-points with prtvol == 0. Only important messages will be printed...')
4205 : : end if
4206 [ + + ]: 2728 : qq = qibz(:,iq_ibz)
4207 : 682 : iq_file = db%findq(qq)
4208 : :
4209 : : ! Examine the symmetries of the q wavevector
4210 : 682 : call littlegroup_q(cryst%nsym,qq,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=db%prtvol)
4211 : :
4212 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4213 : : ! 0 for non-target perturbations
4214 : : ! 1 for basis perturbations
4215 : : ! -1 for perturbations that can be found from basis perturbations
4216 : : call irreducible_set_pert(cryst%indsym,db%mpert,cryst%natom,cryst%nsym,&
4217 : 682 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4218 : :
4219 [ + - ]: 682 : if (iq_file /= -1) then
4220 : : ! This q-point is in the DVDB. Test if all the independent perturbations are available.
4221 [ + + ]: 682 : if (iq_ibz <= enough) then
4222 : 526 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is present in the DVDB file"))
4223 : 526 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4224 : : end if
4225 : 682 : ii = 0; weird_q = 0; miss_q = 0
4226 [ + + ]: 6039 : do ipert=1,db%mpert
4227 [ + + ]: 22110 : do idir=1,3
4228 : 16071 : psy = pertsy(idir,ipert)
4229 [ + + ]: 16071 : if (psy == 0) cycle
4230 : 3795 : iv1 = db%pos_dpq(idir,ipert,iq_file)
4231 [ + + ]: 3795 : ptype = "independent"; if (psy == -1) ptype = "symmetric"
4232 [ + + ]: 3795 : found = "Yes"; if (iv1 == 0) found = "No"
4233 : :
4234 [ - + ]: 3795 : if (psy == 1 .and. iv1 == 0) miss_q = miss_q + 1
4235 [ - + ]: 3795 : if (psy == -1 .and. iv1 /= 0) weird_q = weird_q + 1
4236 : :
4237 : 3795 : ii=ii+1
4238 [ + + ]: 9152 : if (iq_ibz <= enough) then
4239 : 2886 : write(msg,'(i5,a,i2,a,i4,4a)')ii,') idir=',idir,', ipert=',ipert,", type=",trim(ptype),", found=",trim(found)
4240 : 2886 : call wrtout(unt, msg)
4241 : : end if
4242 : : end do
4243 : : end do
4244 : :
4245 [ - + ]: 682 : if (weird_q /= 0) then
4246 : 0 : write(msg,"(a,i0,a)")" DVDB is overcomplete. ",weird_q, " perturbation(s) can be reconstructed by symmetry."
4247 : 0 : call wrtout(unt, msg)
4248 : : end if
4249 : :
4250 : 682 : npert_redund = npert_redund + weird_q
4251 : 682 : npert_miss = npert_miss + miss_q
4252 [ - + ]: 682 : if (miss_q /=0) then
4253 : 0 : call wrtout(unt, sjoin(" WARNING:", itoa(miss_q), "independent perturbation(s) are missing!."))
4254 : : end if
4255 : :
4256 : : else
4257 : : ! This q-point is not present in dvdb. Print the list of independent perturbations.
4258 : 0 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is NOT present in the DVDB file"))
4259 : 0 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4260 : 0 : ii = 0
4261 [ # # ]: 0 : do ipert=1,db%mpert
4262 [ # # ]: 0 : do idir=1,3
4263 [ # # ]: 0 : if (pertsy(idir,ipert) == 1) then
4264 : 0 : ii=ii+1
4265 : 0 : write(msg,'(i5,a,i2,a,i4,a)')ii,') idir=',idir,', ipert=',ipert,", type=independent, found=No"
4266 : 0 : call wrtout(unt, msg)
4267 : 0 : npert_miss = npert_miss + 1
4268 : : end if
4269 : : end do
4270 : : end do
4271 : : end if
4272 : :
4273 [ + + ]: 1480 : if (iq_ibz <= enough) call wrtout(unt," ")
4274 : : end do ! iq_ibz
4275 : :
4276 [ - + ]: 116 : if (npert_miss /= 0) then
4277 : 0 : call wrtout(unt, sjoin(ch10, " There are ",itoa(npert_miss), "independent perturbations missing!"))
4278 : : else
4279 : 116 : call wrtout(unt, " All the independent perturbations are available")
4280 [ - + ]: 116 : if (npert_redund /= 0) then
4281 : 0 : call wrtout(unt, " Note however that the DVDB is overcomplete as symmetric perturbations are present.")
4282 : : end if
4283 : : end if
4284 : :
4285 [ - + ]: 116 : ABI_FREE(qibz)
4286 [ - + ]: 116 : ABI_FREE(rfpert)
4287 [ - + ]: 116 : ABI_FREE(symq)
4288 [ - + ]: 116 : ABI_FREE(pertsy)
4289 : :
4290 [ - + - + ]: 116 : end subroutine dvdb_list_perts
4291 : : !!***
4292 : :
4293 : : !----------------------------------------------------------------------
4294 : :
4295 : : !!****f* m_dvdb/dvdb_merge_files
4296 : : !! NAME
4297 : : !! dvdb_merge_files
4298 : : !!
4299 : : !! FUNCTION
4300 : : !! Merge a list of POT1 or DEN1 files.
4301 : : !!
4302 : : !! INPUT
4303 : : !! nfiles=Number of files to be merged.
4304 : : !! dvdb_filepath=Name of output DVDB file.
4305 : : !! prtvol=Verbosity level.
4306 : : !!
4307 : : !! SIDE EFFECTS
4308 : : !! v1files=List of file names to merge. This list could be changed if POT1 files in netcdf format are found.
4309 : : !!
4310 : : !! SOURCE
4311 : :
4312 : 17 : subroutine dvdb_merge_files(nfiles, v1files, dvdb_filepath, prtvol)
4313 : :
4314 : : !Arguments ------------------------------------
4315 : : !scalars
4316 : : integer,intent(in) :: nfiles,prtvol
4317 : : character(len=*),intent(in) :: dvdb_filepath
4318 : : character(len=*),intent(inout) :: v1files(nfiles)
4319 : :
4320 : : !Local variables-------------------------------
4321 : : !scalars
4322 : : ! Here I made a mistake because 102 corresponds to GS potentials
4323 : : ! as a consequence DVDB files generated with version <= 8.1.6
4324 : : ! contain list of potentials with fform = 102.
4325 : : !integer :: fform_pot=102
4326 : : integer :: fform_pot = 111, gpu_option0 = 0
4327 : : integer :: ii,jj,fform,ount,cplex,nfft,ifft,ispden,nperts
4328 : : integer :: n1,n2,n3,v1_varid,ierr, npert_miss, first_fform
4329 : : logical :: qeq0
4330 : : character(len=500) :: msg
4331 : : type(hdr_type),pointer :: hdr1
4332 [ + + + + : 1394 : type(dvdb_t) :: dvdb
+ + + + +
+ + + + +
+ + + + +
+ + + +
+ ]
4333 : : !arrays
4334 : 34 : integer :: units(nfiles)
4335 : : real(dp) :: rhog1_g0(2)
4336 : 17 : real(dp),allocatable :: v1(:)
4337 : 34 : logical :: has_rhog1_g0(nfiles)
4338 : 17 : type(hdr_type),target,allocatable :: hdr1_list(:)
4339 : : !************************************************************************
4340 : :
4341 [ - + ]: 17 : if (file_exists(dvdb_filepath)) then
4342 : 0 : ABI_ERROR(sjoin("Cannot overwrite existing file:", dvdb_filepath))
4343 : : end if
4344 : :
4345 : : ! If a file is not found, try the netcdf version and change v1files accordingly.
4346 [ + + ]: 296 : do ii=1,nfiles
4347 [ - + ]: 296 : if (nctk_try_fort_or_ncfile(v1files(ii), msg) /= 0) then
4348 : 0 : ABI_ERROR(msg)
4349 : : end if
4350 : : end do
4351 : :
4352 : : ! Read the headers
4353 [ - + + - : 330 : ABI_MALLOC(hdr1_list, (nfiles))
+ - + - -
+ - + +
+ ]
4354 : 17 : nperts = size(hdr1_list)
4355 : :
4356 : : ! Write dvdb file (we only support fortran binary format)
4357 [ - + ]: 17 : if (open_file(dvdb_filepath, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
4358 : 0 : ABI_ERROR(msg)
4359 : : end if
4360 [ + - ]: 17 : write(ount, err=10, iomsg=msg) dvdb_last_version
4361 [ + - ]: 17 : write(ount, err=10, iomsg=msg) nperts
4362 : :
4363 : : ! Validate headers.
4364 : : ! TODO: Should perform consistency check on the headers
4365 : : ! rearrange them in blocks of q-points for efficiency reason.
4366 : : ! ignore POT1 files that do not correspond to atomic perturbations.
4367 : : ! Add POT file from GS run to support Sternheimer in eph_task = 4
4368 : :
4369 [ + + ]: 296 : do ii=1,nfiles
4370 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Reading header of file [",ii,"]: ",trim(v1files(ii))
4371 : :
4372 [ + - ]: 279 : if (endswith(v1files(ii), ".nc")) then
4373 [ - + ]: 279 : NCF_CHECK(nctk_open_read(units(ii), v1files(ii), xmpi_comm_self))
4374 : 279 : call hdr1_list(ii)%ncread(units(ii), fform)
4375 : : else
4376 [ # # ]: 0 : if (open_file(v1files(ii), msg, newunit=units(ii), form="unformatted", action="read", status="old") /= 0) then
4377 : 0 : ABI_ERROR(msg)
4378 : : end if
4379 : 0 : call hdr1_list(ii)%fort_read(units(ii), fform)
4380 : : end if
4381 : :
4382 [ - + ]: 279 : if (dvdb_check_fform(fform, "merge_dvdb", msg) /= 0) then
4383 : 0 : ABI_ERROR(sjoin("While reading:", v1files(ii), msg))
4384 : : end if
4385 [ - + ]: 279 : if (prtvol > 0) call hdr1_list(ii)%echo(fform, 3, unit=std_out)
4386 [ - + ]: 279 : if (hdr1_list(ii)%pertcase == 0) then
4387 : 0 : ABI_ERROR(sjoin("Found GS potential:", v1files(ii)))
4388 : : end if
4389 : : !write(std_out,*)"done", trim(v1files(ii))
4390 : :
4391 [ + + ]: 279 : if (ii == 1) then
4392 : 17 : first_fform = fform
4393 : : else
4394 [ - + ]: 262 : ABI_CHECK_IEQ(fform, first_fform, "Trying to merge files with different quantities")
4395 : : end if
4396 : :
4397 : : ! Supported fform:
4398 : : ! 109 POT1 files without vh1(G=0)
4399 : : ! 111 POT1 files with extra record with vh1(G=0) after FFT data.
4400 : : ! 54 RHO1 files (treating DRHODB as DVDB)
4401 : :
4402 : 279 : has_rhog1_g0(ii) = .True.
4403 [ + + ]: 279 : if (any(fform == [54, 109])) has_rhog1_g0(ii) = .False.
4404 : :
4405 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Merging file [",ii,"]: ",trim(v1files(ii))
4406 : 279 : jj = ii
4407 : 279 : hdr1 => hdr1_list(jj)
4408 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4409 : 199 : call hdr1%fort_write(ount, fform_pot, ierr)
4410 : : else
4411 : 80 : call hdr1%fort_write(ount, den1_fforms(1), ierr)
4412 : : end if
4413 [ - + ]: 279 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
4414 : :
4415 : 279 : qeq0 = (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14)
4416 [ + + ]: 279 : cplex = 2; if (qeq0) cplex = 1
4417 [ + + ]: 1116 : nfft = product(hdr1%ngfft(1:3))
4418 : 279 : n1 = hdr1%ngfft(1); n2 = hdr1%ngfft(2); n3 = hdr1%ngfft(3)
4419 : :
4420 [ - + + - : 837 : ABI_MALLOC(v1, (cplex*nfft))
+ - + - -
+ - + -
+ ]
4421 : :
4422 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4423 : : ! Fortran IO
4424 [ # # ]: 0 : do ispden=1,hdr1%nspden
4425 [ # # ]: 0 : read(units(jj), err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4426 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4427 : : end do
4428 : : ! Add rhog1(G=0)
4429 : 0 : rhog1_g0 = zero
4430 [ # # # # ]: 0 : if (has_rhog1_g0(jj)) read(units(jj), err=10, iomsg=msg) rhog1_g0
4431 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4432 : : else
4433 : : ! Netcdf IO
4434 : : ! netcdf array has shape [cplex, n1, n2, n3, nspden]
4435 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4436 [ - + ]: 199 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_potential", v1_varid))
4437 [ + + ]: 398 : do ispden=1,hdr1%nspden
4438 [ + + + + : 2189 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4439 [ + - ]: 398 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4440 : : end do
4441 : : ! Add rhog1(G=0)
4442 : 199 : rhog1_g0 = zero
4443 [ + - ]: 199 : if (has_rhog1_g0(jj)) then
4444 [ - + ]: 199 : NCF_CHECK(nf90_get_var(units(ii), nctk_idname(units(ii), "rhog1_g0"), rhog1_g0))
4445 : : end if
4446 [ + - ]: 80 : else if (any(fform == den1_fforms)) then
4447 : : ! v below should read as rho
4448 [ - + ]: 80 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_density", v1_varid))
4449 [ + + ]: 160 : do ispden=1,hdr1%nspden
4450 [ + + + + : 880 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4451 [ + - ]: 160 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4452 : : end do
4453 : : else
4454 : 0 : ABI_ERROR(sjoin("Don't know how to handle fform:", itoa(fform)))
4455 : : end if
4456 [ + - ]: 279 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4457 : : end if
4458 : :
4459 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4460 : 0 : close(units(ii))
4461 : : else
4462 [ - + ]: 279 : NCF_CHECK(nf90_close(units(ii)))
4463 : : end if
4464 : :
4465 [ - + ]: 296 : ABI_FREE(v1)
4466 : : end do ! nperts
4467 : :
4468 : 17 : close(ount)
4469 : :
4470 [ + + ]: 296 : do ii=1,size(hdr1_list)
4471 : 296 : call hdr1_list(ii)%free()
4472 : : end do
4473 [ + - + + : 296 : ABI_FREE(hdr1_list)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + ]
4474 : :
4475 : 17 : write(std_out,"(a,i0,a)")" Merged successfully ", nfiles, " files"
4476 : :
4477 : : ! List available perturbations.
4478 : 17 : call dvdb%init(dvdb_filepath, gpu_option0, xmpi_comm_self)
4479 [ + + ]: 34 : call dvdb%print([std_out], "", 0)
4480 : 17 : call dvdb%list_perts([-1, -1, -1], npert_miss)
4481 : 17 : call dvdb%free()
4482 : :
4483 : 17 : return
4484 : :
4485 : : ! Handle Fortran IO error
4486 : : 10 continue
4487 : 0 : ABI_ERROR(sjoin("Error while merging files", ch10, msg))
4488 : :
4489 [ - + - + : 17 : end subroutine dvdb_merge_files
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
4490 : : !!***
4491 : :
4492 : : !!****f* m_dvdb/calc_eiqr
4493 : : !! NAME
4494 : : !! calc_eiqr
4495 : : !!
4496 : : !! FUNCTION
4497 : : !! Compute e^{iq.r} for nrpt R-points.
4498 : : !!
4499 : : !! INPUTS
4500 : : !!
4501 : : !! OUTPUT
4502 : : !!
4503 : : !! SOURCE
4504 : :
4505 : 5596 : subroutine calc_eiqr(qpt, nrpt, rpt, eiqr)
4506 : :
4507 : : !Arguments -------------------------------
4508 : : !scalars
4509 : : integer,intent(in) :: nrpt
4510 : : !arrays
4511 : : real(dp),intent(in) :: qpt(3), rpt(3, nrpt)
4512 : : real(dp),intent(out) :: eiqr(2, nrpt)
4513 : :
4514 : : !Local variables -------------------------
4515 : : !scalars
4516 : : integer :: ir
4517 : : real(dp) :: qr
4518 : : ! *********************************************************************
4519 : :
4520 : : !$OMP PARALLEL DO PRIVATE(qr)
4521 [ + + ]: 222124 : do ir=1,nrpt
4522 [ + + ]: 866112 : qr = two_pi * dot_product(qpt, rpt(:,ir))
4523 : 222124 : eiqr(1, ir) = cos(qr); eiqr(2, ir) = sin(qr)
4524 : : end do
4525 : :
4526 : 5596 : end subroutine calc_eiqr
4527 : : !!***
4528 : :
4529 : : !----------------------------------------------------------------------
4530 : :
4531 : : !!****f* m_dvdb/dvdb_check_fform
4532 : : !! NAME
4533 : : !! dvdb_check_fform
4534 : : !!
4535 : : !! FUNCTION
4536 : : !! Check the value of fform. Return exit status and error message.
4537 : : !!
4538 : : !! INPUTS
4539 : : !! fform=Value read from the header
4540 : : !! mode="merge_dvdb" to check the value of fform when we are merging POT1 files
4541 : : !! "read_dvdb" when we are reading POT1 files from a DVDB file.
4542 : : !!
4543 : : !! OUTPUT
4544 : : !! errmsg=String with error message if ierr /= 0
4545 : : !!
4546 : : !! SOURCE
4547 : :
4548 : 11795 : integer function dvdb_check_fform(fform, mode, errmsg) result(ierr)
4549 : :
4550 : : !Arguments ------------------------------------
4551 : : integer,intent(in) :: fform
4552 : : character(len=*),intent(in) :: mode
4553 : : character(len=*),intent(out) :: errmsg
4554 : : ! *************************************************************************
4555 : :
4556 : 11795 : ierr = 0
4557 : :
4558 : : ! Here I made a mistake because 102 corresponds to GS potentials
4559 : : ! as a consequence DVDB files generated with version <= 8.1.6
4560 : : ! contain list of potentials with fform = 102.
4561 : : !
4562 : : ! In GWPT, one may want to use DRHODB as DVDB. For this, here I
4563 : : ! also allow merging and reading first order density with fform = 54.
4564 : : !
4565 : : !integer :: fform_rho=54
4566 : : !integer :: fform_pot=102
4567 : : !integer :: fform_pot=109
4568 : : !integer :: fform_pot=111
4569 : :
4570 : 11795 : if (fform == 0) then
4571 [ # # # # ]: 0 : errmsg = "fform == 0! Either corrupted/nonexistent file or IO error"
4572 : 0 : ierr = 42; return
4573 : : end if
4574 : :
4575 : 279 : select case (mode)
4576 : : case ("merge_dvdb")
4577 [ + + - + ]: 279 : if (all(fform /= [54, 109, 111])) then
4578 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `merge_dvdb` mode")
4579 : 0 : ierr = 1; return
4580 : : end if
4581 : :
4582 : : case ("read_dvdb")
4583 [ + + - + ]: 11516 : if (all(fform /= [54, 102, 109, 111])) then
4584 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `read_dvdb` mode")
4585 : 0 : ierr = 1; return
4586 : : end if
4587 : :
4588 : : case default
4589 [ # # # # ]: 0 : errmsg = sjoin("Invalid mode:", mode)
4590 [ + + - ]: 11795 : ierr = -1; return
4591 : : end select
4592 : :
4593 [ - + ]: 11795 : end function dvdb_check_fform
4594 : : !!***
4595 : :
4596 : : !!****f* m_dvdb/dvdb_test_v1rsym
4597 : : !! NAME
4598 : : !! dvdb_test_v1rsym
4599 : : !!
4600 : : !! FUNCTION
4601 : : !! Debugging tool used to check whether the DFPT potentials in real space fulfill
4602 : : !! the correct symmetries on the real space FFT mesh.
4603 : : !!
4604 : : !! INPUTS
4605 : : !! db_path=Filename
4606 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 to disable it.
4607 : : !! comm=MPI communicator.
4608 : : !!
4609 : : !! OUTPUT
4610 : : !! Only writing.
4611 : : !!
4612 : : !! SOURCE
4613 : :
4614 : 0 : subroutine dvdb_test_v1rsym(db_path, symv1scf, comm)
4615 : :
4616 : : !Arguments ------------------------------------
4617 : : character(len=*),intent(in) :: db_path
4618 : : integer,intent(in) :: symv1scf, comm
4619 : :
4620 : : !Local variables-------------------------------
4621 : : !scalars
4622 : : integer,parameter :: rfmeth2=2, syuse0=0, gpu_option0 = 0
4623 : : integer :: iqpt,idir,ipert,nsym1,cplex,v1pos, isym,nfft,ifft,ifft_rot,ispden
4624 : : real(dp) :: max_err,re,im,vre,vim !,pre,pim
4625 : : character(len=500) :: msg
4626 : : logical :: isok
4627 [ # # # # : 0 : type(dvdb_t),target :: db
# # # # #
# # # # #
# # # # #
# # # #
# ]
4628 : : type(crystal_t),pointer :: cryst
4629 : : !arrays
4630 : : integer :: ngfft(18)
4631 : 0 : integer,allocatable :: symafm1(:),symrel1(:,:,:),irottb(:,:)
4632 : : real(dp) :: qpt(3)
4633 : 0 : real(dp),allocatable :: tnons1(:,:),v1scf(:,:)
4634 : : ! *************************************************************************
4635 : :
4636 : 0 : call db%init(db_path, gpu_option0, comm)
4637 : 0 : db%debug = .True.
4638 : 0 : db%symv1 = symv1scf
4639 [ # # ]: 0 : call db%print([std_out], "", 0)
4640 : : !call db%list_perts([-1,-1,-1], npert_miss)
4641 : :
4642 : 0 : call ngfft_seq(ngfft, db%ngfft3_v1(:,1))
4643 [ # # ]: 0 : nfft = product(ngfft(1:3))
4644 : 0 : call db%open_read(ngfft, comm)
4645 : :
4646 : 0 : cryst => db%cryst
4647 [ # # # # : 0 : ABI_MALLOC(symafm1, (cryst%nsym))
# # # # #
# # # ]
4648 [ # # # # : 0 : ABI_MALLOC(symrel1, (3,3,cryst%nsym))
# # # # #
# # # ]
4649 [ # # # # : 0 : ABI_MALLOC(tnons1, (3,cryst%nsym))
# # # # #
# # # ]
4650 : :
4651 [ # # ]: 0 : do iqpt=1,db%nqpt
4652 : 0 : qpt = db%qpts(:, iqpt)
4653 [ # # ]: 0 : do ipert=1,db%natom
4654 [ # # ]: 0 : do idir=1,3
4655 [ # # ]: 0 : v1pos = db%pos_dpq(idir, ipert, iqpt); if (v1pos == 0) cycle
4656 : :
4657 : : ! Determines the set of symmetries that leaves the perturbation invariant.
4658 : : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
4659 : : cryst%symafm,symafm1,db%symq_table(:,:,:,iqpt),cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,&
4660 : 0 : tnons1,unit=dev_null)
4661 : :
4662 : 0 : cplex = db%cplex_v1(v1pos)
4663 [ # # ]: 0 : ngfft(1:3) = db%ngfft3_v1(:, v1pos)
4664 [ # # ]: 0 : nfft = product(ngfft(:3))
4665 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex*nfft, db%nspden))
# # # # #
# # # # #
# # ]
4666 : :
4667 [ # # ]: 0 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) /= 0) then
4668 : 0 : ABI_ERROR(msg)
4669 : : end if
4670 : :
4671 [ # # # # : 0 : ABI_MALLOC(irottb, (nfft,nsym1))
# # # # #
# # # # #
# # ]
4672 : 0 : call rotate_fft_mesh(nsym1,symrel1,tnons1,ngfft,irottb,isok)
4673 [ # # ]: 0 : if (.not. isok) then
4674 : 0 : ABI_WARNING("Real space FFT mesh is not compatible with symmetries!")
4675 : : end if
4676 : :
4677 : 0 : max_err = zero
4678 [ # # ]: 0 : do isym=1,nsym1
4679 [ # # ]: 0 : do ispden=1,db%nspden
4680 [ # # ]: 0 : do ifft=1,nfft
4681 : 0 : ifft_rot = irottb(ifft, isym)
4682 : : !pre = cos(two_pi * dot_product(qpt, tnons1(:,isym)))
4683 : : !pim = -sin(two_pi * dot_product(qpt, tnons1(:,isym)))
4684 [ # # ]: 0 : if (cplex == 2) then
4685 : 0 : re = v1scf(2*ifft_rot-1, ispden)
4686 : 0 : im = v1scf(2*ifft_rot , ispden)
4687 : : !vre = re * pre - im * pim
4688 : : !vim = re * pim + im * pre
4689 : 0 : vre = re; vim = im
4690 : :
4691 : 0 : re = v1scf(2*ifft-1, ispden) - vre
4692 : 0 : im = v1scf(2*ifft , ispden) - vim
4693 : : else
4694 : 0 : re = v1scf(ifft, ispden) - v1scf(ifft_rot, ispden)
4695 : 0 : im = zero
4696 : : end if
4697 : : !if (sqrt(re**2 + im**2) > tol6) write(std_out,*)"ifft,isym,err: ",ifft,isym,sqrt(re**2 + im**2)
4698 : 0 : max_err = max(max_err, sqrt(re**2 + im**2))
4699 : : end do
4700 : : end do
4701 : : end do
4702 [ # # ]: 0 : if (nsym1>1) then
4703 : 0 : write(std_out,"(3(a,i2),a,i2,a,es16.8)")"For iqpt= ",iqpt,&
4704 : 0 : ", idir= ",idir,", ipert= ",ipert,", nsym= ",nsym1,", max_err= ",max_err
4705 : : end if
4706 : :
4707 [ # # ]: 0 : ABI_FREE(irottb)
4708 [ # # ]: 0 : ABI_FREE(v1scf)
4709 : : end do
4710 : : end do
4711 : :
4712 : : end do ! iqpt
4713 : :
4714 [ # # ]: 0 : ABI_FREE(symafm1)
4715 [ # # ]: 0 : ABI_FREE(symrel1)
4716 [ # # ]: 0 : ABI_FREE(tnons1)
4717 : :
4718 : 0 : call db%free()
4719 : :
4720 [ # # # # : 0 : end subroutine dvdb_test_v1rsym
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4721 : : !!***
4722 : :
4723 : : !----------------------------------------------------------------------
4724 : :
4725 : : !!****f* m_dvdb/dvdb_test_v1complete
4726 : : !! NAME
4727 : : !! dvdb_test_v1complete
4728 : : !!
4729 : : !! FUNCTION
4730 : : !! Debugging tool used to test the symmetrization of the DFPT potentials.
4731 : : !! Assumes DVDB file containing all 3*natom perturbations (either generated with nsym == 1 or
4732 : : !! via other specialized variables e.g. prepgkk)
4733 : : !!
4734 : : !! INPUTS
4735 : : !! db_path=Filename of the DVDB file.
4736 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 ti disable it.
4737 : : !! dump_path=File used to dump potentials (empty string to disable output)
4738 : : !! comm=MPI communicator.
4739 : : !!
4740 : : !! OUTPUT
4741 : : !! Only writing.
4742 : : !!
4743 : : !! SOURCE
4744 : :
4745 : 0 : subroutine dvdb_test_v1complete(dvdb_filepath, symv1scf, dump_path, comm)
4746 : :
4747 : : !Arguments ------------------------------------
4748 : : character(len=*),intent(in) :: dvdb_filepath,dump_path
4749 : : integer,intent(in) :: symv1scf, comm
4750 : :
4751 : : !Local variables-------------------------------
4752 : : !scalars
4753 : : integer,parameter :: master = 0, gpu_option0 = 0
4754 : : integer :: iqpt,pcase,idir,ipert,cplex,nfft,ispden,timerev_q,ifft,unt,my_rank, ncid
4755 : : integer :: i1,i2,i3,n1,n2,n3,id1,id2,id3,cnt, npert_miss
4756 : : integer :: ncerr
4757 : : character(len=500) :: msg
4758 : : type(crystal_t),pointer :: cryst
4759 [ # # # # : 0 : type(dvdb_t),target :: dvdb
# # # # #
# # # # #
# # # # #
# # # #
# ]
4760 : : type(vdiff_t) :: vd
4761 : : !arrays
4762 : : integer :: ngfft(18), rfdir(3)
4763 : 0 : integer,allocatable :: pflag(:,:), pertsy(:,:),rfpert(:),symq(:,:,:)
4764 : : real(dp) :: qpt(3)
4765 : 0 : real(dp),allocatable :: file_v1scf(:,:,:,:),symm_v1scf(:,:,:,:), work2(:,:,:,:)
4766 : : ! *************************************************************************
4767 : :
4768 : 0 : my_rank = xmpi_comm_rank(comm)
4769 : :
4770 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
4771 : 0 : dvdb%debug = .false.
4772 : 0 : dvdb%symv1 = symv1scf
4773 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
4774 : 0 : call dvdb%list_perts([-1,-1,-1], npert_miss)
4775 : :
4776 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
4777 [ # # ]: 0 : nfft = product(ngfft(1:3))
4778 : 0 : call dvdb%open_read(ngfft, comm)
4779 : :
4780 : 0 : cryst => dvdb%cryst
4781 : :
4782 : 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
4783 : 0 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
4784 : :
4785 [ # # # # : 0 : ABI_MALLOC(pflag, (3, dvdb%natom))
# # # # #
# # # ]
4786 : :
4787 : : ! Initialize the list of perturbations rfpert and rdfir
4788 : : ! WARNING: Only phonon perturbations are considered for the time being.
4789 [ # # # # : 0 : ABI_MALLOC(rfpert,(dvdb%mpert))
# # # # #
# # # ]
4790 [ # # # # : 0 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
# # ]
4791 [ # # # # : 0 : ABI_MALLOC(symq, (4,2,cryst%nsym))
# # # # #
# # # ]
4792 [ # # # # : 0 : ABI_MALLOC(pertsy, (3,dvdb%mpert))
# # # # #
# # # ]
4793 : :
4794 : 0 : unt = -1; ncid = nctk_noid
4795 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
4796 : 0 : write(std_out,"(a)")sjoin("Will write potentials to:", dump_path)
4797 [ # # ]: 0 : if (endswith(dump_path, ".nc")) then
4798 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
4799 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
4800 : : ncerr = nctk_def_dims(ncid, [&
4801 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
4802 : : nctkdim_t("natom3", cryst%natom * 3), nctkdim_t("mpert", dvdb%mpert), nctkdim_t("nqpt", dvdb%nqpt)], &
4803 [ # # ]: 0 : defmode=.True.)
4804 [ # # ]: 0 : NCF_CHECK(ncerr)
4805 [ # # # # : 0 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "symv1scf"]))
# # ]
4806 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
4807 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("origin_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4808 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("recons_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4809 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("pertsy_qpt", "int", "three, mpert, nqpt")))
4810 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
4811 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
4812 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
4813 [ # # # # ]: 0 : "symv1scf"], [symv1scf])
4814 [ # # ]: 0 : NCF_CHECK(ncerr)
4815 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
4816 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
4817 : : else
4818 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
4819 : 0 : ABI_ERROR(msg)
4820 : : end if
4821 : : end if
4822 : : end if
4823 : :
4824 [ # # # # : 0 : ABI_CALLOC(work2, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4825 : :
4826 : : ! loop over the q-points available in the dvdb (likely qpts in the IBZ)
4827 : : ! For each q-point, use symmetries to reconstruct all 3*natom perts for the independent ones
4828 : : ! and compare with the corresponding results available in the DVDB file
4829 : :
4830 [ # # ]: 0 : do iqpt=1,dvdb%nqpt
4831 [ # # ]: 0 : qpt = dvdb%qpts(:,iqpt)
4832 : :
4833 : : ! Examine the symmetries of the q wavevector
4834 : 0 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=dvdb%prtvol)
4835 : :
4836 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4837 : : ! 0 for non-target perturbations
4838 : : ! 1 for basis perturbations
4839 : : ! -1 for perturbations that can be found from basis perturbations
4840 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
4841 : 0 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4842 : :
4843 : : ! Read all potentials (here we assume that all perturbations are available in the DVDB)
4844 [ # # ]: 0 : call dvdb%readsym_allv1(iqpt, cplex, nfft, ngfft, file_v1scf, dvdb%comm)
4845 : :
4846 : : ! Copy basis perturbations in symm_v1scf and set pflag
4847 [ # # # # : 0 : ABI_MALLOC(symm_v1scf, (cplex, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4848 [ # # # # : 0 : symm_v1scf = huge(one); pflag = 0
# # # # #
# # # ]
4849 [ # # ]: 0 : do pcase=1,3*dvdb%cryst%natom
4850 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4851 [ # # ]: 0 : if (pertsy(idir, ipert) == 1) then
4852 [ # # # # : 0 : symm_v1scf(:,:,:,pcase) = file_v1scf(:,:,:,pcase)
# # ]
4853 : 0 : pflag(idir,ipert) = 1
4854 : : end if
4855 : : end do
4856 : :
4857 : : ! Complete potentials by symmetry.
4858 : 0 : call v1phq_complete(cryst,qpt,ngfft,cplex,nfft,dvdb%nspden,dvdb%nsppol,dvdb%mpi_enreg,dvdb%symv1,pflag,symm_v1scf)
4859 : :
4860 [ # # ]: 0 : if (ncid /= nctk_noid) then
4861 [ # # # # : 0 : work2 = zero
# # # # ]
4862 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = file_v1scf(1,:,:,:)
# # # # ]
4863 [ # # # # : 0 : if (cplex == 2) work2 = file_v1scf
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4864 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "origin_v1scf"), work2, start=[1,1,1,1,iqpt])
4865 [ # # ]: 0 : NCF_CHECK(ncerr)
4866 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = symm_v1scf(1,:,:,:)
# # # # ]
4867 [ # # # # : 0 : if (cplex == 2) work2 = symm_v1scf
# # # # #
# # # # #
# # # # #
# # # ]
4868 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "recons_v1scf"), work2, start=[1,1,1,1,iqpt])
4869 [ # # ]: 0 : NCF_CHECK(ncerr)
4870 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "pertsy_qpt"), pertsy, start=[1,1,iqpt]))
# # ]
4871 : : end if
4872 : :
4873 : : ! Compare potentials.
4874 [ # # ]: 0 : do pcase=1,3*cryst%natom
4875 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4876 [ # # ]: 0 : if (pflag(idir,ipert) /= 2) cycle
4877 : 0 : cnt = cnt+1
4878 : :
4879 [ # # ]: 0 : do ispden=1,dvdb%nspden
4880 : : !write(std_out,"(5(a,i0),3a,es12.4)")"For cnt: ",cnt ,", iqpt: ", iqpt, ", idir: ", idir, &
4881 : : ! ", ipert: ", ipert, ", ispden: ", ispden, ", qpt: ", trim(ktoa(qpt)) ,", max_err: ", &
4882 : : ! maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4883 : : !write(std_out,"(a,es10.3)")" max(abs(f1-f2))", maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4884 : 0 : call vd%eval(cplex,nfft,file_v1scf(:,:,ispden,pcase),symm_v1scf(:,:,ispden,pcase),cryst%ucvol, unit=std_out)
4885 : :
4886 : : ! Debug: write potentials to file.
4887 [ # # ]: 0 : if (unt /= -1) then
4888 : 0 : write(unt,*)"# count:", cnt
4889 [ # # # # ]: 0 : write(unt,*)"# q-point:", trim(ktoa(qpt)), ", iqpt: ", trim(itoa(iqpt))
4890 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
4891 : 0 : write(unt,*)"# file_v1scf, symmetrized_v1scf, diff"
4892 [ # # ]: 0 : if (cplex == 1) then
4893 [ # # ]: 0 : do i3=1,n3
4894 [ # # ]: 0 : do i2=1,n2
4895 [ # # ]: 0 : do i1=1,n1
4896 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4897 : : write(unt,"(3i3,3(es12.4,2x))") &
4898 : 0 : i1,i2,i3, &
4899 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4900 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase)
4901 : : end do
4902 : : end do
4903 : : end do
4904 : : else
4905 [ # # ]: 0 : do i3=1,n3
4906 [ # # ]: 0 : do i2=1,n2
4907 [ # # ]: 0 : do i1=1,n1
4908 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4909 : : write(unt, "(3i3,6(es12.4,2x))") &
4910 : 0 : i1,i2,i3, &
4911 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4912 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase), &
4913 : 0 : file_v1scf(2,ifft,ispden,pcase), symm_v1scf(2,ifft,ispden,pcase), &
4914 : 0 : file_v1scf(2,ifft,ispden,pcase) - symm_v1scf(2,ifft,ispden,pcase)
4915 : : end do
4916 : : end do
4917 : : end do
4918 : : end if
4919 : 0 : write(unt,*)
4920 : 0 : write(unt,*)
4921 : : end if
4922 : :
4923 : : end do
4924 : : !write(std_out,*)""
4925 : : end do
4926 : :
4927 [ # # ]: 0 : ABI_FREE(symm_v1scf)
4928 [ # # ]: 0 : ABI_FREE(file_v1scf)
4929 : : end do
4930 : :
4931 [ # # ]: 0 : ABI_FREE(work2)
4932 [ # # ]: 0 : ABI_FREE(pflag)
4933 [ # # ]: 0 : ABI_FREE(rfpert)
4934 [ # # ]: 0 : ABI_FREE(symq)
4935 [ # # ]: 0 : ABI_FREE(pertsy)
4936 : :
4937 : 0 : call dvdb%free()
4938 : :
4939 [ # # ]: 0 : if (unt /= -1) close(unt)
4940 [ # # ]: 0 : if (ncid /= nctk_noid) then
4941 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
4942 : : end if
4943 : :
4944 [ # # # # : 0 : end subroutine dvdb_test_v1complete
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4945 : : !!***
4946 : :
4947 : : !----------------------------------------------------------------------
4948 : :
4949 : : !!****f* m_dvdb/dvdb_write_v1qavg
4950 : : !! NAME
4951 : : !! dvdb_write_v1qavg
4952 : : !!
4953 : : !! FUNCTION
4954 : : !! Computes the average over the unit cell of the periodic part of the DFPT potentials
4955 : : !! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
4956 : : !! Results are stored in the V1QAVG netcdf file. Two options are available:
4957 : : !!
4958 : : !! eph_task = -15 --> Use list of q-points found in the DVDB file. Mainly used to plot the average
4959 : : !! along a q-path. The procedure required to generate a DVDB with a q-path is rather lengthy
4960 : : !! as it requires several phonon calculations with WKQ followed by a merge of the POT files.
4961 : : !!
4962 : : !! eph_task = +15 --> Assume DVDB file with q-mesh (dvdb_ngqpt), use Fourier interpolation
4963 : : !! to interpolate potentials along the path specified by ph_qpath and ph_nqpath.
4964 : : !!
4965 : : !! INPUTS
4966 : : !! dtset<dataset_type>= Input variables.
4967 : : !! out_ncpath=Filename for output netcdf file.
4968 : : !!
4969 : : !! OUTPUT
4970 : : !! Only writing.
4971 : : !!
4972 : : !! SOURCE
4973 : :
4974 : 2 : subroutine dvdb_write_v1qavg(dvdb, dtset, out_ncpath)
4975 : :
4976 : : !Arguments ------------------------------------
4977 : : class(dvdb_t),target,intent(inout) :: dvdb
4978 : : type(dataset_type),target,intent(in) :: dtset
4979 : : character(len=*),intent(in) :: out_ncpath
4980 : :
4981 : : !Local variables-------------------------------
4982 : : !scalars
4983 : : integer,parameter :: master = 0
4984 : : integer :: nfft, iq, cplex, ispden, comm_rpt, my_rank, idir, ipert, ipc, imyp
4985 : : integer :: n1, n2, n3, unt, this_nqpt, interpolated
4986 : : integer :: i1, i2, i3, ifft, ig, ngsmall, ii, qptopt
4987 : : integer :: ncid, ncerr
4988 : : real(dp) :: gsq_max, g2
4989 : : !type(vdiff_t) :: vd_max
4990 : : logical :: write_v1r
4991 : : character(len=500) :: msg
4992 : : character(len=fnlen) :: dump_path
4993 : : !arrays
4994 : : integer :: ngfft(18), units(2)
4995 : 2 : integer, allocatable :: gfft(:,:),ig2ifft(:), gsmall(:,:)
4996 : : real(dp) :: dvdb_qdamp(1)
4997 : : real(dp) :: vals2(2)
4998 : 2 : real(dp),pointer :: this_qpts(:,:)
4999 : 2 : real(dp),allocatable :: file_v1r(:,:,:,:),long_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5000 : 2 : real(dp),allocatable :: maxw(:,:), all_rpt(:,:), all_rmod(:), workg(:,:), work_gsmall(:,:)
5001 : : ! *************************************************************************
5002 : :
5003 : 4 : my_rank = xmpi_comm_rank(dvdb%comm)
5004 [ + + ]: 6 : units = [std_out, ab_out]
5005 : :
5006 : 2 : call wrtout(units, " Computing average over the unit cell of the periodic part of the DFPT potentials", newlines=2)
5007 [ + + ]: 4 : call dvdb%print([std_out], "", 0)
5008 : :
5009 : : ! Define FFT mesh
5010 [ + + ]: 38 : ngfft = dvdb%ngfft
5011 [ + + ]: 8 : nfft = product(ngfft(1:3))
5012 : 2 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
5013 : :
5014 : : ! Get list of G-vectors in FFT mesh.
5015 [ - + + - : 6 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5016 : 2 : call get_gfft(ngfft, [zero, zero, zero], dvdb%cryst%gmet, gsq_max, gfft)
5017 [ - + + - : 6 : ABI_MALLOC(workg, (2, nfft))
+ - + - -
+ - + ]
5018 : :
5019 : : ! Select G-vectors in small sphere (ratio of gsq_max)
5020 [ + + ]: 6 : do ii=1,2
5021 [ + + ]: 4 : if (ii == 2) then
5022 [ - + + - : 6 : ABI_MALLOC(ig2ifft, (ngsmall))
+ - + - -
+ - + -
+ ]
5023 : : end if
5024 : 4 : ngsmall = 0
5025 [ + + ]: 16390 : do ig=1,nfft
5026 : : ! Don't include (2pi)**2 to be consistent with get_gfft
5027 [ + + + + : 327680 : g2 = dot_product(gfft(:,ig), matmul(dvdb%cryst%gmet, gfft(:, ig)))
+ + + - +
+ ]
5028 [ + + ]: 16384 : if (g2 <= gsq_max * 0.01_dp) ngsmall = ngsmall + 1
5029 [ + + ]: 16388 : if (ii == 2) ig2ifft(ngsmall) = ig
5030 : : end do
5031 : : end do
5032 : 2 : write(std_out, *)"Found ngsmall", ngsmall
5033 : :
5034 : : !call ig2fft_sphere(dvdb%cryst%gmet, gfft, ig2ifft)
5035 [ - + + - : 6 : ABI_MALLOC(gsmall, (3, ngsmall))
+ - + - -
+ - + -
+ ]
5036 [ + + ]: 56 : do ig=1,ngsmall
5037 [ + + ]: 218 : gsmall(:, ig) = gfft(:, ig2ifft(ig))
5038 : : end do
5039 [ - + + - : 6 : ABI_MALLOC(work_gsmall, (2, ngsmall))
+ - + - -
+ - + -
+ ]
5040 : :
5041 [ - + + - : 10 : ABI_MALLOC(long_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - + -
+ - - + -
+ - + ]
5042 [ - + + - : 8 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - - +
- + - + ]
5043 : :
5044 : 2 : unt = -1; dump_path = ""
5045 : : !dump_path = "V1QAVG.dat"
5046 [ - + - - ]: 2 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5047 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
5048 : 0 : ABI_ERROR(msg)
5049 : : end if
5050 : 0 : write(std_out,"(a)")sjoin(" Will write potentials in text format to:", dump_path)
5051 : : end if
5052 : :
5053 : : ! Select list of q-points depending on eph_task (either from DVDB file or interpolated)
5054 : 2 : write_v1r = .False.
5055 [ + + ]: 2 : if (dtset%eph_task == -15) then
5056 : 1 : call wrtout(units, " Using list of q-points found in the DVDB file")
5057 : 1 : this_nqpt = dvdb%nqpt
5058 : 1 : this_qpts => dvdb%qpts
5059 : 1 : interpolated = 0
5060 : :
5061 [ + - ]: 1 : else if (dtset%eph_task == +15) then
5062 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
5063 : 1 : call wrtout(units, msg)
5064 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "When eph_task = +15, ph_qpath must be given in input.")
5065 : 1 : this_nqpt = dtset%ph_nqpath
5066 : 1 : this_qpts => dtset%ph_qpath(:, 1:this_nqpt)
5067 : 1 : comm_rpt = xmpi_comm_self
5068 [ - + ]: 1 : qptopt = dtset%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5069 : 1 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfft, ngfft, comm_rpt)
5070 : 1 : interpolated = 1
5071 : 1 : write_v1r = dtset%prtpot > 0
5072 : : else
5073 : 0 : ABI_ERROR(sjoin("Invalid value for eph_task:", itoa(dtset%eph_task)))
5074 : : end if
5075 : :
5076 : 2 : call wrtout(units, sjoin(ch10, "- Results stored in: ", out_ncpath))
5077 : 2 : call wrtout(units, " Use `abiopen.py out_V1QAVG.nc -e` to visualize results")
5078 : :
5079 [ + - ]: 2 : if (my_rank == master) then
5080 [ - + ]: 2 : NCF_CHECK(nctk_open_create(ncid, out_ncpath, xmpi_comm_self))
5081 [ - + ]: 2 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5082 : : ncerr = nctk_def_dims(ncid, [ &
5083 : : nctkdim_t("nspden", dvdb%nspden), nctkdim_t("natom", dvdb%natom3 / 3), nctkdim_t("nqpt", this_nqpt), &
5084 [ + + ]: 12 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("ngsmall", ngsmall)], defmode=.True.)
5085 [ - + ]: 2 : NCF_CHECK(ncerr)
5086 : :
5087 [ + + ]: 2 : if (interpolated == 1) then
5088 : : ! Define arrays for Max_r |W(R, r)|
5089 [ + + - + : 3 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nrpt", dvdb%nrtot), nctkdim_t("nfft", nfft)]))
- - ]
5090 : : ncerr = nctk_def_arrays(ncid, [ &
5091 : : nctkarr_t("ngqpt", "int", "three"), nctkarr_t("rpt", "dp", "three, nrpt"), nctkarr_t("rmod", "dp", "nrpt"), &
5092 : : nctkarr_t("ngfft", "int", "three"), &
5093 : : nctkarr_t("maxw", "dp", "nrpt, natom3") &
5094 [ + + ]: 6 : ])
5095 [ - + ]: 1 : NCF_CHECK(ncerr)
5096 : : end if
5097 : :
5098 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5099 [ + + ]: 10 : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"])
5100 [ - + ]: 2 : NCF_CHECK(ncerr)
5101 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5102 [ + + ]: 12 : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield", "dvdb_add_lr"])
5103 [ - + ]: 2 : NCF_CHECK(ncerr)
5104 [ + + - + : 4 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"]))
- - ]
5105 : : ncerr = nctk_def_arrays(ncid, [ &
5106 : : nctkarr_t("v1scf_avg", "dp", "two, nspden, three, natom, nqpt"), &
5107 : : nctkarr_t("v1lr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5108 : : nctkarr_t("v1scfmlr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5109 : : nctkarr_t("v1scfmlr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5110 : : nctkarr_t("v1scf_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5111 : : nctkarr_t("v1lr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5112 : : nctkarr_t("gsmall", "int", "three, ngsmall"), &
5113 : : nctkarr_t("v1scf_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5114 : : nctkarr_t("v1lr_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5115 : : nctkarr_t("qpoints", "dp", "three, nqpt") &
5116 [ + + ]: 22 : ])
5117 [ - + ]: 2 : NCF_CHECK(ncerr)
5118 : :
5119 [ - + ]: 2 : if (write_v1r) then
5120 : : ncerr = nctk_def_arrays(ncid, [ &
5121 : : nctkarr_t("v1r_interpolated", "dp", "two, nfft, nspden, natom3"), &
5122 : : nctkarr_t("v1r_lrmodel", "dp", "two, nfft, nspden, natom3") &
5123 [ # # ]: 0 : ])
5124 [ # # ]: 0 : NCF_CHECK(ncerr)
5125 : : end if
5126 : :
5127 [ - + ]: 2 : NCF_CHECK(nctk_set_datamode(ncid))
5128 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpoints"), this_qpts))
5129 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5130 : : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"], &
5131 [ + + + + ]: 18 : [dtset%symdynmat, dvdb%symv1, dtset%dvdb_add_lr, interpolated])
5132 [ - + ]: 2 : NCF_CHECK(ncerr)
5133 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5134 : : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield"], &
5135 [ + + + + ]: 18 : l2int([dvdb%has_dielt, dvdb%has_zeff, dvdb%has_quadrupoles, dvdb%has_efield]))
5136 [ - + ]: 2 : NCF_CHECK(ncerr)
5137 [ + + ]: 4 : dvdb_qdamp = dvdb%qdamp
5138 [ + + - + : 4 : NCF_CHECK(nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"], dvdb_qdamp))
- - ]
5139 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "gsmall"), gsmall))
5140 : : end if
5141 : :
5142 [ + + ]: 10 : do iq=1,this_nqpt
5143 : :
5144 [ + + ]: 8 : if (interpolated == 0) then
5145 [ - + ]: 3 : call wrtout(std_out, sjoin(" Treating qpt:", ktoa(this_qpts(:,iq))))
5146 : :
5147 : : ! Read data from DVDB file, reconstruct all 3*natom perturbations in tmp_v1r.
5148 [ - + - + ]: 3 : call dvdb%readsym_allv1(dvdb%findq(this_qpts(:, iq)), cplex, nfft, ngfft, tmp_v1r, xmpi_comm_self)
5149 : :
5150 : : ! Transfer data to file_v1r taking into account my_npert
5151 [ + + ]: 21 : do imyp=1,dvdb%my_npert
5152 : 18 : ipc = dvdb%my_pinfo(3, imyp)
5153 [ + + ]: 21 : if (cplex == 1) then
5154 [ + + + + ]: 24588 : file_v1r(1,:,:,imyp) = tmp_v1r(1,:,:,ipc)
5155 [ + + + + ]: 24588 : file_v1r(2,:,:,imyp) = zero
5156 : : else
5157 [ + + + + : 147480 : file_v1r(:,:,:,imyp) = tmp_v1r(:,:,:,ipc)
+ + ]
5158 : : end if
5159 : : end do
5160 [ - + ]: 3 : ABI_FREE(tmp_v1r)
5161 : :
5162 : : else
5163 : : ! Interpolate my_npert potentials for this q-point.
5164 [ - + ]: 5 : call wrtout(std_out, sjoin(" Interpolating qpt:", ktoa(this_qpts(:,iq))))
5165 [ - + ]: 5 : call dvdb%ftinterp_qpt(this_qpts(:, iq), nfft, ngfft, file_v1r, comm_rpt) !, add_lr=?)
5166 : 5 : cplex = 2
5167 : : end if
5168 : :
5169 : : ! Compute the periodic part of the LR term (note add_qphase = 0 because we want the periodic part)
5170 [ + + ]: 56 : do imyp=1,dvdb%my_npert
5171 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5172 [ + + ]: 104 : do ispden=1,min(dvdb%nspden, 2)
5173 [ - + ]: 96 : call dvdb%get_v1r_long_range(this_qpts(:,iq), idir, ipert, nfft, ngfft, long_v1r(:,:,ispden,imyp), add_qphase=0)
5174 : : end do
5175 : : end do
5176 : :
5177 : : ! Compute average and write to file.
5178 [ + - ]: 8 : if (my_rank /= master) cycle
5179 : :
5180 [ - + ]: 8 : if (write_v1r .and. iq == 1) then
5181 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_interpolated"), file_v1r))
5182 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_lrmodel"), long_v1r))
5183 : : end if
5184 : :
5185 [ + + ]: 58 : do imyp=1,dvdb%my_npert
5186 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5187 [ + + ]: 104 : do ispden=1,dvdb%nspden
5188 : :
5189 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp), dim=2) / nfft
5190 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_avg"), vals2, &
5191 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5192 [ - + ]: 48 : NCF_CHECK(ncerr)
5193 : :
5194 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp)), dim=2) / nfft
5195 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_abs_avg"), vals2, &
5196 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5197 [ - + ]: 48 : NCF_CHECK(ncerr)
5198 : :
5199 [ + + + + ]: 393360 : vals2 = sum(long_v1r(:,:,ispden,imyp), dim=2) / nfft
5200 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_avg"), vals2, &
5201 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5202 [ - + ]: 48 : NCF_CHECK(ncerr)
5203 [ + + + + ]: 393360 : vals2 = sum(abs(long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5204 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_abs_avg"), vals2, &
5205 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5206 [ - + ]: 48 : NCF_CHECK(ncerr)
5207 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp), dim=2) / nfft
5208 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_avg"), vals2, &
5209 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5210 [ - + ]: 48 : NCF_CHECK(ncerr)
5211 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5212 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_abs_avg"), vals2, &
5213 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5214 [ - + ]: 48 : NCF_CHECK(ncerr)
5215 : :
5216 : : ! Compute G-components of DFPT potentials and LR model for G in small-sphere and save results to disk
5217 : 48 : call fourdp(2, workg, file_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5218 [ + + ]: 1344 : do ig=1,ngsmall
5219 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5220 : : end do
5221 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_gsmall"), work_gsmall, &
5222 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5223 [ - + ]: 48 : NCF_CHECK(ncerr)
5224 : :
5225 : 48 : call fourdp(2, workg, long_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5226 [ + + ]: 1344 : do ig=1,ngsmall
5227 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5228 : : end do
5229 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_gsmall"), work_gsmall, &
5230 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5231 [ - + ]: 48 : NCF_CHECK(ncerr)
5232 : :
5233 : : ! Debugging section.
5234 : : !write(std_out, "(a)")"--- !DVDB_LONGRANGE_DIFF"
5235 : : !write(std_out,"(3a)")" qpoint: ", trim(ktoa(this_qpts(:,iq))), ","
5236 : : !write(std_out,"(a,i0,a)")" iq: ", iq, ","
5237 : : !write(std_out,"(2(a,i0))")" idir: ", idir, ", ipert:", ipert
5238 : : !write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5239 : : !call call vd%eval(2, nfft, file_v1r(:,:,ispden,imyp), long_v1r(:,:,ispden,imyp), &
5240 : : ! dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out))
5241 : : !write(std_out,"(a)")"..."
5242 : :
5243 : : ! Debug: write potentials to file.
5244 [ - + ]: 96 : if (unt /= -1) then
5245 [ # # # # : 0 : write(unt,*)"# q-point:", trim(ktoa(this_qpts(:,iq))), ", iq: ", trim(itoa(iq))
# # ]
5246 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
5247 : 0 : write(unt,*)"# file_v1r, long_v1r, diff"
5248 : :
5249 [ # # ]: 0 : if (cplex == 1) then
5250 [ # # ]: 0 : do i3=1,n3
5251 [ # # ]: 0 : do i2=1,n2
5252 [ # # ]: 0 : do i1=1,n1
5253 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5254 : : write(unt,"(3(i0,1x),3(es12.4,2x))") &
5255 : 0 : i1,i2,i3, &
5256 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5257 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp)
5258 : : end do
5259 : : end do
5260 : : end do
5261 : : else
5262 [ # # ]: 0 : do i3=1,n3
5263 [ # # ]: 0 : do i2=1,n2
5264 [ # # ]: 0 : do i1=1,n1
5265 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5266 : : write(unt, "(3(i0,1x),6(es12.4,2x))") &
5267 : 0 : i1,i2,i3, &
5268 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5269 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp), &
5270 : 0 : file_v1r(2,ifft,ispden,imyp), long_v1r(2,ifft,ispden,imyp), &
5271 : 0 : file_v1r(2,ifft,ispden,imyp) - long_v1r(2,ifft,ispden,imyp)
5272 : : end do
5273 : : end do
5274 : : end do
5275 : : end if
5276 : 0 : write(unt,*)
5277 : 0 : write(unt,*)
5278 : : end if
5279 : :
5280 : : end do
5281 : : end do
5282 : : !write(std_out,*)" "
5283 : : end do ! iq
5284 : :
5285 [ - + ]: 2 : ABI_FREE(long_v1r)
5286 [ - + ]: 2 : ABI_FREE(file_v1r)
5287 [ - + ]: 2 : ABI_FREE(workg)
5288 [ - + ]: 2 : ABI_FREE(gfft)
5289 [ - + ]: 2 : ABI_FREE(ig2ifft)
5290 [ - + ]: 2 : ABI_FREE(gsmall)
5291 [ - + ]: 2 : ABI_FREE(work_gsmall)
5292 : :
5293 [ + + ]: 2 : if (interpolated == 1) then
5294 : : ! Compute max_r |W(R,r)| and write data to file.
5295 [ - + - + : 1 : call dvdb%get_maxw(dtset%ddb_ngqpt, all_rpt, all_rmod, maxw)
- + ]
5296 [ + - ]: 1 : if (my_rank == master) then
5297 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), dtset%ddb_ngqpt))
5298 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rpt"), all_rpt))
5299 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rmod"), all_rmod))
5300 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5301 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "maxw"), maxw))
5302 : : end if
5303 [ - + ]: 1 : ABI_FREE(all_rpt)
5304 [ - + ]: 1 : ABI_FREE(all_rmod)
5305 [ - + ]: 1 : ABI_FREE(maxw)
5306 : : end if
5307 : :
5308 [ + - ]: 2 : if (my_rank == master) then
5309 [ - + ]: 2 : NCF_CHECK(nf90_close(ncid))
5310 : : end if
5311 : :
5312 [ - + - + : 4 : end subroutine dvdb_write_v1qavg
- + - + -
+ - + - +
- + ]
5313 : : !!***
5314 : :
5315 : : !----------------------------------------------------------------------
5316 : :
5317 : : !!****f* m_dvdb/dvdb_test_ftinterp
5318 : : !! NAME
5319 : : !! dvdb_test_ftinterp
5320 : : !!
5321 : : !! FUNCTION
5322 : : !! Debugging tool used to test the Fourier interpolation of the DFPT potentials.
5323 : : !!
5324 : : !! INPUTS
5325 : : !! dvdb_filepath=Filename
5326 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equat to ddb_ngqpt)
5327 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5328 : : !! qdamp=Defines exponential damping in LR potential
5329 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5330 : : !! prtvol=Verbosity level.
5331 : : !! coarse_ngqpt(3)= Coarse q-mesh used to analyze the accuracy of the FT interpolation
5332 : : !! Must be divisor of dvdb_ngqpt. Use 0 to disable the test.
5333 : : !! comm=MPI communicator.
5334 : : !!
5335 : : !! OUTPUT
5336 : : !! Only writing.
5337 : : !!
5338 : : !! SOURCE
5339 : :
5340 : 0 : subroutine dvdb_test_ftinterp(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5341 : : ddb_filepath, prtvol, coarse_ngqpt, dump_path, comm)
5342 : :
5343 : : !Arguments ------------------------------------
5344 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5345 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5346 : : real(dp),intent(in) :: dvdb_qdamp
5347 : : integer,intent(in) :: dvdb_ngqpt(3), coarse_ngqpt(3)
5348 : :
5349 : : !Local variables-------------------------------
5350 : : !scalars
5351 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0
5352 : : integer :: nfft, iq, cplex, mu, ispden, comm_rpt, iblock_dielt, iblock_dielt_zeff, my_rank, ierr
5353 : : integer :: ncid, ncerr
5354 : : logical :: autotest
5355 [ # # # # : 0 : type(dvdb_t) :: dvdb, coarse_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5356 : : type(vdiff_t) :: vd_max, vd
5357 : 0 : type(ddb_type) :: ddb
5358 : : character(len=fnlen) :: coarse_fname
5359 : : !arrays
5360 : : integer :: ngfft(18)
5361 : 0 : real(dp),allocatable :: file_v1r(:,:,:,:),intp_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5362 : : ! *************************************************************************
5363 : :
5364 : 0 : my_rank = xmpi_comm_rank(comm)
5365 : :
5366 : 0 : write(std_out,"(a)")sjoin(" Testing Fourier interpolation of V1(r) with ngqpt:", ltoa(dvdb_ngqpt))
5367 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5368 : 0 : write(std_out,"(a)")sjoin(" Reading Zeff and eps_inf from DDB file:", ddb_filepath)
5369 : 0 : write(std_out,"(a)")sjoin(" dvdb_add_lr set to:", itoa(dvdb_add_lr))
5370 : : end if
5371 : :
5372 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5373 : 0 : dvdb%debug = .False.
5374 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5375 : 0 : dvdb%symv1 = symv1
5376 : 0 : dvdb%add_lr = dvdb_add_lr
5377 : 0 : dvdb%qdamp = dvdb_qdamp
5378 : 0 : dvdb%rspace_cell = rspace_cell
5379 : :
5380 : : !call dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5381 : :
5382 : 0 : iblock_dielt = 0; iblock_dielt_zeff = 0
5383 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5384 : 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5385 : : else
5386 : 0 : dvdb%add_lr = 0
5387 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5388 : : end if
5389 : :
5390 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5391 : :
5392 : : ! Define FFT mesh for real space representation.
5393 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5394 [ # # ]: 0 : nfft = product(ngfft(1:3))
5395 : 0 : call dvdb%open_read(ngfft, comm)
5396 : :
5397 [ # # # # : 0 : ABI_MALLOC(intp_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5398 [ # # # # : 0 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5399 : :
5400 : : ! Prepare FT interpolation.
5401 : 0 : comm_rpt = xmpi_comm_self
5402 : :
5403 : : ! Optionally dump ab-initio and interpolated V1(r) to a netcdf file for post-processing in python.
5404 : 0 : ncid = nctk_noid
5405 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5406 : 0 : write(std_out,"(a)")sjoin(" Will write ab-initio and interpolated potentials to:", dump_path)
5407 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5408 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5409 : : ncerr = nctk_def_dims(ncid, [ &
5410 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5411 [ # # ]: 0 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nqpt", dvdb%nqpt)], defmode=.True.)
5412 [ # # ]: 0 : NCF_CHECK(ncerr)
5413 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
5414 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
5415 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5416 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5417 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5418 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_ngqpt", "int", "three")))
5419 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5420 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5421 : : end if
5422 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5423 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
5424 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5425 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5426 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_ngqpt"), coarse_ngqpt))
5427 : : end if
5428 : : end if
5429 : :
5430 : 0 : autotest = .True.
5431 : : if (autotest) then
5432 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5433 : :
5434 : : ! First step: Use FT interpolation to get q-points in the initial ab-initio mesh.
5435 : : ! We should get the same result...
5436 [ # # ]: 0 : do iq=1,dvdb%nqpt
5437 : : ! Read data from DVDB file and store it in file_v1r
5438 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5439 : :
5440 [ # # ]: 0 : if (cplex == 1) then
5441 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5442 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5443 : : else
5444 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5445 : : end if
5446 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5447 : :
5448 : : ! Interpolate data at the same q-point.
5449 : 0 : call dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5450 : :
5451 : 0 : write(std_out,"(a)")sjoin("=== For q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5452 [ # # ]: 0 : do mu=1,dvdb%natom3
5453 [ # # ]: 0 : do ispden=1,dvdb%nspden
5454 : 0 : write(std_out, "(a)")"--- !DVDB_SELF_DIFF"
5455 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5456 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5457 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5458 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5459 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5460 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5461 : 0 : write(std_out,"(a)")"..."
5462 : : !do ifft=1,nfft
5463 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5464 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5465 : : !end do
5466 : : end do
5467 : : end do
5468 : :
5469 [ # # ]: 0 : if (ncid /= nctk_noid) then
5470 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5471 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5472 : : end if
5473 : :
5474 : 0 : write(std_out,*)" "
5475 : : end do ! iq
5476 : :
5477 : 0 : write(std_out, "(/, a)")" Max values over q-points and perturbations"
5478 : 0 : call vd_max%print()
5479 [ # # ]: 0 : ABI_FREE(dvdb%wsr)
5480 : : end if
5481 : :
5482 : : ! Now downsample the q-mesh, build real-space representation with coarse q-mesh and
5483 : : ! compare with ab-intio values in the initial dvdb.
5484 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5485 [ # # ]: 0 : write(std_out, "(/, 2a)")" Downsampling Q-mesh using coarse_ngqpt:", trim(ltoa(coarse_ngqpt))
5486 : :
5487 [ # # ]: 0 : coarse_fname = strcat(dvdb_filepath, "_COARSE")
5488 : 0 : call dvdb%qdownsample(coarse_fname, qptopt1, coarse_ngqpt, comm)
5489 : :
5490 : 0 : call coarse_dvdb%init(coarse_fname, gpu_option0, comm)
5491 : 0 : call coarse_dvdb%open_read(ngfft, comm)
5492 : : !call coarse_dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5493 : :
5494 : 0 : coarse_dvdb%debug = dvdb%debug
5495 : 0 : coarse_dvdb%symv1 = dvdb%symv1
5496 : 0 : coarse_dvdb%add_lr = dvdb%add_lr
5497 : 0 : coarse_dvdb%has_dielt = dvdb%has_dielt
5498 : 0 : coarse_dvdb%has_zeff = dvdb%has_zeff
5499 : 0 : coarse_dvdb%has_quadrupoles = dvdb%has_quadrupoles
5500 : 0 : coarse_dvdb%has_efield = dvdb%has_efield
5501 [ # # # # ]: 0 : coarse_dvdb%dielt = dvdb%dielt
5502 [ # # # # : 0 : coarse_dvdb%zeff = dvdb%zeff
# # # # #
# # # # #
# # # # #
# # # ]
5503 [ # # # # : 0 : coarse_dvdb%zeff_raw = dvdb%zeff_raw
# # # # #
# # # # #
# # # # #
# # # ]
5504 [ # # # # : 0 : coarse_dvdb%qstar = dvdb%qstar
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5505 : 0 : coarse_dvdb%qdamp = dvdb%qdamp
5506 : : !call coarse_dvdb%print()
5507 : :
5508 : : ! Prepare FT interpolation using coarse q-mesh.
5509 : 0 : call coarse_dvdb%ftinterp_setup(coarse_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5510 : :
5511 [ # # ]: 0 : do iq=1,dvdb%nqpt
5512 : : ! Read data from DVDB file and store it in file_v1r
5513 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5514 : :
5515 [ # # ]: 0 : if (cplex == 1) then
5516 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5517 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5518 : : else
5519 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5520 : : end if
5521 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5522 : :
5523 : : ! Interpolate data at the same q-point using the coarse Q-mesh
5524 : 0 : call coarse_dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5525 : :
5526 : 0 : write(std_out,"(a)")sjoin("=== For COARSE q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5527 [ # # ]: 0 : do mu=1,dvdb%natom3
5528 [ # # ]: 0 : do ispden=1,dvdb%nspden
5529 : 0 : write(std_out, "(a)")"--- !DVDB_COARSE_DIFF"
5530 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5531 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5532 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5533 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5534 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5535 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5536 : 0 : write(std_out,"(a)")"..."
5537 : : !do ifft=1,nfft
5538 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5539 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5540 : : !end do
5541 : : end do
5542 : : end do
5543 : :
5544 [ # # ]: 0 : if (ncid /= nctk_noid) then
5545 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5546 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5547 : : end if
5548 : :
5549 : 0 : write(std_out,*)" "
5550 : : end do ! iq
5551 : :
5552 : 0 : write(std_out, "(/, a)")" COARSE DVDB: Max values over q-points and perturbations"
5553 : 0 : call vd_max%print()
5554 : 0 : call coarse_dvdb%free()
5555 [ # # ]: 0 : if (my_rank == master) call delete_file(coarse_fname, ierr)
5556 : : end if
5557 : :
5558 [ # # ]: 0 : ABI_FREE(intp_v1r)
5559 [ # # ]: 0 : ABI_FREE(file_v1r)
5560 : :
5561 [ # # ]: 0 : if (ncid /= nctk_noid) then
5562 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5563 : : end if
5564 : :
5565 : 0 : call dvdb%free()
5566 : 0 : call ddb%free()
5567 : :
5568 [ # # # # : 0 : end subroutine dvdb_test_ftinterp
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5569 : : !!***
5570 : :
5571 : : !----------------------------------------------------------------------
5572 : :
5573 : : !!****f* m_dvdb/dvdb_test_symcheck
5574 : : !! NAME
5575 : : !! dvdb_test_symcheck
5576 : : !!
5577 : : !! FUNCTION
5578 : : !! Debugging tool: checks whether Fourier-interpolating the DFPT potential independently
5579 : : !! at q_source and at q_target = I(itimrev) S(isym) q_source (for every symmetry of the
5580 : : !! crystal) gives results consistent with each other via the exact rotation formula
5581 : : !! implemented in v1phq_rotate. This isolates the Fourier-interpolation machinery
5582 : : !! (dvdb_ftinterp_qpt) from gstore_symmetrize: no e-ph coupling / m_gstore.F90 code is
5583 : : !! involved at all. q_source need not be on the native ab-initio q-mesh.
5584 : : !!
5585 : : !! INPUTS
5586 : : !! dvdb_filepath=Filename
5587 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equal to ddb_ngqpt)
5588 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5589 : : !! qdamp=Defines exponential damping in LR potential
5590 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5591 : : !! prtvol=Verbosity level.
5592 : : !! qpt_source(3)=Source q-point (reduced coordinates, arbitrary, need not be on the ab-initio mesh).
5593 : : !! comm=MPI communicator.
5594 : : !!
5595 : : !! OUTPUT
5596 : : !! Only writing.
5597 : : !!
5598 : : !! SOURCE
5599 : :
5600 : 0 : subroutine dvdb_test_symcheck(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5601 : : ddb_filepath, prtvol, qpt_source, dump_path, comm)
5602 : :
5603 : : !Arguments ------------------------------------
5604 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5605 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5606 : : real(dp),intent(in) :: dvdb_qdamp
5607 : : integer,intent(in) :: dvdb_ngqpt(3)
5608 : : real(dp),intent(in) :: qpt_source(3)
5609 : :
5610 : : !Local variables-------------------------------
5611 : : !scalars
5612 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0, cplex2 = 2
5613 : : integer :: nfft, isym, itimrev, tsign, mu, ispden, comm_rpt, iat, my_rank, ncid, ncerr
5614 [ # # # # : 0 : type(dvdb_t) :: dvdb
# # # # #
# # # # #
# # # # #
# # # #
# ]
5615 : : type(vdiff_t) :: vd_max, vd
5616 : : !arrays
5617 : : integer :: ngfft(18), g0q(3)
5618 : : real(dp) :: qpt_target(3)
5619 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5620 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5621 : : ! *************************************************************************
5622 : :
5623 : 0 : my_rank = xmpi_comm_rank(comm)
5624 : :
5625 : 0 : write(std_out,"(2a)")" Testing cross-q-point symmetry consistency of the FT interpolation of V1(r)", ch10
5626 : 0 : write(std_out,"(a)")sjoin(" q_source: ", ktoa(qpt_source))
5627 : :
5628 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5629 : 0 : dvdb%debug = .False.
5630 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5631 : 0 : dvdb%symv1 = symv1
5632 : 0 : dvdb%add_lr = dvdb_add_lr
5633 : 0 : dvdb%qdamp = dvdb_qdamp
5634 : 0 : dvdb%rspace_cell = rspace_cell
5635 : :
5636 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5637 : 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5638 : : else
5639 : 0 : dvdb%add_lr = 0
5640 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5641 : : end if
5642 : :
5643 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5644 : :
5645 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5646 [ # # ]: 0 : nfft = product(ngfft(1:3))
5647 : 0 : call dvdb%open_read(ngfft, comm)
5648 : :
5649 : 0 : comm_rpt = xmpi_comm_self
5650 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5651 : :
5652 [ # # # # : 0 : ABI_MALLOC(v1r_source, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5653 [ # # # # : 0 : ABI_MALLOC(v1r_target, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5654 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5655 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5656 : :
5657 : : ! Interpolate once at q_source (this itself is a genuine off-grid interpolation if q_source
5658 : : ! is not on the coarse ab-initio mesh).
5659 : 0 : call dvdb%ftinterp_qpt(qpt_source, nfft, ngfft, v1r_source, dvdb%comm_rpt)
5660 : :
5661 : : ! Optionally dump v1r_target (independent re-interpolation at q_target) and v1r_predicted
5662 : : ! (rotated prediction from q_source) to a netcdf file for post-processing in python.
5663 : 0 : ncid = nctk_noid
5664 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5665 : 0 : write(std_out,"(a)")sjoin(" Will write target and predicted potentials to:", dump_path)
5666 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5667 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5668 : : ncerr = nctk_def_dims(ncid, [ &
5669 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5670 : : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nsym", dvdb%cryst%nsym), nctkdim_t("ntimrev", 2)], &
5671 [ # # ]: 0 : defmode=.True.)
5672 [ # # ]: 0 : NCF_CHECK(ncerr)
5673 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_source", "dp", "three")))
5674 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_target", "dp", "three, ntimrev, nsym")))
5675 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_target", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5676 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_predicted", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5677 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5678 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_source"), qpt_source))
5679 : : end if
5680 : :
5681 : 0 : g0q = 0
5682 [ # # ]: 0 : do isym=1,dvdb%cryst%nsym
5683 [ # # ]: 0 : do itimrev=1,2
5684 : 0 : tsign = 3 - 2*itimrev
5685 [ # # # # : 0 : qpt_target = tsign * matmul(dvdb%cryst%symrec(:,:,isym), qpt_source)
# # # # #
# # # ]
5686 : :
5687 : : ! Independent, direct interpolation at the target q (no symmetry involved at all).
5688 : 0 : call dvdb%ftinterp_qpt(qpt_target, nfft, ngfft, v1r_target, dvdb%comm_rpt)
5689 : :
5690 : : ! Predicted potential at q_target obtained by ROTATING the q_source interpolation
5691 : : ! with the exact same formula gstore_symmetrize/v1phq_rotate uses to expand IBZ->BZ.
5692 : : call v1phq_rotate(dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5693 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5694 : :
5695 [ # # ]: 0 : if (ncid /= nctk_noid) then
5696 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_target"), qpt_target, start=[1,itimrev,isym]))
# # ]
5697 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_target"), v1r_target, start=[1,1,1,1,itimrev,isym]))
# # ]
5698 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_predicted"), v1r_predicted, start=[1,1,1,1,itimrev,isym]))
# # ]
5699 : : end if
5700 : :
5701 [ # # ]: 0 : do mu=1,dvdb%natom3
5702 : 0 : iat = (mu - 1) / 3 + 1
5703 [ # # ]: 0 : do ispden=1,dvdb%nspden
5704 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5705 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5706 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5707 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5708 : : end do
5709 : : end do
5710 : :
5711 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK"
5712 : 0 : write(std_out,"(a,i0,a)")" isym: ", isym, ","
5713 : 0 : write(std_out,"(a,i0,a)")" itimrev: ", itimrev, ","
5714 [ # # ]: 0 : write(std_out,"(3a)")" qpt_target: ", trim(ktoa(qpt_target)), ","
5715 : 0 : call vd_max%print()
5716 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5717 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5718 : : end do
5719 : 0 : write(std_out,"(a)")"..."
5720 : : end do ! itimrev
5721 : : end do ! isym
5722 : :
5723 [ # # ]: 0 : ABI_FREE(v1r_source)
5724 [ # # ]: 0 : ABI_FREE(v1r_target)
5725 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5726 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5727 : :
5728 [ # # ]: 0 : if (ncid /= nctk_noid) then
5729 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5730 : : end if
5731 : :
5732 : 0 : call dvdb%free()
5733 : :
5734 [ # # # # : 0 : end subroutine dvdb_test_symcheck
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5735 : : !!***
5736 : :
5737 : : !----------------------------------------------------------------------
5738 : :
5739 : : !!****f* m_dvdb/dvdb_test_symcheck_native
5740 : : !! NAME
5741 : : !! dvdb_test_symcheck_native
5742 : : !!
5743 : : !! FUNCTION
5744 : : !! Debugging tool: like dvdb_test_symcheck but operates on TWO LITERAL, independently
5745 : : !! DFPT-computed q-points already present in the DVDB (no Fourier interpolation involved
5746 : : !! at all -- no ftinterp_setup/ftinterp_qpt call anywhere). Reads q_source and q_target
5747 : : !! directly via readsym_allv1, predicts q_target from q_source via v1phq_rotate, and
5748 : : !! compares against q_target's own literal data. Isolates v1phq_rotate/rotate_fqg
5749 : : !! completely from the W(R,r) real-space Fourier-interpolation machinery.
5750 : : !!
5751 : : !! INPUTS
5752 : : !! dvdb_filepath=Filename (must contain BOTH q_source and q_target as literal,
5753 : : !! fully-available (3*natom perturbations) q-points, e.g. produced with nsym 1).
5754 : : !! sym_dvdb_filepath=Filename of a DIFFERENT DVDB (or any file crystal_from_file can read) that
5755 : : !! carries the crystal's TRUE, full symmetry table (dvdb_filepath's own nsym is typically 1,
5756 : : !! since that's what forces every requested perturbation/q to be explicitly, independently
5757 : : !! computed in the first place -- so its own %cryst cannot be used to look up isym > 1).
5758 : : !! qpt_source(3), qpt_target(3)=The two q-points (reduced coordinates), assumed related by
5759 : : !! the given isym/itimrev/g0q.
5760 : : !! isym, itimrev, g0q(3)=Symmetry indices such that qpt_target = I(itimrev) S(isym) qpt_source + g0q.
5761 : : !! comm=MPI communicator.
5762 : : !!
5763 : : !! OUTPUT
5764 : : !! Only writing.
5765 : : !!
5766 : : !! SOURCE
5767 : :
5768 : 0 : subroutine dvdb_test_symcheck_native(dvdb_filepath, sym_dvdb_filepath, qpt_source, qpt_target, &
5769 : : isym, itimrev, g0q, comm)
5770 : :
5771 : : !Arguments ------------------------------------
5772 : : character(len=*),intent(in) :: dvdb_filepath, sym_dvdb_filepath
5773 : : integer,intent(in) :: comm, isym, itimrev
5774 : : integer,intent(in) :: g0q(3)
5775 : : real(dp),intent(in) :: qpt_source(3), qpt_target(3)
5776 : :
5777 : : !Local variables-------------------------------
5778 : : !scalars
5779 : : integer,parameter :: gpu_option0 = 0, cplex2 = 2
5780 : : integer :: nfft, mu, ispden, iq_source, iq_target, iat
5781 [ # # # # : 0 : type(dvdb_t) :: dvdb, sym_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5782 : : type(vdiff_t) :: vd_max, vd
5783 : : !arrays
5784 : : integer :: ngfft(18)
5785 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5786 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5787 : : ! *************************************************************************
5788 : :
5789 : 0 : write(std_out,"(2a)")" Testing v1phq_rotate against TWO LITERAL, non-interpolated q-points", ch10
5790 [ # # ]: 0 : write(std_out,"(2a)")" q_source: ", trim(ktoa(qpt_source))
5791 [ # # ]: 0 : write(std_out,"(2a)")" q_target: ", trim(ktoa(qpt_target))
5792 : :
5793 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5794 : 0 : dvdb%debug = .False.
5795 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5796 : :
5797 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5798 [ # # ]: 0 : nfft = product(ngfft(1:3))
5799 : 0 : call dvdb%open_read(ngfft, comm)
5800 : :
5801 : : ! Load a SEPARATE dvdb just to get the crystal's true, full symmetry table (dvdb_filepath's
5802 : : ! own %cryst normally has nsym=1, see docstring above).
5803 : 0 : call sym_dvdb%init(sym_dvdb_filepath, gpu_option0, comm)
5804 : 0 : write(std_out,"(a,i0,a,i0)")" sym_dvdb nsym: ", sym_dvdb%cryst%nsym, " dvdb (literal) nsym: ", dvdb%cryst%nsym
5805 : :
5806 : 0 : iq_source = dvdb%findq(qpt_source)
5807 : 0 : iq_target = dvdb%findq(qpt_target)
5808 [ # # ]: 0 : ABI_CHECK(iq_source /= -1, "qpt_source not found in DVDB!")
5809 [ # # ]: 0 : ABI_CHECK(iq_target /= -1, "qpt_target not found in DVDB!")
5810 : :
5811 : 0 : call dvdb%readsym_allv1(iq_source, mu, nfft, ngfft, v1r_source, comm) ! mu reused as cplex out-arg
5812 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_source")
5813 : 0 : call dvdb%readsym_allv1(iq_target, mu, nfft, ngfft, v1r_target, comm)
5814 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_target")
5815 : :
5816 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5817 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5818 : :
5819 : : call v1phq_rotate(sym_dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5820 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5821 : :
5822 : 0 : call sym_dvdb%free()
5823 : :
5824 [ # # ]: 0 : do mu=1,dvdb%natom3
5825 : 0 : iat = (mu - 1) / 3 + 1
5826 [ # # ]: 0 : do ispden=1,dvdb%nspden
5827 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5828 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5829 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5830 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5831 : : end do
5832 : : end do
5833 : :
5834 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK_NATIVE"
5835 : 0 : call vd_max%print()
5836 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5837 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5838 : : end do
5839 : 0 : write(std_out,"(a)")"..."
5840 : :
5841 [ # # ]: 0 : ABI_FREE(v1r_source)
5842 [ # # ]: 0 : ABI_FREE(v1r_target)
5843 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5844 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5845 : :
5846 : 0 : call dvdb%free()
5847 : :
5848 [ # # # # : 0 : end subroutine dvdb_test_symcheck_native
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5849 : : !!***
5850 : :
5851 : : !----------------------------------------------------------------------
5852 : :
5853 : : !!****f* m_dvdb/dvdb_get_v1r_long_range
5854 : : !! NAME
5855 : : !! dvdb_get_v1r_long_range
5856 : : !!
5857 : : !! FUNCTION
5858 : : !! Compute the long-range part of the phonon potential
5859 : : !! due to the Born effective charges, PRL 115, 176401 (2015) [[cite:Verdi2015]].
5860 : : !!
5861 : : !! V^L_{iatom,idir}(r) = i (4pi/vol) sum_G (q+G) . Zeff_{iatom,idir}
5862 : : !! e^{i (q+G).(r - tau_{iatom})} / ((q+G) . dielt . (q+G))
5863 : : !!
5864 : : !! where Zeff and dielt are the Born effective charge tensor and the dielectric tensor in cart coords,
5865 : : !! tau is the atom position, and vol is the volume of the unit cell.
5866 : : !! Note that internally the tensors are stored in Cartesian coordinates while in output we need
5867 : : !! the contribution due to the displacement of the iatom-sublattice along the reduced direction idir
5868 : : !! hence we need to perform some tensor gymnastics to go from Cart to reduced.
5869 : : !!
5870 : : !! INPUTS
5871 : : !! db = the DVDB object.
5872 : : !! qpt = the q-point in reduced coordinates.
5873 : : !! idir = direction index.
5874 : : !! iatom = atom index.
5875 : : !! nfft = number of fft points.
5876 : : !! ngfft(18) = FFT mesh.
5877 : : !! [add_qphase]=By default, the routine returns the LR potential with the e^{iqr} phase.
5878 : : !! Use add_qphase = 0 to get the lattice-periodic part.
5879 : : !!
5880 : : !! OUTPUT
5881 : : !! v1r_lr = dipole potential
5882 : : !!
5883 : : !! SOURCE
5884 : :
5885 : 22234 : subroutine dvdb_get_v1r_long_range(db, qpt, idir, iatom, nfft, ngfft, v1r_lr, add_qphase)
5886 : :
5887 : : !Arguments ------------------------------------
5888 : : !scalars
5889 : : class(dvdb_t),intent(in) :: db
5890 : : integer,intent(in) :: idir, iatom, nfft
5891 : : integer,optional,intent(in) :: add_qphase
5892 : : !arrays
5893 : : integer,intent(in) :: ngfft(18)
5894 : : real(dp),intent(in) :: qpt(3)
5895 : : real(dp),intent(out) :: v1r_lr(2,nfft)
5896 : :
5897 : : !Local variables-------------------------------
5898 : : !scalars
5899 : : integer :: n1, n2, n3, nfftot, ig, iphase, ii, jj, kk, ll, mm, ifft, ispden
5900 : : real(dp) :: fac, qGZ, qGS, denom, denom_inv, qtau, re, im, phre, phim, qg_mod, gsq_max
5901 : : real(dp),parameter :: tol_denom = tol8
5902 : : !arrays
5903 : 22234 : integer, allocatable :: gfft(:,:)
5904 : : real(dp) :: gprimd(3,3), rprimd(3,3), dielt_red(3,3)
5905 : : real(dp) :: qG_red(3), qG_cart(3), Zstar(3), Sstar(3,3), tau_red(3)
5906 : 22234 : real(dp), allocatable :: v1G_lr(:,:), v1G_lr33(:,:,:,:), workr(:,:)
5907 : : ! *************************************************************************
5908 : :
5909 : : ! Return immediately if metals by
5910 : : !if (db%has_zeff .or. db%has_quadrupoles) then
5911 : :
5912 [ + + ]: 22234 : iphase = 1; if (present(add_qphase)) iphase = add_qphase
5913 : :
5914 : : ! Make sure FFT parallelism is not used
5915 [ + + ]: 88936 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
5916 [ - + ]: 22234 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
5917 : :
5918 : : ! Allocate memory
5919 [ - + + - : 66702 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5920 [ - + + - : 66702 : ABI_MALLOC(v1G_lr, (2, nfft))
+ - + - -
+ - + ]
5921 : :
5922 : : ! Reciprocal and real space primitive vectors
5923 [ + + + + : 555850 : gprimd = db%cryst%gprimd; rprimd = db%cryst%rprimd
+ + + + ]
5924 : :
5925 : : ! Prefactor
5926 : 22234 : fac = four_pi / db%cryst%ucvol
5927 : :
5928 : : ! Transform the Born effective charge tensor from Cartesian to reduced coordinates
5929 : : ! and select the relevant direction.
5930 [ + - + - : 689254 : Zstar = matmul(transpose(gprimd), matmul(db%zeff(:,:,iatom), rprimd(:,idir))) * two_pi
+ - - + -
+ + + + +
+ + + - +
- + - +
+ ]
5931 : :
5932 [ - + ]: 22234 : if (db%has_quadrupoles) then
5933 : : ! Transform Qstar from Cartesian to reduced coordinates and select the relevant direction.
5934 : 0 : Sstar = zero
5935 [ # # ]: 0 : do ii=1,3
5936 [ # # ]: 0 : do jj=1,3
5937 [ # # ]: 0 : do kk=1,3
5938 [ # # ]: 0 : do ll=1,3
5939 [ # # ]: 0 : do mm=1,3
5940 : : Sstar(ii,jj) = Sstar(ii,jj) + &
5941 : 0 : gprimd(mm,jj) * gprimd(ll,ii) * db%qstar(mm,ll,kk,iatom) * rprimd(kk,idir) * two_pi ** 2
5942 : : end do
5943 : : end do
5944 : : end do
5945 : : end do
5946 : : end do
5947 : : end if
5948 : :
5949 : : ! Transform the dielectric tensor from Cartesian to reduced coordinates.
5950 : : ! q_cart e_cart q_cart = q_red (G^t e_cart G) q_red
5951 [ + + + + : 2023294 : dielt_red = matmul(transpose(gprimd), matmul(db%dielt, gprimd)) * two_pi ** 2
+ + + + +
+ + + + +
+ + ]
5952 : :
5953 : : ! Atom position
5954 [ + + ]: 88936 : tau_red = db%cryst%xred(:,iatom)
5955 : :
5956 : : ! Get the set of G vectors
5957 : : ! TODO: May use zero-padded FFT with small G-sphere
5958 : 22234 : call get_gfft(ngfft, qpt, db%cryst%gmet, gsq_max, gfft)
5959 : :
5960 : : ! Compute the long-range potential in G-space due to Z* and Q* (if present)
5961 [ + + + + ]: 336598582 : v1G_lr = zero
5962 [ - + - - ]: 22234 : if (db%has_zeff .or. db%has_quadrupoles) then
5963 : :
5964 [ + + ]: 112214350 : do ig=1,nfft
5965 : : ! (q + G)
5966 [ + + ]: 448768464 : qG_red = qpt + gfft(:,ig)
5967 [ + + + + : 1795073856 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
+ + ]
5968 [ + + ]: 448768464 : qG_mod = sqrt(sum(qG_cart ** 2))
5969 : : ! (q + G) . Zeff(:,idir,iatom)
5970 [ + + ]: 448768464 : qGZ = dot_product(qG_red, Zstar)
5971 : : ! (q + G) . dielt . (q + G)
5972 [ + + + + : 1795073856 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
+ + ]
5973 : : ! Avoid (q + G) = 0
5974 [ + + ]: 112192116 : if (denom < tol_denom) cycle
5975 : 112191608 : denom_inv = one / denom
5976 : : ! HM hard cutoff, in this case qdamp takes the meaning of an energy cutoff in Hartree (hardcoded to 1 for the moment)
5977 : : !if (half*qG_mod**2 > 1) cycle
5978 [ + - ]: 112191608 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
5979 : 112191608 : qGS = zero
5980 [ - + ]: 112191608 : if (db%has_quadrupoles) then
5981 [ # # ]: 0 : do ii=1,3
5982 [ # # ]: 0 : do jj=1,3
5983 : 0 : qGS = qGS + qG_red(ii) * qG_red(jj) * Sstar(ii,jj) / two
5984 : : end do
5985 : : end do
5986 : : end if
5987 : :
5988 : : ! Phase factor exp(-i (q+G) . tau)
5989 [ + + ]: 448766432 : qtau = - two_pi * dot_product(qG_red, tau_red)
5990 : 112191608 : phre = cos(qtau); phim = sin(qtau)
5991 : : !phre = one; phim = zero
5992 : :
5993 : 112191608 : re = +fac * qGS * denom_inv !re = zero
5994 : 112191608 : im = fac * qGZ * denom_inv
5995 : 112191608 : v1G_lr(1,ig) = phre * re - phim * im
5996 : 112213842 : v1G_lr(2,ig) = phim * re + phre * im
5997 : : end do
5998 : : end if
5999 : :
6000 : : ! FFT to get the long-range potential in r-space
6001 : 22234 : call fourdp(2, v1G_lr, v1r_lr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6002 : :
6003 [ - + ]: 22234 : if (db%has_efield) then
6004 : : ! Add term due to Electric field.
6005 : : ! TODO: Change API to account for ispden/isppol. return nspden LR part
6006 : : ! although only the electric field part depends on nsppden.
6007 : : !v1r_lr = zero ! Comment this line to have only efield contribution
6008 [ # # ]: 0 : ABI_CHECK(db%nspden == 1, "nspden != 1 not coded")
6009 : 0 : ispden = 1
6010 [ # # # # : 0 : ABI_CALLOC(v1G_lr33, (3, 3, 2, nfft))
# # # # #
# # # # #
# # # # #
# ]
6011 [ # # ]: 0 : do ig=1,nfft
6012 : : !if (ig > 1) cycle
6013 : : ! (q + G)
6014 [ # # ]: 0 : qG_red = qpt + gfft(:,ig)
6015 [ # # # # : 0 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
# # ]
6016 [ # # ]: 0 : qG_mod = sqrt(sum(qG_cart ** 2))
6017 : : ! (q + G) . Zeff(:,idir,iatom)
6018 : : !qGZ = dot_product(qG_red, Zstar)
6019 : : ! (q + G) . dielt . (q + G)
6020 [ # # # # : 0 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
# # ]
6021 : : ! Avoid (q + G) = 0
6022 [ # # ]: 0 : if (denom < tol_denom) cycle
6023 : 0 : denom_inv = one / denom
6024 [ # # ]: 0 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6025 : 0 : fac = (four_pi / db%cryst%ucvol) * denom_inv !* qGZ
6026 : : ! Phase factor exp(-i (q+G) . tau)
6027 [ # # ]: 0 : qtau = - two_pi * dot_product(qG_red, tau_red)
6028 : 0 : phre = cos(qtau); phim = sin(qtau)
6029 : : !phre = one; phim = zero
6030 : :
6031 [ # # ]: 0 : do ii=1,3
6032 [ # # ]: 0 : do jj=1,3
6033 : 0 : v1G_lr33(ii, jj, 1, ig) = fac * phre * qG_red(ii) * qG_red(jj)
6034 : 0 : v1G_lr33(ii, jj, 2, ig) = fac * phim * qG_red(ii) * qG_red(jj)
6035 : : end do
6036 : : end do
6037 : : end do ! ig
6038 : :
6039 [ # # # # : 0 : ABI_MALLOC(workr, (2, nfft))
# # # # ]
6040 [ # # ]: 0 : do ii=1,3
6041 [ # # ]: 0 : do jj=1,3
6042 [ # # # # : 0 : v1G_lr = v1G_lr33(ii, jj, :, :)
# # ]
6043 : 0 : call fourdp(2, v1G_lr, workr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6044 : : ! Two pi comes for qpt but we should check whether the gradient wrt E-field is in gprimd or 2pi gprimd coordinates.
6045 : : ! MG: Remove two_pi factor because jump discontinuity in the real part for G != 0 are overestimated.
6046 [ # # ]: 0 : do ifft=1,nfft
6047 : : !v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) * two_pi
6048 [ # # ]: 0 : v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) ! * two_pi
6049 : : end do
6050 : : end do
6051 : : end do
6052 : :
6053 [ # # ]: 0 : ABI_FREE(workr)
6054 [ # # ]: 0 : ABI_FREE(v1G_lr33)
6055 : : end if
6056 : :
6057 : : ! Multiply by exp(i q.r)
6058 [ + + ]: 22234 : if (iphase == 1) call times_eikr(qpt, ngfft, nfft, 1, v1r_lr)
6059 : :
6060 [ - + ]: 22234 : ABI_FREE(gfft)
6061 [ - + ]: 22234 : ABI_FREE(v1G_lr)
6062 : :
6063 : 22234 : end subroutine dvdb_get_v1r_long_range
6064 : : !!***
6065 : :
6066 : : !----------------------------------------------------------------------
6067 : :
6068 : : !!****f* m_dvdb/dvdb_load_ddb
6069 : : !! NAME
6070 : : !! dvdb_load_ddb
6071 : : !!
6072 : : !! FUNCTION
6073 : : !! Load information about the Born effective charges and dielectric tensor from a DDB file
6074 : : !!
6075 : : !! TODO
6076 : : !! Use this function in eph driver
6077 : :
6078 : 0 : subroutine dvdb_load_ddb(dvdb, chneut, prtvol, comm, ddb_filepath, ddb)
6079 : :
6080 : : !Arguments ------------------------------------
6081 : : !scalars
6082 : : class(dvdb_t),intent(inout) :: dvdb
6083 : : integer,intent(in) :: chneut, prtvol, comm
6084 : : character(len=*),optional,intent(in) :: ddb_filepath
6085 : : type(ddb_type),optional,target,intent(in) :: ddb
6086 : :
6087 : : !Local variables ------------------------------
6088 : : integer,parameter :: master = 0, rfmeth1 = 1, selectz0 = 0
6089 : : integer :: my_rank, iblock_dielt, iblock_dielt_zeff, iblock_quadrupoles
6090 : : logical :: free_ddb
6091 [ # # # # : 0 : type(crystal_t) :: cryst_ddb
# # # # #
# # # # #
# # # # ]
6092 : : type(ddb_type),pointer :: ddb_ptr
6093 : 0 : type(ddb_type),target :: this_ddb
6094 [ # # # # : 0 : type(ddb_hdr_type) :: ddb_hdr
# # # # #
# # # # #
# # # # ]
6095 : : !arrays
6096 : : real(dp) :: dielt(3,3)
6097 : 0 : real(dp),allocatable :: zeff(:,:,:), zeff_raw(:,:,:)
6098 : : ! *************************************************************************
6099 : :
6100 : 0 : my_rank = xmpi_comm_rank(comm)
6101 : :
6102 [ # # ]: 0 : if (present(ddb_filepath)) then
6103 : : ! Build ddb object from file. Will release memory before returning.
6104 [ # # ]: 0 : ABI_CHECK(.not. present(ddb), "ddb argument cannot be present when ddb_filepath is used")
6105 : 0 : call this_ddb%from_file(ddb_filepath, ddb_hdr, cryst_ddb, comm, prtvol=prtvol)
6106 : 0 : call this_ddb%set_brav(dvdb%brav)
6107 : 0 : call cryst_ddb%free()
6108 : 0 : ddb_ptr => this_ddb
6109 : 0 : free_ddb = .True.
6110 : : else
6111 : : ! Point input ddb, won't release memory.
6112 : : free_ddb = .False.
6113 : : ddb_ptr => ddb
6114 : : end if
6115 : :
6116 : : ! Get dielectric Tensor
6117 : 0 : iblock_dielt = ddb_ptr%get_dielt(rfmeth1, dielt)
6118 [ # # # # ]: 0 : dvdb%dielt = dielt
6119 : :
6120 : : ! Get Dielectric Tensor and Effective Charges
6121 : : ! (initialized to one_3D and zero if the derivatives are not available in the DDB file)
6122 [ # # # # : 0 : ABI_MALLOC(zeff, (3, 3, dvdb%natom))
# # # # #
# # # ]
6123 [ # # # # : 0 : ABI_MALLOC(zeff_raw, (3, 3, dvdb%natom))
# # # # ]
6124 : 0 : iblock_dielt_zeff = ddb_ptr%get_dielt_zeff(dvdb%cryst, rfmeth1, chneut, selectz0, dielt, zeff, zeff_raw=zeff_raw)
6125 : :
6126 [ # # ]: 0 : if (my_rank == master) then
6127 [ # # ]: 0 : if (iblock_dielt_zeff == 0) then
6128 : 0 : call wrtout(ab_out, sjoin("- Cannot find dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6129 : 0 : call wrtout(ab_out, "Values initialized with zeros")
6130 : : else
6131 : 0 : call wrtout(ab_out, sjoin("- Found dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6132 : : end if
6133 : : end if
6134 : :
6135 [ # # ]: 0 : if (iblock_dielt /= 0) then
6136 : 0 : dvdb%has_dielt = .True.
6137 [ # # # # ]: 0 : dvdb%dielt = dielt
6138 : : end if
6139 [ # # ]: 0 : if (iblock_dielt_zeff /= 0) then
6140 [ # # # # : 0 : dvdb%has_zeff = .True.; dvdb%zeff = zeff; dvdb%zeff_raw = zeff_raw
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6141 : : end if
6142 [ # # # # : 0 : if (dvdb%has_dielt .and. (dvdb%has_zeff .or. dvdb%has_quadrupoles)) then
# # ]
6143 [ # # ]: 0 : if (dvdb%add_lr == 0) then
6144 : : call wrtout([std_out, ab_out], &
6145 [ # # ]: 0 : " WARNING: dvdb_add_lr set to 0. Long-range term won't be subtracted in Fourier interpolation.")
6146 : : end if
6147 : : end if
6148 : :
6149 : : ! Read the quadrupoles
6150 : 0 : iblock_quadrupoles = ddb_ptr%get_quadrupoles(ddb_hdr%ddb_version,1,BLKTYP_d3E_xx,dvdb%qstar)
6151 [ # # ]: 0 : if (iblock_quadrupoles /=0) dvdb%has_quadrupoles = .True.
6152 : :
6153 [ # # ]: 0 : if (present(ddb_filepath)) call ddb_hdr%free()
6154 : :
6155 [ # # ]: 0 : ABI_FREE(zeff)
6156 [ # # ]: 0 : ABI_FREE(zeff_raw)
6157 [ # # ]: 0 : if (free_ddb) call ddb_ptr%free()
6158 : :
6159 [ # # # # : 0 : end subroutine dvdb_load_ddb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6160 : : !!***
6161 : :
6162 : : !!****f* m_dvdb/dvdb_load_efield
6163 : : !! NAME
6164 : : !! dvdb_load_efield
6165 : : !!
6166 : : !! FUNCTION
6167 : : !! Load first order derivatives wrt the electric file from files
6168 : : !!
6169 : : !! INPUTS
6170 : : !! pot_paths=List of strings with paths to POT1 files.
6171 : : !! comm=MPI communicator.
6172 : :
6173 : 0 : subroutine dvdb_load_efield(dvdb, pot_paths, comm)
6174 : :
6175 : : !Arguments ------------------------------------
6176 : : !scalars
6177 : : class(dvdb_t),intent(inout) :: dvdb
6178 : : integer,intent(in) :: comm
6179 : : character(len=*),intent(in) :: pot_paths(3)
6180 : :
6181 : : !Local variables-------------------------------
6182 : : !scalars
6183 : : integer,parameter :: pawread0 = 0, cplex1 = 1
6184 : : integer :: ii, idir, ipert, nfft
6185 : 0 : type(hdr_type) :: hdr
6186 : : !arrays
6187 : 0 : real(dp),allocatable :: v1e_red(:,:,:)
6188 : 0 : type(pawrhoij_type),allocatable :: pawrhoij(:)
6189 : : ! *************************************************************************
6190 : :
6191 [ # # # # : 0 : ABI_CHECK(all(dvdb%ngfft /= -1), "dbvd%ngfft must be defined!")
# # ]
6192 : :
6193 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6194 [ # # # # : 0 : ABI_CALLOC(v1e_red, (nfft, dvdb%nspden, 3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
6195 : :
6196 [ # # ]: 0 : do ii=1,3
6197 : : ! Read DFPT potentials due to E-field.
6198 : : ! TODO: Should implement symmetries so that only the irred pots are needed.
6199 : 0 : call wrtout(std_out, sjoin("Loading Efield DFPT potential from:", pot_paths(ii)))
6200 : : call read_rhor(pot_paths(ii), cplex1, dvdb%nspden, nfft, dvdb%ngfft, pawread0, &
6201 : 0 : dvdb%mpi_enreg, v1e_red(:,:,ii), hdr, pawrhoij, comm, allow_interp=.True., want_varname="first_order_potential")
6202 : :
6203 : : ! Consistency check: expecting E-field perturbation.
6204 : 0 : idir = mod(hdr%pertcase - 1, 3) + 1; ipert = (hdr%pertcase - idir) / 3 + 1
6205 [ # # # # : 0 : ABI_CHECK(all(abs(hdr%qptn) < tol12), sjoin("Expecting Gamma point in E-field pert, got qpt:", ktoa(hdr%qptn)))
# # ]
6206 [ # # ]: 0 : ABI_CHECK(ipert == hdr%natom + 2, sjoin("Expecting E-field perturbation, got ipert:", itoa(ipert)))
6207 [ # # ]: 0 : ABI_CHECK(idir == ii, sjoin("Expecting E-field perturbation along idir:", itoa(ii), " got idir:", itoa(idir)))
6208 : 0 : call hdr%free()
6209 : : end do
6210 : :
6211 : : ! Transfer data.
6212 [ # # # # : 0 : ABI_MALLOC(dvdb%v1r_efield, (nfft, 3, dvdb%nspden))
# # # # #
# # # # #
# # # # ]
6213 [ # # ]: 0 : do ii=1,3
6214 [ # # # # ]: 0 : dvdb%v1r_efield(:,ii,:) = v1e_red(:,:,ii)
6215 : : end do
6216 [ # # ]: 0 : ABI_FREE(v1e_red)
6217 : :
6218 : 0 : dvdb%has_efield = .True.
6219 : :
6220 [ # # # # : 0 : end subroutine dvdb_load_efield
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6221 : : !!***
6222 : :
6223 : : !----------------------------------------------------------------------
6224 : :
6225 : : !!****f* m_dvdb/dvdb_interpolate_and_write
6226 : : !! NAME
6227 : : !! dvdb_interpolate_and_write
6228 : : !!
6229 : : !! FUNCTION
6230 : : !! Interpolate the phonon potential onto a fine q-point grid
6231 : : !! and write the data in a new DVDB file.
6232 : : !!
6233 : : !! INPUTS
6234 : : !!
6235 : : !! OUTPUT
6236 : : !!
6237 : : !! SOURCE
6238 : :
6239 : 8 : subroutine dvdb_interpolate_and_write(dvdb, dtset, new_dvdb_fname, ngfft, ngfftf, cryst, &
6240 [ - + - - : 8 : ngqpt_coarse, nqshift_coarse, qshift_coarse, comm, custom_qpt)
- - ]
6241 : :
6242 : : !Arguments ------------------------------------
6243 : : !scalars
6244 : : integer,intent(in) :: nqshift_coarse, comm
6245 : : character(len=*),intent(in) :: new_dvdb_fname
6246 : : type(crystal_t),intent(in) :: cryst
6247 : : class(dvdb_t),intent(inout) :: dvdb
6248 : : type(dataset_type),intent(in) :: dtset
6249 : : !arrays
6250 : : integer,intent(in) :: ngfft(18), ngfftf(18)
6251 : : integer,intent(in) :: ngqpt_coarse(3)
6252 : : real(dp),intent(in) :: qshift_coarse(3,nqshift_coarse)
6253 : : real(dp),optional,intent(in) :: custom_qpt(:,:)
6254 : :
6255 : : !Local variables ------------------------------
6256 : : !scalars
6257 : : integer,parameter :: master=0, fform_pot=111
6258 : : integer :: my_rank,nproc,idir,ipert,iat,ipc,ispden, ierr
6259 : : integer :: cplex,db_iqpt,natom,natom3,npc,trev_q,nspden
6260 : : integer :: nqbz, nqibz, iq, ifft, nqbz_coarse
6261 : : integer :: nperts_read, nperts_interpolate, nperts
6262 : : integer :: nqpt_read, nqpt_interpolate, qptopt
6263 : : integer :: nfft,nfftf, dimv1, ount, unt, fform, ncid, ncerr
6264 : : logical :: use_netcdf
6265 : : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
6266 : : character(len=500) :: msg
6267 : : character(len=fnlen) :: tmp_fname
6268 : 8 : type(hdr_type) :: hdr_ref
6269 : : !arrays
6270 : 16 : integer :: qptrlatt(3,3), rfdir(3), symq(4,2,cryst%nsym)
6271 : 8 : integer,allocatable :: pinfo(:,:),rfpert(:),pertsy(:,:,:),iq_read(:),this_pertsy(:,:)
6272 : : real(dp) :: qpt(3), rhog1_g0(2)
6273 : 8 : real(dp),allocatable :: v1scf(:,:,:), v1scf_rpt(:,:,:,:),v1(:)
6274 : 8 : real(dp),allocatable :: wtq(:),qibz(:,:),qbz(:,:),q_interp(:,:),q_read(:,:)
6275 : : !************************************************************************
6276 : :
6277 : 8 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6278 : :
6279 : 8 : write(msg, '(2a)') " Interpolation of the electron-phonon coupling potential", ch10
6280 : 8 : call wrtout(ab_out, msg, do_flush=.True.); call wrtout(std_out, msg, do_flush=.True.)
6281 : :
6282 : 8 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6283 : :
6284 [ + + - + ]: 8 : if (dtset%eph_task == 5 .or. present(custom_qpt)) then
6285 [ + - ]: 7 : msg = sjoin(" From coarse q-mesh:", ltoa(ngqpt_coarse), "to:", ltoa(dtset%eph_ngqpt_fine))
6286 [ + + ]: 21 : call wrtout([std_out, ab_out], msg)
6287 : : ! Setup fine q-point grid in the IBZ
6288 : : ! Generate the list of irreducible q-points in the grid
6289 : 7 : qptrlatt = 0
6290 : 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)
6291 [ + + ]: 7 : qptopt = 1; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
6292 : 7 : call wrtout(std_out, sjoin(" Generating q-IBZ for DVDB with qptopt:", itoa(qptopt)))
6293 [ - + - + : 7 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
- + ]
6294 : :
6295 [ + - ]: 1 : else if (dtset%eph_task == -5) then
6296 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
6297 [ + + ]: 3 : call wrtout([std_out, ab_out], msg)
6298 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "ph_nqpath must be specified when eph_task == -5")
6299 : 1 : nqibz = dtset%ph_nqpath
6300 [ - + + - : 3 : ABI_MALLOC(qibz, (3, nqibz))
+ - + - -
+ - + -
+ ]
6301 [ + - - + : 22 : qibz = dtset%ph_qpath(:, 1:nqibz)
- - + + +
+ ]
6302 [ - + + - : 8 : ABI_CALLOC(wtq, (nqibz))
+ - + - -
+ - + - +
+ + ]
6303 : 1 : nqbz = nqibz
6304 [ - + + - : 2 : ABI_MALLOC(qbz, (3, nqbz))
- + - + -
+ ]
6305 [ + - + - : 22 : qbz = qibz
- + - - +
+ + + ]
6306 : :
6307 : : else
6308 : 0 : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
6309 : : end if
6310 : :
6311 [ - + ]: 8 : if (present(custom_qpt)) then
6312 [ # # ]: 0 : ABI_SFREE(qibz)
6313 [ # # ]: 0 : ABI_SFREE(wtq)
6314 [ # # ]: 0 : ABI_SFREE(qbz)
6315 : 0 : nqibz = size(custom_qpt,dim=2)
6316 [ # # # # : 0 : ABI_MALLOC(qibz, (3, nqibz))
# # # # #
# # # #
# ]
6317 [ # # # # : 0 : qibz = custom_qpt
# # # # #
# # # ]
6318 [ # # # # : 0 : ABI_CALLOC(wtq, (nqibz))
# # # # #
# # # # #
# # ]
6319 : 0 : nqbz = nqibz
6320 [ # # # # : 0 : ABI_MALLOC(qbz, (3, nqbz))
# # # # #
# ]
6321 [ # # # # : 0 : qbz = qibz
# # # # #
# # # ]
6322 : : end if
6323 : :
6324 [ + + ]: 32 : nfft = product(ngfft(1:3)); nfftf = product(ngfftf(1:3))
6325 : :
6326 : : ! check that ngqpt_coarse is in DVDB.
6327 [ + + ]: 32 : nqbz_coarse = product(ngqpt_coarse) * nqshift_coarse
6328 : :
6329 : : ! ==========================================
6330 : : ! Prepare the header to write the potentials
6331 : : ! ==========================================
6332 : :
6333 : : ! Read the first header
6334 [ + - ]: 8 : if (my_rank == master) then
6335 [ - + ]: 8 : if (open_file(dvdb%path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
6336 : 0 : ABI_ERROR(msg)
6337 : : end if
6338 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%version
6339 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%numv1
6340 : :
6341 : 8 : call hdr_ref%fort_read(unt, fform)
6342 [ - + ]: 8 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
6343 : 0 : ABI_ERROR(sjoin("While reading:", dvdb%path, ch10, msg))
6344 : : end if
6345 : 8 : close(unt)
6346 : : end if
6347 : :
6348 : : ! Reset the symmetries of the header
6349 : : ! One might have disable the symmetries in the response function calculation
6350 : : ! that produced the initial set of potentials present in the DVDB.
6351 : : ! This is because the symmetry features are not used in all parts
6352 : : ! of the response function driver.
6353 : : !write(std_out,*)hdr_ref%nsym, cryst%nsym
6354 : : !ABI_CHECK(hdr_ref%nsym == cryst%nsym, "Diff nsym")
6355 [ + - ]: 8 : ABI_SFREE(hdr_ref%symrel)
6356 [ + - ]: 8 : ABI_SFREE(hdr_ref%tnons)
6357 [ + - ]: 8 : ABI_SFREE(hdr_ref%symafm)
6358 : 8 : hdr_ref%nsym = cryst%nsym
6359 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symrel, (3,3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6360 [ - + + - : 24 : ABI_MALLOC(hdr_ref%tnons, (3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6361 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symafm, (hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6362 : :
6363 [ + + + + : 5000 : hdr_ref%symrel(:,:,:) = cryst%symrel(:,:,:)
+ + ]
6364 [ + + + + ]: 1544 : hdr_ref%tnons(:,:) = cryst%tnons(:,:)
6365 [ + + ]: 392 : hdr_ref%symafm(:) = cryst%symafm(:)
6366 [ + + ]: 32 : hdr_ref%ngfft = ngfftf(1:3)
6367 : :
6368 : : ! =======================================
6369 : : ! Open DVDB and copy important dimensions
6370 : : ! =======================================
6371 : :
6372 : 8 : call dvdb%open_read(ngfftf, xmpi_comm_self)
6373 : :
6374 : : ! Besides perturbations with same q-points won't be contiguous on file --> IO is gonna be inefficient.
6375 [ + + ]: 16 : call dvdb%print([std_out], "", dtset%prtvol)
6376 : :
6377 : 8 : natom = cryst%natom
6378 : 8 : natom3 = 3 * natom
6379 : 8 : nspden = dvdb%nspden
6380 : :
6381 : : ! ==================================================
6382 : : ! Sort the q-points to read and those to interpolate
6383 : : ! and find the irreducible perturbations
6384 : : ! ==================================================
6385 [ - + + - : 24 : ABI_MALLOC(iq_read, (nqibz))
+ - + - -
+ - + ]
6386 [ - + + - : 24 : ABI_MALLOC(q_read, (3,nqibz))
+ - + - -
+ - + ]
6387 [ - + + - : 16 : ABI_MALLOC(q_interp, (3,nqibz))
- + - + ]
6388 [ - + + - : 32 : ABI_MALLOC(pertsy, (nqibz,3,dvdb%mpert))
- + + - +
- + - - +
- + ]
6389 [ - + + - : 24 : ABI_MALLOC(this_pertsy, (3,dvdb%mpert))
+ - + - -
+ - + ]
6390 [ - + + - : 24 : ABI_MALLOC(rfpert, (dvdb%mpert))
+ - + - -
+ - + ]
6391 [ + - - + : 24 : ABI_MALLOC(pinfo, (3,3*dvdb%mpert))
+ - + - +
- - + -
+ ]
6392 [ + + + + : 110 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
6393 : :
6394 [ + + + + : 2645 : pertsy = 0
+ + ]
6395 : 8 : nqpt_read = 0
6396 : 8 : nperts_read = 0
6397 : 8 : nqpt_interpolate = 0
6398 : 8 : nperts_interpolate = 0
6399 : :
6400 [ + + ]: 111 : do iq=1,nqibz
6401 [ + + ]: 412 : qpt = qibz(:,iq)
6402 : :
6403 : : ! Find the index of the q-point in the DVDB.
6404 : 103 : db_iqpt = dvdb%findq(qpt)
6405 : : !if (db_iqpt /= 1) db_iqpt = -1
6406 : :
6407 [ + + ]: 111 : if (db_iqpt /= -1) then
6408 [ + + ]: 29 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt)," found in DVDB with index ",itoa(db_iqpt)))
6409 : 29 : nqpt_read = nqpt_read + 1
6410 [ + + ]: 116 : q_read(:,nqpt_read) = qpt(:)
6411 : 29 : iq_read(nqpt_read) = db_iqpt
6412 : :
6413 : : ! Count the perturbations
6414 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6415 [ + + ]: 85 : do ipc=1,npc
6416 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6417 [ + - ]: 85 : if (iat .le. natom) nperts_read = nperts_read + 1
6418 : : end do
6419 : :
6420 : : else
6421 [ + + ]: 74 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt), "not found in DVDB. Will interpolate."))
6422 : 74 : nqpt_interpolate = nqpt_interpolate + 1
6423 [ + + ]: 296 : q_interp(:,nqpt_interpolate) = qpt(:)
6424 : :
6425 : : ! Examine the symmetries of the q wavevector
6426 : 74 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
6427 : :
6428 : : ! Find the list of irreducible perturbations for this q-point.
6429 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
6430 : 74 : this_pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
6431 [ + + + + ]: 2358 : pertsy(nqpt_interpolate,:,:) = this_pertsy
6432 : : !pertsy = 1
6433 : :
6434 [ + + ]: 201 : do iat=1,natom
6435 [ + + ]: 582 : do idir=1,3
6436 : 381 : ipert = (iat-1) * 3 + idir
6437 [ + + ]: 508 : if (pertsy(nqpt_interpolate,idir,iat) == 1) nperts_interpolate = nperts_interpolate + 1
6438 : : end do
6439 : : end do
6440 : :
6441 : : end if
6442 : : end do
6443 : :
6444 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points found in input DVDB:", itoa(nqpt_read)))
6445 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points requiring Fourier interpolation", itoa(nqpt_interpolate)))
6446 : :
6447 : : ! =================================================
6448 : : ! Open the new DVDB file and write preliminary info
6449 : : ! =================================================
6450 : 8 : nperts = nperts_read + nperts_interpolate
6451 : :
6452 [ + - ]: 8 : if (my_rank == master) then
6453 [ - + ]: 8 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6454 : 0 : ABI_ERROR(msg)
6455 : : end if
6456 [ + - ]: 8 : write(ount, err=10, iomsg=msg) dvdb_last_version
6457 [ + - ]: 8 : write(ount, err=10, iomsg=msg) nperts
6458 : : end if
6459 : :
6460 : : ! =================================================================
6461 : : ! Master reads all available perturbations and copy in the new DVDB
6462 : : ! =================================================================
6463 : :
6464 : 0 : rhog1_g0 = zero
6465 : :
6466 : : if (my_rank == master) then
6467 [ + + ]: 37 : do iq=1,nqpt_read
6468 [ + + ]: 116 : qpt = q_read(:,iq)
6469 : 29 : db_iqpt = iq_read(iq)
6470 : :
6471 : : ! Read each irreducible perturbation potentials
6472 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6473 [ - + ]: 29 : ABI_CHECK(npc /= 0, "npc == 0!")
6474 : :
6475 : : ! These arrays depend on cplex.
6476 [ - + + - : 145 : ABI_MALLOC(v1scf, (cplex, nfftf, nspden))
- + + - -
+ + - + -
+ - - + -
+ - + ]
6477 [ - + + - : 87 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6478 : :
6479 [ + + ]: 85 : do ipc=1,npc
6480 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6481 [ - + ]: 56 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfftf, ngfftf, v1scf, msg) /= 0) then
6482 : 0 : ABI_ERROR(msg)
6483 : : end if
6484 : :
6485 : : ! Write header
6486 [ + + ]: 224 : hdr_ref%qptn = qpt
6487 : 56 : hdr_ref%pertcase = ipert
6488 : 56 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6489 [ - + ]: 56 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6490 : :
6491 [ + + ]: 112 : do ispden=1,nspden
6492 [ + + ]: 112 : v1 = reshape(v1scf(:,:,ispden), (/cplex*nfftf/))
6493 [ + - ]: 112 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6494 : : end do
6495 [ + - ]: 85 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6496 : : end do
6497 : :
6498 [ - + ]: 29 : ABI_FREE(v1scf)
6499 [ - + ]: 37 : ABI_FREE(v1)
6500 : : end do
6501 : : end if ! master
6502 : :
6503 : 8 : call xmpi_barrier(comm)
6504 : :
6505 : : ! ================================================================
6506 : : ! Interpolate the potential for q-points not in the original DVDB
6507 : : ! ================================================================
6508 : :
6509 : 8 : dvdb%my_nrpt = nqbz_coarse
6510 [ - + + - : 40 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2, dvdb%my_nrpt, nfftf, dvdb%nspden), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
6511 : :
6512 : 8 : cplex = 2
6513 [ - + + - : 32 : ABI_MALLOC(v1scf, (cplex,nfftf,nspden))
- + + - +
- + - - +
- + - + ]
6514 [ - + + - : 24 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6515 : :
6516 : : use_netcdf = .False.
6517 : : ! Create temporary netcdf file used to write Fortran file with contiguous perturbations.
6518 : 8 : use_netcdf = .True.
6519 [ + - ]: 8 : if (my_rank == master) then
6520 [ + - ]: 8 : tmp_fname = strcat(new_dvdb_fname, "_TEMPORARY_TRANSFER_FILE.nc")
6521 : 8 : dimv1 = cplex * nfftf
6522 [ - + ]: 8 : NCF_CHECK(nctk_open_create(ncid, tmp_fname, xmpi_comm_self))
6523 : : ncerr = nctk_def_dims(ncid, [&
6524 : : nctkdim_t("dimv1", dimv1), nctkdim_t("nspden", nspden), &
6525 : : nctkdim_t("natom", natom), nctkdim_t("nqpt_intp", nqpt_interpolate), &
6526 : : nctkdim_t("nrpt", dvdb%my_nrpt), nctkdim_t("nfft", nfftf), nctkdim_t("natom3", natom * 3) &
6527 [ + + ]: 64 : ])
6528 [ - + ]: 8 : NCF_CHECK(ncerr)
6529 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1", "dp", "dimv1, nspden, three, natom, nqpt_intp")))
6530 : : !NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1scf_rpt", "dp", "two, nrpt, nfft, nspden, natom3")))
6531 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(ncid))
6532 : : end if
6533 : :
6534 [ + + ]: 23 : do iat=1,natom
6535 [ + + ]: 68 : do idir=1,3
6536 : 45 : ipert = (iat-1) * 3 + idir
6537 : :
6538 : : ! Entry set to -1 for perturbations that can be found from basis perturbations.
6539 [ + + + + ]: 576 : if (sum(pertsy(:,idir,iat)) == -nqpt_interpolate) cycle
6540 : :
6541 : 31 : call wrtout(std_out, sjoin(" Interpolating perturbation iat, idir = ",itoa(iat), itoa(idir)), do_flush=.True.)
6542 : 31 : call cwtime(cpu, wall, gflops, "start")
6543 : :
6544 : : ! TODO: This part is slow.
6545 : : ! Compute phonon potential in real space lattice representation.
6546 : : call dvdb_get_v1scf_rpt(dvdb, cryst, ngqpt_coarse, nqshift_coarse, &
6547 : : qshift_coarse, nfftf, ngfftf, &
6548 : 31 : dvdb%my_nrpt, dvdb%nspden, ipert, v1scf_rpt, comm)
6549 : :
6550 : : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1scf_rpt"), v1scf_rpt, start=[1,1,1,1,ipert]))
6551 : 31 : call cwtime_report(" v1scf_rpt built", cpu, wall, gflops)
6552 : :
6553 [ + + ]: 348 : do iq=1,nqpt_interpolate
6554 [ + + ]: 317 : if (pertsy(iq,idir,iat) == -1) cycle
6555 [ + + ]: 976 : qpt = q_interp(:,iq)
6556 : :
6557 : : ! Interpolate the phonon potential
6558 : : call dvdb_get_v1scf_qpt(dvdb, cryst, qpt, nfftf, ngfftf, dvdb%my_nrpt, &
6559 : 244 : dvdb%nspden, ipert, v1scf_rpt, v1scf, comm)
6560 : :
6561 : : !call wrtout(std_out, sjoin("Writing q-point", itoa(iq)))
6562 [ + - ]: 275 : if (my_rank == master) then
6563 : : if (use_netcdf) then
6564 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6565 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6566 [ - + ]: 244 : NCF_CHECK(ncerr)
6567 : : else
6568 : : ! Master writes the file (change also qpt and ipert in hdr%)
6569 : : hdr_ref%qptn = qpt
6570 : : hdr_ref%pertcase = ipert
6571 : : call hdr_ref%fort_write(ount, fform_pot, ierr)
6572 : : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6573 : :
6574 : : do ispden=1,nspden
6575 : : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6576 : : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6577 : : end do
6578 : : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6579 : : end if
6580 : : end if
6581 : : end do
6582 : :
6583 : 31 : call cwtime_report(" q-points interpolated and written to new DVDB file.", cpu, wall, gflops)
6584 [ - + ]: 122 : ABI_FREE(dvdb%my_rpt)
6585 : : end do
6586 : : end do
6587 : :
6588 [ + - ]: 8 : if (use_netcdf .and. my_rank == master) then
6589 [ + + ]: 82 : do iq=1,nqpt_interpolate
6590 [ + + ]: 296 : qpt = q_interp(:,iq)
6591 [ + + ]: 209 : do iat=1,natom
6592 [ + + ]: 582 : do idir=1,3
6593 [ + + ]: 381 : if (pertsy(iq,idir,iat) == -1) cycle
6594 : 244 : ipert = (iat-1) * 3 + idir
6595 [ + + ]: 976 : hdr_ref%qptn = qpt
6596 : 244 : hdr_ref%pertcase = ipert
6597 : 244 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6598 : : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6599 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6600 [ - + ]: 244 : NCF_CHECK(ncerr)
6601 [ + + ]: 488 : do ispden=1,nspden
6602 [ + + ]: 488 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6603 [ + - ]: 488 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6604 : : end do
6605 [ + - ]: 371 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6606 : : end do
6607 : : end do
6608 : : end do
6609 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
6610 : 8 : call delete_file(tmp_fname, ierr)
6611 : : end if
6612 : :
6613 : 8 : if (my_rank == master) close(ount)
6614 : :
6615 : : ! Free memory
6616 [ - + ]: 8 : ABI_FREE(v1scf)
6617 [ - + ]: 8 : ABI_FREE(v1)
6618 [ - + ]: 8 : ABI_FREE(v1scf_rpt)
6619 [ - + ]: 8 : ABI_FREE(qbz)
6620 [ - + ]: 8 : ABI_FREE(qibz)
6621 [ - + ]: 8 : ABI_FREE(q_interp)
6622 [ - + ]: 8 : ABI_FREE(q_read)
6623 [ - + ]: 8 : ABI_FREE(wtq)
6624 [ - + ]: 8 : ABI_FREE(iq_read)
6625 [ - + ]: 8 : ABI_FREE(pertsy)
6626 [ - + ]: 8 : ABI_FREE(this_pertsy)
6627 [ - + ]: 8 : ABI_FREE(rfpert)
6628 [ - + ]: 8 : ABI_FREE(pinfo)
6629 : :
6630 : 8 : call hdr_ref%free()
6631 : :
6632 : 8 : write(msg, '(2a)') "Interpolation of the electron-phonon coupling potential completed", ch10
6633 [ + + ]: 24 : call wrtout([std_out, ab_out], msg, do_flush=.True.)
6634 : :
6635 : 8 : call cwtime_report(" Overall time:", cpu_all, wall_all, gflops_all)
6636 : :
6637 : 8 : return
6638 : :
6639 : : ! Handle Fortran IO error
6640 : : 10 continue
6641 : 0 : ABI_ERROR(msg)
6642 : :
6643 [ - + - + : 24 : end subroutine dvdb_interpolate_and_write
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - ]
6644 : : !!***
6645 : :
6646 : : !----------------------------------------------------------------------
6647 : :
6648 : : !!****f* m_dvdb/dvdb_qdownsample
6649 : : !! NAME
6650 : : !! dvdb_qdownsample
6651 : : !!
6652 : : !! FUNCTION
6653 : : !! Downsample the q-mesh. Produce new DVDB file
6654 : : !!
6655 : : !! INPUTS
6656 : : !! new_dvdb_fname=Path of output DVDB
6657 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
6658 : : !! ngqpt(3)=Division of coarse Q-mesh
6659 : : !! comm=MPI communicator.
6660 : : !!
6661 : : !! OUTPUT
6662 : : !! Only writing
6663 : : !!
6664 : : !! SOURCE
6665 : :
6666 : 0 : subroutine dvdb_qdownsample(dvdb, new_dvdb_fname, qptopt, ngqpt, comm)
6667 : :
6668 : : !Arguments ------------------------------------
6669 : : !scalars
6670 : : integer,intent(in) :: comm
6671 : : class(dvdb_t),intent(inout) :: dvdb
6672 : : character(len=*),intent(in) :: new_dvdb_fname
6673 : : !arrays
6674 : : integer,intent(in) :: qptopt, ngqpt(3)
6675 : :
6676 : : !Local variables ------------------------------
6677 : : !scalars
6678 : : integer,parameter :: master=0, fform_pot=111
6679 : : integer :: ierr,my_rank,nproc,idir,ipert,iat,ipc,ispden
6680 : : integer :: cplex, db_iqpt, npc, nqbz, nqibz, iq, ifft, nperts_read, nfft, ount
6681 : : character(len=500) :: msg
6682 : : !arrays
6683 : : integer :: qptrlatt(3,3)
6684 : 0 : integer,allocatable :: iq_read(:), pinfo(:,:)
6685 : : real(dp) :: rhog1_g0(2)
6686 : 0 : real(dp),allocatable :: v1scf(:,:,:), v1(:), wtq(:), qibz(:,:), qbz(:,:)
6687 : : !************************************************************************
6688 : :
6689 : 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6690 [ # # ]: 0 : if (my_rank /= master) goto 20
6691 : :
6692 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6693 : :
6694 : : ! =======================
6695 : : ! Setup fine q-point grid
6696 : : ! =======================
6697 : : ! Generate the list of irreducible q-points in the coarse grid
6698 : 0 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
6699 : 0 : call kpts_ibz_from_kptrlatt(dvdb%cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
6700 : :
6701 : : ! =======================================
6702 : : ! Open DVDB and copy important dimensions
6703 : : ! =======================================
6704 : :
6705 [ # # # # : 0 : ABI_MALLOC(iq_read, (nqibz))
# # # # #
# # # ]
6706 [ # # # # : 0 : ABI_MALLOC(pinfo, (3, 3*dvdb%mpert))
# # # # #
# # # #
# ]
6707 : 0 : nperts_read = 0
6708 : :
6709 [ # # ]: 0 : do iq=1,nqibz
6710 : : ! Find the index of the q-point in the DVDB.
6711 : 0 : db_iqpt = dvdb%findq(qibz(:, iq))
6712 [ # # ]: 0 : ABI_CHECK(db_iqpt /= -1, sjoin("Q-point:", ktoa(qibz(:, iq)), "not found in DVDB!"))
6713 : 0 : iq_read(iq) = db_iqpt
6714 : :
6715 : : ! Count the number of perturbations.
6716 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6717 [ # # ]: 0 : do ipc=1,npc
6718 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6719 [ # # ]: 0 : if (iat <= dvdb%cryst%natom) nperts_read = nperts_read + 1
6720 : : end do
6721 : : end do
6722 : :
6723 : : ! =================================================
6724 : : ! Open the new DVDB file and write preliminary info
6725 : : ! =================================================
6726 : : !nperts = nperts_read + nperts_interpolate
6727 [ # # ]: 0 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6728 : 0 : ABI_ERROR(msg)
6729 : : end if
6730 [ # # ]: 0 : write(ount, err=10, iomsg=msg) dvdb_last_version
6731 [ # # ]: 0 : write(ount, err=10, iomsg=msg) nperts_read
6732 : :
6733 : : ! Read all perturbations on the coarse Q-mesh and write them to the new DVDB
6734 : 0 : rhog1_g0 = zero
6735 : :
6736 [ # # ]: 0 : do iq=1,nqibz
6737 : 0 : db_iqpt = iq_read(iq)
6738 : :
6739 : : ! Read each irreducible perturbation potentials
6740 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6741 [ # # ]: 0 : ABI_CHECK(npc /= 0, "npc == 0!")
6742 : :
6743 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex, nfft, dvdb%nspden))
# # # # #
# # # # #
# # # # #
# ]
6744 [ # # # # : 0 : ABI_MALLOC(v1, (cplex*nfft))
# # # # #
# # # ]
6745 : :
6746 [ # # ]: 0 : do ipc=1,npc
6747 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6748 [ # # ]: 0 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfft, dvdb%ngfft, v1scf, msg) /= 0) then
6749 : 0 : ABI_ERROR(msg)
6750 : : end if
6751 : :
6752 : : ! Change the header.
6753 [ # # ]: 0 : dvdb%hdr_ref%qptn = qibz(:, iq)
6754 : 0 : dvdb%hdr_ref%pertcase = ipert
6755 : :
6756 : : ! Write header
6757 : 0 : call dvdb%hdr_ref%fort_write(ount, fform_pot, ierr)
6758 [ # # ]: 0 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6759 : :
6760 [ # # ]: 0 : do ispden=1,dvdb%nspden
6761 [ # # ]: 0 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfft])
6762 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
6763 : : end do
6764 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6765 : : end do
6766 : :
6767 [ # # ]: 0 : ABI_FREE(v1scf)
6768 [ # # ]: 0 : ABI_FREE(v1)
6769 : : end do
6770 : :
6771 : 0 : close(ount)
6772 : :
6773 : : ! Free memory
6774 [ # # ]: 0 : ABI_FREE(qbz)
6775 [ # # ]: 0 : ABI_FREE(qibz)
6776 [ # # ]: 0 : ABI_FREE(wtq)
6777 [ # # ]: 0 : ABI_FREE(iq_read)
6778 [ # # ]: 0 : ABI_FREE(pinfo)
6779 : :
6780 : 0 : write(msg, '(2a)') " Downsampling of the e-ph coupling potential completed", ch10
6781 : 0 : call wrtout(std_out, msg, do_flush=.True.)
6782 : :
6783 : : 20 continue
6784 : 0 : call xmpi_barrier(comm)
6785 : :
6786 : 0 : return
6787 : :
6788 : : ! Handle Fortran IO error
6789 : : 10 continue
6790 : 0 : ABI_ERROR(msg)
6791 : :
6792 [ # # # # : 0 : end subroutine dvdb_qdownsample
# # # # #
# # # #
# ]
6793 : : !!***
6794 : :
6795 [ - + - - : 38966 : end module m_dvdb
+ + - + +
- - + - +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6796 : : !!***
|
