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, kpts_timrev_from_kptopt
63 : : use m_spacepar, only : symrhg, setsym
64 : : use m_fourier_interpol,only : fourier_interpol_seq
65 : : use m_pawrhoij, only : pawrhoij_type
66 : : use m_dfpt_mkvxc, only : dfpt_mkvxc
67 : :
68 : : implicit none
69 : :
70 : : private
71 : : !!***
72 : :
73 : : ! Version 1: header + vscf1(r)
74 : : ! Version 2: header + vscf1(r) + record with rhog1(G=0)
75 : : integer,public,parameter :: dvdb_last_version = 2
76 : :
77 : : integer,private,parameter :: DVDB_NOMODE = 0
78 : : integer,private,parameter :: DVDB_READMODE = 1
79 : : integer,private,parameter :: DVDB_WRITEMODE = 2
80 : :
81 : : !----------------------------------------------------------------------
82 : :
83 : : !!****t* m_dvdb/dvdb_t
84 : : !! NAME
85 : : !! dvdb_t
86 : : !!
87 : : !! FUNCTION
88 : : !! Database of DFPT results. The database contains `numv1` perturbations
89 : : !! and the corresponding first order local potentials in real space on the FFT mesh.
90 : : !! Provides methods to Fourier interpolate the potentials including the
91 : : !! treatment of long-range behaviour in the FT interpolation in polar semiconductors.
92 : : !! Note that one can have different FFT meshes for the different perturbations.
93 : : !!
94 : : !! NOTES
95 : : !! natom, nspden, nspinor, and usepaw are global variables in the sense that it is not possible to add
96 : : !! new entries to the database if these dimensions differ from the global ones.
97 : : !!
98 : : !! SOURCE
99 : :
100 : : type,public :: dvdb_t
101 : :
102 : : integer :: fh
103 : : ! file handle
104 : : ! Fortran unit number if iomode==IO_MODE_FORTRAN
105 : : ! MPI file handler if iomode==IO_MODE_MPI
106 : :
107 : : integer :: fform
108 : : ! File format
109 : :
110 : : integer :: comm
111 : : ! Global MPI communicator used for IO.
112 : :
113 : : integer :: gpu_option = 0
114 : : ! Input variable
115 : :
116 : : integer :: comm_rpt = xmpi_comm_self
117 : : ! MPI communicator used to distributed R-points.
118 : :
119 : : integer :: nprocs_rpt = 1
120 : : ! Number of cpus for parallelism over R-points.
121 : :
122 : : integer :: me_rpt = 0
123 : : ! My rank in comm_rpt.
124 : :
125 : : integer :: comm_pert = xmpi_comm_self
126 : : ! MPI communicator for parallelism over atomic perturbations.
127 : :
128 : : integer :: nprocs_pert = 1
129 : : ! Number of cpus for parallelism over atomic perturbations.
130 : :
131 : : integer :: me_pert = 0
132 : : ! My rank in comm over atomic perturbations.
133 : :
134 : : integer :: my_npert
135 : : ! Number of atomic perturbations or phonon modes treated by this MPI rank
136 : :
137 : : integer,allocatable :: my_pinfo(:,:)
138 : : ! my_pinfo(3, my_npert)
139 : : ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
140 : : ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
141 : : ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
142 : :
143 : : integer,allocatable :: pert_table(:,:)
144 : : ! pert_table(2, natom3)
145 : : ! pert_table(1, npert): rank of the processor treating this atomic perturbation.
146 : : ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
147 : :
148 : : integer :: version
149 : : ! File format version read from file.
150 : :
151 : : integer :: iomode = IO_MODE_FORTRAN
152 : : ! Method used to access the DVDB file:
153 : : ! IO_MODE_FORTRAN for usual Fortran IO routines
154 : : ! IO_MODE_MPI if MPI/IO routines.
155 : :
156 : : integer :: rw_mode = DVDB_NOMODE
157 : : ! (Read|Write) mode
158 : :
159 : : integer :: current_fpos
160 : : ! The current position of the file pointer used for sequential access with Fortran-IO
161 : :
162 : : integer :: numv1
163 : : ! Number of v1 potentials present in file.
164 : :
165 : : integer :: nqpt
166 : : ! Number of q-points (usually the IBZ)
167 : :
168 : : integer :: natom
169 : : ! Number of atoms
170 : :
171 : : integer :: natom3
172 : : ! 3 * natom
173 : :
174 : : integer :: nspden
175 : : ! Number of spin density components
176 : :
177 : : integer :: nsppol
178 : : ! Number of spin polarizations.
179 : :
180 : : integer :: nspinor
181 : : ! Number of spinor components.
182 : :
183 : : integer :: usepaw
184 : : ! 1 if PAW calculation, 0 otherwise
185 : :
186 : : integer :: mpert
187 : : ! Maximum number of perturbations
188 : :
189 : : integer :: my_nrpt = 0
190 : : ! Number of real space points used for Fourier interpolation treated by this MPI rank.
191 : :
192 : : integer :: nrtot = 0
193 : : ! Total Number of real space points used for Fourier interpolation.
194 : :
195 : : integer :: prtvol = 0
196 : : ! Verbosity level
197 : :
198 : : integer :: brav = 1
199 : : ! Option for the sampling of the BZ (input variable, the same option is stored in ifc_t)
200 : :
201 : : real(dp) :: qdamp = 0.1_dp
202 : : ! Exponential damping used in the Fourier transform of the long-range potentials
203 : : ! Use negative value to deactivate damping.
204 : :
205 : : logical :: debug = .False.
206 : : ! Debug flag
207 : :
208 : : logical :: has_dielt = .False.
209 : : ! True if the dielectric tensor is available.
210 : :
211 : : logical :: has_zeff = .False.
212 : : ! True if Born effective charges are available.
213 : :
214 : : logical :: has_quadrupoles = .False.
215 : : ! True if quadrupoles are available.
216 : :
217 : : logical :: has_efield = .False.
218 : : ! True if electric field perturbations are available.
219 : :
220 : : integer :: add_lr = 1
221 : : ! Flag defining the treatment of the long range component in the interpolation of the DFPT potentials.
222 : : !
223 : : ! 0 --> No treatment
224 : : ! 1 --> Remove LR model when building W(R,r). Add it back after W(R,r) --> v(q) Fourier interpolation
225 : : ! This is the standard approach for polar materials.
226 : : ! -1 --> Remove LR model when building W(R,r). DO NOT reintroduce it after Fourier interpolation.
227 : : ! This procedure should be used for homopolar materials with (spurious) non-zero BECS
228 : : ! in order to remove the long range component from the DFPT potentials.
229 : : ! 2 --> Similar to 1 but include only the dipole part. Q* are set to zero even if the DDB file contains them.
230 : : ! 4,5,6,7 --> Use model for the LR part only.
231 : : ! 4: Use dipole + quadrupole part (if available)
232 : : ! 5: Use dipole part only.
233 : : ! 6: Use quadrupole part only.
234 : : ! 7: Use electric field only.
235 : :
236 : : integer :: symv1 = 0
237 : : ! Flag for the symmetrization of v1 potentials.
238 : : ! 0 --> No symmetrization
239 : : ! 1 --> Symmetrization in real space
240 : : ! 2 --> Call v1phq_complete after interpolation of the potentials in ftinterp_qpt
241 : :
242 : : integer :: rspace_cell = 0
243 : : ! Flag defining the algorithm for generating the list of R-points and the weights used to go from W(r,R) to v1scf(r,q)
244 : : ! 0 --> Use unit supercell for R space. All weights set to 1.
245 : : ! 1 --> Use Wigner-Seitz super cell and atom dependent weights (same algo as for dynmat)
246 : :
247 : : character(len=fnlen) :: path = ABI_NOFILE
248 : : ! File name of the DVDB file.
249 : :
250 : : real(dp) :: dielt(3, 3) = zero
251 : : ! Dielectric tensor in Cartesian coordinates.
252 : : ! Used to deal with the long-range component in the Fourier interpolation.
253 : :
254 : : integer,allocatable :: pos_dpq(:,:,:)
255 : : ! pos_dpq(3, mpert, nqpt)
256 : : ! The position of the (idir, ipert, iqpt) potential in the file (in units of POT1 blocks)
257 : : ! 0 if the corresponding entry is not available.
258 : :
259 : : integer,allocatable :: cplex_v1(:)
260 : : ! cplex_v1(numv1)
261 : : ! The value of cplex for each v1(cplex*nfft, nspden) potential
262 : : ! 2 if the potential is complex, 1 if real (q==Gamma)
263 : :
264 : : integer,allocatable :: symq_table(:,:,:,:)
265 : : ! symq(4,2,nsym,nqpt)
266 : : ! Table computed by littlegroup_q for all q-points found in the DVDB.
267 : : ! three first numbers define the G vector;
268 : : ! fourth number is zero if the q-vector is not preserved, is 1 otherwise
269 : : ! second index is one without time-reversal symmetry, two with time-reversal symmetry
270 : :
271 : : integer :: ngfft(18) = -1
272 : : ! Info on the FFT to be used for the potentials.
273 : :
274 : : integer,allocatable :: iv_pinfoq(:,:)
275 : : !iv_pinfoq(4, numv1)
276 : : ! iv_pinfoq(1, iv1) gives the `idir` index of the iv1 potential
277 : : ! iv_pinfoq(2, iv1) gives the `ipert` index of the iv1 potential
278 : : ! iv_pinfoq(3, iv1) gives `pertcase`=idir + (ipert-1)*3
279 : : ! iv_pinfoq(4, iv1) gives the `iqpt` index of the iv1 potential
280 : :
281 : : integer,allocatable :: ngfft3_v1(:,:)
282 : : ! ngfft3_v1(3, numv1)
283 : : ! The FFT mesh used for each v1 potential (the one used to store data in the file).
284 : :
285 : : integer,allocatable :: my_irpt2tot(:)
286 : : ! Mapping my_irpt index to full list of R-points.
287 : :
288 : : real(dp),allocatable :: qpts(:,:)
289 : : ! qpts(3,nqpt)
290 : : ! List of q-points in reduced coordinates.
291 : :
292 : : real(dp),allocatable :: my_rpt(:,:)
293 : : ! my_rpt(3, my_nrpt)
294 : : ! Real space points for Fourier interpolation (MPI distributed if nprocs_rpt > 1)
295 : :
296 : : real(kind=sp),allocatable :: wsr(:,:,:,:,:)
297 : : ! DFPT potential in the real space supercell representation.
298 : : ! wsr(1, my_nrpt, nfft, nspden, my_npert)
299 : : ! NOTE kind=sp to save memory as much as possible.
300 : : !
301 : : ! TODO: Use MPI shared window
302 : :
303 : : real(dp),allocatable :: my_wratm(:,:)
304 : : ! my_wratm(my_nrpt, minatom:maxatom)
305 : : ! Weight for the FT associated to the atom and the R vector.
306 : :
307 : : real(dp),allocatable :: rhog1_g0(:,:)
308 : : ! rhog1_g0(2, numv1)
309 : : ! G=0 component of rhog1. Used to treat the long range component in (polar) semiconductors.
310 : : ! NB: For the time being, this quantity is not used. Long range term is treated with Verdi's model and quadrupoles
311 : :
312 : : real(dp),allocatable :: zeff(:,:,:)
313 : : ! zeff(3, 3, natom)
314 : : ! Effective charges on each atom, versus electric field and atomic displacement in Cartesian coordinates.
315 : : ! Used to deal with the long-range component in the Fourier interpolation.
316 : :
317 : : real(dp),allocatable :: zeff_raw(:,:,:)
318 : : ! Raw Effective charges i.e. values before enforcing the charge-neutrality condition.
319 : :
320 : : real(dp),allocatable :: qstar(:,:,:,:)
321 : : ! qstar(3, 3, 3, natom)
322 : : ! dynamical quadrupole in Cartesian coordinates.
323 : : ! First two dimension are associated to the q-point, then atomic perturbation in Cart coords.
324 : :
325 : : real(dp),allocatable :: v1r_efield(:,:,:)
326 : : ! v1r_efield(nfft, 3, nspden)
327 : : ! First order potentials due to the three different directions of the electric field perturbation.
328 : : ! Potentials are in r-space
329 : :
330 : : type(crystal_t) :: cryst
331 : : ! Crystalline structure read from the the DVDB file.
332 : :
333 : : type(hdr_type) :: hdr_ref
334 : : ! Header associated to the first potential in the DVDB. Used to backspace.
335 : : ! Gives the number of Fortran records required to backspace the header
336 : : ! Assume all headers with same fform and same basic dimensions e.g. npsp
337 : :
338 : : type(mpi_type) :: mpi_enreg
339 : : ! Internal object used to call fourdp and other GS/DFPT routines
340 : :
341 : : contains
342 : :
343 : : procedure :: init => dvdb_init !
344 : : ! Create new object.
345 : :
346 : : procedure :: open_read => dvdb_open_read
347 : : ! Open the file in read-only mode.
348 : :
349 : : procedure :: close => dvdb_close
350 : : ! Close the DVDB file.
351 : :
352 : : procedure :: free => dvdb_free
353 : : ! Release the memory allocated and close the file.
354 : :
355 : : procedure :: has_fields => dvdb_has_fields
356 : : ! Check whether the DVDB database stores first-order potentials or first-order densities
357 : :
358 : : procedure :: print => dvdb_print
359 : : ! Print info on object.
360 : :
361 : : procedure :: findq => dvdb_findq
362 : : ! Returns the index of the q-point.
363 : :
364 : : procedure :: find_qpts => dvdb_find_qpts
365 : : ! Returns the index of a list of q-points.
366 : :
367 : : procedure :: need_ftinterp => dvdb_need_ftinterp
368 : : ! Check whether input list of q-points requires Fourier interpolation.
369 : :
370 : : procedure :: map_qpt => dvdb_map_qpt
371 : : ! Symmetry mapping (SYMREC convention) between a q-point and the q-points in the DVDB.
372 : :
373 : : procedure :: set_pert_distrib => dvdb_set_pert_distrib
374 : : ! Activate parallelism over perturbations
375 : :
376 : : procedure :: read_onev1 => dvdb_read_onev1
377 : : ! Read and return the DFPT potential for given (idir, ipert, iqpt).
378 : :
379 : : procedure :: readsym_allv1 => dvdb_readsym_allv1
380 : : ! Read and return all the 3*natom DFPT potentials (either from file or symmetrized)
381 : :
382 : : procedure :: readsym_qbz => dvdb_readsym_qbz
383 : : ! Reconstruct the DFPT potential for a q-point in the BZ from its symmetrical image in the IBZ.
384 : :
385 : : procedure :: read_vxc1_qbz => dvdb_read_vxc1_qbz
386 : : ! Compute the first-order change of exchange-correlation potential
387 : : ! for a q-point in the BZ starting from its symmetrical image in the IBZ.
388 : :
389 : : procedure :: list_perts => dvdb_list_perts
390 : : ! Check if all the (phonon) perts are available taking into account symmetries.
391 : :
392 : : procedure :: ftinterp_setup => dvdb_ftinterp_setup
393 : : ! Prepare the internal tables for Fourier interpolation.
394 : :
395 : : procedure :: get_maxw => dvdb_get_maxw
396 : : ! Compute max_r |W(R,r)|
397 : :
398 : : procedure :: ftinterp_qpt => dvdb_ftinterp_qpt
399 : : ! Fourier interpolation of potentials for given q-point
400 : :
401 : : procedure :: get_ftqbz => dvdb_get_ftqbz
402 : : ! Retrieve Fourier interpolated potential for a given q-point in the BZ.
403 : : ! Use cache to reduce number of slow FTs.
404 : :
405 : : procedure :: get_vxc1_ftqbz => dvdb_get_vxc1_ftqbz
406 : : ! Retrieve Fourier interpolated first-order change of exchange-correlation
407 : : ! potential v1xc for a given q-point in the BZ.
408 : :
409 : : procedure :: get_v1r_long_range => dvdb_get_v1r_long_range
410 : : ! Long-range part of the phonon potential
411 : :
412 : : procedure :: load_ddb => dvdb_load_ddb
413 : : ! Load information about the Born effective charges and dielectric tensor from a DDB file
414 : :
415 : : procedure :: interpolate_v1scf => dvdb_interpolate_v1scf
416 : : ! Fourier interpolation of the phonon potentials
417 : :
418 : : procedure :: get_v1scf_rpt => dvdb_get_v1scf_rpt
419 : : ! Fourier transform of the phonon potential from qpt to R
420 : :
421 : : procedure :: get_v1scf_qpt => dvdb_get_v1scf_qpt
422 : : ! Fourier transform of the phonon potential from R to qpt
423 : :
424 : : procedure :: load_efield => dvdb_load_efield
425 : : ! Load the potential due to the Electric field.
426 : :
427 : : procedure :: interpolate_and_write => dvdb_interpolate_and_write
428 : : ! Interpolate the phonon potentials and write a new DVDB file.
429 : :
430 : : procedure :: qdownsample => dvdb_qdownsample
431 : : ! Downsample the q-mesh. Produce new DVDB file
432 : :
433 : : procedure :: write_v1qavg => dvdb_write_v1qavg
434 : : ! Computes the average over the unit cell of the periodic part of the DFPT potentials
435 : : ! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
436 : :
437 : : end type dvdb_t
438 : :
439 : : ! Utilities
440 : : public :: dvdb_merge_files ! Merge a list of POT1 files.
441 : :
442 : : ! Debugging tools. These functions are interfaced with mrgdv. Use mrgdv --help to access the documentation
443 : : public :: dvdb_test_v1rsym ! Check symmetries in real-space of the DFPT potentials.
444 : : public :: dvdb_test_v1complete ! Test the symmetrization of the DFPT potentials.
445 : : public :: dvdb_test_ftinterp ! Test the Fourier interpolation of DFPT potentials.
446 : : public :: dvdb_test_symcheck ! Test cross-q-point symmetry consistency of the FT interpolation.
447 : : public :: dvdb_test_symcheck_native ! Same test but on two literal, non-interpolated q-points.
448 : :
449 : : !----------------------------------------------------------------------
450 : :
451 : 80 : integer,private,parameter :: pot1_fforms(2) = [109, 111], den1_fforms(1) = [54]
452 : :
453 : : contains
454 : : !!***
455 : :
456 : : !----------------------------------------------------------------------
457 : :
458 : : !!****f* m_dvdb/dvdb_init
459 : : !! NAME
460 : : !! dvdb_init
461 : : !!
462 : : !! FUNCTION
463 : : !! Initialize the object from file. This is a COLLECTIVE procedure that must be called
464 : : !! by each process in the MPI communicator comm.
465 : : !! We don't pass dtset because in mrgdvd, we need to build an instance and dtset is not available there.
466 : : !!
467 : : !! INPUTS
468 : : !! path=DVDB Filename.
469 : : !! comm=MPI communicator.
470 : : !!
471 : : !! SOURCE
472 : :
473 : 116 : subroutine dvdb_init(new, path, gpu_option, comm)
474 : :
475 : : !Arguments ------------------------------------
476 : : !scalars
477 : : class(dvdb_t),intent(out) :: new
478 : : character(len=*),intent(in) :: path
479 : : integer,intent(in) :: gpu_option, comm
480 : :
481 : : !Local variables-------------------------------
482 : : !scalars
483 : : integer,parameter :: master = 0
484 : : integer :: iv1,ii,ierr,unt,fform,nqpt,iq,iq_found,cplex,trev_q
485 : : integer :: idir,ipert,my_rank, nprocs, iatom, pertcase
486 : : real(dp) :: cpu, wall, gflops
487 : : character(len=500) :: msg
488 : 116 : type(hdr_type) :: hdr1
489 : : !arrays
490 : 116 : integer,allocatable :: tmp_pos(:,:,:)
491 : : real(dp) :: tsec(2)
492 : 116 : real(dp),allocatable :: tmp_qpts(:,:)
493 : : !************************************************************************
494 : :
495 : : ! Keep track of total time spent.
496 : 116 : call timab(1800, 1, tsec)
497 : :
498 : 116 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
499 [ - + ]: 116 : new%path = path; new%comm = comm; new%iomode = IO_MODE_FORTRAN
500 : 116 : new%gpu_option = gpu_option
501 : :
502 : 116 : call wrtout(std_out, sjoin("- Analyzing DVDB file: ", path, "..."))
503 : 116 : call cwtime(cpu, wall, gflops, "start")
504 : :
505 : : ! Master reads the header and builds useful tables
506 [ + - ]: 116 : if (my_rank == master) then
507 : :
508 [ - + ]: 116 : if (open_file(path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
509 : 0 : ABI_ERROR(msg)
510 : : end if
511 [ + - ]: 116 : read(unt, err=10, iomsg=msg) new%version
512 [ + - ]: 116 : read(unt, err=10, iomsg=msg) new%numv1
513 : :
514 : : ! Get important dimensions from the first header and rewind the file.
515 : 116 : call new%hdr_ref%fort_read(unt, new%fform)
516 [ - + ]: 116 : if (dvdb_check_fform(new%fform, "read_dvdb", msg) /= 0) then
517 : 0 : ABI_ERROR(sjoin("While reading:", path, ch10, msg))
518 : : end if
519 [ - + ]: 116 : if (new%debug) call new%hdr_ref%echo(new%fform, 4, unit=std_out)
520 : :
521 : 116 : rewind(unt)
522 [ + - ]: 116 : read(unt, err=10, iomsg=msg)
523 [ + - ]: 116 : read(unt, err=10, iomsg=msg)
524 : :
525 : : ! The code below must be executed by the other procs if MPI.
526 : 116 : new%natom = new%hdr_ref%natom
527 : 116 : new%natom3 = 3 * new%hdr_ref%natom
528 : 116 : new%nspden = new%hdr_ref%nspden
529 : 116 : new%nsppol = new%hdr_ref%nsppol
530 : 116 : new%nspinor = new%hdr_ref%nspinor
531 : 116 : new%usepaw = new%hdr_ref%usepaw
532 [ - + ]: 116 : ABI_CHECK(new%usepaw == 0, "PAW not yet supported")
533 : :
534 : : ! TODO: Write function to return mpert from natom!
535 : 116 : new%mpert = new%natom + 6
536 : :
537 [ - + + - : 348 : ABI_MALLOC(tmp_qpts, (3, new%numv1))
+ - + - -
+ - + ]
538 [ - + + - : 464 : ABI_MALLOC(tmp_pos, (3, new%mpert, new%numv1))
- + + - +
- + - - +
- + ]
539 [ + + + + : 67979 : tmp_pos = 0
+ + ]
540 : :
541 [ - + + - : 348 : ABI_MALLOC(new%cplex_v1, (new%numv1))
+ - + - -
+ - + -
+ ]
542 [ - + + - : 348 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
+ - + - -
+ - + -
+ ]
543 [ - + + - : 348 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
+ - + - -
+ - + -
+ ]
544 [ - + + - : 348 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
+ - + - -
+ - + -
+ ]
545 : :
546 : 116 : nqpt = 0
547 [ + + ]: 2195 : do iv1=1,new%numv1
548 : 2079 : call hdr1%fort_read(unt, fform)
549 [ - + ]: 2079 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
550 : 0 : ABI_ERROR(sjoin("While reading hdr of v1 potential of index:", itoa(iv1), ch10, msg))
551 : : end if
552 : :
553 : : ! Save cplex and FFT mesh associated to this perturbation.
554 [ + + ]: 2079 : cplex = 2; if (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14) cplex = 1
555 : 2079 : new%cplex_v1(iv1) = cplex
556 [ + + ]: 8316 : new%ngfft3_v1(:, iv1) = hdr1%ngfft(:3)
557 : :
558 : : ! Skip the records with v1.
559 [ + + ]: 4158 : do ii=1,hdr1%nspden
560 [ + - ]: 4158 : read(unt, err=10, iomsg=msg)
561 : : end do
562 : : ! Read rhog1_g0 (if available)
563 [ + + ]: 6237 : new%rhog1_g0(:, iv1) = zero
564 [ + - + - ]: 2079 : if (new%version > 1) read(unt, err=10, iomsg=msg) new%rhog1_g0(:, iv1)
565 : :
566 : : ! Check whether this q-point is already in the list.
567 : : ! Assume qpoints are grouped so invert the iq loop for better performance.
568 : : ! This is gonna be slow if lots of q-points and perturbations are not grouped.
569 : 2079 : iq_found = 0
570 [ + + ]: 4629 : do iq=nqpt,1,-1
571 [ + + + + : 9353 : if (all(abs(hdr1%qptn - tmp_qpts(:,iq)) < tol14)) then
+ + ]
572 : : iq_found = iq; exit
573 : : end if
574 : : end do
575 : :
576 : : ! pertcase = idir + (ipert-1)*3 where ipert=iatom in the interesting cases
577 : 2079 : idir = mod(hdr1%pertcase-1, 3) + 1
578 : 2079 : ipert = (hdr1%pertcase - idir) / 3 + 1
579 : :
580 : : ! Increment nqpt is new q-points and update tmp_pos
581 [ + + ]: 2079 : if (iq_found == 0) then
582 : 682 : nqpt = nqpt + 1
583 [ + + ]: 2728 : tmp_qpts(:, nqpt) = hdr1%qptn
584 : : iq_found = nqpt
585 : : end if
586 : 2079 : tmp_pos(idir, ipert, iq_found) = iv1
587 [ + + ]: 10395 : new%iv_pinfoq(:,iv1) = [idir, ipert, hdr1%pertcase, iq_found]
588 : :
589 : 2195 : call hdr1%free()
590 : : end do
591 : :
592 : : ! Allocate arrays with correct nqpt dimension
593 : 116 : new%nqpt = nqpt
594 [ - + + - : 348 : ABI_MALLOC(new%qpts, (3, nqpt))
+ - + - -
+ - + -
+ ]
595 [ - + + + : 2960 : new%qpts = tmp_qpts(:,1:nqpt)
+ + ]
596 [ - + ]: 116 : ABI_FREE(tmp_qpts)
597 : :
598 [ - + + - : 464 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, nqpt))
- + + - +
- + - - +
- + - + ]
599 [ + - - + : 22342 : new%pos_dpq = tmp_pos(:, :, 1:nqpt)
- - + + +
+ + + ]
600 [ - + ]: 116 : ABI_FREE(tmp_pos)
601 : :
602 : 116 : close(unt)
603 : : end if
604 : :
605 : : ! Master broadcasts data.
606 [ - + ]: 116 : if (xmpi_comm_size(comm) > 1) then
607 : 0 : call xmpi_bcast(new%version, master, comm, ierr)
608 : 0 : call xmpi_bcast(new%fform, master, comm, ierr)
609 : 0 : call xmpi_bcast(new%numv1, master, comm, ierr)
610 : 0 : call xmpi_bcast(new%nqpt, master, comm, ierr)
611 : 0 : call new%hdr_ref%bcast(master, my_rank, comm)
612 : :
613 : 0 : new%natom = new%hdr_ref%natom
614 : 0 : new%natom3 = 3 * new%hdr_ref%natom
615 : 0 : new%nspden = new%hdr_ref%nspden
616 : 0 : new%nsppol = new%hdr_ref%nsppol
617 : 0 : new%nspinor = new%hdr_ref%nspinor
618 : 0 : new%usepaw = new%hdr_ref%usepaw
619 : 0 : new%mpert = new%natom + 6
620 : :
621 [ # # ]: 0 : if (my_rank /= master) then
622 [ # # # # : 0 : ABI_MALLOC(new%cplex_v1, (new%numv1))
# # # # #
# # # #
# ]
623 [ # # # # : 0 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
# # # # #
# # # #
# ]
624 [ # # # # : 0 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
# # # # #
# # # #
# ]
625 [ # # # # : 0 : ABI_MALLOC(new%qpts, (3, new%nqpt))
# # # # #
# # # #
# ]
626 [ # # # # : 0 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, new%nqpt))
# # # # #
# # # # #
# # # # ]
627 [ # # # # : 0 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
# # # # #
# # # #
# ]
628 : : end if
629 : :
630 : 0 : call xmpi_bcast(new%cplex_v1, master, comm, ierr)
631 : 0 : call xmpi_bcast(new%ngfft3_v1, master, comm, ierr)
632 : 0 : call xmpi_bcast(new%iv_pinfoq, master, comm, ierr)
633 : 0 : call xmpi_bcast(new%qpts, master, comm, ierr)
634 : 0 : call xmpi_bcast(new%pos_dpq, master, comm, ierr)
635 : 0 : call xmpi_bcast(new%rhog1_g0, master, comm, ierr)
636 : : end if
637 : :
638 : : ! Init crystal_t from the hdr read from file.
639 [ - + - + : 116 : new%cryst = new%hdr_ref%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
640 : 116 : new%my_npert = new%natom3
641 : :
642 : : ! Init tables assuming no MPI distribution of perturbations.
643 [ - + + - : 348 : ABI_MALLOC(new%my_pinfo, (3, new%natom3))
+ - + - -
+ - + -
+ ]
644 [ - + + - : 348 : ABI_MALLOC(new%pert_table, (2, new%natom3))
+ - + - -
+ - + -
+ ]
645 [ + + ]: 337 : do iatom=1,new%natom
646 [ + + ]: 1000 : do idir=1,3
647 : 663 : pertcase = idir + (iatom-1) * 3
648 [ + + ]: 2652 : new%my_pinfo(:, pertcase) = [idir, iatom, pertcase]
649 : : ! pert_table(1,:) is the rank treating this perturbation (0 as there is no MPI distribution).
650 [ + + ]: 2210 : new%pert_table(:, pertcase) = [0, pertcase]
651 : : end do
652 : : end do
653 : :
654 : : ! Init Born effective charges
655 [ - + + - : 3221 : ABI_CALLOC(new%zeff, (3, 3, new%natom))
+ - + - -
+ - + - +
+ + + + +
+ ]
656 [ - + + - : 3105 : ABI_CALLOC(new%zeff_raw, (3, 3, new%natom))
- + - + -
+ + + + +
+ + ]
657 [ - + + - : 9188 : ABI_CALLOC(new%qstar, (3, 3, 3, new%natom))
+ - + - -
+ - + - +
+ + + + +
+ + + ]
658 : :
659 : : ! Internal MPI_type needed for calling fourdp!
660 : 116 : call initmpi_seq(new%mpi_enreg)
661 : :
662 : : ! Precompute symq_table for all q-points in the DVDB.
663 [ - + + - : 313282 : ABI_ICALLOC(new%symq_table, (4, 2, new%cryst%nsym, new%nqpt))
- + + - +
- + - - +
- + - + +
+ + + + +
+ + ]
664 [ + + ]: 798 : do iq=1,new%nqpt
665 [ - + ]: 682 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
666 : : call littlegroup_q(new%cryst%nsym, new%qpts(:,iq), new%symq_table(:,:,:,iq), &
667 : 798 : new%cryst%symrec, new%cryst%symafm, trev_q, prtvol=0)
668 : : end do
669 : 116 : call xmpi_sum(new%symq_table, comm, ierr)
670 : :
671 : 116 : call cwtime_report("- dvdb_init", cpu, wall, gflops)
672 : 116 : call timab(1800, 2, tsec)
673 : :
674 : 116 : return
675 : :
676 : : ! Handle Fortran IO error
677 : : 10 continue
678 : 0 : ABI_ERROR(sjoin("Error while reading:", path, ch10, msg))
679 : :
680 [ + - - + : 464 : end subroutine dvdb_init
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - ]
681 : : !!***
682 : :
683 : : !----------------------------------------------------------------------
684 : :
685 : : !!****f* m_dvdb/dvdb_open_read
686 : : !! NAME
687 : : !! dvdb_open_read
688 : : !!
689 : : !! FUNCTION
690 : : !! Open the file in read-only mode.
691 : : !!
692 : : !! INPUTS
693 : : !! ngfft(18)=Info on the FFT mesh used for the DFPT potentials. Note that ngfft
694 : : !! is the mesh used by the parent. In principle, it can differ from the one
695 : : !! found in the file. In this case a Fourier interpolation is required.
696 : : !! comm=MPI communicator
697 : : !!
698 : : !! SOURCE
699 : :
700 : 95 : subroutine dvdb_open_read(db, ngfft, comm)
701 : :
702 : : !Arguments ------------------------------------
703 : : !scalars
704 : : integer,intent(in) :: comm
705 : : class(dvdb_t),intent(inout) :: db
706 : : !arrays
707 : : integer,intent(in) :: ngfft(18)
708 : :
709 : : !Local variables-------------------------------
710 : : !scalars
711 : : integer :: nprocs, unt, ii
712 : : character(len=500) :: msg
713 : : !arrays
714 : : character(len=fnlen) :: pot_paths(3)
715 : : !************************************************************************
716 : :
717 [ - + ]: 95 : if (db%rw_mode /= DVDB_NOMODE) then
718 : 0 : ABI_ERROR("DVDB should be in DVDB_NOMODE when open_read is called.")
719 : : end if
720 : 95 : db%rw_mode = DVDB_READMODE
721 : :
722 : 95 : nprocs = xmpi_comm_size(comm)
723 : :
724 : : ! Initialize tables to call fourdp in sequential
725 [ + + ]: 1805 : db%ngfft = ngfft
726 : 95 : call db%mpi_enreg%distribfft%init_seq('c', ngfft(2), ngfft(3), 'all')
727 : 95 : call db%mpi_enreg%distribfft%init_seq('f', ngfft(2), ngfft(3), 'all')
728 : :
729 : : ! Open the file.
730 : 190 : select case (db%iomode)
731 : : case (IO_MODE_FORTRAN)
732 [ - + ]: 95 : if (open_file(db%path, msg, newunit=db%fh, form="unformatted", status="old", action="read") /= 0) then
733 : 0 : ABI_ERROR(msg)
734 : : end if
735 [ + - ]: 95 : read(db%fh, err=10, iomsg=msg)
736 [ + - ]: 95 : read(db%fh, err=10, iomsg=msg)
737 : 95 : db%current_fpos = 1
738 : :
739 : : case (IO_MODE_MPI)
740 : 0 : ABI_ERROR("MPI not coded")
741 : :
742 : : case default
743 [ + - - ]: 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
744 : : end select
745 : :
746 : : ! Read potentials induced by electric fields
747 : : ! This requires ngfft so for the time being we call it here.
748 : : ! I should try to add efield perturbations to DVDB but then I also have to handle symmetrization wrt idir!
749 [ - + ]: 95 : if (file_exists("__EFIELD_POTS__")) then
750 : 0 : call wrtout(std_out, " Reading Efield potentials from EFIELD_POTS")
751 [ # # ]: 0 : if (open_file("__EFIELD_POTS__", msg, newunit=unt, form="formatted") /= 0) then
752 : 0 : ABI_ERROR(msg)
753 : : end if
754 [ # # ]: 0 : do ii=1,3
755 : 0 : read(unt, "(a)") pot_paths(ii)
756 : : end do
757 : 0 : close(unt)
758 : 0 : call db%load_efield(pot_paths, comm)
759 : : end if
760 : :
761 : 95 : return
762 : :
763 : : ! Handle Fortran IO error
764 : : 10 continue
765 : 0 : ABI_ERROR(sjoin("Error while reading", db%path, ch10, msg))
766 : :
767 : : end subroutine dvdb_open_read
768 : : !!***
769 : :
770 : : !----------------------------------------------------------------------
771 : :
772 : : !!****f* m_dvdb/dvdb_close
773 : : !! NAME
774 : : !! dvdb_close
775 : : !!
776 : : !! FUNCTION
777 : : !! Close the file
778 : : !!
779 : : !! SOURCE
780 : :
781 : 95 : subroutine dvdb_close(db)
782 : :
783 : : !Arguments ------------------------------------
784 : : class(dvdb_t),intent(inout) :: db
785 : : !************************************************************************
786 : :
787 : 190 : select case (db%iomode)
788 : : case (IO_MODE_FORTRAN)
789 : 95 : close(db%fh)
790 : : case default
791 [ + - ]: 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
792 : : end select
793 : :
794 : 95 : db%rw_mode = DVDB_NOMODE
795 : :
796 : 95 : end subroutine dvdb_close
797 : : !!***
798 : :
799 : : !----------------------------------------------------------------------
800 : :
801 : : !!****f* m_dvdb/dvdb_free
802 : : !! NAME
803 : : !! dvdb_free
804 : : !!
805 : : !! FUNCTION
806 : : !! Close the file and release the memory allocated.
807 : : !!
808 : : !! SOURCE
809 : :
810 : 235 : subroutine dvdb_free(db)
811 : :
812 : : !Arguments ------------------------------------
813 : : class(dvdb_t),target,intent(inout) :: db
814 : :
815 : : !Local variables-------------------------------
816 : 235 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
817 : : !************************************************************************
818 : :
819 : : ! integer arrays
820 : 116 : ABI_SFREE(db%my_pinfo)
821 [ + + ]: 235 : ABI_SFREE(db%pert_table)
822 [ + + ]: 235 : ABI_SFREE(db%pos_dpq)
823 [ + + ]: 235 : ABI_SFREE(db%cplex_v1)
824 [ + + ]: 235 : ABI_SFREE(db%symq_table)
825 [ + + ]: 235 : ABI_SFREE(db%iv_pinfoq)
826 [ + + ]: 235 : ABI_SFREE(db%ngfft3_v1)
827 [ + + ]: 235 : ABI_SFREE(db%my_irpt2tot)
828 : :
829 : : ! real arrays
830 [ + + ]: 235 : ABI_SFREE(db%qpts)
831 [ + + ]: 235 : ABI_SFREE(db%my_rpt)
832 : :
833 [ + + ]: 235 : ABI_SFREE(db%my_wratm)
834 [ + + ]: 235 : ABI_SFREE(db%rhog1_g0)
835 [ + + ]: 235 : ABI_SFREE(db%zeff)
836 [ + + ]: 235 : ABI_SFREE(db%zeff_raw)
837 [ + + ]: 235 : ABI_SFREE(db%qstar)
838 [ - + ]: 235 : ABI_SFREE(db%v1r_efield)
839 : :
840 : : ! Deallocate GPU arrays
841 : 235 : wsr_ptr => db%wsr
842 : : #ifdef HAVE_OPENMP_OFFLOAD
843 : : !$OMP TARGET EXIT DATA MAP(delete:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
844 : : #endif
845 [ + + ]: 235 : ABI_SFREE(db%wsr)
846 : :
847 : : ! types
848 : 235 : call db%hdr_ref%free()
849 : 235 : call db%cryst%free()
850 : 235 : call destroy_mpi_enreg(db%mpi_enreg)
851 : :
852 : : ! Close the file but only if we have performed IO.
853 [ + + ]: 235 : if (db%rw_mode == DVDB_NOMODE) return
854 : 95 : call db%close()
855 : :
856 [ + + ]: 235 : end subroutine dvdb_free
857 : : !!***
858 : :
859 : : !!****f* m_dvdb/dvdb_has_fields
860 : : !! NAME
861 : : !! dvdb_has_fields
862 : : !!
863 : : !! FUNCTION
864 : : !! Check whether the database stores first-order potentials (pot1) or first-order densities (den1)
865 : : !!
866 : : !! SOURCE
867 : :
868 : 182 : logical function dvdb_has_fields(db, choice, msg) result(ok)
869 : :
870 : : !Arguments ------------------------------------
871 : : class(dvdb_t),intent(in) :: db
872 : : character(len=*),intent(in) :: choice
873 : : character(len=*),intent(out) :: msg
874 : : !************************************************************************
875 : :
876 : : ! See m_hdr, more specifically all_abifiles for the correspondence between data and fform.
877 : 182 : msg = ""
878 : 176 : select case (choice)
879 : : case ("pot1")
880 : 176 : ok = any(db%fform == pot1_fforms)
881 [ - + - - : 176 : if (.not. ok) msg = sjoin("expecting first order potentials with headform in", ltoa(pot1_fforms), "but got", itoa(db%fform))
- - ]
882 : : case ("den1")
883 : 6 : ok = any(db%fform == den1_fforms)
884 [ - + - - : 6 : if (.not. ok) msg = sjoin("expecting first order densities with headform in", ltoa(den1_fforms), "but got", itoa(db%fform))
- - ]
885 : : case default
886 [ + + - ]: 182 : ABI_ERROR(sjoin("Invalid choice:", choice))
887 : : end select
888 : :
889 [ + - ]: 182 : end function dvdb_has_fields
890 : : !!***
891 : :
892 : : !----------------------------------------------------------------------
893 : :
894 : : !!****f* m_dvdb/dvdb_print
895 : : !! NAME
896 : : !! dvdb_print
897 : : !!
898 : : !! FUNCTION
899 : : !! Print info on the object.
900 : : !!
901 : : !! INPUTS
902 : : !! units=Unit numbers for output.
903 : : !! header=Header string
904 : : !! prtvol=verbosity level
905 : : !!
906 : : !! SOURCE
907 : :
908 : 380 : subroutine dvdb_print(db, units, header, prtvol)
909 : :
910 : : !Arguments ------------------------------------
911 : : !scalars
912 : : class(dvdb_t),intent(in) :: db
913 : : integer,intent(in) :: units(:), prtvol
914 : : character(len=*),intent(in) :: header
915 : :
916 : : !Local variables-------------------------------
917 : : integer :: iv1,iq,idir,ipert,iatom
918 : : character(len=5000) :: msg
919 : : ! *************************************************************************
920 : :
921 [ + + ]: 190 : if (len_trim(header) == 0) then
922 : 85 : msg = ' ==== Info on the dvdb% object ==== '
923 : : else
924 [ + - + - ]: 105 : msg = ' ==== '//trim(adjustl(header))//' ==== '
925 : : end if
926 : 190 : call wrtout(units, msg)
927 : :
928 : 190 : call wrtout(units, sjoin(" DVDB version:", itoa(db%version)))
929 : 190 : call wrtout(units, sjoin(" File path:", db%path))
930 : 190 : call wrtout(units, sjoin(" Number of v1scf potentials:", itoa(db%numv1)))
931 : 190 : call wrtout(units, sjoin(" Number of q-points in DVDB: ", itoa(db%nqpt)))
932 : 190 : call wrtout(units, sjoin("-P Number of CPUs for parallelism over perturbations:", itoa(db%nprocs_pert)))
933 : 190 : call wrtout(units, sjoin("-P Number of perturbations treated by this CPU:", itoa(db%my_npert)))
934 : 190 : call wrtout(units, sjoin(" Option for symmetrization of v1scf(r):", itoa(db%symv1)))
935 : 190 : call wrtout(units, " List of q-points: min(10, nqpt)")
936 [ + + ]: 1238 : do iq=1,min(db%nqpt, 10)
937 : 1238 : call wrtout(units, sjoin("[", itoa(iq),"]", ktoa(db%qpts(:,iq))))
938 : : end do
939 [ + + ]: 190 : if (db%nqpt > 10) call wrtout(units, "...")
940 : :
941 : 190 : call wrtout(units, sjoin(" Have dielectric tensor:", yesno(db%has_dielt)))
942 : 190 : call wrtout(units, sjoin(" Have Born effective charges:", yesno(db%has_zeff)))
943 : 190 : call wrtout(units, sjoin(" Have quadrupoles:", yesno(db%has_quadrupoles)))
944 : 190 : call wrtout(units, sjoin(" Have electric field:", yesno(db%has_efield)))
945 : 190 : call wrtout(units, sjoin(" Treatment of long-range part in V1scf (add_lr):", itoa(db%add_lr)))
946 : 190 : write(msg,"(a, f6.1)")" Damping factor for Gaussian filter (qdamp):", db%qdamp
947 : 190 : call wrtout(units, msg)
948 : :
949 [ + + ]: 190 : if (db%has_dielt) then
950 : 82 : write(msg, '(a,3(a,3es16.6))') ' Dielectric tensor in Cart coords:', ch10, &
951 : 82 : db%dielt(1,1), db%dielt(1,2), db%dielt(1,3), ch10, &
952 : 82 : db%dielt(2,1), db%dielt(2,2), db%dielt(2,3), ch10, &
953 : 164 : db%dielt(3,1), db%dielt(3,2), db%dielt(3,3)
954 : 82 : call wrtout(units, msg)
955 : : end if
956 : :
957 [ + + ]: 190 : if (db%has_zeff) then
958 : 82 : call print_zeff(units, db%cryst, db%zeff, title=' Born effectives charges in Cart coords:')
959 : : !call print_zeff(units, db%zeff_raw, db%cryst, title=' Born effectives charges before chneut: ')
960 : : end if
961 : :
962 [ + + ]: 190 : if (db%has_quadrupoles) then
963 : 2 : call wrtout(units, ' Dynamical Quadrupoles in Cartesian Coordinates:')
964 [ + + ]: 6 : do iatom=1,db%natom
965 [ + + ]: 18 : do idir=1,3
966 : 12 : write(msg,'(2(a,i0), 3(a,3es16.6))')' Q* for iatom: ', iatom, ' idir: ', idir, ch10, &
967 : 12 : db%qstar(1,1,idir,iatom), db%qstar(1,2,idir,iatom), db%qstar(1,3,idir,iatom), ch10, &
968 : 12 : db%qstar(2,1,idir,iatom), db%qstar(2,2,idir,iatom), db%qstar(2,3,idir,iatom), ch10, &
969 : 24 : db%qstar(3,1,idir,iatom), db%qstar(3,2,idir,iatom), db%qstar(3,3,idir,iatom)
970 : 16 : call wrtout(units, msg)
971 : : end do
972 : : end do
973 : :
974 : 2 : call wrtout(units, " Dynamical quadrupoles sum rule: \sum_\iatom Q_{beta,gamma}{iatom,idir} = 0 for nonpolar materials")
975 [ + + ]: 8 : do idir=1,3
976 : 6 : write(msg,'(a,i0,a,3(a,3es16.6))')" Sum rule for idir: ", idir, ch10, ch10, &
977 [ + + + + : 42 : sum(db%qstar(1,1,idir,:)), sum(db%qstar(1,2,idir,:)), sum(db%qstar(1,3,idir,:)), ch10, &
+ + ]
978 [ + + + + : 42 : sum(db%qstar(2,1,idir,:)), sum(db%qstar(2,2,idir,:)), sum(db%qstar(2,3,idir,:)), ch10, &
+ + ]
979 [ + + + + : 48 : sum(db%qstar(3,1,idir,:)), sum(db%qstar(3,2,idir,:)), sum(db%qstar(3,3,idir,:))
+ + ]
980 : 8 : call wrtout(units, msg)
981 : : end do
982 : : end if
983 : :
984 [ - + + + ]: 380 : if (prtvol > 0) then
985 : 43 : call db%cryst%print(header="Crystal structure in DVDB file")
986 : 43 : call wrtout(units, "FFT mesh for potentials on file:")
987 : 43 : call wrtout(units, "q-point, idir, ipert, ngfft(:3)")
988 [ + + ]: 517 : do iv1=1,db%numv1
989 : 474 : idir = db%iv_pinfoq(1, iv1); ipert = db%iv_pinfoq(2, iv1); iq = db%iv_pinfoq(4, iv1)
990 : 517 : call wrtout(units, sjoin(ktoa(db%qpts(:,iq)), itoa(idir), itoa(ipert), ltoa(db%ngfft3_v1(:,iv1))))
991 : : end do
992 : : end if
993 : :
994 : : contains
995 : :
996 [ - + ]: 82 : subroutine print_zeff(units, cryst, zeff, title)
997 : :
998 : : !Arguments ------------------------------------
999 : : !scalars
1000 : : integer,intent(in) :: units(:)
1001 : : type(crystal_t),intent(in) :: cryst
1002 : : real(dp),intent(in) :: zeff(3,3,cryst%natom)
1003 : : character(len=*),optional,intent(in) :: title
1004 : :
1005 : : !Local variables-------------------------------
1006 : : integer :: iatom
1007 : : character(len=5000) :: msg
1008 : : ! *************************************************************************
1009 : :
1010 [ + - ]: 82 : if (present(title)) then
1011 [ + - ]: 82 : call wrtout(units, trim(title))
1012 : : else
1013 : 0 : call wrtout(units, ' Born effectives charges in Cartesian coordinates: ')
1014 : : end if
1015 : :
1016 [ + + ]: 246 : do iatom=1,cryst%natom
1017 : 164 : write(msg, '(a,i0,1x,2a,3(a,3es16.6),a)')' iatom: ', iatom, ", type: ", cryst%symbol_iatom(iatom), ch10, &
1018 : 164 : zeff(1,1,iatom), zeff(1,2,iatom), zeff(1,3,iatom), ch10, &
1019 : 164 : zeff(2,1,iatom), zeff(2,2,iatom), zeff(2,3,iatom), ch10, &
1020 : 328 : zeff(3,1,iatom), zeff(3,2,iatom), zeff(3,3,iatom), ch10
1021 : 246 : call wrtout(units, msg)
1022 : : end do
1023 : :
1024 : 82 : write(msg,'(2a,3(a,3es16.6),a)')ch10,' Fulfillment of charge neutrality, \sum_{atom} Z^*_{ij,atom} = 0', ch10, &
1025 [ + + + + : 738 : sum(zeff(1,1,:)), sum(zeff(1,2,:)), sum(zeff(1,3,:)), ch10, &
+ + ]
1026 [ + + + + : 738 : sum(zeff(2,1,:)), sum(zeff(2,2,:)), sum(zeff(2,3,:)), ch10, &
+ + ]
1027 [ + + + + : 820 : sum(zeff(3,1,:)), sum(zeff(3,2,:)), sum(zeff(3,3,:)), ch10
+ + ]
1028 : 82 : call wrtout(units, msg)
1029 : :
1030 : 82 : end subroutine print_zeff
1031 : :
1032 : : end subroutine dvdb_print
1033 : : !!***
1034 : :
1035 : : !----------------------------------------------------------------------
1036 : :
1037 : : !!****f* m_dvdb/dvdb_get_pinfo
1038 : : !! NAME
1039 : : !! dvdb_get_pinfo
1040 : : !!
1041 : : !! FUNCTION
1042 : : !! Return information on the perturbations available for a given q-point index.
1043 : : !!
1044 : : !! INPUTS
1045 : : !! iqpt=Index of the q-point
1046 : : !!
1047 : : !! OUTPUT
1048 : : !! nperts=Number of perturbations found.
1049 : : !! cplex=2 if potentials are complex, 1 for real
1050 : : !! pinfo(3,3*db%mpert)=Array with info on the perturbations present on file
1051 : : !! pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
1052 : : !! pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
1053 : : !! pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
1054 : : !!
1055 : : !! SOURCE
1056 : :
1057 : 1718 : integer function dvdb_get_pinfo(db, iqpt, cplex, pinfo) result(nperts)
1058 : :
1059 : : !Arguments ------------------------------------
1060 : : !scalars
1061 : : type(dvdb_t),intent(in) :: db
1062 : : integer,intent(in) :: iqpt
1063 : : integer,intent(out) :: cplex
1064 : : !arrays
1065 : : integer,intent(out) :: pinfo(3,3*db%mpert)
1066 : :
1067 : : !Local variables-------------------------------
1068 : : !scalars
1069 : : integer :: idir,ipert,iv1
1070 : : ! *************************************************************************
1071 : :
1072 : : ! Get the number of perturbations computed for this iqpt
1073 [ + + + + ]: 165374 : pinfo = 0; cplex = 0; nperts = 0
1074 [ + + ]: 5048 : do ipert=1,db%natom ! selects atomic perturbations only.
1075 [ + + ]: 15038 : do idir=1,3
1076 : 9990 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1077 [ + + ]: 13320 : if (iv1 /= 0) then
1078 : 5416 : nperts = nperts + 1
1079 [ + + ]: 21664 : pinfo(:, nperts) = [idir, ipert, idir + (ipert-1)*3]
1080 [ + + ]: 5416 : if (cplex == 0) cplex = db%cplex_v1(iv1)
1081 [ - + ]: 5416 : ABI_CHECK_IEQ(cplex, db%cplex_v1(iv1), "cplex should be constant for given q!")
1082 : : end if
1083 : : end do
1084 : : end do
1085 : :
1086 : 1718 : end function dvdb_get_pinfo
1087 : : !!***
1088 : :
1089 : : !----------------------------------------------------------------------
1090 : :
1091 : : !!****f* m_dvdb/dvdb_read_onev1
1092 : : !! NAME
1093 : : !! dvdb_read_onev1
1094 : : !!
1095 : : !! FUNCTION
1096 : : !! Read the DFPT potential for the specified (idir, ipert, iqpt).
1097 : : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1098 : : !! get the index from the q-point in reduced coordinates.
1099 : : !!
1100 : : !! INPUTS
1101 : : !! idir=Direction of the perturbation
1102 : : !! ipert=Perturbation type.
1103 : : !! iqpt=Index of the q-point in dvdb%qpts
1104 : : !! cplex=1 if real, 2 if complex potentials.
1105 : : !! nfft=Number of fft-points treated by this processors
1106 : : !! ngfft(18)=contain all needed information about 3D FFT.
1107 : : !!
1108 : : !! OUTPUT
1109 : : !! ierr=Non-zero if error.
1110 : : !! v1scf(cplex*nfft, nspden)=DFT potential associated to (idir, ipert, iqpt).
1111 : : !! msg=String with error message if ierr /= 0.
1112 : : !!
1113 : : !! SOURCE
1114 : :
1115 : 5360 : integer function dvdb_read_onev1(db, idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) result(ierr)
1116 : :
1117 : : !Arguments ------------------------------------
1118 : : !scalars
1119 : : integer,intent(in) :: idir,ipert,iqpt,cplex,nfft
1120 : : character(len=*),intent(out) :: msg
1121 : : class(dvdb_t),intent(inout) :: db
1122 : : !arrays
1123 : : integer,intent(in) :: ngfft(18)
1124 : : real(dp),intent(out) :: v1scf(cplex*nfft,db%nspden)
1125 : :
1126 : : !Local variables-------------------------------
1127 : : !scalars
1128 : : integer,save :: enough = 0
1129 : : integer :: iv1,ispden,nfftot_file,nfftot_out,ifft
1130 : : !arrays
1131 : : integer :: ngfft_in(18),ngfft_out(18)
1132 : 5360 : real(dp),allocatable :: v1r_file(:,:)
1133 : : ! *************************************************************************
1134 : :
1135 : : ! Consistency checks
1136 : 5360 : ierr = 1
1137 : 5360 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1138 : :
1139 : 5360 : if (iv1 == 0) then
1140 : 0 : write(msg,"(3(a,i0))")"Cannot find idir: ",idir,", ipert: ",ipert,", iqpt:",iqpt
1141 : 0 : return
1142 : : end if
1143 : :
1144 [ - + ]: 5360 : if (cplex /= db%cplex_v1(iv1)) then
1145 : 0 : write(msg,"(2(a,i0))")"Wrong cplex. Expecting: ",db%cplex_v1(iv1),", received: ",cplex
1146 : 0 : return
1147 : : end if
1148 : :
1149 : : ! Find (idir, ipert, iqpt) and skip the header.
1150 : 5360 : call dvdb_seek(db, idir, ipert, iqpt)
1151 : 5360 : ierr = my_hdr_skip(db%fh, idir, ipert, db%qpts(:,iqpt), msg)
1152 [ - + ]: 5360 : if (ierr /= 0) then
1153 [ # # # # ]: 0 : msg = sjoin("In my_hdr_skip:", msg)
1154 : 0 : return
1155 : : end if
1156 : :
1157 : : ! Read v1 from file.
1158 [ + + ]: 21440 : nfftot_out = product(ngfft(:3)); nfftot_file = product(db%ngfft3_v1(:3, iv1))
1159 : :
1160 [ + + + + : 16244 : if (all(ngfft(:3) == db%ngfft3_v1(:3, iv1))) then
+ + ]
1161 [ + + ]: 7256 : do ispden=1,db%nspden
1162 [ + - ]: 7256 : read(db%fh, err=10, iomsg=msg) (v1scf(ifft, ispden), ifft=1,cplex*nfftot_file)
1163 : : end do
1164 : : else
1165 : : ! The FFT mesh used in the caller differ from the one found in the DVDB --> Fourier interpolation
1166 [ + + ]: 1732 : if (enough == 0) ABI_COMMENT("Performing FFT interpolation of DFPT potentials as input ngfft differs from ngfft_file.")
1167 : 1732 : enough = enough + 1
1168 [ - + + - : 6928 : ABI_MALLOC(v1r_file, (cplex*nfftot_file, db%nspden))
- + + - +
- + - - +
- + ]
1169 [ + + ]: 3464 : do ispden=1,db%nspden
1170 [ + - ]: 3464 : read(db%fh, err=10, iomsg=msg) (v1r_file(ifft, ispden), ifft=1,cplex*nfftot_file)
1171 : : end do
1172 : :
1173 : : ! Call fourier_interpol_seq to get v1scf on the ngfft mesh.
1174 : 1732 : ngfft_in = ngfft; ngfft_out = ngfft
1175 [ + + + + ]: 12124 : ngfft_in(1:3) = db%ngfft3_v1(1:3, iv1); ngfft_out(1:3) = ngfft(1:3)
1176 [ + + + + ]: 12124 : ngfft_in(4:6) = ngfft_in(1:3); ngfft_out(4:6) = ngfft_out(1:3)
1177 [ + + + + ]: 36372 : ngfft_in(9:18) = 0; ngfft_out(9:18) = 0
1178 : 1732 : ngfft_in(10) = 1; ngfft_out(10) = 1
1179 : :
1180 : 1732 : call fourier_interpol_seq(cplex, db%nspden, nfftot_file, ngfft_in, nfft, ngfft, v1r_file, v1scf)
1181 [ - + ]: 1732 : ABI_FREE(v1r_file)
1182 : : end if
1183 : :
1184 : : ! Skip record with rhog1_g0 (if present)
1185 [ + - + - ]: 5360 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
1186 : :
1187 : 5360 : db%current_fpos = db%current_fpos + 1
1188 : : !write(std_out, *)"incr current_fpos", db%current_fpos
1189 : :
1190 : 5360 : return
1191 : :
1192 : : ! Handle Fortran IO error
1193 : : 10 continue
1194 : 0 : ierr = 1
1195 [ # # # # ]: 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
1196 : :
1197 [ - + - + ]: 10720 : end function dvdb_read_onev1
1198 : : !!***
1199 : :
1200 : : !----------------------------------------------------------------------
1201 : :
1202 : : !!****f* m_dvdb/dvdb_readsym_allv1
1203 : : !! NAME
1204 : : !! dvdb_readsym_allv1
1205 : : !!
1206 : : !! FUNCTION
1207 : : !! Read all 3*natom DFPT potentials for the given iqpt (only atomic perturbations).
1208 : : !!
1209 : : !! The routine will:
1210 : : !!
1211 : : !! 1) Reconstruct the potentials by symmetry if the DVDB contains less than 3*natom potentials.
1212 : : !! 2) interpolate the data if the input FFT mesh defined by `ngfft` differs
1213 : : !! from the one used to store data in the file.
1214 : : !!
1215 : : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1216 : : !! get the index from the q-point in reduced coordinates.
1217 : : !!
1218 : : !! INPUTS
1219 : : !! iqpt=Index of the q-point in dvdb%qpts
1220 : : !! nfft=Number of fft-points treated by this processors
1221 : : !! ngfft(18)=contain all needed information about 3D FFT
1222 : : !! comm=MPI communicator
1223 : : !!
1224 : : !! OUTPUT
1225 : : !! cplex=1 if real, 2 if complex.
1226 : : !! v1scf(cplex, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
1227 : : !!
1228 : : !! SOURCE
1229 : :
1230 : 1660 : subroutine dvdb_readsym_allv1(db, iqpt, cplex, nfft, ngfft, v1scf, comm)
1231 : :
1232 : : !Arguments ------------------------------------
1233 : : !scalars
1234 : : integer,intent(in) :: iqpt,nfft,comm
1235 : : integer,intent(out) :: cplex
1236 : : class(dvdb_t),intent(inout) :: db
1237 : : !arrays
1238 : : integer,intent(in) :: ngfft(18)
1239 : : real(dp) ABI_ASYNC ,allocatable,intent(out) :: v1scf(:,:,:,:)
1240 : :
1241 : : !Local variables-------------------------------
1242 : : !scalars
1243 : : integer,parameter :: master=0
1244 : : integer :: ipc,npc,idir,ipert,pcase,my_rank,nproc,ierr,mu
1245 : : character(len=500) :: msg
1246 : : !arrays
1247 : 1660 : integer :: pinfo(3,3*db%mpert),pflag(3, db%natom)
1248 : : real(dp) :: tsec(2)
1249 : 1660 : integer,allocatable :: requests(:)
1250 : : ! *************************************************************************
1251 : :
1252 : : ! Keep track of total time spent.
1253 : 1660 : call timab(1805, 1, tsec)
1254 : :
1255 : 1660 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
1256 : :
1257 : : ! Get number of perturbations computed for this iqpt as well as cplex.
1258 : 1660 : npc = dvdb_get_pinfo(db, iqpt, cplex, pinfo)
1259 [ - + ]: 1660 : ABI_CHECK(npc /= 0, "npc == 0!")
1260 : :
1261 [ - + + - : 9960 : ABI_MALLOC_OR_DIE(v1scf, (cplex, nfft, db%nspden, 3*db%natom), ierr)
- + + - -
+ + - + -
- + + - +
- + - + -
+ - - + +
- - + ]
1262 : :
1263 : : ! Master read all available perturbations and broadcasts data (non-blocking to overlap IO and MPI)
1264 [ - + + - : 4980 : ABI_MALLOC(requests, (npc))
+ - + - -
+ - + ]
1265 : :
1266 [ + + ]: 6964 : do ipc=1,npc
1267 : 5304 : idir = pinfo(1,ipc); ipert = pinfo(2,ipc); pcase = pinfo(3, ipc)
1268 [ + - ]: 5304 : if (my_rank == master) then
1269 [ - + ]: 5304 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf(:,:,:,pcase), msg) /= 0) then
1270 : 0 : ABI_ERROR(msg)
1271 : : end if
1272 : : end if
1273 [ - + ]: 6964 : if (nproc > 1) call xmpi_ibcast(v1scf(:,:,:,pcase), master, comm, requests(ipc), ierr)
1274 : : end do
1275 : :
1276 [ - + ]: 1660 : if (nproc > 1) call xmpi_waitall(requests, ierr)
1277 [ - + ]: 1660 : ABI_FREE(requests)
1278 : :
1279 : : ! Return if all perts are available.
1280 [ + + ]: 1660 : if (npc == 3*db%natom) then
1281 [ + + ]: 380 : if (db%symv1==1) then
1282 [ - + ]: 16 : if (db%debug) write(std_out,*)"Potentials are available but will call v1phq_symmetrize because of symv1"
1283 [ + + ]: 112 : do mu=1,db%natom3
1284 : : !if (mod(mu, nproc) /= my_rank) cycle ! MPI parallelism.
1285 : 96 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1286 : : call v1phq_symmetrize(db%cryst,idir,ipert,db%symq_table(:,:,:,iqpt),ngfft,cplex,nfft,&
1287 : 112 : db%nspden,db%nsppol,db%mpi_enreg,v1scf(:,:,:,mu))
1288 : : !call MPI_Ibcast(void *buffer, int count, MPI_Datatype datatype, int root, MPI_Comm comm, MPI_Request *request)
1289 : : end do
1290 : : end if
1291 [ - + ]: 380 : if (db%debug) write(std_out,*)"All perts available. Returning"
1292 : 380 : call timab(1805, 2, tsec)
1293 : : return
1294 : : end if
1295 : :
1296 : : ! Perturbation are missing and we have to reconstruct them by symmetry.
1297 : : ! This is the common case when DFPT calculations are done for independent perturbations only.
1298 [ - + ]: 1280 : if (db%debug) write(std_out,*)sjoin("Will use symmetries to recostruct:", itoa(3*db%natom - npc), "perturbations")
1299 : :
1300 : : ! 0 if pert is not available.
1301 : : ! 1 if pert is on file.
1302 : : ! 2 if pert has been reconstructed by symmetry.
1303 [ + + + + ]: 11240 : pflag = 0
1304 [ + + ]: 4364 : do ipc=1,npc
1305 : 4364 : pflag(pinfo(1,ipc), pinfo(2,ipc)) = 1
1306 : : end do
1307 : :
1308 : 1280 : call v1phq_complete(db%cryst,db%qpts(:,iqpt),ngfft,cplex,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,v1scf)
1309 : :
1310 : 1280 : call timab(1805, 2, tsec)
1311 : :
1312 : : end subroutine dvdb_readsym_allv1
1313 : : !!***
1314 : :
1315 : : !----------------------------------------------------------------------
1316 : :
1317 : : !!****f* m_dvdb/dvdb_readsym_qbz
1318 : : !! NAME
1319 : : !! dvdb_readsym_qbz
1320 : : !!
1321 : : !! FUNCTION
1322 : : !! This is the MAIN ENTRY POINT for client code.
1323 : : !! Reconstruct the DFPT potential for a q-point in the BZ starting
1324 : : !! from its symmetrical image in the IBZ.
1325 : : !!
1326 : : !! INPUTS
1327 : : !! cryst<crystal_t>=crystal structure parameters
1328 : : !! qbz(3)=Q-point in BZ.
1329 : : !! qbz2db(6)=Symmetry mapping qbz --> DVDB qpoints produced using the SYMREC convention.
1330 : : !! Note that qbz2db(1) should give the index in the set of q-points in the DVDB
1331 : : !! that is not necessarily ORDERED as the IBZ computed by the Abinit routines.
1332 : : !! nfft=Number of fft-points treated by this processors
1333 : : !! ngfft(18)=contain all needed information about 3D FFT
1334 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations.
1335 : : !!
1336 : : !! OUTPUT
1337 : : !! cplex=1 if real, 2 if complex.
1338 : : !! v1scf(cplex, nfft, nspden, db%my_npert)= v1scf potentials on the real-space FFT mesh
1339 : : !! for the db%my_npert perturbations treated by this MPI rank.
1340 : : !!
1341 : : !! SOURCE
1342 : :
1343 : 1285 : subroutine dvdb_readsym_qbz(db, cryst, qbz, qbz2db, cplex, nfft, ngfft, v1scf, comm)
1344 : :
1345 : : !Arguments ------------------------------------
1346 : : !scalars
1347 : : class(dvdb_t),intent(inout) :: db
1348 : : integer,intent(in) :: nfft,comm
1349 : : integer,intent(out) :: cplex
1350 : : type(crystal_t),intent(in) :: cryst
1351 : : !arrays
1352 : : real(dp),intent(in) :: qbz(3)
1353 : : integer,intent(in) :: ngfft(18), qbz2db(6)
1354 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
1355 : :
1356 : : !Local variables-------------------------------
1357 : : !scalars
1358 : : integer :: db_iqpt, itimrev, isym, imyp
1359 : : logical :: isirr_q
1360 : : !arrays
1361 : : integer :: g0q(3)
1362 : : real(dp) :: tsec(2)
1363 : 1285 : real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:)
1364 : : ! *************************************************************************
1365 : :
1366 : : ABI_UNUSED(qbz(1))
1367 : :
1368 : : ! Keep track of total time spent.
1369 : 1285 : call timab(1802, 1, tsec)
1370 : :
1371 : 1285 : db_iqpt = qbz2db(1)
1372 : :
1373 : : ! IS(q_dvdb) + g0q = q_bz
1374 [ + + ]: 5140 : isym = qbz2db(2); itimrev = qbz2db(6) + 1; g0q = qbz2db(3:5)
1375 [ + + + + : 4731 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
1376 : :
1377 : : ! Read the dvscf potentials in the IBZ for all 3*natom perturbations.
1378 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
1379 [ - + ]: 1285 : call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm)
1380 : :
1381 [ + + ]: 1285 : if (.not. isirr_q) then
1382 : : ! Must rotate db_iqpt to get potential for qpoint in the BZ.
1383 : : ! Be careful with the shape of output v1scf because the routine returns db%my_npert potentials.
1384 : :
1385 [ + - ]: 702 : if (db%my_npert == db%natom3) then
1386 [ - + + - : 4212 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1387 [ + - + - : 154012518 : work = v1scf
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
1388 : : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1389 : 702 : db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert)
1390 [ - + ]: 702 : ABI_FREE(work)
1391 : :
1392 : : else
1393 : : ! Parallelism over perturbations.
1394 [ # # # # : 0 : ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1395 : :
1396 : : ! All 3 natom have been read in v1scf by dvdb_readsym_allv1
1397 : : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1398 : 0 : db%nspden, db%mpi_enreg, v1scf, work2, db%comm_pert)
1399 : :
1400 : : ! Reallocate v1scf with my_npert and extract data from work2.
1401 [ # # # # : 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1402 [ # # ]: 0 : do imyp=1,db%my_npert
1403 [ # # # # : 0 : v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp))
# # ]
1404 : : end do
1405 [ # # ]: 0 : ABI_FREE(work2)
1406 : : end if
1407 : :
1408 : : else
1409 : : ! Handle potentials read from file in case of parallelism over perturbations.
1410 [ - + ]: 583 : if (db%my_npert /= db%natom3) then
1411 [ # # # # : 0 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1412 [ # # ]: 0 : do imyp=1,db%my_npert
1413 [ # # # # : 0 : work(:,:,:,imyp) = v1scf(:,:,:,db%my_pinfo(3, imyp))
# # ]
1414 : : end do
1415 : :
1416 [ # # # # : 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1417 [ # # # # : 0 : v1scf = work
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1418 [ # # ]: 0 : ABI_FREE(work)
1419 : : end if
1420 : : end if ! not isirr_q
1421 : :
1422 : 1285 : call timab(1802, 2, tsec)
1423 : :
1424 [ - + - + ]: 1285 : end subroutine dvdb_readsym_qbz
1425 : : !!***
1426 : :
1427 : : !----------------------------------------------------------------------
1428 : :
1429 : : !!****f* m_dvdb/dvdb_read_vxc1_qbz
1430 : : !! NAME
1431 : : !! dvdb_read_vxc1_qbz
1432 : : !!
1433 : : !! FUNCTION
1434 : : !! Compute the first-order change of the exchange-correlation potential
1435 : : !! for a q-point in the BZ starting from its symmetrical image in the IBZ.
1436 : : !!
1437 : : !! INPUTS
1438 : : !! cryst<crystal_t>=crystal structure parameters
1439 : : !! dtset<dataset_type>=All input variables for this dataset
1440 : : !! qbz(3)=Q-point in BZ.
1441 : : !! mapc_qq2dvdb(6)=Symmetry mapping qbz, see m_kpts.f for a description
1442 : : !! nfft=Number of fft-points treated by this processors
1443 : : !! ngfft(18)=contain all needed information about 3D FFT
1444 : : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
1445 : : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
1446 : : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
1447 : : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
1448 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
1449 : : !!
1450 : : !! OUTPUT
1451 : : !! drho_cplex=1 if real, 2 if complex.
1452 : : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
1453 : : !! for the db%my_npert perturbations treated by this MPI rank.
1454 : : !!
1455 : : !! SOURCE
1456 : :
1457 : 80 : subroutine dvdb_read_vxc1_qbz(db, dtset, cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, nkxc, kxc, &
1458 : : vxc1, non_magnetic_xc, usexcnhat, comm)
1459 : :
1460 : : !Arguments ------------------------------------
1461 : : !scalars
1462 : : class(dvdb_t),intent(inout) :: db
1463 : : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
1464 : : integer,intent(out) :: drho_cplex
1465 : : real(dp),intent(in) :: qbz(3)
1466 : : type(dataset_type),intent(in) :: dtset
1467 : : type(crystal_t),intent(in) :: cryst
1468 : : logical,intent(in) :: non_magnetic_xc
1469 : : !arrays
1470 : : integer,intent(in) :: ngfft(18), mapc_qq2dvdb(6)
1471 : : real(dp),intent(in) :: kxc(nfft,nkxc)
1472 : : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
1473 : :
1474 : : !Local variables-------------------------------
1475 : : !scalars
1476 : : integer :: option,imyp
1477 : : !arrays
1478 : 80 : real(dp),allocatable :: rho1(:,:,:,:)
1479 : : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
1480 : : ! *************************************************************************
1481 : :
1482 : : ! Get rho1(cplex, nfftf, nspden, my_npert))
1483 : 80 : call db%readsym_qbz(cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, rho1, comm)
1484 : :
1485 : 80 : option=2 ! if 2, treat only density change
1486 [ - + ]: 80 : ABI_CHECK_IEQ(dtset%nspden, db%nspden, "dtset%nspden /= db%nspden")
1487 [ - + + - : 480 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1488 [ + + ]: 560 : do imyp=1,db%my_npert
1489 : : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
1490 : : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp), &
1491 : 560 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
1492 : : end do
1493 [ - + ]: 80 : ABI_FREE(rho1)
1494 : :
1495 : 80 : end subroutine dvdb_read_vxc1_qbz
1496 : : !!***
1497 : :
1498 : : !----------------------------------------------------------------------
1499 : :
1500 : : !!****f* m_dvdb/v1phq_complete
1501 : : !! NAME
1502 : : !! v1phq_complete
1503 : : !!
1504 : : !! FUNCTION
1505 : : !! Use the symmetries of the little group of the q-point to reconstruct
1506 : : !! the first order potentials starting from an initial irreducible set.
1507 : : !!
1508 : : !! INPUTS
1509 : : !! cryst<crystal_t>=crystal structure parameters
1510 : : !! qpt(3)=q-point in reduced coordinates.
1511 : : !! ngfft(18)=Info of FFT grid.
1512 : : !! cplex=1 if real potentials (qpt==gamma), 2 if complex
1513 : : !! nfft=(effective) number of FFT grid points (for this proc).
1514 : : !! nspden=number of spin-density components
1515 : : !! nsppol=Number of independent spin polarizations
1516 : : !! mpi_enreg=information about MPI parallelization
1517 : : !! symv1=If 1, the new potentials are symmetrized using the set of symmetries that leaves the
1518 : : !! perturbation invariant.
1519 : : !!
1520 : : !! SIDE EFFECTS
1521 : : !! pflag(3,natom)= For each atomic perturbation:
1522 : : !! 0 if pert is not available. 1 if pert is available. 2 if pert has been reconstructed by symmetry.
1523 : : !! Initialized by the caller. Changed in output.
1524 : : !! v1scf(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials.
1525 : : !! in input: filled with the irreducible potentials (corresponding pflag set to 1)
1526 : : !! output: Contains full set of perturbations.
1527 : : !!
1528 : : !! SOURCE
1529 : :
1530 : 1280 : subroutine v1phq_complete(cryst,qpt,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,symv1,pflag,v1scf)
1531 : :
1532 : : !Arguments ------------------------------------
1533 : : !scalars
1534 : : integer,intent(in) :: cplex,nfft,nspden,nsppol
1535 : : integer,intent(in) :: symv1
1536 : : type(crystal_t),intent(in) :: cryst
1537 : : type(MPI_type),intent(in) :: mpi_enreg
1538 : : !arrays
1539 : : integer,intent(in) :: ngfft(18)
1540 : : integer,intent(inout) :: pflag(3, cryst%natom)
1541 : : real(dp),intent(in) :: qpt(3)
1542 : : real(dp),intent(inout) :: v1scf(cplex*nfft,nspden,3*cryst%natom)
1543 : :
1544 : : !Local variables-------------------------------
1545 : : !scalars
1546 : : integer,parameter :: syuse0=0,rfmeth2=2,tim_fourdp0=0
1547 : : integer :: idir,ipert,tsign,isym_eq,itirev_eq,ipert_eq !,itirev
1548 : : integer :: pcase,trev_q,idir_eq,pcase_eq,ispden,cnt
1549 : : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot
1550 : : real(dp) :: arg
1551 : : logical :: has_phase
1552 : : logical,parameter :: debug=.False.
1553 : : character(len=500) :: msg
1554 : : !integer,save :: enough=0
1555 : : !arrays
1556 : : integer :: symrel_eq(3,3),symrec_eq(3,3),g0_qpt(3),l0(3),tsm1g(3) !symm(3,3),
1557 : 2560 : integer :: symq(4,2,cryst%nsym)
1558 : : real(dp) :: phnon1(2),tnon(3)
1559 : 1280 : real(dp),allocatable :: workg(:,:), workg_eq(:,:),v1g(:,:,:)
1560 : : ! *************************************************************************
1561 : :
1562 [ + + ]: 5120 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
1563 [ - + ]: 1280 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
1564 : 1280 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
1565 : :
1566 [ - + + - : 5120 : ABI_MALLOC(v1g, (2,nfft,nspden))
- + + - +
- + - - +
- + ]
1567 [ - + + - : 3840 : ABI_MALLOC(workg_eq, (2, nfft))
+ - + - -
+ - + ]
1568 [ - + + - : 2560 : ABI_MALLOC(workg, (2, nfft))
- + - + ]
1569 : :
1570 : : ! Examine the symmetries of the q wavevector
1571 : 1280 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
1572 : :
1573 : : pcase_loop: &
1574 [ + + ]: 8750 : do pcase=1,3*cryst%natom
1575 : 7470 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
1576 [ + + ]: 7470 : if (pflag(idir, ipert) /= 0) cycle ! This pcase is available
1577 : :
1578 : : ! Find symmetry which links to the perturbation requested (pcase)
1579 : 4386 : call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1580 : : !if (isym_eq == -1) then
1581 : : ! call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1582 : : !end if
1583 : :
1584 [ + - ]: 4386 : if (isym_eq == -1) then
1585 : : if (debug) write(std_out,*)"Cannot find isym eq for idir, ipert:", idir,ipert
1586 : : cycle pcase_loop
1587 : : end if
1588 : :
1589 : : ! set flag since we will reconstruct pcase from isym_eq.
1590 : 4386 : pflag(idir, ipert) = 2
1591 : :
1592 [ + + + + ]: 57018 : symrel_eq = cryst%symrel(:,:,isym_eq)
1593 [ + + + + ]: 57018 : symrec_eq = cryst%symrec(:,:,isym_eq)
1594 : 4386 : tsign = 3-2*itirev_eq
1595 : :
1596 : : ! Phase due to L0 + R^{-1}tau
1597 [ + + ]: 17544 : l0 = cryst%indsym(1:3,isym_eq,ipert)
1598 : :
1599 [ + + + + : 122808 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym_eq))
+ + + + +
- + + ]
1600 [ + + + + ]: 10615 : has_phase = any(abs(tnon) > tol12)
1601 : : ! FIXME
1602 : : !ABI_CHECK(.not. has_phase, "has phase must be tested")
1603 : : !if (has_phase) then
1604 : : ! enough = enough + 1
1605 : : ! if (enough == 1) ABI_WARNING("has phase must be tested")
1606 : : !end if
1607 : :
1608 [ + + + + ]: 156331938 : workg = zero
1609 : :
1610 : : ! Reconstruct DFPT potential. Final results stored in v1g.
1611 : : if (debug) write(std_out,*)"Reconstructing idir:", idir, ", ipert:", ipert
1612 [ + + + + : 156336324 : v1g = zero; cnt = 0
+ + ]
1613 [ + + ]: 17544 : do idir_eq=1,3
1614 [ + + ]: 13158 : if (symrec_eq(idir, idir_eq) == 0) cycle
1615 : 5792 : cnt = cnt + 1
1616 : 5792 : pcase_eq = idir_eq + (ipert_eq-1)*3
1617 : : if (debug) write(std_out,*) "idir_eq: ", idir_eq, ", ipert_eq: ", ipert_eq, ", tsign: ", tsign
1618 : :
1619 [ - + ]: 5792 : if (pflag(idir_eq, ipert_eq) == 0) then
1620 : 0 : write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1621 : 0 : ABI_ERROR(msg)
1622 : : end if
1623 : :
1624 : : !if (pflag(idir_eq, ipert_eq) == 0) then
1625 : : ! write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1626 : : ! ABI_ERROR(msg)
1627 : : !end if
1628 : :
1629 [ + + ]: 15970 : do ispden=1,nspden
1630 : : ! Get symmetric perturbation in G-space in workg_eq array.
1631 : 5792 : call fourdp(cplex,workg_eq,v1scf(:,ispden,pcase_eq),-1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1632 : : !call zerosym(workg_eq,cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1633 : :
1634 : : !call rotate_fqg(itirev_eq,symrec_eq,qpt,tnon,ngfft,nfft,nspden,workg_eq,workg)
1635 : 5792 : ind1=0
1636 [ + + ]: 125902 : do i3=1,n3
1637 : : ! Get location of G vector (grid point) centered at 0 0 0
1638 : 120110 : l3 = i3-(i3/id3)*n3-1
1639 [ + + ]: 2853400 : do i2=1,n2
1640 : 2727498 : l2 = i2-(i2/id2)*n2-1
1641 [ + + ]: 71026750 : do i1=1,n1
1642 : 68179142 : ind1=ind1+1
1643 : :
1644 : 68179142 : l1 = i1-(i1/id1)*n1-1
1645 : :
1646 : : ! Get rotated G vector Gj for each symmetry element
1647 : : ! -- here we use the TRANSPOSE of symrel_eq; assuming symrel_eq expresses
1648 : : ! the rotation in real space, the transpose is then appropriate
1649 : : ! for G space symmetrization (p. 1172d,e of notes, 2 June 1995).
1650 : 68179142 : j1 = tsign * (symrel_eq(1,1)*l1+symrel_eq(2,1)*l2+symrel_eq(3,1)*l3)
1651 : 68179142 : j2 = tsign * (symrel_eq(1,2)*l1+symrel_eq(2,2)*l2+symrel_eq(3,2)*l3)
1652 : 68179142 : j3 = tsign * (symrel_eq(1,3)*l1+symrel_eq(2,3)*l2+symrel_eq(3,3)*l3)
1653 : :
1654 : : ! We are not working on the G-sphere thus SG may be outside of the box
1655 : : ! (only for G outside the sphere inscribed in the box): set these components to zero.
1656 : : ! This check is not done in irrzg.
1657 : : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
1658 [ + + + + : 68179142 : (j2 > n2/2 .or. j2 < -(n2-1)/2) .or. &
+ + + + +
+ + + ]
1659 : : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
1660 [ + + ]: 57935811 : workg(:, ind1) = zero; cycle
1661 : : end if
1662 : :
1663 [ + + ]: 195468820 : tsm1g = [j1,j2,j3] ! +- S^{-1} G
1664 : :
1665 : : ! Map into [0,n-1] and then add 1 for array index in [1,n]
1666 : 48867205 : k1=1+mod(n1+mod(j1,n1),n1)
1667 : 48867205 : k2=1+mod(n2+mod(j2,n2),n2)
1668 : 48867205 : k3=1+mod(n3+mod(j3,n3),n3)
1669 : :
1670 : : ! Get linear index of rotated point Gj
1671 : 48867205 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
1672 : :
1673 [ + + ]: 48867205 : if (has_phase) then
1674 : : ! compute exp(-2*Pi*I*G dot tau) using original G
1675 : : ! NB: this phase is same as that in irrzg and phnons1, and corresponds
1676 : : ! to complex conjugate of phase from G to Gj;
1677 : : ! we use it immediately below, to go _to_ workg_eq(ind1)
1678 [ + + ]: 109219508 : arg = two_pi * dot_product(qpt + tsm1g, tnon)
1679 : 27304877 : phnon1(1) = cos(arg); phnon1(2) = -sin(arg)
1680 : :
1681 : : ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G)
1682 : 27304877 : workg(1, ind1) = phnon1(1) * workg_eq(1, ind2) - phnon1(2) * workg_eq(2, ind2)
1683 : 27304877 : workg(2, ind1) = phnon1(1) * workg_eq(2, ind2) + phnon1(2) * workg_eq(1, ind2)
1684 : : else
1685 : 21562328 : workg(1, ind1) = workg_eq(1, ind2)
1686 : 21562328 : workg(2, ind1) = workg_eq(2, ind2)
1687 : : end if
1688 : :
1689 : : ! Take complex conjugate if time-reversal is used.
1690 [ + + ]: 51594703 : if (tsign == -1) workg(2, ind1) = -workg(2, ind1)
1691 : : end do
1692 : : end do
1693 : : end do
1694 : :
1695 [ + + + + ]: 204556376 : v1g(:,:,ispden) = v1g(:,:,ispden) + workg * symrec_eq(idir, idir_eq)
1696 : : end do ! ispden
1697 : : end do ! idir_eq
1698 : : !if (debug) write(std_out,*)"Used ",cnt," equivalent perturbations"
1699 : :
1700 : : ! Get potential in real space (results in v1scf)
1701 [ + + ]: 8772 : do ispden=1,nspden
1702 : : !call zerosym(v1g(:,:,ispden),cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1703 : 4386 : call fourdp(cplex,v1g(:,:,ispden),v1scf(:,ispden,pcase),+1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1704 : :
1705 : : ! IS(q) = q + G0
1706 : : ! we want q so we have to multiply by exp(iG0r) in real space.
1707 [ + + + + : 16731 : if (any(g0_qpt /= 0)) then
+ + ]
1708 [ - + ]: 1802 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1709 : : if (debug) write(std_out,*)"Found not zero g0_qpt", g0_qpt ! for idir: ", idir, ", ipert: ", ipert
1710 : 1802 : call times_eigr(g0_qpt, ngfft, nfft, 1, v1scf(:,ispden,pcase))
1711 : : end if
1712 : : end do
1713 : :
1714 [ + + ]: 5666 : if (symv1 == 1) then
1715 : : if (debug) write(std_out,*)" Calling v1phq_symmetrize"
1716 : 376 : call v1phq_symmetrize(cryst,idir,ipert,symq,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,v1scf(:,:,pcase))
1717 : : end if
1718 : : end do pcase_loop
1719 : :
1720 [ - + ]: 1280 : ABI_FREE(v1g)
1721 [ - + ]: 1280 : ABI_FREE(workg)
1722 [ - + ]: 1280 : ABI_FREE(workg_eq)
1723 : :
1724 : : ! Handle possible error.
1725 [ + + + + : 11240 : if (any(pflag == 0)) then
+ - - + ]
1726 [ # # ]: 0 : write(std_out,"(2a)")"The following perturbations cannot be recostructed by symmetry for q-point: ",trim(ktoa(qpt))
1727 [ # # ]: 0 : do ipert=1,cryst%natom
1728 [ # # ]: 0 : do idir=1,3
1729 [ # # ]: 0 : if (pflag(idir, ipert) == 0) write(std_out,"(2(a,i0))")"idir= ",idir,", ipert= ",ipert
1730 : : end do
1731 : : end do
1732 : : write(msg,"(5a)")&
1733 : 0 : "Cannot recostruct all 3*natom atomic perturbations from file",ch10,&
1734 : 0 : "This usually happens when the DVDB does not contain all the independent perturbations for this q-point",ch10,&
1735 : 0 : "See above message for further information."
1736 : 0 : ABI_ERROR(msg)
1737 : : end if
1738 : :
1739 : 1280 : end subroutine v1phq_complete
1740 : : !!***
1741 : :
1742 : : !----------------------------------------------------------------------
1743 : :
1744 : : !!****f* m_dvdb/find_symeq
1745 : : !! NAME
1746 : : !! find_symeq
1747 : : !!
1748 : : !! FUNCTION
1749 : : !! Find symmetry which links to the perturbation specified by (idir, ipert)
1750 : : !!
1751 : : !! INPUTS
1752 : : !! cryst<crystal_t>=crystal structure parameters
1753 : : !! idir=Direction of the perturbation
1754 : : !! ipert=Perturbation type.
1755 : : !! symq(4,2,nsym)=Table produced by littlegroup_q for this q-point.
1756 : : !! pflag(3,natom)= For each atomic perturbation:
1757 : : !! 0 if pert is not available. 1 if pert is available. 2 if pert can been reconstructed by symmetry.
1758 : : !!
1759 : : !! OUTPUT
1760 : : !! ipert_eq
1761 : : !! isym_eq
1762 : : !! itirev_eq
1763 : : !! g0_qpt(3)
1764 : : !!
1765 : : !! SOURCE
1766 : :
1767 : 4386 : subroutine find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0)
1768 : :
1769 : : !Arguments ------------------------------------
1770 : : !scalars
1771 : : integer,intent(in) :: idir,ipert
1772 : : integer,intent(out) :: ipert_eq,isym_eq,itirev_eq
1773 : : type(crystal_t),intent(in) :: cryst
1774 : : logical,optional :: allow_g0
1775 : : !arrays
1776 : : integer,intent(in) :: symq(4,2,cryst%nsym),pflag(3,cryst%natom)
1777 : : integer,intent(out) :: g0_qpt(3)
1778 : :
1779 : : !Local variables-------------------------------
1780 : : !scalars
1781 : : logical :: do_allow_g0
1782 : : integer :: isym,idir_eq,ip,itirev
1783 : : ! *************************************************************************
1784 : :
1785 : 4386 : isym_eq = -1; ipert_eq = -1
1786 [ + - ]: 4386 : do_allow_g0 = .true.; if (present(allow_g0)) do_allow_g0 = allow_g0
1787 : :
1788 : : symloop: &
1789 [ + - ]: 4687 : do itirev=1,2
1790 : 4687 : itirev_eq = itirev
1791 [ + + ]: 54562 : do isym=1,cryst%nsym
1792 : :
1793 : : ! Check that isym preserves the q-point
1794 : : ! The condition is
1795 : : !
1796 : : ! $q = O S(q) - G$
1797 : : !
1798 : : ! with O being either the identity or the time reversal symmetry (= inversion in reciprocal space)
1799 : : ! and G being a primitive vector of the reciprocal lattice.
1800 : :
1801 : : !if (symq(4,itirev,isym) /= 1 .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1802 [ + + ]: 49875 : if (symq(4,itirev,isym) /= 1) cycle ! .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1803 [ + + + + : 60918 : if (any(symq(1:3,itirev,isym) /= 0) .and. .not. do_allow_g0) cycle
- + ]
1804 [ + + ]: 72440 : g0_qpt = symq(1:3,itirev,isym)
1805 : :
1806 : : ! indsym map is computed in symatm.
1807 [ + + ]: 46354 : do ip=1,cryst%natom
1808 : : !if (.not. cryst%indsym(4,isym,ip) == ipert) cycle
1809 [ + + ]: 32329 : if (.not. cryst%indsym(4,isym,ipert) == ip) cycle
1810 : 18110 : isym_eq = isym; ipert_eq = ip
1811 [ + + ]: 72440 : do idir_eq=1,3
1812 [ + + + + : 54330 : if (idir_eq == idir .and. ip == ipert .and. cryst%symrec(idir,idir_eq,isym) /= 0) isym_eq = -1
+ + ]
1813 [ + + + + ]: 72440 : if (cryst%symrec(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1814 : : !if (cryst%symrel(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1815 : : !if (idir_eq == idir .and. ip == ipert) cycle
1816 : 16209 : isym_eq = -1
1817 : : end if
1818 : : end do
1819 [ + + ]: 63599 : if (isym_eq /= -1) exit symloop
1820 : : end do
1821 : : end do
1822 : : end do symloop
1823 : :
1824 [ - + ]: 4386 : if (isym_eq == -1) then
1825 : 0 : ipert_eq = -1; itirev_eq = -1
1826 : : end if
1827 : :
1828 : 4386 : end subroutine find_symeq
1829 : : !!***
1830 : :
1831 : : !----------------------------------------------------------------------
1832 : :
1833 : : !!****f* m_dvdb/v1phq_rotate
1834 : : !! NAME
1835 : : !! v1phq_rotate
1836 : : !!
1837 : : !! FUNCTION
1838 : : !! Reconstruct all the DFPT potential for a q-point in the BZ (qpt_bz) starting from its symmetrical image in the IBZ (q_ibz)
1839 : : !!
1840 : : !! INPUTS
1841 : : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1842 : : !! cryst<crystal_t>=crystal structure parameters
1843 : : !! isym, itimrev, g0q: Symmetry indices and umklapp. The q-point in the BZ is given by:
1844 : : !!
1845 : : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
1846 : : !!
1847 : : !! where S is symrec(:,:,isym)
1848 : : !! ngfft=array of dimensions for different FFT grids
1849 : : !! ngfft(18)=contain all needed information about 3D FFT.
1850 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
1851 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
1852 : : !! nspden=number of spin-density components
1853 : : !! mpi_enreg=information about MPI parallelization
1854 : : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
1855 : : !! for the irreducible q-point `qpt_ibz`
1856 : : !! comm: MPI communicator to distribute natom3 * nspden FFT calls
1857 : : !!
1858 : : !! OUTPUT
1859 : : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
1860 : : !!
1861 : : !! SOURCE
1862 : :
1863 : 2050 : subroutine v1phq_rotate(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
1864 : 2050 : mpi_enreg, v1r_qibz, v1r_qbz, comm)
1865 : :
1866 : : !Arguments ------------------------------------
1867 : : !scalars
1868 : : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, comm
1869 : : type(crystal_t),intent(in) :: cryst
1870 : : type(MPI_type),intent(in) :: mpi_enreg
1871 : : !arrays
1872 : : integer,intent(in) :: g0q(3),ngfft(18)
1873 : : real(dp),intent(in) :: qpt_ibz(3)
1874 : : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
1875 : : real(dp) ABI_ASYNC, intent(out) :: v1r_qbz(cplex*nfft,nspden,3*cryst%natom)
1876 : :
1877 : : !Local variables-------------------------------
1878 : : !scalars
1879 : : integer,parameter :: tim_fourdp0 = 0
1880 : : !integer,save :: enough = 0
1881 : : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,my_rank,nproc,ierr,root
1882 : : !arrays
1883 : : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
1884 : : real(dp) :: tnon(3), tsec(2)
1885 : 2050 : real(dp) ABI_ASYNC, allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
1886 : 4100 : integer :: requests(nspden, 3*cryst%natom), requests_v1r_qbz(3*cryst%natom)
1887 : 4100 : logical :: requests_v1g_qibz_done(nspden, 3*cryst%natom)
1888 : : ! *************************************************************************
1889 : :
1890 : : ! Keep track of total time spent.
1891 : 2050 : call timab(1804, 1, tsec)
1892 : :
1893 [ - + ]: 2050 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1894 : :
1895 : 2050 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1896 : 2050 : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
1897 : :
1898 : : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
1899 [ + - - + : 10250 : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
1900 [ + + + + ]: 25612 : requests_v1g_qibz_done = .False.
1901 : : cnt = 0
1902 [ + + ]: 13831 : do mu=1,natom3
1903 [ + + ]: 25612 : do ispden=1,nspden
1904 : 11781 : cnt = cnt + 1; root = mod(cnt, nproc)
1905 [ + - ]: 11781 : if (root == my_rank) then ! Non-blocking
1906 : 11781 : call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1907 : : end if
1908 : 23562 : call xmpi_ibcast(v1g_qibz(:,ispden,mu), root, comm, requests(ispden, mu), ierr)
1909 : : end do
1910 : : end do
1911 : :
1912 [ - + + - : 8200 : ABI_MALLOC(workg, (2*nfft, nspden))
- + + - +
- + - - +
- + - + ]
1913 [ - + + - : 6150 : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
- + + - -
+ - + -
+ ]
1914 : :
1915 [ + + + + ]: 26650 : symrec_eq = cryst%symrec(:,:,isym)
1916 : : ! Compute sm1 = symrec_eq^{-1}
1917 [ + + + + : 51250 : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
+ + + + ]
1918 : :
1919 : : ! For each perturbation (idir, ipert, qpt_bz), rotate the symmetrical potentials at (idir_eq, ipert_eq, q_ibz)
1920 : : ! computed in g-space and take linear combinations using symrec_eq(idir, idir_eq).
1921 : : ! Finally, perform g -- >r FFTs of the potentials at qpt_bz and multiply by e^{-ig0.r} to account for umklapp.
1922 : :
1923 : : ! See Eq C2 in [[cite:Brunin2020b]] 10.1103/PhysRevB.102.094308
1924 [ + + ]: 13831 : do mu=1,natom3
1925 : 11781 : root = mod(mu, nproc)
1926 : : ! MPI parallelism.
1927 [ + - ]: 11781 : if (root == my_rank) then
1928 : 11781 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1929 : :
1930 : : ! Phase due to L0 + R^{-1} tau where R is a symrel operation hence R^{-1} = symrec_eq^T
1931 [ + + ]: 47124 : l0 = cryst%indsym(1:3,isym,ipert)
1932 [ + + + + : 329868 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
+ + + + +
- + + ]
1933 : : !if (.not. all(abs(tnon) < tol12)) then
1934 : : ! enough = enough + 1
1935 : : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
1936 : : !end if
1937 : :
1938 : 11781 : ipert_eq = cryst%indsym(4, isym, ipert)
1939 : :
1940 [ + + + + ]: 236947674 : v1g_mu = zero; cnt = 0
1941 [ + + ]: 47124 : do idir_eq=1,3
1942 [ + + ]: 35343 : if (symrec_eq(idir, idir_eq) == 0) cycle
1943 : 18377 : mu_eq = idir_eq + (ipert_eq - 1) * 3
1944 : 18377 : cnt = cnt + 1
1945 : :
1946 : : ! Wait for request before operating on v1g_qibz
1947 [ + + + + : 24973 : if (.not. all(requests_v1g_qibz_done(:, mu_eq))) then
+ + ]
1948 [ + + ]: 23562 : do ispden=1,nspden
1949 : 11781 : call xmpi_wait(requests(ispden, mu_eq), ierr)
1950 : 23562 : requests_v1g_qibz_done(ispden, mu_eq) = .True.
1951 : : end do
1952 : : end if
1953 : :
1954 : : ! Rotate in G-space: output in workg
1955 : 18377 : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
1956 : : ! And accumulate in v1g_mu
1957 [ + - + - : 367576854 : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
- + - - +
+ + + ]
1958 : : end do ! idir_eq
1959 : :
1960 [ - + ]: 11781 : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
1961 : :
1962 : : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
1963 [ + + ]: 23562 : do ispden=1,nspden
1964 : 11781 : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, mu), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1965 [ + + ]: 58905 : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, mu))
1966 : : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,mu))
1967 : : end do
1968 : :
1969 : : end if ! root == myrank
1970 : :
1971 : 13831 : call xmpi_ibcast(v1r_qbz(:,:,mu), root, comm, requests_v1r_qbz(mu), ierr)
1972 : : end do ! mu
1973 : :
1974 : : ! Release all requests
1975 : 2050 : call xmpi_waitall(requests, ierr)
1976 : 2050 : call xmpi_waitall(requests_v1r_qbz, ierr)
1977 : :
1978 [ - + ]: 2050 : ABI_FREE(workg)
1979 [ - + ]: 2050 : ABI_FREE(v1g_mu)
1980 [ - + ]: 2050 : ABI_FREE(v1g_qibz)
1981 : :
1982 : 2050 : call timab(1804, 2, tsec)
1983 : :
1984 [ - + - + : 2050 : end subroutine v1phq_rotate
- + ]
1985 : : !!***
1986 : :
1987 : : !----------------------------------------------------------------------
1988 : :
1989 : : !!****f* m_dvdb/v1phq_rotate_myperts
1990 : : !! NAME
1991 : : !! v1phq_rotate_myperts
1992 : : !!
1993 : : !! FUNCTION
1994 : : !! Reconstruct all the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ.
1995 : : !!
1996 : : !! INPUTS
1997 : : !! cryst<crystal_t>=crystal structure parameters
1998 : : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1999 : : !! ngfft=array of dimensions for different FFT grids
2000 : : !! isym, itimrev, g0q:
2001 : : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
2002 : : !! ngfft(18)=contain all needed information about 3D FFT.
2003 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2004 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2005 : : !! nspden=number of spin-density components
2006 : : !! mpi_enreg=information about MPI parallelization
2007 : : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
2008 : : !! for the irreducible q-point `qpt_ibz`
2009 : : !!
2010 : : !! OUTPUT
2011 : : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
2012 : : !!
2013 : : !! SOURCE
2014 : :
2015 : : subroutine v1phq_rotate_myperts(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
2016 : : mpi_enreg, my_npert, my_pinfo, v1r_qibz, v1r_qbz)
2017 : :
2018 : : !Arguments ------------------------------------
2019 : : !scalars
2020 : : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, my_npert
2021 : : type(crystal_t),intent(in) :: cryst
2022 : : type(MPI_type),intent(in) :: mpi_enreg
2023 : : !arrays
2024 : : integer,intent(in) :: g0q(3), ngfft(18), my_pinfo(3, my_npert)
2025 : : real(dp),intent(in) :: qpt_ibz(3)
2026 : : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
2027 : : real(dp),intent(out) :: v1r_qbz(cplex*nfft,nspden,my_npert)
2028 : :
2029 : : !Local variables-------------------------------
2030 : : !scalars
2031 : : integer,parameter :: tim_fourdp0 = 0
2032 : : !integer,save :: enough = 0
2033 : : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,imyp !ierr,
2034 : : !arrays
2035 : : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
2036 : : logical :: fourdp_done(3*cryst%natom)
2037 : : real(dp) :: tnon(3), tsec(2)
2038 : : real(dp), allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
2039 : : ! *************************************************************************
2040 : :
2041 : : ! Keep track of total time spent.
2042 : : call timab(1804, 1, tsec)
2043 : :
2044 : : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
2045 : :
2046 : : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
2047 : :
2048 : : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
2049 : : fourdp_done = .False.
2050 : : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
2051 : : !do mu=1,natom3
2052 : : ! do ispden=1,nspden
2053 : : ! call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2054 : : ! end do
2055 : : !end do
2056 : :
2057 : : ABI_MALLOC(workg, (2*nfft, nspden))
2058 : : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
2059 : :
2060 : : symrec_eq = cryst%symrec(:,:,isym)
2061 : : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
2062 : :
2063 : : ! For each perturbation treated by this MPI proc
2064 : : do imyp=1,my_npert
2065 : : idir = my_pinfo(1, imyp); ipert = my_pinfo(2, imyp); mu = my_pinfo(3, imyp)
2066 : :
2067 : : ! Phase due to L0 + R^{-1}tau
2068 : : l0 = cryst%indsym(1:3,isym,ipert)
2069 : : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
2070 : : !if (.not. all(abs(tnon) < tol12)) then
2071 : : ! enough = enough + 1
2072 : : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
2073 : : !end if
2074 : :
2075 : : ipert_eq = cryst%indsym(4, isym, ipert)
2076 : :
2077 : : v1g_mu = zero; cnt = 0
2078 : : do idir_eq=1,3
2079 : : if (symrec_eq(idir, idir_eq) == 0) cycle
2080 : : mu_eq = idir_eq + (ipert_eq - 1) * 3
2081 : : cnt = cnt + 1
2082 : :
2083 : : if (.not. fourdp_done(mu_eq)) then
2084 : : do ispden=1,nspden
2085 : : call fourdp(cplex, v1g_qibz(:,ispden,mu_eq), v1r_qibz(:,ispden,mu_eq), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2086 : : end do
2087 : : fourdp_done(mu_eq) = .True.
2088 : : end if
2089 : :
2090 : : ! Rotate in G-space and accumulate in workg
2091 : : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
2092 : : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
2093 : : end do ! idir_eq
2094 : :
2095 : : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
2096 : :
2097 : : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
2098 : : do ispden=1,nspden
2099 : : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, imyp), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2100 : : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, imyp))
2101 : : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,imyp))
2102 : : end do
2103 : :
2104 : : end do ! imyp
2105 : :
2106 : : ABI_FREE(workg)
2107 : : ABI_FREE(v1g_mu)
2108 : : ABI_FREE(v1g_qibz)
2109 : :
2110 : : call timab(1804, 2, tsec)
2111 : :
2112 : : end subroutine v1phq_rotate_myperts
2113 : : !!***
2114 : :
2115 : : !!****f* m_dvdb/v1phq_symmetrize
2116 : : !! NAME
2117 : : !! v1phq_symmetrize
2118 : : !!
2119 : : !! FUNCTION
2120 : : !! Enforce spatial-symmetry on the DFPT potential.
2121 : : !!
2122 : : !! INPUTS
2123 : : !! cryst<crystal_t>=crystal structure parameters
2124 : : !! idir=Direction of the perturbation
2125 : : !! ipert=Perturbation type.
2126 : : !! symq(4,2,nsym)= Table computed by littlegroup_q.
2127 : : !! three first numbers define the G vector;
2128 : : !! fourth number is zero if the q-vector is not preserved, is 1 otherwise
2129 : : !! second index is one without time-reversal symmetry, two with time-reversal symmetry
2130 : : !! ngfft=array of dimensions for different FFT grids
2131 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2132 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2133 : : !! nspden=number of spin-density components
2134 : : !! mpi_enreg=information about MPI parallelization
2135 : : !!
2136 : : !! SIDE EFFECTS
2137 : : !! v1r(cplex*nfft,nspden)=Array with first order potentials in real space. Symmetrized in output.
2138 : : !!
2139 : : !! SOURCE
2140 : :
2141 : 1718 : subroutine v1phq_symmetrize(cryst, idir, ipert, symq, ngfft, cplex, nfft, nspden, nsppol, mpi_enreg, v1r)
2142 : :
2143 : : !Arguments ------------------------------------
2144 : : !scalars
2145 : : integer,intent(in) :: idir, ipert, cplex, nfft, nspden, nsppol
2146 : : type(crystal_t),intent(in) :: cryst
2147 : : type(MPI_type),intent(in) :: mpi_enreg
2148 : : !arrays
2149 : : integer,intent(in) :: symq(4,2,cryst%nsym),ngfft(18)
2150 : : real(dp),intent(inout) :: v1r(cplex*nfft,nspden)
2151 : :
2152 : : !Local variables-------------------------------
2153 : : integer,parameter :: syuse0 = 0, rfmeth2 = 2, iscf1 = 1
2154 : : integer :: nsym1, nfftot
2155 : : !arrays
2156 : 3436 : integer :: symafm1(cryst%nsym),symrel1(3,3,cryst%nsym),symrc1(3,3,cryst%nsym)
2157 : 1718 : integer,allocatable :: irrzon1(:,:,:),indsy1(:,:,:)
2158 : 0 : real(dp) :: tnons1(3,cryst%nsym)
2159 : 1718 : real(dp),allocatable :: phnons1(:,:,:),v1g(:,:)
2160 : : ! *************************************************************************
2161 : :
2162 [ - + ]: 1718 : if (cryst%nsym == 1) return
2163 : :
2164 [ + + ]: 6872 : nfftot = product(ngfft(1:3))
2165 [ - + ]: 1718 : ABI_CHECK(nfft == nfftot, "MPI-FFT not coded")
2166 : :
2167 : : ! Symmetrize (copied from dfpt_looppert)
2168 : : ! Determines the set of symmetries that leaves the perturbation invariant.
2169 : : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
2170 : 1718 : cryst%symafm,symafm1,symq,cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,tnons1,unit=dev_null)
2171 : :
2172 : : ! Set up corresponding symmetry data
2173 [ - + + - : 6872 : ABI_MALLOC(irrzon1, (nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4)))
- + + - +
- + - - +
- + ]
2174 [ - + + - : 6872 : ABI_MALLOC(phnons1, (2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4)))
- + + - +
- + - - +
- + ]
2175 [ - + + - : 6872 : ABI_MALLOC(indsy1,(4,nsym1,cryst%natom))
- + + - +
- + - - +
- + ]
2176 : :
2177 : : call setsym(indsy1,irrzon1,iscf1,cryst%natom,nfft,ngfft,nspden,nsppol,&
2178 : 1718 : nsym1,phnons1,symafm1,symrc1,symrel1,tnons1,cryst%typat,cryst%xred)
2179 : :
2180 : : !if (psps%usepaw==1) then
2181 : : ! ! Allocate/initialize only zarot in pawang1 datastructure
2182 : : ! call pawang_init(pawang1,0,0,pawang%l_max-1,0,0,nsym1,0,0,0,0)
2183 : : ! call setsym_ylm(gprimd,pawang1%l_max-1,pawang1%nsym,0,rprimd,symrc1,pawang1%zarot)
2184 : : !end if
2185 : :
2186 : : ! FIXME Be careful here because symrhg was written for densities!
2187 [ + - - + ]: 1718 : ABI_CHECK(nsppol == 1 .and. nspden == 1, "symrhg was written for densities, not for potentials")
2188 : :
2189 [ - + + - : 5154 : ABI_MALLOC(v1g, (2,nfft))
+ - + - -
+ - + ]
2190 : : call symrhg(cplex,cryst%gprimd,irrzon1,mpi_enreg,nfft,nfftot,ngfft,nspden,nsppol,nsym1,&
2191 : 1718 : phnons1,v1g,v1r,cryst%rprimd,symafm1,symrel1,tnons1)
2192 : :
2193 [ - + ]: 1718 : ABI_FREE(irrzon1)
2194 [ - + ]: 1718 : ABI_FREE(phnons1)
2195 [ - + ]: 1718 : ABI_FREE(indsy1)
2196 [ - + ]: 1718 : ABI_FREE(v1g)
2197 : :
2198 : : end subroutine v1phq_symmetrize
2199 : : !!***
2200 : :
2201 : : !----------------------------------------------------------------------
2202 : :
2203 : : !!****f* m_dvdb/rotate_fqg
2204 : : !! NAME
2205 : : !! rotate_fqg
2206 : : !!
2207 : : !! FUNCTION
2208 : : !! Rotate density/potential infg_q(g) in g-space to obtain outfg_{ISq}(g)
2209 : : !!
2210 : : !! INPUTS
2211 : : !! itirev=2 if time-reversal symmetry should be used, 1 otherwise.
2212 : : !! symm(3,3)=Symmetry operation S in reciprocal space.
2213 : : !! NB: symm usually corresponds to the inverso of one of the symrec operations.
2214 : : !! qpt(3)=q-point in the IBZ (this is the q-point associated to infg)
2215 : : !! tnon(3)=Fractional translation associate the the symmetry operation.
2216 : : !! ngfft(18)=contain all needed information about 3D FFT.
2217 : : !! nfft=Number of fft-points treated by this processors
2218 : : !! nspden=number of spin-density components
2219 : : !! infg(2,nfft,nspden)=Input array in g-space on the FFT box.
2220 : : !!
2221 : : !! OUTPUTS
2222 : : !! outfg(2,nfft,nspden)= Input array in g-space on the FFT box. In pseudo-equation:
2223 : : !!
2224 : : !! outfg(g) = infg(IS G) e^{-i(IS^{-1} G)} exp(2*pi*I*(G) dot tau_S) rho(IS^{-1} G)
2225 : : !!
2226 : : !! SOURCE
2227 : :
2228 : 18377 : subroutine rotate_fqg(itirev, symm, qpt, tnon, ngfft, nfft, nspden, infg, outfg)
2229 : :
2230 : : !Arguments ------------------------------------
2231 : : !scalars
2232 : : integer,intent(in) :: itirev,nfft,nspden
2233 : : !arrays
2234 : : integer,intent(in) :: symm(3,3),ngfft(18)
2235 : : real(dp),intent(in) :: qpt(3),tnon(3)
2236 : : real(dp),intent(in) :: infg(2,nfft,nspden)
2237 : : real(dp),intent(out) :: outfg(2,nfft,nspden)
2238 : :
2239 : : !Local variables-------------------------------
2240 : : !scalars
2241 : : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot,isp,tsign
2242 : : real(dp) :: arg
2243 : : logical :: has_phase
2244 : : !arrays
2245 : : integer :: tsg(3)
2246 : : real(dp) :: phnon1(2), tsec(2)
2247 : : ! *************************************************************************
2248 : :
2249 : : ! Keep track of total time spent.
2250 : 18377 : call timab(1803, 1, tsec)
2251 : :
2252 [ + + ]: 73508 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
2253 [ - + ]: 18377 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
2254 : 18377 : id1 = n1/2+2; id2 = n2/2+2; id3=n3/2+2
2255 : :
2256 [ - + ]: 18377 : ABI_CHECK(any(itirev == [1, 2]), "Wrong itirev")
2257 [ + + + + ]: 53619 : tsign = 3-2*itirev; has_phase = any(abs(tnon) > tol12)
2258 : :
2259 : : !outfg = zero
2260 : :
2261 [ + + ]: 36754 : do isp=1,nspden
2262 : : ind1 = 0
2263 [ + + ]: 376070 : do i3=1,n3
2264 : : ! Get location of G vector (grid point) centered at 0 0 0
2265 : 339316 : l3 = i3-(i3/id3)*n3-1
2266 [ + + ]: 7781485 : do i2=1,n2
2267 : 7423792 : l2 = i2-(i2/id2)*n2-1
2268 [ + + ]: 191509596 : do i1=1,n1
2269 : 183746488 : ind1 = ind1 + 1
2270 : : !ind1 = 1 + i1 + (i2-1)*n1 + (i3-1)*n1*n2
2271 : : !if (mod(ind1, nprocs) /= my_rank) cycle
2272 : :
2273 : 183746488 : l1 = i1-(i1/id1)*n1-1
2274 : :
2275 : : ! Get rotated G vector: IS(G)
2276 : 183746488 : j1 = tsign * (symm(1,1)*l1+symm(1,2)*l2+symm(1,3)*l3)
2277 : 183746488 : j2 = tsign * (symm(2,1)*l1+symm(2,2)*l2+symm(2,3)*l3)
2278 : 183746488 : j3 = tsign * (symm(3,1)*l1+symm(3,2)*l2+symm(3,3)*l3)
2279 : :
2280 : : ! We are not working on the G-sphere thus SG may be outside of the box
2281 : : ! (only for G outside the sphere inscribed in the box): set these components to zero.
2282 : : ! This check is not done in irrzg.
2283 : : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
2284 [ + + + + : 183746488 : (j2 > n2/2 .or. j2 < -(n2-1)/2) .or. &
+ + + + +
+ + + ]
2285 : : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
2286 [ + + ]: 209063463 : outfg(:,ind1,isp) = zero
2287 : : cycle
2288 : : end if
2289 : :
2290 [ + + ]: 456234668 : tsg = [j1,j2,j3] ! IS^{-1} G
2291 : :
2292 : : ! Map into [0,n-1] and then add 1 for array index in [1, n]
2293 : 114058667 : k1=1+mod(n1+mod(j1,n1),n1)
2294 : 114058667 : k2=1+mod(n2+mod(j2,n2),n2)
2295 : 114058667 : k3=1+mod(n3+mod(j3,n3),n3)
2296 : :
2297 : : ! Get linear index of rotated point Gj
2298 : 114058667 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
2299 : :
2300 : : ! TODO: Here I believe there are lots of cache misses, should perform low-level profiling
2301 : : ! OMP perhaps can accelerate this part but mind false sharing...
2302 [ + + ]: 114058667 : if (has_phase) then
2303 : : ! compute exp(-2*pi*I*G dot tau_S) using original G
2304 [ + + ]: 217976096 : arg = two_pi * dot_product(qpt + tsg, tnon)
2305 : 54494024 : phnon1(1) = cos(arg); phnon1(2) =-sin(arg)
2306 : :
2307 : : ! rho(Strans*G)=exp(2*pi*IG dot tau_S) rho(G)
2308 : 54494024 : outfg(1, ind1, isp) = phnon1(1) * infg(1, ind2, isp) - phnon1(2) * infg(2, ind2, isp)
2309 : 54494024 : outfg(2, ind1, isp) = phnon1(1) * infg(2, ind2, isp) + phnon1(2) * infg(1, ind2, isp)
2310 : : else
2311 : 59564643 : outfg(1, ind1, isp) = infg(1, ind2, isp)
2312 : 59564643 : outfg(2, ind1, isp) = infg(2, ind2, isp)
2313 : : end if
2314 : :
2315 : : ! Take complex conjugate if time-reversal is used.
2316 [ + + ]: 121482459 : if (tsign == -1) outfg(2, ind1, isp) = -outfg(2, ind1, isp)
2317 : : end do
2318 : : end do
2319 : : end do
2320 : : end do ! isp
2321 : :
2322 : : !call xmpi_sum(comm, outfg, ierr)
2323 : 18377 : call timab(1803, 2, tsec)
2324 : :
2325 : 18377 : end subroutine rotate_fqg
2326 : : !!***
2327 : :
2328 : : !----------------------------------------------------------------------
2329 : :
2330 : : !!****f* m_dvdb/dvdb_ftinterp_setup
2331 : : !! NAME
2332 : : !! dvdb_ftinterp_setup
2333 : : !!
2334 : : !! FUNCTION
2335 : : !! Precompute the wsr array with the DFPT potential in the supercell
2336 : : !! required for the Fourier interpolation.
2337 : : !! This is a collective routine that should be called by all procs inside db%comm.
2338 : : !!
2339 : : !! \begin{equation}
2340 : : !! \label{eq:dfpt_pot_realspace}
2341 : : !! W_{\kappa\alpha}(\rr,\RR) = \dfrac{1}{N_\qq} \sum_\qq e^{-i\qq\cdot(\RR - \rr)}\,
2342 : : !! \partial_{\kappa\alpha\qq}{v^{\text{scf}}}(\rr)
2343 : : !! \end{equation}
2344 : : !!
2345 : : !! INPUTS
2346 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
2347 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
2348 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
2349 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
2350 : : !! nfft=Number of fft-points treated by this processors
2351 : : !! ngfft(18)=contain all needed information about 3D FFT
2352 : : !! comm_rpt = MPI communicator used to distribute R-lattice points.
2353 : : !!
2354 : : !! SOURCE
2355 : :
2356 : 36 : subroutine dvdb_ftinterp_setup(db, ngqpt, qptopt, nqshift, qshift, nfft, ngfft, comm_rpt)
2357 : :
2358 : : !Arguments ------------------------------------
2359 : : !scalars
2360 : : class(dvdb_t),target,intent(inout) :: db
2361 : : integer,intent(in) :: qptopt,nqshift,nfft,comm_rpt
2362 : : !arrays
2363 : : integer,intent(in) :: ngqpt(3), ngfft(18)
2364 : : real(dp),intent(in) :: qshift(3,nqshift)
2365 : :
2366 : : !Local variables-------------------------------
2367 : : !scalars
2368 : : integer,parameter :: master=0
2369 : : integer :: iq_ibz,nqibz,iq_bz,nqbz !, timerev_q
2370 : : integer :: ii,jj,cplex_qibz,ispden,imyp,irpt,idir,ipert,ipc, iqst, itimrev, isym
2371 : : integer :: ifft, ierr, my_rstart, my_rstop, iatom
2372 : : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
2373 : : logical :: isirr_q
2374 : : character(len=500) :: msg
2375 : : !arrays
2376 : : integer :: g0q(3)
2377 : : !integer :: symq(4,2,db%cryst%nsym)
2378 : 36 : integer,allocatable :: indqq(:,:), iperm(:), nqsts(:), iqs_dvdb(:), all_cell(:,:)
2379 : : real(dp) :: qpt_bz(3)
2380 : 36 : real(dp),allocatable :: qibz(:,:), qbz(:,:), emiqr(:,:), all_rpt(:,:), all_wghatm(:,:,:)
2381 : 36 : real(dp),allocatable :: v1r_qibz(:,:,:,:), v1r_qbz(:,:,:,:), v1r_lr(:,:,:)
2382 : 36 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
2383 : : logical,parameter :: DEBUG_WSR_IMAG = .False.
2384 : 36 : real(dp),allocatable :: wsi_diag(:,:,:,:)
2385 : : ! *************************************************************************
2386 : :
2387 : : ! Set communicator for R-point parallelism.
2388 : : ! Note that client code is responsible for calling the interpolation routine dvdb_get_ftqbz (R -> q)
2389 : : ! with all procs inside comm_rpt to avoid MPI deadlocks.
2390 : 36 : db%comm_rpt = comm_rpt; db%nprocs_rpt = xmpi_comm_size(db%comm_rpt); db%me_rpt = xmpi_comm_rank(db%comm_rpt)
2391 : :
2392 [ - + ]: 36 : if (db%add_lr >= 4) then
2393 : 0 : call wrtout(std_out, " Skipping construction of W(R,r) because add_lr >= 4. Will use LR part only!")
2394 : 0 : return
2395 : : end if
2396 : :
2397 : 36 : call cwtime(cpu_all, wall_all, gflops_all, "start")
2398 : :
2399 : : call wrtout(std_out, sjoin(ch10, "Building W(R,r) using q-mesh ngqpt: ", ltoa(ngqpt), &
2400 : 36 : ", with nprocs_rpt:", itoa(db%nprocs_rpt)), do_flush=.True.)
2401 : 36 : call wrtout(std_out, sjoin(" Using Gaussian filter with qdamp: ", ftoa(db%qdamp, fmt="(f6.1)")))
2402 : 36 : call wrtout(std_out, "")
2403 : 36 : call wrtout(std_out, " Note: this part may take some time depending on the number of MPI procs, ngqpt and nfft points.")
2404 : 36 : call wrtout(std_out, " Use boxcutmin < 2.0 (> 1.1) to decrease nfft, reduce memory requirements and speedup the calculation.")
2405 : : !call wrtout(std_out, " Q-mesh shifts:")
2406 : : !do ii=1,nqshift
2407 : : ! call wrtout(std_out, ltoa(qshift(:, ii)))
2408 : : !end do
2409 : :
2410 : : call prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2411 : 36 : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm, db%comm)
2412 : :
2413 : 36 : nqibz = size(qibz, dim=2); nqbz = size(qbz, dim=2); db%nrtot = size(all_rpt, dim=2)
2414 : :
2415 : : ! Distribute R-points inside comm_rpt.
2416 : 36 : call xmpi_split_work(db%nrtot, db%comm_rpt, my_rstart, my_rstop)
2417 : :
2418 : : ! Select my_rpoints.
2419 : : ! Use REMALLOC so that we can call this routine multiple times i.e. for changing add_lr
2420 : 36 : db%my_nrpt = my_rstop - my_rstart + 1
2421 [ - + ]: 36 : ABI_CHECK(db%my_nrpt /= 0, "my_nrpt == 0!")
2422 : :
2423 [ - + - + : 108 : ABI_REMALLOC(db%my_rpt, (3, db%my_nrpt))
+ - + - +
- - + - +
- + ]
2424 [ + - + - : 5036 : db%my_rpt = all_rpt(:, my_rstart:my_rstop)
- + - - +
+ + + ]
2425 [ - + - + : 108 : ABI_REMALLOC(db%my_irpt2tot, (db%my_nrpt))
+ - + - +
- - + - +
- + ]
2426 [ + + ]: 1277 : do irpt=1,db%my_nrpt
2427 : 1277 : db%my_irpt2tot(irpt) = my_rstart + (irpt - 1)
2428 : : end do
2429 : :
2430 : : ! Copy weights for the atoms treated by this proc.
2431 [ + + + + ]: 462 : ii = minval(db%my_pinfo(2,:)); jj = maxval(db%my_pinfo(2,:))
2432 [ - + - + : 144 : ABI_REMALLOC(db%my_wratm, (db%my_nrpt, ii:jj))
+ - - + +
- + - + -
- + - + -
+ ]
2433 [ + + + + ]: 2581 : db%my_wratm = one
2434 [ - + ]: 36 : if (db%rspace_cell == 1) then
2435 [ # # ]: 0 : do iatom=1,db%cryst%natom
2436 [ # # # # ]: 0 : if (iatom >= ii .and. iatom <= jj) db%my_wratm(:, iatom) = all_wghatm(iatom, iatom, my_rstart:my_rstop)
2437 : : end do
2438 : : end if
2439 : :
2440 : 36 : write(std_out, "(a, i0)")" Using rspace_cell method for integration weights: ", db%rspace_cell
2441 : 36 : write(std_out, "(a, i0)")" Total number of R-points in real-space big box: ", db%nrtot
2442 : 36 : write(std_out, "(a, i0)")" Number of R-points treated by this MPI rank: ", db%my_nrpt
2443 : 36 : write(std_out, "(a, 3(i0, 1x))")" ngfft: ", ngfft(1:3)
2444 : 36 : write(std_out, "(a, i0)")" dvdb_add_lr: ", db%add_lr
2445 : :
2446 : : ! Allocate potential in the supercell. Memory is MPI-distributed over my_nrpt and my_npert
2447 : : call wrtout(std_out, sjoin(" Memory required for W(R,r): ", &
2448 : 36 : ftoa(one * db%my_nrpt * nfft * db%nspden * db%my_npert * sp * b2Mb, fmt="f8.1"), "[Mb] <<< MEM"))
2449 : :
2450 : : ABI_SFREE(all_cell)
2451 [ - + ]: 36 : ABI_SFREE(all_wghatm)
2452 [ - + ]: 36 : ABI_FREE(all_rpt)
2453 : :
2454 [ - + + - : 108 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
2455 [ - + + - : 180 : ABI_MALLOC(v1r_qbz, (2, nfft, db%nspden, db%natom3))
- + + - -
+ + - + -
+ - - + -
+ ]
2456 [ - + + - : 8410533 : ABI_CALLOC(v1r_lr, (2, nfft, db%my_npert))
- + + - +
- + - - +
- + + + +
+ + + ]
2457 : :
2458 [ - + ]: 36 : ABI_SFREE(db%wsr)
2459 [ - + + - : 216 : ABI_MALLOC_OR_DIE(db%wsr, (1, db%my_nrpt, nfft, db%nspden, db%my_npert), ierr)
- + + - -
+ + - - +
+ - + - +
- + - + -
- + + - -
+ ]
2460 [ + + + + : 138868110 : db%wsr = zero
+ + + + +
+ ]
2461 : :
2462 : : if (DEBUG_WSR_IMAG) then
2463 : : ABI_MALLOC(wsi_diag, (db%my_nrpt, nfft, db%nspden, db%my_npert))
2464 : : wsi_diag = zero
2465 : : end if
2466 : :
2467 : : ! TODO: Parallelize this part over q-points using comm_rpt. For the time being only pert parallelism.
2468 : 36 : iqst = 0
2469 [ + + ]: 237 : do iq_ibz=1,nqibz
2470 : 201 : call cwtime(cpu, wall, gflops, "start")
2471 : : !
2472 : : ! Here all procs get all potentials for this IBZ q-point on the real-space FFT mesh.
2473 : : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
2474 : : ! Note that here we need all 3*natom perturbations because of v1phq_rotate.
2475 [ - + ]: 201 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, db%comm)
2476 : :
2477 : : ! Reconstruct by symmetry the potentials for the star of this q-point,
2478 : : ! perform slow FT and accumulate in wsr. Be careful with the gamma point.
2479 [ + + ]: 1442 : do ii=1,nqsts(iq_ibz)
2480 : 1241 : iqst = iqst + 1
2481 : : !if (mod(ii, nproc) /= my_rank) cycle ! MPI parallelism.
2482 : 1241 : iq_bz = iperm(iqst)
2483 [ - + ]: 1241 : ABI_CHECK(iq_ibz == indqq(1, iq_bz), "iq_ibz !/ indqq(1)")
2484 [ + + ]: 4964 : qpt_bz = qbz(:, iq_bz)
2485 : : !if (all(abs(qpt_bz) < tol12)) cycle
2486 : : ! IS(q_ibz) + g0q = q_bz
2487 [ + + ]: 4964 : isym = indqq(2, iq_bz); itimrev = indqq(6, iq_bz) + 1; g0q = indqq(3:5, iq_bz)
2488 [ + + + + : 4182 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
2489 : : !write(std_out, *)"qbz", trim(ktoa(qpt_bz)), " --> qibz ", trim(ktoa(qibz(:,iq_ibz)))
2490 : : !write(std_out, *)"via isym, itimrev, g0q:", isym, itimrev, g0q
2491 : :
2492 : : ! Compute long-range part of the coupling potential at qpt_bz.
2493 [ + + ]: 1241 : if (db%add_lr /= 0) then
2494 [ + + ]: 7959 : do imyp=1,db%my_npert
2495 : 6822 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2496 : 7959 : call db%get_v1r_long_range(qpt_bz, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
2497 : : end do
2498 : : end if
2499 : :
2500 [ + + ]: 1442 : if (cplex_qibz == 1) then
2501 : : ! Gamma point.
2502 [ - + ]: 36 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
2503 [ + + + - : 144 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
- + ]
2504 : :
2505 [ + + ]: 36 : if (db%add_lr /= 0) then
2506 : : ! Subtract the long-range part of the potential.
2507 : : ! The LR model is spin-independent: only the diagonal components (v_up, v_dn or v11, v22) are affected.
2508 [ + + ]: 161 : do imyp=1,db%my_npert
2509 : 138 : ipc = db%my_pinfo(3, imyp)
2510 [ + + ]: 299 : do ispden=1,min(db%nspden, 2)
2511 [ + + ]: 961668 : v1r_qibz(1, :, ispden, ipc) = v1r_qibz(1, :, ispden, ipc) - v1r_lr(1, :, imyp)
2512 : : end do
2513 : : end do
2514 : : end if
2515 : :
2516 : : ! Slow FT.
2517 [ + + ]: 249 : do imyp=1,db%my_npert
2518 : 213 : ipc = db%my_pinfo(3, imyp)
2519 [ + + ]: 462 : do ispden=1,db%nspden
2520 [ + + ]: 2803818 : do ifft=1,nfft
2521 [ + + ]: 70835733 : do irpt=1,db%my_nrpt
2522 : : db%wsr(1, irpt, ifft, ispden, imyp) = db%wsr(1, irpt, ifft, ispden, imyp) + &
2523 : 70835520 : v1r_qibz(1, ifft, ispden, ipc)
2524 : : end do
2525 : : end do
2526 : : end do
2527 : : end do
2528 : :
2529 : : else
2530 : : ! q /= Gamma. Get the periodic part of the potential in BZ (v1r_qbz)
2531 [ + + ]: 1205 : if (isirr_q) then
2532 [ + - + - : 33744234 : v1r_qbz = v1r_qibz
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
2533 : : else
2534 : : call v1phq_rotate(db%cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
2535 : 1040 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
2536 : : end if
2537 : :
2538 : : ! Multiply by e^{iqpt_bz.r}
2539 : 1205 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden * db%natom3, v1r_qbz)
2540 : :
2541 [ + + ]: 1205 : if (db%add_lr /= 0) then
2542 : : ! Subtract the long-range part of the potential (diagonal spin components only).
2543 [ + + ]: 7798 : do imyp=1,db%my_npert
2544 : 6684 : ipc = db%my_pinfo(3, imyp)
2545 [ + + ]: 14482 : do ispden=1,min(db%nspden, 2)
2546 [ + + + + ]: 157017576 : v1r_qbz(:, :, ispden, ipc) = v1r_qbz(:, :, ispden, ipc) - v1r_lr(:, :, imyp)
2547 : : end do
2548 : : end do
2549 : : end if
2550 : :
2551 : : ! Compute FT phases for this qpt_bz.
2552 [ + + ]: 4820 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
2553 : :
2554 : : ! Slow FT.
2555 [ + + ]: 8414 : do imyp=1,db%my_npert
2556 : 7209 : ipc = db%my_pinfo(3, imyp)
2557 [ + + ]: 15623 : do ispden=1,db%nspden
2558 [ + + ]: 65243154 : do ifft=1,nfft
2559 : : db%wsr(1, :, ifft, ispden, imyp) = db%wsr(1, :, ifft, ispden, imyp) &
2560 : : + emiqr(1, :) * v1r_qbz(1, ifft, ispden, ipc) &
2561 [ + + ]: 3408342336 : - emiqr(2, :) * v1r_qbz(2, ifft, ispden, ipc)
2562 : :
2563 : 7209 : if (DEBUG_WSR_IMAG) then
2564 : : wsi_diag(:, ifft, ispden, imyp) = wsi_diag(:, ifft, ispden, imyp) &
2565 : : + emiqr(1, :) * v1r_qbz(2, ifft, ispden, ipc) &
2566 : : + emiqr(2, :) * v1r_qbz(1, ifft, ispden, ipc)
2567 : : end if
2568 : : end do
2569 : :
2570 : : !call zgerc(db%my_nrpt, nfft, cone, emiqr, 1, v1r_qbz(:,:,ispden,ipc), 1, &
2571 : : ! db%wsr(:,:,:,ispden,imyp), db%my_nrpt)
2572 : :
2573 : : end do ! ispden
2574 : : end do ! imyp
2575 : : end if
2576 : :
2577 : : end do ! iqst
2578 : :
2579 : 201 : write(msg,'(2(a,i0),a)') " IBZ q-point [", iq_ibz, "/", nqibz, "]"
2580 : 201 : call cwtime_report(msg, cpu, wall, gflops)
2581 [ - + ]: 438 : ABI_FREE(v1r_qibz)
2582 : : end do ! iq_ibz
2583 : :
2584 [ - + ]: 36 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
2585 : 36 : call wrtout(std_out, ch10//ch10)
2586 : :
2587 [ - + ]: 36 : ABI_FREE(iperm)
2588 [ - + ]: 36 : ABI_FREE(emiqr)
2589 [ - + ]: 36 : ABI_FREE(qibz)
2590 [ - + ]: 36 : ABI_FREE(qbz)
2591 [ - + ]: 36 : ABI_FREE(indqq)
2592 [ - + ]: 36 : ABI_FREE(iqs_dvdb)
2593 [ - + ]: 36 : ABI_FREE(nqsts)
2594 [ - + ]: 36 : ABI_FREE(v1r_qbz)
2595 [ - + ]: 36 : ABI_FREE(v1r_lr)
2596 : :
2597 : : !call xmpi_sum(db%wsr, db%comm, ierr)
2598 [ + + + + : 138868110 : db%wsr = db%wsr / nqbz
+ + + + +
+ ]
2599 : :
2600 : : if (DEBUG_WSR_IMAG) then
2601 : : wsi_diag = wsi_diag / nqbz
2602 : : write(std_out, "(a)")" --- DEBUG_WSR_IMAG: discarded Im[W(R,r)] vs kept Re[W(R,r)], per perturbation (imyp) ---"
2603 : : do imyp=1,db%my_npert
2604 : : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2605 : : write(std_out, "(a,i0,a,i0,a,i0,a,es12.4,a,es12.4)") &
2606 : : " imyp=", imyp, " idir=", idir, " ipert=", ipert, &
2607 : : " max|Im[wsr]|=", maxval(abs(wsi_diag(:,:,:,imyp))), &
2608 : : " max|Re[wsr]|=", maxval(abs(real(db%wsr(1,:,:,:,imyp), kind=dp)))
2609 : : end do
2610 : : ABI_FREE(wsi_diag)
2611 : : end if
2612 : :
2613 : 36 : wsr_ptr => db%wsr
2614 : : #ifdef HAVE_OPENMP_OFFLOAD
2615 : : ! Upload wsr array to GPU
2616 : : !$OMP TARGET ENTER DATA MAP(to:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
2617 : : #endif
2618 : :
2619 : 36 : call cwtime_report(" Construction of W(R,r)", cpu_all, wall_all, gflops_all)
2620 : :
2621 [ - + - + : 144 : end subroutine dvdb_ftinterp_setup
- + - + -
+ - + - +
- + - + ]
2622 : : !!***
2623 : :
2624 : : !----------------------------------------------------------------------
2625 : :
2626 : : !!****f* m_dvdb/dvdb_get_maxw
2627 : : !! NAME
2628 : : !! dvdb_get_maxw
2629 : : !!
2630 : : !! FUNCTION
2631 : : !! Compute max_r |W(R,r)|
2632 : : !!
2633 : : !! INPUTS
2634 : : !!
2635 : : !! FUNCTION
2636 : :
2637 : 1 : subroutine dvdb_get_maxw(db, ngqpt, all_rpt, all_rmod, maxw)
2638 : :
2639 : : !Arguments ------------------------------------
2640 : : !scalars
2641 : : class(dvdb_t),intent(in) :: db
2642 : : integer,intent(in) :: ngqpt(3)
2643 : : real(dp),allocatable,intent(out) :: maxw(:,:), all_rpt(:,:), all_rmod(:)
2644 : :
2645 : : !Local variables-------------------------------
2646 : : !scalars
2647 : : integer :: imyp, ipc, irpt, irpt_tot, ifft, nfft, ispden, ierr, ii
2648 : : real(dp) :: phre
2649 : : !arrays
2650 : 1 : integer,allocatable :: iperm_irpt(:)
2651 : : real(dp) :: sc_rprimd(3,3)
2652 : : ! *************************************************************************
2653 : :
2654 [ - + ]: 1 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
2655 : :
2656 : 1 : nfft = size(db%wsr, dim=3)
2657 [ - + + - : 58 : ABI_CALLOC(maxw, (db%nrtot, db%natom3))
- + + - +
- + - - +
- + - + +
+ + + ]
2658 : :
2659 : : ! Need all RPTs to sort output.
2660 [ - + + - : 35 : ABI_CALLOC(all_rpt, (3, db%nrtot))
+ - + - -
+ - + - +
+ + + + ]
2661 [ + + ]: 9 : do irpt=1,db%my_nrpt
2662 : 8 : irpt_tot = db%my_irpt2tot(irpt)
2663 [ + + ]: 33 : all_rpt(:, irpt_tot) = db%my_rpt(:, irpt)
2664 : : end do
2665 : 1 : call xmpi_sum(all_rpt, db%comm_rpt, ierr)
2666 : :
2667 [ + + ]: 7 : do imyp=1,db%my_npert
2668 : 6 : ipc = db%my_pinfo(3, imyp)
2669 [ + + ]: 55 : do irpt=1,db%my_nrpt
2670 : 48 : irpt_tot = db%my_irpt2tot(irpt)
2671 : 48 : phre = zero
2672 [ + + ]: 96 : do ispden=1,db%nspden
2673 [ + + ]: 196704 : do ifft=1,nfft
2674 : 196656 : phre = max(phre, real(db%wsr(1,irpt,ifft,ispden,imyp), kind=dp) ** 2) ! + db%wsr(2,irpt,ifft,ispden,imyp) ** 2)
2675 : : end do
2676 : : end do
2677 : 54 : maxw(irpt_tot, ipc) = sqrt(phre)
2678 : : end do
2679 : : end do
2680 : :
2681 : : ! Handle parallelism
2682 [ - + ]: 1 : if (db%nprocs_rpt /= 1) call xmpi_sum(maxw, db%comm_rpt, ierr)
2683 [ - + ]: 1 : if (db%nprocs_pert /= 1) call xmpi_sum(maxw, db%comm_pert, ierr)
2684 : :
2685 : 1 : sc_rprimd(:, 1) = ngqpt(1) * db%cryst%rprimd(:, 1)
2686 : : sc_rprimd(:, 2) = ngqpt(2) * db%cryst%rprimd(:, 2)
2687 : : sc_rprimd(:, 3) = ngqpt(3) * db%cryst%rprimd(:, 3)
2688 [ - + ]: 1 : call sort_rpts(db%nrtot, all_rpt, db%cryst%rmet, iperm_irpt, rmod=all_rmod)
2689 : :
2690 : : ! Sort output results by |R|.
2691 [ + - + + : 66 : all_rpt = all_rpt(:, iperm_irpt(:))
+ + + - -
+ - - + +
+ + ]
2692 [ + + ]: 7 : do ii=1,db%natom3
2693 [ + - + + : 103 : maxw(:, ii) = maxw(iperm_irpt(:), ii)
+ + ]
2694 : : end do
2695 : :
2696 [ - + ]: 1 : ABI_FREE(iperm_irpt)
2697 : :
2698 : 1 : end subroutine dvdb_get_maxw
2699 : : !!***
2700 : :
2701 : : !----------------------------------------------------------------------
2702 : :
2703 : : !!****f* m_dvdb/prepare_ftinterp
2704 : : !! NAME
2705 : : !! prepare_ftinterp
2706 : : !!
2707 : : !! FUNCTION
2708 : : !! Helper function used to prepare the Fourier interpolation of the DFPT potentials.
2709 : :
2710 : 36 : subroutine prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2711 : : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm, comm)
2712 : :
2713 : : !Arguments ------------------------------------
2714 : : !scalars
2715 : : integer,intent(in) :: nqshift, qptopt, comm
2716 : : class(dvdb_t),target,intent(in) :: db
2717 : : !arrays
2718 : : integer,intent(in) :: ngqpt(3)
2719 : : real(dp),intent(in) :: qshift(3,nqshift)
2720 : : integer,allocatable,intent(out) :: indqq(:,:), nqsts(:), iqs_dvdb(:), iperm(:)
2721 : : real(dp),allocatable,intent(out) :: all_rpt(:,:), all_wghatm(:,:,:)
2722 : : real(dp),allocatable,intent(out) :: qibz(:,:),qbz(:,:)
2723 : :
2724 : : !Local variables-------------------------------
2725 : : !scalars
2726 : : integer,parameter :: cutmode2 = 2
2727 : : integer :: iq_ibz,nqibz,iq_bz,nqbz,ii,iq_dvdb
2728 : : integer :: iqst,nqst,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3, nrtot
2729 : : real(dp) :: r_inscribed_sphere
2730 : : logical :: found
2731 : : character(len=500) :: msg
2732 : : type(crystal_t),pointer :: cryst
2733 : 36 : type(krank_t) :: qrank
2734 : : !arrays
2735 : : integer :: qptrlatt(3,3)
2736 : 36 : integer,allocatable :: bz2ibz_sort(:),all_cell(:,:)
2737 : 72 : real(dp) :: shift(3), rcan(3, db%cryst%natom), trans(3, db%cryst%natom), acell(3), rprim(3,3), gprim(3,3)
2738 : 36 : real(dp),allocatable :: wtq(:),all_rcart(:,:)
2739 : : ! *************************************************************************
2740 : :
2741 : 36 : cryst => db%cryst
2742 : :
2743 : : ! Generate q-mesh: find BZ, IBZ and the corresponding weights from ngqpt.
2744 : 36 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3)
2745 : 36 : qptrlatt = 0; qptrlatt(1, 1) = ngqpt(1); qptrlatt(2, 2) = ngqpt(2); qptrlatt(3, 3) = ngqpt(3)
2746 : :
2747 [ - + ]: 36 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
2748 [ + + + - : 144 : ABI_CHECK(all(qshift(:, 1) == zero), "qshift != 0 not supported")
- + ]
2749 : :
2750 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nqshift, qshift, &
2751 [ - + - + ]: 36 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
2752 : :
2753 [ + + - + ]: 144 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
2754 : :
2755 : 72 : select case (db%rspace_cell)
2756 : : case (0)
2757 : : ! Generate q-mesh
2758 : : #if 1
2759 [ - + ]: 36 : ABI_FREE(qbz)
2760 [ - + + - : 108 : ABI_MALLOC(qbz, (3, nqbz))
+ - + - -
+ - + ]
2761 : 36 : ii = 0
2762 [ + + ]: 143 : do iz=0,nq3-1
2763 [ + + ]: 494 : do iy=0,nq2-1
2764 [ + + ]: 1699 : do ix=0,nq1-1
2765 : 1241 : ii = ii + 1
2766 [ + + ]: 4964 : qbz(:, ii) = [ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)]
2767 [ + + ]: 5315 : call wrap2_pmhalf([ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)], qbz(:,ii), shift)
2768 : : end do
2769 : : end do
2770 : : end do
2771 : : #endif
2772 : :
2773 : : ! Compute real-space points in the supercell
2774 : : ! Use the following indexing (N means ngfft on the adequate direction)
2775 : : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
2776 : : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
2777 : 36 : nrtot = nqbz
2778 [ - + + - : 5036 : ABI_CALLOC(all_rpt, (3, nrtot))
- + - + -
+ + + +
+ ]
2779 : 36 : ii = 0
2780 [ + + ]: 143 : do iz=1,nq3
2781 : 107 : r3 = ig2gfft(iz, nq3)
2782 [ + + ]: 494 : do iy=1,nq2
2783 : 351 : r2 = ig2gfft(iy, nq2)
2784 [ + + ]: 1699 : do ix=1,nq1
2785 : 1241 : r1 = ig2gfft(ix, nq1)
2786 : 1241 : ii = ii + 1
2787 [ + + ]: 5315 : all_rpt(:, ii) = [r1, r2, r3]
2788 : : end do
2789 : : end do
2790 : : end do
2791 : :
2792 : : case (1)
2793 : : ! Use Wigner-Seitz cell.
2794 : : !
2795 : : ! Compute rprim, and gprim
2796 : 0 : call mkradim(acell, rprim, cryst%rprimd)
2797 : 0 : call canat9(db%brav, cryst%natom, rcan, rprim, trans, cryst%xred)
2798 : 0 : call matr3inv(rprim, gprim)
2799 : :
2800 : : ! In principle one may have N_R that depends on iatom to minimize memory.
2801 : : call get_bigbox_and_weights(db%brav, cryst%natom, nqbz, ngqpt, nqshift, qshift, rprim, cryst%rprimd, gprim, rcan, &
2802 [ # # ]: 0 : cutmode2, nrtot, all_rcart, all_cell, all_wghatm, r_inscribed_sphere, comm)
2803 [ # # ]: 0 : ABI_FREE(all_cell)
2804 [ # # ]: 0 : do ii=1,nrtot
2805 [ # # ]: 0 : all_rcart(:,ii) = all_rcart(:,ii) * acell(:)
2806 : : end do
2807 [ # # # # : 0 : ABI_MALLOC(all_rpt, (3, nrtot))
# # # # #
# # # #
# ]
2808 : 0 : call xcart2xred(nrtot, cryst%rprimd, all_rcart, all_rpt)
2809 [ # # ]: 0 : ABI_FREE(all_rcart)
2810 : :
2811 : : case default
2812 [ + - - ]: 36 : ABI_ERROR(sjoin("Wrong rspace_cell:", itoa(db%rspace_cell)))
2813 : : end select
2814 : :
2815 : : ! Find correspondence BZ --> IBZ. Note:
2816 : : ! - q --> -q symmetry is always used for phonons.
2817 : : ! - we use symrec instead of symrel
2818 : :
2819 [ - + + - : 108 : ABI_MALLOC(indqq, (6, nqbz))
+ - + - -
+ - + -
+ ]
2820 : 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2821 : :
2822 [ - + ]: 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2823 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2824 : : end if
2825 : :
2826 : 36 : call qrank%free()
2827 : :
2828 : : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
2829 [ - + + - : 108 : ABI_MALLOC(iperm, (nqbz))
+ - + - -
+ - + -
+ ]
2830 [ - + + - : 72 : ABI_MALLOC(bz2ibz_sort, (nqbz))
- + - + ]
2831 [ - + + + : 3795 : iperm = [(ii, ii=1,nqbz)]
+ - + + +
- - + - -
+ + ]
2832 [ + - - + : 1313 : bz2ibz_sort = indqq(1, :)
- - + + ]
2833 : 36 : call sort_int(nqbz, bz2ibz_sort, iperm)
2834 : :
2835 : : ! Reconstruct the IBZ according to what is present in the DVDB.
2836 [ - + + - : 108 : ABI_MALLOC(nqsts, (nqibz))
+ - + - -
+ - + -
+ ]
2837 [ - + + - : 72 : ABI_MALLOC(iqs_dvdb, (nqibz))
- + - + -
+ ]
2838 [ + + ]: 237 : iqs_dvdb = -1
2839 : :
2840 : : iqst = 0
2841 [ + + ]: 237 : do iq_ibz=1,nqibz
2842 : : ! In each q-point star, count the number of q-points and find the one present in the DVDB.
2843 : 201 : nqst = 0
2844 : 201 : found = .false.
2845 [ + + ]: 1442 : do ii=iqst+1,nqbz
2846 [ + + ]: 1406 : if (bz2ibz_sort(ii) /= iq_ibz) exit
2847 : 1241 : nqst = nqst + 1
2848 : 1241 : iq_bz = iperm(ii)
2849 [ + + ]: 1442 : if (.not. found) then
2850 : 671 : iq_dvdb = db%findq(qbz(:,iq_bz))
2851 [ + + ]: 671 : if (iq_dvdb /= -1) then
2852 [ + + ]: 804 : qibz(:,iq_ibz) = qbz(:,iq_bz)
2853 : 201 : iqs_dvdb(iq_ibz) = iq_dvdb
2854 : 201 : found = .true.
2855 : : end if
2856 : : end if
2857 : : end do
2858 : :
2859 : : ! Check that nqst has been counted properly.
2860 [ + - - + ]: 201 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst + 1) == iq_ibz, "Wrong iqst")
2861 [ - + ]: 201 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
2862 : 0 : write(msg, "(a,i0,a,f5.2)")"Error in q-point star or q-weights. nqst:", nqst, "wtq * nqbz = ", wtq(iq_ibz) * nqbz
2863 : 0 : ABI_ERROR(msg)
2864 : : end if
2865 : :
2866 : : ! Check that the q-point has been found in DVDB.
2867 [ - + ]: 201 : ABI_CHECK(found, sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
2868 : :
2869 : 201 : iqst = iqst + nqst
2870 : 237 : nqsts(iq_ibz) = nqst
2871 : : end do
2872 : :
2873 [ - + ]: 36 : ABI_FREE(wtq)
2874 [ - + ]: 36 : ABI_FREE(bz2ibz_sort)
2875 : :
2876 : : ! Redo the mapping with the new IBZ
2877 : 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2878 : :
2879 [ - + ]: 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2880 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2881 : : end if
2882 : 36 : call qrank%free()
2883 : :
2884 [ - + - + : 36 : end subroutine prepare_ftinterp
- + - + -
+ ]
2885 : : !!***
2886 : :
2887 : : !----------------------------------------------------------------------
2888 : :
2889 : : !!****f* m_dvdb/dvdb_ftinterp_qpt
2890 : : !! NAME
2891 : : !! dvdb_ftinterp_qpt
2892 : : !!
2893 : : !! FUNCTION
2894 : : !! Fourier interpolation of potentials for a given q-point
2895 : : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
2896 : : !!
2897 : : !! \begin{equation}
2898 : : !! \partial v^{scf}_{\tilde\qq\kappa\alpha}(\rr) \approx \sum_\RR e^{+i\tilde{\qq}\cdot(\RR - \rr)} W_{\kappa\alpha}(\rr,\RR).
2899 : : !! \end{equation
2900 : : !!
2901 : : !! INPUTS
2902 : : !! qpt(3)=q-point in reduced coordinates (arbitrary point in the BZ).
2903 : : !! nfft=Number of FFT-points treated by this processors.
2904 : : !! ngfft(18)=contain all needed information about 3D FFT.
2905 : : !! comm=MPI communicator for R-points.
2906 : : !! [add_lr]= If present, use this value for the LR treatment instead of dv%add_lr
2907 : : !!
2908 : : !! OUTPUT
2909 : : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point (periodic part)
2910 : : !!
2911 : : !! SOURCE
2912 : :
2913 : 3762 : subroutine dvdb_ftinterp_qpt(db, qpt, nfft, ngfft, ov1r, comm_rpt, add_lr)
2914 : :
2915 : : !Arguments ------------------------------------
2916 : : !scalars
2917 : : integer,intent(in) :: nfft, comm_rpt
2918 : : integer,optional,intent(in) :: add_lr
2919 : : class(dvdb_t),intent(inout) :: db
2920 : : !arrays
2921 : : integer,intent(in) :: ngfft(18)
2922 : : real(dp),intent(in) :: qpt(3)
2923 : : real(dp),intent(out) :: ov1r(2, nfft, db%nspden, db%my_npert)
2924 : :
2925 : : !Local variables-------------------------------
2926 : : !scalars
2927 : : integer,parameter :: cplex2 = 2
2928 : : integer :: ispden, imyp, idir, ipert, timerev_q, ierr, my_add_lr !, ifft, ir
2929 : : !real(dp) :: qmod
2930 : : !real(sp) :: beta_sp !, wr !,wi
2931 : : logical :: prev_has_zeff, prev_has_quadrupoles, prev_has_efield
2932 : : !arrays
2933 [ + - ]: 3762 : integer :: symq(4,2,db%cryst%nsym), rfdir(3)
2934 : 3762 : integer,allocatable :: pertsy(:,:), rfpert(:), pflag(:,:)
2935 : : !real(dp) :: qcart(3)
2936 : 3762 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:,:)
2937 : 3762 : real(sp),allocatable :: weiqr_sp(:,:), ov1r_sp(:, :), eiqr_sp(:,:)
2938 : : ! *************************************************************************
2939 : :
2940 [ - + ]: 3762 : my_add_lr = db%add_lr; if (present(add_lr)) my_add_lr = add_lr
2941 : :
2942 : : !qcart = two_pi * matmul(db%cryst%gprimd, qpt)
2943 : : !qmod = sqrt(dot_product(qcart, qcart))
2944 : :
2945 [ - + ]: 3762 : if (my_add_lr >= 4) then
2946 : : ! Use LR part only and return immediately.
2947 [ # # ]: 0 : if (my_add_lr > 4) then
2948 : 0 : prev_has_zeff = db%has_zeff
2949 : 0 : prev_has_quadrupoles = db%has_quadrupoles
2950 : 0 : prev_has_efield = db%has_efield
2951 : 0 : db%has_zeff = .False.
2952 : 0 : db%has_quadrupoles = .False.
2953 : 0 : db%has_efield = .False.
2954 [ # # ]: 0 : if (my_add_lr == 5 .and. prev_has_zeff) db%has_zeff = .True.
2955 [ # # ]: 0 : if (my_add_lr == 6 .and. prev_has_quadrupoles) db%has_quadrupoles = .True.
2956 [ # # ]: 0 : if (my_add_lr == 7 .and. prev_has_efield) db%has_efield = .True.
2957 : : end if
2958 : :
2959 [ # # # # : 0 : ov1r = zero
# # # # ]
2960 [ # # ]: 0 : do imyp=1,db%my_npert
2961 : 0 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2962 : 0 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, ov1r(:, :, 1, imyp))
2963 : : ! Remove the phase to get the lattice-periodic part.
2964 [ # # ]: 0 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, 1, imyp))
2965 [ # # # # : 0 : if (db%nspden /= 1) ov1r(:, :, 2, imyp) = ov1r(:, :, 1, imyp)
# # ]
2966 : : end do
2967 : :
2968 [ # # ]: 0 : if (my_add_lr > 4) then
2969 : : ! Restore input flags.
2970 : 0 : db%has_zeff = prev_has_zeff
2971 : 0 : db%has_quadrupoles = prev_has_quadrupoles
2972 : 0 : db%has_efield = prev_has_efield
2973 : : end if
2974 : :
2975 : 0 : return
2976 : : end if
2977 : :
2978 [ - + ]: 3762 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
2979 : :
2980 : : ! Examine the symmetries of the q-wavevector
2981 : 3762 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
2982 : :
2983 : : ! Compute long-range part of the coupling potential.
2984 [ + + ]: 3762 : if (my_add_lr > 0) then
2985 : : !call wrtout(std_out, "dvdb_ftinterp_qpt: Computing long-range part of the coupling potential.")
2986 [ - + + - : 10056 : ABI_MALLOC(v1r_lr, (2, nfft, db%my_npert))
- + + - +
- + - - +
- + ]
2987 [ + + ]: 17598 : do imyp=1,db%my_npert
2988 : 15084 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2989 : 17598 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
2990 : : end do
2991 : : end if
2992 : :
2993 : : ! Compute e^{iq.R} FT phases for this q-point.
2994 [ - + + - : 11286 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
2995 : 3762 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
2996 : :
2997 : : ! Interpolate potentials (results in ov1r)
2998 [ - + - - : 3762 : if (db%nprocs_rpt > 1) ov1r = zero
- - - - -
- ]
2999 [ - + + - : 11286 : ABI_MALLOC(ov1r_sp, (2, nfft))
+ - + - -
+ - + ]
3000 : :
3001 [ - + + - : 11286 : ABI_MALLOC(weiqr_sp, (db%my_nrpt, 2))
+ - + - -
+ - + ]
3002 [ - + + - : 7524 : ABI_MALLOC(eiqr_sp, (db%my_nrpt, 2))
- + - + ]
3003 [ - + + + : 275908 : eiqr_sp = transpose(eiqr)
+ + ]
3004 : :
3005 [ + + ]: 23778 : do imyp=1,db%my_npert
3006 : 20016 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
3007 : :
3008 [ + + ]: 782148 : weiqr_sp(:, 1) = db%my_wratm(:, ipert) * eiqr_sp(:, 1)
3009 [ + + ]: 782148 : weiqr_sp(:, 2) = db%my_wratm(:, ipert) * eiqr_sp(:, 2)
3010 : :
3011 [ + + ]: 40032 : do ispden=1,db%nspden
3012 : :
3013 : : ! We need to compute: sum_R W(R, r) e^{iq.R} with W real matrix.
3014 : : ! Use BLAS2 to compute ov1r = W (x + iy) but need to handle kind conversion as ov1r is double-precision
3015 : : ! NB: Can use MKL BLAS-like extensions to perform 2 matrix-vector operations:
3016 : : ! call dgem2vu(m, n, alpha, a, lda, x1, incx1, x2, incx2, beta, y1, incy1, y2, incy2)
3017 : : ! unfortunately the API does not support transa so one has to transport db%wsr.
3018 : : ! Alternatively, compute all my_npert with ZGEMM (more memory but it should be more efficient).
3019 : :
3020 : : !select case (db%gpu_option)
3021 : : !case (ABI_GPU_DISABLED)
3022 : : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,1), 1, &
3023 : 20016 : zero_sp, ov1r_sp(1,1), 2)
3024 : : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,2), 1, &
3025 : 20016 : zero_sp, ov1r_sp(2,1), 2)
3026 : : !case (ABI_GPU_OPENMP)
3027 : : ! TODO
3028 : : !case default
3029 : : ! ABI_ERROR(sjoin("ftinterp_qpt: unsupported gpu_option:", itoa(db%gpu_option)))
3030 : : !end select
3031 : :
3032 [ + + + + ]: 406968624 : ov1r(:, :, ispden, imyp) = ov1r_sp(:, :)
3033 : :
3034 : : ! Need to collect results if R-points are distributed (TODO Non-blocking API?)
3035 : : ! Sum before adding the long-range part, else it is counted nprocs_rpt times.
3036 [ - + ]: 20016 : if (db%nprocs_rpt > 1) call xmpi_sum(ov1r(:,:,ispden,imyp), comm_rpt, ierr)
3037 : :
3038 : : ! Add the long-range part of the potential (spin-independent --> diagonal spin components only)
3039 [ + + ]: 20016 : if (my_add_lr > 0 .and. ispden <= 2) then
3040 : : !call wrtout(std_out, "Adding the long-range part of the potential")
3041 [ + + + + ]: 164629692 : ov1r(:, :, ispden, imyp) = ov1r(:, :, ispden, imyp) + v1r_lr(:, :, imyp)
3042 : : end if
3043 : :
3044 : : ! Remove the phase to get the lattice-periodic part.
3045 [ + + ]: 100080 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, ispden, imyp))
3046 : : end do ! ispden
3047 : :
3048 : : ! Be careful with Gamma-point and cplex!
3049 [ + + ]: 23778 : if (db%symv1 == 1) then !(.and. receiver == -1 .or. receiver == db%comm_rpt%my_rank)
3050 : : call v1phq_symmetrize(db%cryst, idir, ipert, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, &
3051 : 1218 : db%mpi_enreg, ov1r(:,:,:,imyp))
3052 : : end if
3053 : : end do ! imyp
3054 : :
3055 [ - + ]: 3762 : ABI_FREE(ov1r_sp)
3056 : :
3057 [ - + ]: 3762 : if (db%symv1 == 2) then
3058 : : ! Symmetrize potentials (this part is seldom executed)
3059 : : ! v1phq_complete needs all the 3*natom perturbations in ov1r.
3060 [ # # ]: 0 : ABI_CHECK(db%my_npert == db%natom3, "symv1scf == 2 is not compatible with parallelism over perturbations")
3061 : : ! Initialize the list of perturbations rfpert and rdfir
3062 : : ! WARNING: Only phonon perturbations are considered for the time being.
3063 [ # # # # : 0 : ABI_MALLOC(rfpert, (db%mpert))
# # # # #
# # # ]
3064 [ # # # # : 0 : rfpert = 0; rfpert(1:db%cryst%natom) = 1; rfdir = 1
# # ]
3065 [ # # # # : 0 : ABI_MALLOC(pertsy, (3, db%mpert))
# # # # #
# # # ]
3066 [ # # # # : 0 : ABI_MALLOC(pflag, (3, db%natom))
# # # # #
# # # ]
3067 : :
3068 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
3069 : : ! 0 for non-target perturbations
3070 : : ! 1 for basis perturbations
3071 : : ! -1 for perturbations that can be found from basis perturbations
3072 : : call irreducible_set_pert(db%cryst%indsym,db%mpert,db%cryst%natom,db%cryst%nsym,&
3073 : 0 : pertsy,rfdir,rfpert,symq,db%cryst%symrec,db%cryst%symrel)
3074 : :
3075 [ # # # # ]: 0 : pflag = 0
3076 [ # # ]: 0 : do imyp=1,3*db%cryst%natom
3077 : 0 : idir = mod(imyp-1, 3) + 1; ipert = (imyp - idir) / 3 + 1
3078 [ # # ]: 0 : if (pertsy(idir, ipert) == 1) pflag(idir,ipert) = 1
3079 : : end do
3080 : :
3081 : : ! Complete potentials
3082 : 0 : call v1phq_complete(db%cryst,qpt,ngfft,cplex2,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,ov1r)
3083 : :
3084 [ # # ]: 0 : ABI_FREE(pertsy)
3085 [ # # ]: 0 : ABI_FREE(rfpert)
3086 [ # # ]: 0 : ABI_FREE(pflag)
3087 : : endif
3088 : :
3089 : : ! Set imaginary part to zero if gamma point.
3090 [ + + + + : 6133032 : if (sum(qpt**2) < tol14) ov1r(2, :, :, :) = zero
+ + + + +
+ ]
3091 : :
3092 [ - + ]: 3762 : ABI_FREE(eiqr)
3093 [ - + ]: 3762 : ABI_FREE(weiqr_sp)
3094 [ + + ]: 3762 : ABI_SFREE(v1r_lr)
3095 [ + - ]: 3762 : ABI_SFREE(eiqr_sp)
3096 : :
3097 : 3762 : end subroutine dvdb_ftinterp_qpt
3098 : : !!***
3099 : :
3100 : : !----------------------------------------------------------------------
3101 : :
3102 : : !!****f* m_dvdb/dvdb_get_ftqbz
3103 : : !! NAME
3104 : : !! dvdb_get_ftqbz
3105 : : !!
3106 : : !! FUNCTION
3107 : : !! Fourier interpolation of potentials for a given q-point in the BZ (qbz).
3108 : : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
3109 : : !!
3110 : : !! INPUTS
3111 : : !! qbz(3)= q-point in the BZ in reduced coordinates.
3112 : : !! nfft=Number of fft-points treated by this processors
3113 : : !! ngfft(18)=contain all needed information about 3D FFT
3114 : : !!
3115 : : !! OUTPUT
3116 : : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point.
3117 : : !!
3118 : : !! SOURCE
3119 : :
3120 : 3757 : subroutine dvdb_get_ftqbz(db, qbz, cplex, nfft, ngfft, v1scf, comm)
3121 : :
3122 : : !Arguments ------------------------------------
3123 : : !scalars
3124 : : class(dvdb_t),intent(inout) :: db
3125 : : integer,intent(in) :: nfft, comm
3126 : : integer,intent(out) :: cplex
3127 : : !arrays
3128 : : integer,intent(in) :: ngfft(18)
3129 : : real(dp),intent(in) :: qbz(3)
3130 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3131 : :
3132 : : !Local variables-------------------------------
3133 : : real(dp) :: tsec(2)
3134 : : ! *************************************************************************
3135 : :
3136 : : ABI_UNUSED(comm)
3137 : :
3138 : : ! Keep track of total time spent.
3139 : 3757 : call timab(1809, 1, tsec)
3140 : :
3141 : : ! Interpolate the dvscf potentials directly in the **BZ** for my_npert perturbations.
3142 : : ! This is possible only if all procs inside comm_rpt call this routine else deadlock
3143 : : ! Note that cplex is always set to 2 here
3144 : 3757 : cplex = 2
3145 [ - + + - : 18785 : ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3146 : 3757 : call db%ftinterp_qpt(qbz, nfft, ngfft, v1scf, db%comm_rpt)
3147 : 3757 : call timab(1809, 2, tsec)
3148 : :
3149 : 3757 : end subroutine dvdb_get_ftqbz
3150 : : !!***
3151 : :
3152 : : !----------------------------------------------------------------------
3153 : :
3154 : : !!****f* m_dvdb/dvdb_get_vxc1_ftqbz
3155 : : !! NAME
3156 : : !! dvdb_get_vxc1_ftqbz
3157 : : !!
3158 : : !! FUNCTION
3159 : : !! Fourier interpolation of the first-order change of exchange-correlation potential
3160 : : !! for a given q-point in the BZ (qbz).
3161 : : !!
3162 : : !! INPUTS
3163 : : !! cryst<crystal_t>=crystal structure parameters
3164 : : !! dtset<dataset_type>=All input variables for this dataset
3165 : : !! qbz(3)=Q-point in BZ
3166 : : !! nfft=Number of fft-points treated by this processors
3167 : : !! ngfft(18)=contain all needed information about 3D FFT
3168 : : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
3169 : : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
3170 : : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
3171 : : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
3172 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
3173 : : !!
3174 : : !! OUTPUT
3175 : : !! drho_cplex=1 if real, 2 if complex.
3176 : : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
3177 : : !! for the db%my_npert perturbations treated by this MPI rank.
3178 : : !!
3179 : : !! SOURCE
3180 : :
3181 : 0 : subroutine dvdb_get_vxc1_ftqbz(db, dtset, cryst, qbz, drho_cplex, nfft, ngfft, nkxc, kxc, &
3182 : : vxc1, non_magnetic_xc, usexcnhat, comm)
3183 : :
3184 : : !Arguments ------------------------------------
3185 : : !scalars
3186 : : class(dvdb_t),intent(inout) :: db
3187 : : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
3188 : : integer,intent(out) :: drho_cplex
3189 : : real(dp),intent(in) :: qbz(3)
3190 : : type(dataset_type),intent(in) :: dtset
3191 : : type(crystal_t),intent(in) :: cryst
3192 : : logical,intent(in) :: non_magnetic_xc
3193 : : !arrays
3194 : : integer,intent(in) :: ngfft(18)
3195 : : real(dp),intent(in) :: kxc(nfft,nkxc)
3196 : : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
3197 : :
3198 : : !Local variables-------------------------------
3199 : : !scalars
3200 : : integer :: option,imyp
3201 : : !arrays
3202 : 0 : real(dp),allocatable :: rho1(:,:,:,:)
3203 : : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
3204 : : ! *************************************************************************
3205 : :
3206 : : ! Get rho1(cplex, nfftf, nspden, my_npert))
3207 : 0 : call db%get_ftqbz(qbz, drho_cplex, nfft, ngfft, rho1, comm)
3208 : :
3209 : 0 : option = 2 ! if 2, treat only density change
3210 : : !option = 1 ! if 1, treat both density change and XC core correction
3211 [ # # ]: 0 : ABI_CHECK_IEQ(dtset%nspden, db%nspden, "dtset%nspden /= db%nspden")
3212 [ # # # # : 0 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3213 : :
3214 [ # # ]: 0 : do imyp=1,db%my_npert
3215 : : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
3216 : : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp),&
3217 : 0 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
3218 : : end do
3219 : :
3220 [ # # ]: 0 : ABI_FREE(rho1)
3221 : :
3222 : 0 : end subroutine dvdb_get_vxc1_ftqbz
3223 : : !!***
3224 : :
3225 : : !----------------------------------------------------------------------
3226 : :
3227 : : !!****f* m_dvdb/dvdb_get_v1scf_rpt
3228 : : !! NAME
3229 : : !! dvdb_get_v1scf_rpt
3230 : : !!
3231 : : !! FUNCTION
3232 : : !! Compute the phonon perturbation potential in real space lattice representation.
3233 : : !! This routine is meant to replace dvdb_ftinterp_setup
3234 : : !! and performs the potential interpolation one perturbation at a time.
3235 : : !!
3236 : : !! INPUTS
3237 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3238 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3239 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3240 : : !! nfft=Number of fft-points treated by this processors
3241 : : !! ngfft(18)=contain all needed information about 3D FFT
3242 : : !! nrpt=Number of R-points = number of q-points in the full BZ
3243 : : !! nspden=Number of spin densities.
3244 : : !! ipert=index of the perturbation to be treated [1,natom3]
3245 : : !! comm=MPI communicator
3246 : : !!
3247 : : !! OUTPUT
3248 : : !! v1scf_rpt(2,nrpt,nfft,nspden)
3249 : : !!
3250 : : !! SOURCE
3251 : :
3252 : 31 : subroutine dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3253 : 31 : nrpt, nspden, ipert, v1scf_rpt, comm, qptopt)
3254 : :
3255 : : !Arguments ------------------------------------
3256 : : !scalars
3257 : : integer,intent(in) :: nqshift,nfft,nrpt,nspden,ipert,comm
3258 : : integer,optional,intent(in) :: qptopt
3259 : : class(dvdb_t),target,intent(inout) :: db
3260 : : !arrays
3261 : : integer,intent(in) :: ngqpt(3),ngfft(18)
3262 : : real(dp),intent(in) :: qshift(3,nqshift)
3263 : : real(dp),intent(out) :: v1scf_rpt(2,nrpt,nfft,nspden)
3264 : : type(crystal_t),intent(in) :: cryst
3265 : :
3266 : : !Local variables-------------------------------
3267 : : !scalars
3268 : : integer,parameter :: sppoldbl1=1
3269 : : integer :: my_qptopt,my_timrev,my_nsym,iq_ibz,nqibz,iq_bz,nqbz
3270 : : integer :: ii,iq_dvdb,cplex_qibz,ispden,irpt,idir,iat
3271 : : integer :: iqst,nqst,itimrev,tsign,isym,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3
3272 : : integer :: nproc,my_rank,ifft,cnt,ierr
3273 : : character(len=500) :: msg
3274 : : real(dp) :: dksqmax, cpu, wall, gflops
3275 : : logical :: isirr_q, found
3276 : : !arrays
3277 : : integer :: qptrlatt(3,3),g0q(3)
3278 : 31 : integer,allocatable :: indqq(:,:),iperm(:),bz2ibz_sort(:),nqsts(:),iqs_dvdb(:)
3279 : : real(dp) :: qpt_bz(3),shift(3)
3280 : 31 : real(dp),allocatable :: qibz(:,:),qbz(:,:),wtq(:),emiqr(:,:)
3281 : 31 : real(dp),allocatable :: v1r_qibz(:,:,:,:),v1r_qbz(:,:,:,:), v1r_lr(:,:)
3282 : : ! *************************************************************************
3283 : :
3284 : : !ABI_ERROR("Legacy code!")
3285 : :
3286 : 31 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3287 : :
3288 [ + - ]: 31 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3); my_qptopt = 1; if (present(qptopt)) my_qptopt = qptopt
3289 : :
3290 : : ! Symmetries used to map the BZ onto the IBZ: same convention as kpts_map.
3291 : 31 : my_timrev = kpts_timrev_from_kptopt(my_qptopt)
3292 [ - + ]: 31 : my_nsym = cryst%nsym; if (any(my_qptopt == [2, 3])) my_nsym = 1
3293 : :
3294 : : ! Generate the q-mesh by finding the IBZ and the corresponding weights.
3295 : 31 : qptrlatt = 0
3296 [ + + ]: 124 : do ii=1,3
3297 : 124 : qptrlatt(ii,ii) = ngqpt(ii)
3298 : : end do
3299 : :
3300 : : ! Get IBZ and BZ.
3301 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, &
3302 : 31 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
3303 : :
3304 : : !write(std_out,*)"Irreducible q-points:"
3305 : : !do iq_ibz=1,nqibz; write(std_out,*)trim(ktoa(qibz(:,iq_ibz))),wtq(iq_ibz)*nqbz; end do
3306 [ + + - + ]: 124 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
3307 [ - + ]: 31 : ABI_CHECK(nqbz == nrpt, "nqbz /= nrpt")
3308 : :
3309 : 31 : db%my_nrpt = nqbz
3310 : :
3311 [ - + ]: 31 : ABI_CHECK(nspden == db%nspden, "nspden /= db%nspden")
3312 : :
3313 : : ! We want a gamma centered q-mesh for FFT.
3314 [ - + ]: 31 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
3315 [ + + + - : 124 : ABI_CHECK(all(qshift(:,1) == zero), "qshift != 0 not supported")
- + ]
3316 : :
3317 [ - + ]: 31 : ABI_FREE(qbz)
3318 [ - + + - : 93 : ABI_MALLOC(qbz, (3, nqbz))
+ - + - -
+ - + ]
3319 : 31 : ii = 0
3320 [ + + ]: 99 : do iz=0,nq3-1
3321 [ + + ]: 259 : do iy=0,nq2-1
3322 [ + + ]: 644 : do ix=0,nq1-1
3323 : 416 : ii = ii + 1
3324 [ + + ]: 1664 : qbz(:, ii) = [ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)]
3325 [ + + ]: 1824 : call wrap2_pmhalf([ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)], qbz(:,ii), shift)
3326 : : end do
3327 : : end do
3328 : : end do
3329 : :
3330 : : ! Compute real-space points.
3331 : : ! Use the following indexing (N means ngfft of the adequate direction)
3332 : : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
3333 : : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
3334 [ - + + - : 93 : ABI_MALLOC(db%my_rpt, (3, db%my_nrpt))
+ - + - -
+ - + -
+ ]
3335 : 31 : ii = 0
3336 [ + + ]: 99 : do iz=1,nq3
3337 : 68 : r3 = ig2gfft(iz,nq3)
3338 [ + + ]: 259 : do iy=1,nq2
3339 : 160 : r2 = ig2gfft(iy,nq2)
3340 [ + + ]: 644 : do ix=1,nq1
3341 : 416 : r1 = ig2gfft(ix,nq1)
3342 : 416 : ii = ii + 1
3343 [ + + ]: 1824 : db%my_rpt(:,ii) = [r1, r2, r3]
3344 : : end do
3345 : : end do
3346 : : end do
3347 : :
3348 : : ! Find correspondence BZ --> IBZ. Note:
3349 : : ! q --> -q symmetry is always used for phonons.
3350 : : ! we use symrec instead of symrel
3351 [ - + + - : 93 : ABI_MALLOC(indqq, (nqbz*sppoldbl1,6))
+ - + - -
+ - + ]
3352 : : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,my_nsym,&
3353 : 31 : sppoldbl1,cryst%symafm,cryst%symrec,my_timrev,comm,use_symrec=.True.)
3354 : :
3355 : : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3356 : : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3357 : : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3358 : : !call qrank%free()
3359 : :
3360 [ - + ]: 31 : if (dksqmax > tol12) then
3361 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3362 : : end if
3363 : :
3364 : : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
3365 [ - + + - : 93 : ABI_MALLOC(iperm, (nqbz))
+ - + - -
+ - + ]
3366 [ - + + - : 62 : ABI_MALLOC(bz2ibz_sort, (nqbz))
- + - + ]
3367 [ - + + + : 1310 : iperm = [(ii, ii=1,nqbz)]
+ - + + +
- - + - -
+ + ]
3368 [ - + + + ]: 478 : bz2ibz_sort = indqq(:,1)
3369 : 31 : call sort_int(nqbz, bz2ibz_sort, iperm)
3370 : :
3371 : : ! Reconstruct the IBZ according to what is present in the DVDB.
3372 [ - + + - : 93 : ABI_MALLOC(nqsts, (nqibz))
+ - + - -
+ - + ]
3373 [ - + + - : 62 : ABI_MALLOC(iqs_dvdb, (nqibz))
- + - + ]
3374 [ - + + - : 93 : ABI_MALLOC(v1r_lr, (2,nfft))
+ - + - -
+ - + ]
3375 : :
3376 : 31 : iqst = 0
3377 [ + + ]: 139 : do iq_ibz=1,nqibz
3378 : : ! In each q-point star, count the number of q-points and find the one present in DVDB.
3379 : 108 : nqst = 0
3380 : 108 : found = .false.
3381 [ + + ]: 524 : do ii=iqst+1,nqbz
3382 [ + + ]: 493 : if (bz2ibz_sort(ii) /= iq_ibz) exit
3383 : 416 : nqst = nqst + 1
3384 : :
3385 : 416 : iq_bz = iperm(ii)
3386 [ + + ]: 524 : if (.not. found) then
3387 : 317 : iq_dvdb = db%findq(qbz(:,iq_bz))
3388 [ + + ]: 317 : if (iq_dvdb /= -1) then
3389 [ + + ]: 432 : qibz(:,iq_ibz) = qbz(:,iq_bz)
3390 : 108 : iqs_dvdb(iq_ibz) = iq_dvdb
3391 : 108 : found = .true.
3392 : : end if
3393 : : end if
3394 : : end do
3395 : :
3396 : : ! Check that nqst has been counted properly.
3397 [ + - - + ]: 108 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst+1) == iq_ibz, "Wrong iqst")
3398 [ - + ]: 108 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
3399 : 0 : write(std_out,*)nqst, wtq(iq_ibz) * nqbz
3400 : 0 : ABI_ERROR("Error in counting q-point star or in the weights.")
3401 : : end if
3402 : :
3403 : : ! Check that the q-point has been found in DVDB.
3404 [ - + ]: 108 : if (.not. found) then
3405 : 0 : ABI_ERROR(sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
3406 : : end if
3407 : : !write(std_out,*)sjoin("qpt irred:",ktoa(qibz(:,iq_ibz)))
3408 : :
3409 : 108 : iqst = iqst + nqst
3410 : 139 : nqsts(iq_ibz) = nqst
3411 : : end do
3412 : :
3413 : : ! Redo the mapping with the new IBZ
3414 : : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,my_nsym,&
3415 : 31 : sppoldbl1,cryst%symafm,cryst%symrec,my_timrev,comm,use_symrec=.True.)
3416 : :
3417 : : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3418 : : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3419 : : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3420 : : !call qrank%free()
3421 : :
3422 [ - + ]: 31 : if (dksqmax > tol12) then
3423 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3424 : : end if
3425 : :
3426 [ - + + - : 93 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
3427 [ + + + + : 11230149 : v1scf_rpt = zero
+ + + + ]
3428 : :
3429 [ - + + - : 155 : ABI_MALLOC_OR_DIE(v1r_qbz, (2, nfft, db%nspden, db%natom3), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
3430 : : !v1r_qbz = huge(one)
3431 : :
3432 : 31 : iqst = 0
3433 : 31 : call cwtime(cpu, wall, gflops, "start")
3434 [ + + ]: 139 : do iq_ibz=1,nqibz
3435 : :
3436 : : ! Get potentials for this IBZ q-point on the real-space FFT mesh.
3437 : : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
3438 [ - + ]: 108 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, comm)
3439 : :
3440 : : ! Reconstruct by symmetry the potentials for the star of this q-point, perform FT and accumulate
3441 : : ! Be careful with the gamma point.
3442 [ + + ]: 524 : do ii=1,nqsts(iq_ibz)
3443 : 416 : iqst = iqst + 1
3444 : 416 : iq_bz = iperm(iqst)
3445 [ - + ]: 416 : ABI_CHECK(iq_ibz == indqq(iq_bz,1), "iq_ibz !/ ind qq(1)")
3446 [ + + ]: 1664 : isym = indqq(iq_bz,2); itimrev = indqq(iq_bz,6) + 1; g0q = indqq(iq_bz,3:5) ! IS(q_ibz) + g0q = q_bz
3447 : 416 : tsign = 3-2*itimrev
3448 : :
3449 [ + + ]: 1664 : qpt_bz = qbz(:, iq_bz)
3450 : : !write(std_out,*)" treating:",trim(ktoa(qpt_bz))
3451 [ + + + + : 1681 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
3452 : : !ABI_CHECK(all(g0q == 0), "g0q /= 0")
3453 : :
3454 : : ! Compute long-range part of the coupling potential
3455 : : !call cwtime(cpu, wall, gflops, "start")
3456 [ + + + + ]: 10816136 : v1r_lr = zero; cnt = 0
3457 [ + + ]: 416 : if (db%add_lr /= 0) then
3458 : 128 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3459 : 128 : call db%get_v1r_long_range(qpt_bz, idir, iat, nfft, ngfft, v1r_lr)
3460 : : end if
3461 : : !call cwtime_report(" dvdb_get_v1r_long_range", cpu, wall, gflops)
3462 : :
3463 [ + + ]: 524 : if (cplex_qibz == 1) then
3464 : : ! Gamma point.
3465 [ - + ]: 31 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
3466 [ + + + - : 124 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
- + ]
3467 : :
3468 : : ! Subtract the long-range part of the potential (diagonal spin components only)
3469 [ + + ]: 31 : if (db%add_lr /= 0) then
3470 [ + + ]: 32 : do ispden=1,min(db%nspden, 2)
3471 [ + + ]: 159090 : v1r_qibz(1,:,ispden,ipert) = v1r_qibz(1,:,ispden,ipert) - v1r_lr(1,:)
3472 : : end do
3473 : : end if
3474 : :
3475 : : ! SLOW FT.
3476 : : !call cwtime(cpu, wall, gflops, "start")
3477 : 31 : cnt = 0
3478 [ + + ]: 62 : do ispden=1,db%nspden
3479 [ + + ]: 478 : do irpt=1,db%my_nrpt
3480 : : ! MPI-parallelism
3481 [ + - ]: 416 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
3482 [ + + ]: 3605687 : do ifft=1,nfft
3483 : : v1scf_rpt(1,irpt,ifft,ispden) = v1scf_rpt(1,irpt,ifft,ispden) + &
3484 : 3605656 : v1r_qibz(1, ifft, ispden, ipert)
3485 : : end do
3486 : : end do
3487 : : end do
3488 : : !call cwtime_report(" slow fft", cpu, wall, gflops)
3489 : :
3490 : : else
3491 : : ! q /= Gamma
3492 : : ! Get the periodic part of the potential in BZ (v1r_qbz)
3493 [ + + ]: 385 : if (isirr_q) then
3494 : : !write(std_out,*)sjoin("qpt irred:",ktoa(qpt_bz))
3495 [ + - + - : 15058132 : v1r_qbz = v1r_qibz
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
3496 : : else
3497 : : !call cwtime(cpu, wall, gflops, "start")
3498 : : call v1phq_rotate(cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
3499 : 308 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
3500 : : end if
3501 : :
3502 : : ! Multiply by e^{iqpt_bz.r}
3503 : 385 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden*db%natom3, v1r_qbz)
3504 : :
3505 : : ! Subtract the long-range part of the potential (diagonal spin components only)
3506 [ + + ]: 385 : if (db%add_lr /= 0) then
3507 [ + + ]: 224 : do ispden=1,min(db%nspden, 2)
3508 [ + + ]: 1113518 : v1r_qbz(1,:,ispden,ipert) = v1r_qbz(1,:,ispden,ipert) - v1r_lr(1,:)
3509 [ + + ]: 1113630 : v1r_qbz(2,:,ispden,ipert) = v1r_qbz(2,:,ispden,ipert) - v1r_lr(2,:)
3510 : : end do
3511 : : end if
3512 : :
3513 : : ! Compute FT phases for this qpt_bz.
3514 [ + + ]: 1540 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
3515 : :
3516 : : ! SLOW FT.
3517 : : !call cwtime_report(" phases", cpu, wall, gflops)
3518 : 385 : cnt = 0
3519 [ + + ]: 770 : do ispden=1,db%nspden
3520 [ + + ]: 3191643 : do ifft=1,nfft
3521 [ + - ]: 3190873 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
3522 : :
3523 : : v1scf_rpt(1,:,ifft,ispden) = v1scf_rpt(1,:,ifft,ispden) &
3524 : : + emiqr(1,:) * v1r_qbz(1, ifft, ispden, ipert) &
3525 [ + + ]: 47007009 : - emiqr(2,:) * v1r_qbz(2, ifft, ispden, ipert)
3526 : :
3527 : : v1scf_rpt(2,:,ifft,ispden) = v1scf_rpt(2,:,ifft,ispden) &
3528 : : + emiqr(1,:) * v1r_qbz(2, ifft, ispden, ipert) &
3529 [ + + ]: 47007394 : + emiqr(2,:) * v1r_qbz(1, ifft, ispden, ipert)
3530 : : end do
3531 : : end do
3532 : : !call cwtime_report(" slow fft", cpu, wall, gflops)
3533 : : end if
3534 : :
3535 : : end do ! iqst
3536 : :
3537 : 108 : write(msg,'(2(a,i0),a)') " q-point [",iq_ibz,"/",nqibz,"]"
3538 : 108 : call cwtime_report(msg, cpu, wall, gflops)
3539 : :
3540 [ - + ]: 139 : ABI_FREE(v1r_qibz)
3541 : : end do ! iq_ibz
3542 [ - + ]: 31 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
3543 : :
3544 [ + + + + : 11230149 : v1scf_rpt = v1scf_rpt / nqbz
+ + + + ]
3545 : 31 : call xmpi_sum(v1scf_rpt, comm, ierr)
3546 : :
3547 [ - + ]: 31 : ABI_FREE(emiqr)
3548 [ - + ]: 31 : ABI_FREE(qibz)
3549 [ - + ]: 31 : ABI_FREE(wtq)
3550 [ - + ]: 31 : ABI_FREE(qbz)
3551 [ - + ]: 31 : ABI_FREE(indqq)
3552 [ - + ]: 31 : ABI_FREE(iperm)
3553 [ - + ]: 31 : ABI_FREE(bz2ibz_sort)
3554 [ - + ]: 31 : ABI_FREE(iqs_dvdb)
3555 [ - + ]: 31 : ABI_FREE(nqsts)
3556 [ - + ]: 31 : ABI_FREE(v1r_qbz)
3557 [ - + ]: 31 : ABI_FREE(v1r_lr)
3558 : :
3559 [ - + ]: 62 : end subroutine dvdb_get_v1scf_rpt
3560 : : !!***
3561 : :
3562 : : !----------------------------------------------------------------------
3563 : :
3564 : : !!****f* m_dvdb/dvdb_get_v1scf_qpt
3565 : : !! NAME
3566 : : !! dvdb_get_v1scf_qpt
3567 : : !!
3568 : : !! FUNCTION
3569 : : !! Fourier interpolation of potentials for a given q-point
3570 : : !! This routine is meant to replace dvdb_ftinterp_qpt
3571 : : !! by performing the interpolation one perturbation at a time.
3572 : : !!
3573 : : !! INPUTS
3574 : : !! qpt(3)=q-point in reduced coordinates.
3575 : : !! nfft=Number of fft-points treated by this processors
3576 : : !! ngfft(18)=contain all needed information about 3D FFT
3577 : : !! nrpt=Number of R-points = number of q-points in the full BZ
3578 : : !! nspden=Number of spin densities.
3579 : : !! ipert=index of the perturbation to be treated [1,natom3]
3580 : : !! v1scf_rpt(2,nrpt,nfft,nspden)=phonon perturbation potential in real space lattice representation.
3581 : : !! comm=MPI communicator
3582 : : !!
3583 : : !! OUTPUT
3584 : : !! v1scf_qpt(2*nfft, nspden)=Interpolated DFPT potentials at the given q-point.
3585 : : !!
3586 : : !! SOURCE
3587 : :
3588 : 244 : subroutine dvdb_get_v1scf_qpt(db, cryst, qpt, nfft, ngfft, nrpt, nspden, &
3589 : 244 : ipert, v1scf_rpt, v1scf_qpt, comm)
3590 : :
3591 : : !Arguments ------------------------------------
3592 : : !scalars
3593 : : integer,intent(in) :: nfft,nrpt,nspden,ipert,comm
3594 : : class(dvdb_t),intent(in) :: db
3595 : : type(crystal_t),intent(in) :: cryst
3596 : : !arrays
3597 : : integer,intent(in) :: ngfft(18)
3598 : : real(dp),intent(in) :: qpt(3)
3599 : : real(dp),intent(in) :: v1scf_rpt(2,nrpt,nfft,db%nspden)
3600 : : real(dp),intent(out) :: v1scf_qpt(2,nfft,db%nspden)
3601 : :
3602 : : !Local variables-------------------------------
3603 : : !scalars
3604 : : integer,parameter :: cplex2=2
3605 : : integer :: ir,ispden,ifft,idir,iat,timerev_q,nproc,my_rank,cnt,ierr
3606 : : real(dp) :: wr,wi
3607 : : !arrays
3608 : 488 : integer :: symq(4,2,db%cryst%nsym)
3609 : 244 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:)
3610 : : ! *************************************************************************
3611 : :
3612 : : !ABI_ERROR("Legacy code!")
3613 : :
3614 : : ABI_UNUSED(cryst%natom)
3615 : : ABI_UNUSED(nspden)
3616 : :
3617 : 244 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3618 : :
3619 [ - + + - : 732 : ABI_MALLOC(v1r_lr, (2,nfft))
+ - + - -
+ - + ]
3620 : :
3621 : : ! Examine the symmetries of the q wavevector
3622 : 244 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
3623 : :
3624 : : ! Compute FT phases for this q-point.
3625 [ - + + - : 732 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
3626 : 244 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
3627 : :
3628 : 244 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3629 : :
3630 : : ! Compute long-range part of the coupling potential
3631 [ + + + + ]: 10437202 : v1r_lr = zero; cnt = 0
3632 [ + + ]: 244 : if (db%add_lr > 0) call db%get_v1r_long_range(qpt, idir, iat, nfft, ngfft, v1r_lr)
3633 : :
3634 : : ! TODO: If high-symmetry q-points, one could save flops by FFT interpolating the independent
3635 : : ! TODO: Use ZGEMM with MPI
3636 : : ! perturbations and then rotate ...
3637 [ + + + + : 10437446 : v1scf_qpt = zero; cnt = 0
+ + ]
3638 [ + + ]: 488 : do ispden=1,db%nspden
3639 [ + + ]: 3479230 : do ifft=1,nfft
3640 [ + - ]: 3478986 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI-parallelism
3641 : :
3642 [ + + ]: 36342810 : do ir=1,db%my_nrpt
3643 : 32863824 : wr = v1scf_rpt(1, ir,ifft,ispden)
3644 : 32863824 : wi = v1scf_rpt(2, ir,ifft,ispden)
3645 : 32863824 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + wr*eiqr(1,ir) - wi * eiqr(2,ir)
3646 : 36342810 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + wr*eiqr(2,ir) + wi * eiqr(1,ir)
3647 : : end do
3648 : :
3649 : : ! Add the long-range part of the potential (diagonal spin components only)
3650 [ + + + - ]: 3478986 : if (db%add_lr > 0 .and. ispden <= 2) then
3651 : 2555380 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + v1r_lr(1,ifft)
3652 : 2555380 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + v1r_lr(2,ifft)
3653 : : end if
3654 [ - + ]: 3479230 : if (db%add_lr == 4) then
3655 [ # # ]: 0 : if (ispden <= 2) then
3656 : 0 : v1scf_qpt(1,ifft,ispden) = v1r_lr(1,ifft)
3657 : 0 : v1scf_qpt(2,ifft,ispden) = v1r_lr(2,ifft)
3658 : : else
3659 [ # # ]: 0 : v1scf_qpt(:,ifft,ispden) = zero
3660 : : end if
3661 : : end if
3662 : : end do ! ifft
3663 : :
3664 : 244 : call xmpi_sum(v1scf_qpt(:,:,ispden), comm, ierr)
3665 : :
3666 : : ! Remove the phase.
3667 [ + + ]: 1220 : call times_eikr(-qpt, ngfft, nfft, 1, v1scf_qpt(:,:,ispden))
3668 : : end do
3669 : :
3670 : : ! Be careful with gamma and cplex!
3671 [ + + ]: 244 : if (db%symv1 == 1) then
3672 : 28 : call v1phq_symmetrize(db%cryst, idir, iat, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, db%mpi_enreg, v1scf_qpt)
3673 : : end if
3674 : :
3675 [ - + ]: 244 : ABI_FREE(eiqr)
3676 [ - + ]: 244 : ABI_FREE(v1r_lr)
3677 : :
3678 : 244 : end subroutine dvdb_get_v1scf_qpt
3679 : : !!***
3680 : :
3681 : : !----------------------------------------------------------------------
3682 : :
3683 : : !!****f* m_dvdb/dvdb_interpolate_v1scf
3684 : : !! NAME
3685 : : !! dvdb_interpolate_v1scf
3686 : : !!
3687 : : !! FUNCTION
3688 : : !! Interpolate the phonon perturbation potential.
3689 : : !! This routine is meant to replace dvdb_ftinterp_setup and dvdb_ftinterp_qpt.
3690 : : !! It performs the interpolation one perturbation at a time.
3691 : : !!
3692 : : !! INPUTS
3693 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3694 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3695 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3696 : : !! nfft=Number of fft-points treated by this processors
3697 : : !! ngfft(18)=contain all needed information about 3D FFT
3698 : : !! nfftf=Number of fft-points on the fine grid for interpolated potential
3699 : : !! ngfftf(18)=information on 3D FFT for interpolated potential
3700 : : !! comm=MPI communicator
3701 : : !!
3702 : : !! OUTPUT
3703 : : !! v1scf(2, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
3704 : : !!
3705 : : !! SOURCE
3706 : :
3707 : 0 : subroutine dvdb_interpolate_v1scf(db, cryst, qpt, ngqpt, nqshift, qshift, &
3708 : : nfft, ngfft, nfftf, ngfftf, v1scf, comm)
3709 : :
3710 : : !Arguments ------------------------------------
3711 : : !scalars
3712 : : integer,intent(in) :: nqshift,nfft,nfftf,comm
3713 : : class(dvdb_t),target,intent(inout) :: db
3714 : : !arrays
3715 : : real(dp),intent(in) :: qpt(3)
3716 : : integer,intent(in) :: ngqpt(3),ngfft(18),ngfftf(18)
3717 : : real(dp),intent(in) :: qshift(3,nqshift)
3718 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3719 : : type(crystal_t),intent(in) :: cryst
3720 : :
3721 : : !Local variables-------------------------------
3722 : : !scalars
3723 : : integer :: ipert, nqbz, ierr, nproc, my_rank
3724 : : !real(dp) :: work_size
3725 : : !arrays
3726 : 0 : real(dp),allocatable :: v1scf_rpt(:,:,:,:)
3727 : : ! *************************************************************************
3728 : :
3729 : : ! Not used by any caller. Known issues (see FIXME below): v1scf_rpt is allocated with nfft
3730 : : ! but dvdb_get_v1scf_qpt reads it with nfftf, and dvdb_get_v1scf_rpt allocates db%my_rpt
3731 : : ! (fails if dvdb_ftinterp_setup has been called before).
3732 : 0 : ABI_ERROR("dvdb_interpolate_v1scf is legacy code with known bugs. Use dvdb_ftinterp_setup and dvdb_ftinterp_qpt")
3733 : :
3734 : 0 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3735 : :
3736 [ # # ]: 0 : nqbz = product(ngqpt) * nqshift
3737 : 0 : db%my_nrpt = nqbz
3738 : :
3739 [ # # # # : 0 : ABI_MALLOC_OR_DIE(v1scf, (2,nfftf,db%nspden,db%natom3), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3740 [ # # # # : 0 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2,db%my_nrpt,nfft,db%nspden), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
3741 : :
3742 [ # # ]: 0 : do ipert=1,db%natom3
3743 : 0 : write(std_out, "(a,i4,a,i4,a)") " Interpolating potential for perturbation ", ipert, " / ", db%natom3, ch10
3744 : :
3745 : : ! FIXME I think this should be ngfftf and not ngfft
3746 : : ! Also, other calls to dvdb_ftinterp_setup should use ngfftf.
3747 : : call dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3748 : 0 : db%my_nrpt, db%nspden, ipert, v1scf_rpt, comm)
3749 : :
3750 : : call dvdb_get_v1scf_qpt(db, cryst, qpt, nfftf, ngfftf, db%my_nrpt, db%nspden, &
3751 : 0 : ipert, v1scf_rpt, v1scf(:,:,:,ipert), comm)
3752 : :
3753 [ # # ]: 0 : ABI_FREE(db%my_rpt)
3754 : : end do
3755 : :
3756 [ # # ]: 0 : ABI_FREE(v1scf_rpt)
3757 : :
3758 : 0 : end subroutine dvdb_interpolate_v1scf
3759 : : !!***
3760 : :
3761 : : !----------------------------------------------------------------------
3762 : :
3763 : : !!****f* m_dvdb/dvdb_findq
3764 : : !! NAME
3765 : : !! dvdb_findq
3766 : : !!
3767 : : !! FUNCTION
3768 : : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3769 : : !! Returns -1 if not found.
3770 : : !!
3771 : : !! INPUTS
3772 : : !! qpt(3)=q-point in reduced coordinates.
3773 : : !! [qtol]=Optional tolerance for q-point comparison.
3774 : : !! For each reduced direction the absolute difference between the coordinates must be less that qtol
3775 : : !!
3776 : : !! SOURCE
3777 : :
3778 : 6163 : integer pure function dvdb_findq(db, qpt, qtol) result(iqpt)
3779 : :
3780 : : !Arguments ------------------------------------
3781 : : !scalars
3782 : : real(dp),optional,intent(in) :: qtol
3783 : : class(dvdb_t),intent(in) :: db
3784 : : !arrays
3785 : : real(dp),intent(in) :: qpt(3)
3786 : :
3787 : : !Local variables-------------------------------
3788 : : !scalars
3789 : : integer :: iq
3790 : : real(dp) :: my_qtol
3791 : : ! *************************************************************************
3792 : :
3793 [ - + ]: 6163 : my_qtol = tol6; if (present(qtol)) my_qtol = qtol
3794 : 6163 : iqpt = -1
3795 [ + + ]: 45671 : do iq=1,db%nqpt
3796 [ + + + + : 55237 : if (all(abs(db%qpts(:, iq) - qpt) < my_qtol)) then
+ + ]
3797 : : iqpt = iq; exit
3798 : : end if
3799 : : end do
3800 : :
3801 : 6163 : end function dvdb_findq
3802 : : !!***
3803 : :
3804 : : !----------------------------------------------------------------------
3805 : :
3806 : : !!****f* m_dvdb/dvdb_find_qpts
3807 : : !! NAME
3808 : : !! dvdb_find_qpts
3809 : : !!
3810 : : !! FUNCTION
3811 : : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3812 : : !! Returns -1 if not found.
3813 : : !!
3814 : : !! INPUTS
3815 : : !! nqpt: Number of q-points
3816 : : !! qpt(3,nqpt): q-point in reduced coordinates.
3817 : : !! comm: MPI communicator
3818 : : !!
3819 : : !! OUTPUT
3820 : : !! iq2dvdb(nqpt): index of q-points in dvdb%qpts. Set to -1 if not found
3821 : : !! ierr= Number of points **not** found
3822 : : !!
3823 : : !! SOURCE
3824 : :
3825 : 61 : integer function dvdb_find_qpts(db, nqpt, qpts, iq2dvdb, comm) result(notfound)
3826 : :
3827 : : !Arguments ------------------------------------
3828 : : !scalars
3829 : : class(dvdb_t),intent(in) :: db
3830 : : integer,intent(in) :: nqpt, comm
3831 : : !arrays
3832 : : real(dp),intent(in) :: qpts(3, nqpt)
3833 : : integer,intent(out) :: iq2dvdb(nqpt)
3834 : :
3835 : : !Local variables-------------------------------
3836 : : !scalars
3837 : : integer :: iq, my_rank, nprocs, ierr
3838 : : ! *************************************************************************
3839 : :
3840 : 61 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
3841 : :
3842 [ + + ]: 4070 : iq2dvdb = 0
3843 [ + + ]: 4070 : do iq=1,nqpt
3844 [ - + ]: 4009 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
3845 : 4070 : iq2dvdb(iq) = db%findq(qpts(:, iq))
3846 : : end do
3847 : :
3848 : 61 : call xmpi_sum(iq2dvdb, comm, ierr)
3849 [ + + + + ]: 4070 : notfound = count(iq2dvdb == -1)
3850 : :
3851 : 61 : end function dvdb_find_qpts
3852 : : !!***
3853 : :
3854 : : !----------------------------------------------------------------------
3855 : :
3856 : : !!****f* m_dvdb/dvdb_need_ftinterp
3857 : : !! NAME
3858 : : !! dvdb_need_ftinterp
3859 : : !!
3860 : : !! FUNCTION
3861 : : !! Check whether input list of q-points requires Fourier interpolation.
3862 : : !!
3863 : : !! INPUTS
3864 : : !! nqpt: Number of q-points
3865 : : !! qpt(3,nqpt): q-point in reduced coordinates.
3866 : : !!
3867 : : !! OUTPUT
3868 : : !! qmap_symrec(6, nqpt)
3869 : : !! need_ftinterp
3870 : : !!
3871 : : !! SOURCE
3872 : :
3873 : 7 : subroutine dvdb_need_ftinterp(db, nqpt, qpts, qptopt, qmap_symrec, need_ftinterp)
3874 : :
3875 : : !Arguments ------------------------------------
3876 : : !scalars
3877 : : class(dvdb_t),intent(in) :: db
3878 : : integer,intent(in) :: nqpt, qptopt
3879 : : logical,intent(out) :: need_ftinterp
3880 : : !arrays
3881 : : real(dp),intent(in) :: qpts(3, nqpt)
3882 : : integer,allocatable,intent(out) :: qmap_symrec(:,:)
3883 : :
3884 : : !Local variables-------------------------------
3885 : : !scalars
3886 : 7 : type(krank_t) :: qrank
3887 : : ! *************************************************************************
3888 : :
3889 : 7 : need_ftinterp = .False.
3890 : 7 : call qrank%init(db%nqpt, db%qpts, compute_invrank=.False.)
3891 : :
3892 [ - + + - : 21 : ABI_MALLOC(qmap_symrec, (6, nqpt))
+ - + - -
+ - + -
+ ]
3893 : :
3894 [ + + ]: 7 : if (kpts_map("symrec", qptopt, db%cryst, qrank, nqpt, qpts, qmap_symrec) /= 0) then
3895 : : ! There's at least on-qpoint in qpts that is not the IBZ image of db%qpts.
3896 : 5 : need_ftinterp = .True.; call qrank%free()
3897 : 5 : return
3898 : : end if
3899 : :
3900 : : ! All the IBZ images must be in the DVDB.
3901 : : ! NB: qrank is built from db%qpts so qmap_symrec(1,:) already gives the index in db%qpts
3902 : : ! and the IBZ image is in the DVDB by construction (a check with findq would be a no-op).
3903 : :
3904 : 2 : call qrank%free()
3905 : :
3906 [ - + - + : 7 : end subroutine dvdb_need_ftinterp
- + - + -
+ - + ]
3907 : : !!***
3908 : :
3909 : : !!****f* m_dvdb/dvdb_map_qpt
3910 : : !! NAME
3911 : : !! dvdb_map_qpt
3912 : : !!
3913 : : !! FUNCTION
3914 : : !! Find the symmetry mapping (SYMREC convention) between a q-point and the q-points stored in the DVDB.
3915 : : !! Return non-zero if qpt is not the symmetrical image of a q-point in the DVDB.
3916 : : !!
3917 : : !! INPUTS
3918 : : !! qpt(3)=q-point in reduced coordinates.
3919 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
3920 : : !!
3921 : : !! OUTPUT
3922 : : !! qmap_symrec(6)=Mapping qpt --> db%qpts that can be passed to dvdb_readsym_qbz.
3923 : : !! qmap_symrec(1) is the index in db%qpts.
3924 : : !!
3925 : : !! SOURCE
3926 : :
3927 : 0 : integer function dvdb_map_qpt(db, qpt, qptopt, qmap_symrec) result(ierr)
3928 : :
3929 : : !Arguments ------------------------------------
3930 : : !scalars
3931 : : class(dvdb_t),intent(in) :: db
3932 : : integer,intent(in) :: qptopt
3933 : : !arrays
3934 : : real(dp),intent(in) :: qpt(3)
3935 : : integer,intent(out) :: qmap_symrec(6)
3936 : :
3937 : : !Local variables-------------------------------
3938 : 0 : type(krank_t) :: qrank
3939 : : integer :: qmap(6, 1)
3940 : : ! *************************************************************************
3941 : :
3942 : 0 : call qrank%init(db%nqpt, db%qpts, compute_invrank=.False.)
3943 [ # # ]: 0 : ierr = kpts_map("symrec", qptopt, db%cryst, qrank, 1, reshape(qpt, [3, 1]), qmap)
3944 : 0 : qmap_symrec = qmap(:, 1)
3945 : 0 : call qrank%free()
3946 : :
3947 [ # # # # : 0 : end function dvdb_map_qpt
# # ]
3948 : : !!***
3949 : :
3950 : : !!****f* m_dvdb/dvdb_set_pert_distrib
3951 : : !! NAME
3952 : : !! dvdb_set_pert_distrib
3953 : : !!
3954 : : !! FUNCTION
3955 : : !! Activate MPI distribution of the 3*natom perturbations.
3956 : : !!
3957 : : !! INPUTS
3958 : : !! my_npert=Number of perturbations treated by this rank
3959 : : !! natom3= 3 * natom
3960 : : !! my_pinfo(3, my_npert)
3961 : : !! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
3962 : : !! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
3963 : : !! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
3964 : : !! pert_table(2, natom3)
3965 : : !! pert_table(1, npert): rank of the processor treating this atomic perturbation.
3966 : : !! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
3967 : : !! comm_pert=MPI communicator used to distribute the 3*natom perturbations
3968 : : !!
3969 : : !! SOURCE
3970 : :
3971 : 0 : subroutine dvdb_set_pert_distrib(self, my_npert, natom3, my_pinfo, pert_table, comm_pert)
3972 : :
3973 : : !Arguments ------------------------------------
3974 : : !scalars
3975 : : class(dvdb_t),intent(inout) :: self
3976 : : integer,intent(in) :: my_npert, natom3, comm_pert
3977 : : !arrays
3978 : : integer,intent(in) :: my_pinfo(3,my_npert), pert_table(2,natom3)
3979 : : ! *************************************************************************
3980 : :
3981 : 0 : self%comm_pert = comm_pert
3982 : 0 : self%nprocs_pert = xmpi_comm_size(comm_pert)
3983 : 0 : self%me_pert = xmpi_comm_rank(comm_pert)
3984 : 0 : self%my_npert = my_npert
3985 : :
3986 [ # # ]: 0 : ABI_SFREE(self%my_pinfo)
3987 [ # # ]: 0 : ABI_SFREE(self%pert_table)
3988 [ # # ]: 0 : call alloc_copy(my_pinfo, self%my_pinfo)
3989 [ # # ]: 0 : call alloc_copy(pert_table, self%pert_table)
3990 : :
3991 [ # # ]: 0 : if (self%debug) then
3992 : 0 : write(std_out, *)"Activating perturbation over perturbations:"
3993 : 0 : write(std_out, *)"nprocs_pert: ", self%nprocs_pert
3994 : 0 : write(std_out, *)"my_pinfo: ",self%my_pinfo
3995 : 0 : write(std_out, *)"pert_table: ",self%pert_table
3996 : : end if
3997 : :
3998 : 0 : end subroutine dvdb_set_pert_distrib
3999 : : !!***
4000 : :
4001 : : !!****f* m_dvdb/dvdb_seek
4002 : : !! NAME
4003 : : !! dvdb_seek
4004 : : !!
4005 : : !! FUNCTION
4006 : : !! Move the internal file pointer so that it points to the
4007 : : !! block with (idir, ipert, iqpt). Needed only if dvdb%iomode==IO_MODE_FORTRAN
4008 : : !!
4009 : : !! INPUTS
4010 : : !! idir,ipert,iqpt = (direction, perturbation, q-point) indices
4011 : : !!
4012 : : !! SIDE EFFECTS
4013 : : !! db<type(dvdb_t)>: modifies db%current_fpos.
4014 : : !!
4015 : : !! SOURCE
4016 : :
4017 : 5360 : subroutine dvdb_seek(db, idir, ipert, iqpt)
4018 : :
4019 : : !Arguments ------------------------------------
4020 : : integer,intent(in) :: idir, ipert, iqpt
4021 : : type(dvdb_t),intent(inout) :: db
4022 : :
4023 : : !Local variables-------------------------------
4024 : : integer :: pos_now,pos_wanted,ii,ispden,nn,ierr
4025 : : real(dp),parameter :: fake_qpt(3)=zero
4026 : : character(len=500) :: msg
4027 : : ! *************************************************************************
4028 : :
4029 [ + - ]: 5360 : if (db%iomode == IO_MODE_FORTRAN) then
4030 : 5360 : pos_now = db%current_fpos
4031 : 5360 : pos_wanted = db%pos_dpq(idir,ipert,iqpt)
4032 [ - + ]: 5360 : ABI_CHECK(pos_wanted /= 0, "pos_wanted cannot be zero!")
4033 : :
4034 : : ! Optimal access.
4035 [ + + ]: 6416 : if (pos_now == pos_wanted) return
4036 : :
4037 [ + + ]: 1056 : if (pos_wanted < pos_now) then
4038 : : ! Backspace previous records and header
4039 : : ! but only if nn <= pos_wanted else rewind file and skip pos_wanted potentials (should be faster)
4040 : 850 : nn = pos_now - pos_wanted
4041 [ + + ]: 850 : if (nn <= pos_wanted) then
4042 [ + + ]: 3594 : do ii=1,nn
4043 : : !write(std_out, *)"backspacing"
4044 [ + - + - ]: 2974 : if (db%version > 1) backspace(unit=db%fh, err=10, iomsg=msg)
4045 [ + + ]: 5948 : do ispden=1,db%nspden
4046 [ + - ]: 5948 : backspace(unit=db%fh, err=10, iomsg=msg)
4047 : : end do
4048 : 2974 : ierr = db%hdr_ref%backspace(db%fh, msg)
4049 [ + - ]: 3594 : if (ierr /= 0) goto 10
4050 : : end do
4051 : 620 : db%current_fpos = pos_wanted; return
4052 : : else
4053 : : ! rewind the file and read it from the beginning
4054 [ - + ]: 230 : if (dvdb_rewind(db, msg) /= 0) then
4055 : 0 : ABI_ERROR(msg)
4056 : : end if
4057 : : nn = pos_wanted
4058 : : end if
4059 : :
4060 : : else
4061 : 206 : nn = pos_wanted - pos_now + 1
4062 : : end if
4063 : :
4064 [ + + ]: 4943 : do ii=1,nn-1
4065 : : !write(std_out,*)"in seek with ii: ",ii,"pos_wanted: ",pos_wanted
4066 [ - + ]: 4507 : if (my_hdr_skip(db%fh, -1, -1, fake_qpt, msg) /= 0) then
4067 : 0 : ABI_ERROR(msg)
4068 : : end if
4069 : : ! Skip the records with v1.
4070 [ + + ]: 9014 : do ispden=1,db%nspden
4071 [ + - ]: 9014 : read(db%fh, err=10, iomsg=msg)
4072 : : end do
4073 : : ! Skip record with rhog1_g0 (if present)
4074 [ + - + - ]: 4943 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
4075 : : end do
4076 : :
4077 : 436 : db%current_fpos = pos_wanted
4078 : :
4079 : : else
4080 : 0 : ABI_ERROR("Should not be called when iomode /= IO_MODE_FORTRAN")
4081 : : end if
4082 : :
4083 : 0 : return
4084 : :
4085 : : ! Handle Fortran IO error
4086 : : 10 continue
4087 : 0 : ABI_ERROR(sjoin("Error while reading", db%path, ch10, msg))
4088 : :
4089 : : end subroutine dvdb_seek
4090 : : !!***
4091 : :
4092 : : !----------------------------------------------------------------------
4093 : :
4094 : : !!****f* m_dvdb/dvdb_rewind
4095 : : !! NAME
4096 : : !! dvdb_rewind
4097 : : !!
4098 : : !! FUNCTION
4099 : : !! Rewind the file and move to the first header. Needed only if dvdb%iomode==IO_MODE_FORTRAN
4100 : : !! Return exit code and error message in msg if ierr != 0.
4101 : : !!
4102 : : !! SOURCE
4103 : :
4104 : 230 : integer function dvdb_rewind(db, msg) result(ierr)
4105 : :
4106 : : !Arguments ------------------------------------
4107 : : type(dvdb_t),intent(inout) :: db
4108 : : character(len=*),intent(out) :: msg
4109 : : ! *************************************************************************
4110 : :
4111 : 230 : ierr = 0
4112 : 230 : if (db%iomode == IO_MODE_FORTRAN) then
4113 [ + - ]: 230 : rewind(db%fh, err=10, iomsg=msg)
4114 [ + - ]: 230 : read(db%fh, err=10, iomsg=msg) ! version
4115 [ + - ]: 230 : read(db%fh, err=10, iomsg=msg) ! numv1
4116 : 230 : db%current_fpos = 1
4117 : :
4118 : : else
4119 : 0 : ierr = -1
4120 [ # # # # ]: 0 : msg = "should not be called when iomode /= IO_MODE_FORTRAN"
4121 : : end if
4122 : :
4123 : : return
4124 : :
4125 : : ! Handle Fortran IO error
4126 : : 10 continue
4127 : 0 : ierr = 1
4128 [ # # # # ]: 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4129 : :
4130 [ + - ]: 230 : end function dvdb_rewind
4131 : : !!***
4132 : :
4133 : : !----------------------------------------------------------------------
4134 : :
4135 : : !!****f* m_dvdb/my_hdr_skip
4136 : : !! NAME
4137 : : !! my_hdr_skip
4138 : : !!
4139 : : !! FUNCTION
4140 : : !! Skip the header without rewinding the file. Return exit code.
4141 : : !!
4142 : : !! NOTES
4143 : : !! Because hdr_skip rewinds the file and I'm not gonna change that ugly code.
4144 : : !!
4145 : : !! SOURCE
4146 : :
4147 : 9867 : integer function my_hdr_skip(unit, idir, ipert, qpt, msg) result(ierr)
4148 : :
4149 : : !Arguments ------------------------------------
4150 : : !scalars
4151 : : integer,intent(in) :: unit,idir,ipert
4152 : : real(dp),intent(in) :: qpt(3)
4153 : : character(len=500),intent(out) :: msg
4154 : :
4155 : : !Local variables-------------------------------
4156 : : integer :: fform
4157 : 9867 : type(hdr_type) :: tmp_hdr
4158 : : !************************************************************************
4159 : :
4160 : 9867 : ierr = 0; msg = ""
4161 : 9867 : call tmp_hdr%fort_read(unit, fform)
4162 : 9867 : ierr = dvdb_check_fform(fform, "read_dvdb", msg)
4163 [ + - ]: 9867 : if (ierr /= 0) return
4164 : :
4165 [ + + + - ]: 9867 : if (idir /= -1 .and. ipert /= -1) then
4166 : : if (idir /= mod(tmp_hdr%pertcase-1, 3) + 1 .or. &
4167 [ + + + - : 21440 : ipert /= (tmp_hdr%pertcase - idir) / 3 + 1 .or. &
+ - + - -
+ ]
4168 : : any(abs(qpt - tmp_hdr%qptn) > tol14)) then
4169 : 0 : msg = "Perturbation index on file does not match the one expected by the caller"
4170 : 0 : ierr = -1
4171 : : end if
4172 : : end if
4173 : :
4174 : 9867 : call tmp_hdr%free()
4175 : :
4176 [ - + - + : 9867 : end function my_hdr_skip
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - ]
4177 : : !!***
4178 : :
4179 : : !----------------------------------------------------------------------
4180 : :
4181 : : !!****f* m_dvdb/dvdb_list_perts
4182 : : !! NAME
4183 : : !! dvdb_list_perts
4184 : : !!
4185 : : !! FUNCTION
4186 : : !! Given a q-point mesh, this routine checks if all the (phonon) perturbations
4187 : : !! are available taking into account symmetries.
4188 : : !!
4189 : : !! INPUTS
4190 : : !! ngqpt(3)=Q-mesh divisions. If all(ngqpt == -1), the list of q-points in the DVDB
4191 : : !! (i.e. db%qpts) is analyzed instead of the q-points generated from ngqpt.
4192 : : !! [unit]=Unit number for output. Default `std_out`.
4193 : : !!
4194 : : !! OUTPUT
4195 : : !! npert_miss = Number of missing perturbations.
4196 : : !!
4197 : : !! SOURCE
4198 : :
4199 : 116 : subroutine dvdb_list_perts(db, ngqpt, npert_miss, unit)
4200 : :
4201 : : !Arguments ------------------------------------
4202 : : class(dvdb_t),target,intent(in) :: db
4203 : : integer,intent(out) :: npert_miss
4204 : : integer,optional,intent(in) :: unit
4205 : : !arrays
4206 : : integer,intent(in) :: ngqpt(3)
4207 : :
4208 : : !Local variables-------------------------------
4209 : : !scalars
4210 : : integer :: npert_redund,miss_q,idir,ipert,iv1,psy,weird_q,enough
4211 : : integer :: iq_ibz,nqibz,iq_file,qptopt,nshiftq,ii,timerev_q,unt,nqbz
4212 : : character(len=500) :: msg,ptype,found
4213 : : type(crystal_t),pointer :: cryst
4214 : : !arrays
4215 : : integer :: rfdir(3),qptrlatt(3,3)
4216 : 116 : integer,allocatable :: pertsy(:,:),symq(:,:,:),rfpert(:)
4217 : : real(dp) :: qq(3),shiftq(3,1)
4218 : 116 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:)
4219 : : ! *************************************************************************
4220 : :
4221 [ - + ]: 116 : unt = std_out; if (present(unit)) unt = unit
4222 : 116 : cryst => db%cryst
4223 : :
4224 [ + + + - : 464 : if (all(ngqpt == -1)) then
+ - ]
4225 : : ! Will test the q-points in db
4226 : 116 : call alloc_copy(db%qpts, qibz)
4227 : 116 : nqibz = db%nqpt
4228 : : else
4229 : : ! Will test the q-points in the IBZ associated to ngqpt hence build IBZ and BZ from ngqpt.
4230 : 0 : qptopt = 1; shiftq = zero; nshiftq = 1; qptrlatt = 0
4231 [ # # ]: 0 : do ii=1,3
4232 : 0 : qptrlatt(ii, ii) = ngqpt(ii)
4233 : : end do
4234 : :
4235 : 0 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nshiftq, shiftq, nqibz, qibz, wtq, nqbz, qbz)
4236 : :
4237 [ # # ]: 0 : ABI_FREE(qbz)
4238 [ # # ]: 0 : ABI_FREE(wtq)
4239 : : end if
4240 : :
4241 : : ! Initialize the list of perturbations rfpert and rdfir
4242 : : ! WARNING: Only phonon perturbations are considered for the time being.
4243 [ - + + - : 348 : ABI_MALLOC(rfpert,(db%mpert))
+ - + - -
+ - + ]
4244 [ + + + + : 1602 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
4245 : :
4246 [ - + + - : 348 : ABI_MALLOC(symq, (4,2,cryst%nsym))
+ - + - -
+ - + ]
4247 [ - + + - : 348 : ABI_MALLOC(pertsy, (3,db%mpert))
+ - + - -
+ - + ]
4248 : :
4249 : : ! Loop over the q-points in the IBZ and test whether the q-point is present
4250 : : ! and if all the independent perturbations are available.
4251 : : ! `npert_miss` is the number of irreducible perturbations not found in the DVDB (critical)
4252 : : ! `npert_redund` is the number of redundant perturbations found in the DVDB (not critical)
4253 : : !
4254 [ + + ]: 116 : enough = 5; if (db%prtvol > 0) enough = nqibz + 1
4255 : 116 : npert_miss = 0; npert_redund = 0
4256 [ + + ]: 798 : do iq_ibz=1,nqibz
4257 [ + + ]: 682 : if (iq_ibz == enough) then
4258 : : ! NB: the message says 20 but enough = 5. Not changed because v7/t87 compares stdout with tolnlines = 0.
4259 : 45 : call wrtout(unt,' More than 20 q-points with prtvol == 0. Only important messages will be printed...')
4260 : : end if
4261 [ + + ]: 2728 : qq = qibz(:,iq_ibz)
4262 : 682 : iq_file = db%findq(qq)
4263 : :
4264 : : ! Examine the symmetries of the q wavevector
4265 : 682 : call littlegroup_q(cryst%nsym,qq,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=db%prtvol)
4266 : :
4267 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4268 : : ! 0 for non-target perturbations
4269 : : ! 1 for basis perturbations
4270 : : ! -1 for perturbations that can be found from basis perturbations
4271 : : call irreducible_set_pert(cryst%indsym,db%mpert,cryst%natom,cryst%nsym,&
4272 : 682 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4273 : :
4274 [ + - ]: 682 : if (iq_file /= -1) then
4275 : : ! This q-point is in the DVDB. Test if all the independent perturbations are available.
4276 [ + + ]: 682 : if (iq_ibz <= enough) then
4277 : 526 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is present in the DVDB file"))
4278 : 526 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4279 : : end if
4280 : 682 : ii = 0; weird_q = 0; miss_q = 0
4281 [ + + ]: 6039 : do ipert=1,db%mpert
4282 [ + + ]: 22110 : do idir=1,3
4283 : 16071 : psy = pertsy(idir,ipert)
4284 [ + + ]: 16071 : if (psy == 0) cycle
4285 : 3795 : iv1 = db%pos_dpq(idir,ipert,iq_file)
4286 [ + + ]: 3795 : ptype = "independent"; if (psy == -1) ptype = "symmetric"
4287 [ + + ]: 3795 : found = "Yes"; if (iv1 == 0) found = "No"
4288 : :
4289 [ - + ]: 3795 : if (psy == 1 .and. iv1 == 0) miss_q = miss_q + 1
4290 [ - + ]: 3795 : if (psy == -1 .and. iv1 /= 0) weird_q = weird_q + 1
4291 : :
4292 : 3795 : ii=ii+1
4293 [ + + ]: 9152 : if (iq_ibz <= enough) then
4294 : 2886 : write(msg,'(i5,a,i2,a,i4,4a)')ii,') idir=',idir,', ipert=',ipert,", type=",trim(ptype),", found=",trim(found)
4295 : 2886 : call wrtout(unt, msg)
4296 : : end if
4297 : : end do
4298 : : end do
4299 : :
4300 [ - + ]: 682 : if (weird_q /= 0) then
4301 : 0 : write(msg,"(a,i0,a)")" DVDB is overcomplete. ",weird_q, " perturbation(s) can be reconstructed by symmetry."
4302 : 0 : call wrtout(unt, msg)
4303 : : end if
4304 : :
4305 : 682 : npert_redund = npert_redund + weird_q
4306 : 682 : npert_miss = npert_miss + miss_q
4307 [ - + ]: 682 : if (miss_q /=0) then
4308 : 0 : call wrtout(unt, sjoin(" WARNING:", itoa(miss_q), "independent perturbation(s) are missing!."))
4309 : : end if
4310 : :
4311 : : else
4312 : : ! This q-point is not present in dvdb. Print the list of independent perturbations.
4313 : 0 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is NOT present in the DVDB file"))
4314 : 0 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4315 : 0 : ii = 0
4316 [ # # ]: 0 : do ipert=1,db%mpert
4317 [ # # ]: 0 : do idir=1,3
4318 [ # # ]: 0 : if (pertsy(idir,ipert) == 1) then
4319 : 0 : ii=ii+1
4320 : 0 : write(msg,'(i5,a,i2,a,i4,a)')ii,') idir=',idir,', ipert=',ipert,", type=independent, found=No"
4321 : 0 : call wrtout(unt, msg)
4322 : 0 : npert_miss = npert_miss + 1
4323 : : end if
4324 : : end do
4325 : : end do
4326 : : end if
4327 : :
4328 [ + + ]: 1480 : if (iq_ibz <= enough) call wrtout(unt," ")
4329 : : end do ! iq_ibz
4330 : :
4331 [ - + ]: 116 : if (npert_miss /= 0) then
4332 : 0 : call wrtout(unt, sjoin(ch10, " There are ",itoa(npert_miss), "independent perturbations missing!"))
4333 : : else
4334 : 116 : call wrtout(unt, " All the independent perturbations are available")
4335 [ - + ]: 116 : if (npert_redund /= 0) then
4336 : 0 : call wrtout(unt, " Note however that the DVDB is overcomplete as symmetric perturbations are present.")
4337 : : end if
4338 : : end if
4339 : :
4340 [ - + ]: 116 : ABI_FREE(qibz)
4341 [ - + ]: 116 : ABI_FREE(rfpert)
4342 [ - + ]: 116 : ABI_FREE(symq)
4343 [ - + ]: 116 : ABI_FREE(pertsy)
4344 : :
4345 [ - + - + ]: 116 : end subroutine dvdb_list_perts
4346 : : !!***
4347 : :
4348 : : !----------------------------------------------------------------------
4349 : :
4350 : : !!****f* m_dvdb/dvdb_merge_files
4351 : : !! NAME
4352 : : !! dvdb_merge_files
4353 : : !!
4354 : : !! FUNCTION
4355 : : !! Merge a list of POT1 or DEN1 files.
4356 : : !!
4357 : : !! INPUT
4358 : : !! nfiles=Number of files to be merged.
4359 : : !! dvdb_filepath=Name of output DVDB file.
4360 : : !! prtvol=Verbosity level.
4361 : : !!
4362 : : !! SIDE EFFECTS
4363 : : !! v1files=List of file names to merge. This list could be changed if POT1 files in netcdf format are found.
4364 : : !!
4365 : : !! SOURCE
4366 : :
4367 : 17 : subroutine dvdb_merge_files(nfiles, v1files, dvdb_filepath, prtvol)
4368 : :
4369 : : !Arguments ------------------------------------
4370 : : !scalars
4371 : : integer,intent(in) :: nfiles,prtvol
4372 : : character(len=*),intent(in) :: dvdb_filepath
4373 : : character(len=*),intent(inout) :: v1files(nfiles)
4374 : :
4375 : : !Local variables-------------------------------
4376 : : !scalars
4377 : : ! Here I made a mistake because 102 corresponds to GS potentials
4378 : : ! as a consequence DVDB files generated with version <= 8.1.6
4379 : : ! contain list of potentials with fform = 102.
4380 : : !integer :: fform_pot=102
4381 : : integer :: fform_pot = 111, gpu_option0 = 0
4382 : : integer :: ii,jj,fform,ount,cplex,nfft,ifft,ispden,nperts
4383 : : integer :: n1,n2,n3,v1_varid,ierr, npert_miss, first_fform
4384 : : logical :: qeq0
4385 : : character(len=500) :: msg
4386 : : type(hdr_type),pointer :: hdr1
4387 [ + + + + : 1394 : type(dvdb_t) :: dvdb
+ + + + +
+ + + + +
+ + + + +
+ + + +
+ ]
4388 : : !arrays
4389 : 34 : integer :: units(nfiles)
4390 : : real(dp) :: rhog1_g0(2)
4391 : 17 : real(dp),allocatable :: v1(:)
4392 : 34 : logical :: has_rhog1_g0(nfiles)
4393 : 17 : type(hdr_type),target,allocatable :: hdr1_list(:)
4394 : : !************************************************************************
4395 : :
4396 [ - + ]: 17 : if (file_exists(dvdb_filepath)) then
4397 : 0 : ABI_ERROR(sjoin("Cannot overwrite existing file:", dvdb_filepath))
4398 : : end if
4399 : :
4400 : : ! If a file is not found, try the netcdf version and change v1files accordingly.
4401 [ + + ]: 296 : do ii=1,nfiles
4402 [ - + ]: 296 : if (nctk_try_fort_or_ncfile(v1files(ii), msg) /= 0) then
4403 : 0 : ABI_ERROR(msg)
4404 : : end if
4405 : : end do
4406 : :
4407 : : ! Read the headers
4408 [ - + + - : 330 : ABI_MALLOC(hdr1_list, (nfiles))
+ - + - -
+ - + +
+ ]
4409 : 17 : nperts = size(hdr1_list)
4410 : :
4411 : : ! Write dvdb file (we only support fortran binary format)
4412 [ - + ]: 17 : if (open_file(dvdb_filepath, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
4413 : 0 : ABI_ERROR(msg)
4414 : : end if
4415 [ + - ]: 17 : write(ount, err=10, iomsg=msg) dvdb_last_version
4416 [ + - ]: 17 : write(ount, err=10, iomsg=msg) nperts
4417 : :
4418 : : ! Validate headers.
4419 : : ! TODO: Should perform consistency check on the headers
4420 : : ! rearrange them in blocks of q-points for efficiency reason.
4421 : : ! ignore POT1 files that do not correspond to atomic perturbations.
4422 : : ! Add POT file from GS run to support Sternheimer in eph_task = 4
4423 : :
4424 [ + + ]: 296 : do ii=1,nfiles
4425 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Reading header of file [",ii,"]: ",trim(v1files(ii))
4426 : :
4427 [ + - ]: 279 : if (endswith(v1files(ii), ".nc")) then
4428 [ - + ]: 279 : NCF_CHECK(nctk_open_read(units(ii), v1files(ii), xmpi_comm_self))
4429 : 279 : call hdr1_list(ii)%ncread(units(ii), fform)
4430 : : else
4431 [ # # ]: 0 : if (open_file(v1files(ii), msg, newunit=units(ii), form="unformatted", action="read", status="old") /= 0) then
4432 : 0 : ABI_ERROR(msg)
4433 : : end if
4434 : 0 : call hdr1_list(ii)%fort_read(units(ii), fform)
4435 : : end if
4436 : :
4437 [ - + ]: 279 : if (dvdb_check_fform(fform, "merge_dvdb", msg) /= 0) then
4438 : 0 : ABI_ERROR(sjoin("While reading:", v1files(ii), msg))
4439 : : end if
4440 [ - + ]: 279 : if (prtvol > 0) call hdr1_list(ii)%echo(fform, 3, unit=std_out)
4441 [ - + ]: 279 : if (hdr1_list(ii)%pertcase == 0) then
4442 : 0 : ABI_ERROR(sjoin("Found GS potential:", v1files(ii)))
4443 : : end if
4444 : : !write(std_out,*)"done", trim(v1files(ii))
4445 : :
4446 [ + + ]: 279 : if (ii == 1) then
4447 : 17 : first_fform = fform
4448 : : else
4449 [ - + ]: 262 : ABI_CHECK_IEQ(fform, first_fform, "Trying to merge files with different quantities")
4450 : : end if
4451 : :
4452 : : ! Supported fform:
4453 : : ! 109 POT1 files without vh1(G=0)
4454 : : ! 111 POT1 files with extra record with vh1(G=0) after FFT data.
4455 : : ! 54 RHO1 files (treating DRHODB as DVDB)
4456 : :
4457 : 279 : has_rhog1_g0(ii) = .True.
4458 [ + + ]: 279 : if (any(fform == [54, 109])) has_rhog1_g0(ii) = .False.
4459 : :
4460 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Merging file [",ii,"]: ",trim(v1files(ii))
4461 : 279 : jj = ii
4462 : 279 : hdr1 => hdr1_list(jj)
4463 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4464 : 199 : call hdr1%fort_write(ount, fform_pot, ierr)
4465 : : else
4466 : 80 : call hdr1%fort_write(ount, den1_fforms(1), ierr)
4467 : : end if
4468 [ - + ]: 279 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr /= 0")
4469 : :
4470 : 279 : qeq0 = (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14)
4471 [ + + ]: 279 : cplex = 2; if (qeq0) cplex = 1
4472 [ + + ]: 1116 : nfft = product(hdr1%ngfft(1:3))
4473 : 279 : n1 = hdr1%ngfft(1); n2 = hdr1%ngfft(2); n3 = hdr1%ngfft(3)
4474 : :
4475 [ - + + - : 837 : ABI_MALLOC(v1, (cplex*nfft))
+ - + - -
+ - + -
+ ]
4476 : :
4477 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4478 : : ! Fortran IO
4479 [ # # ]: 0 : do ispden=1,hdr1%nspden
4480 [ # # ]: 0 : read(units(jj), err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4481 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4482 : : end do
4483 : : ! Add rhog1(G=0)
4484 : 0 : rhog1_g0 = zero
4485 [ # # # # ]: 0 : if (has_rhog1_g0(jj)) read(units(jj), err=10, iomsg=msg) rhog1_g0
4486 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4487 : : else
4488 : : ! Netcdf IO
4489 : : ! netcdf array has shape [cplex, n1, n2, n3, nspden]
4490 : : ! rhog1_g0 is written for both POT1 and DEN1 files: reset it for each file.
4491 : 279 : rhog1_g0 = zero
4492 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4493 [ - + ]: 199 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_potential", v1_varid))
4494 [ + + ]: 398 : do ispden=1,hdr1%nspden
4495 [ + + + + : 2189 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4496 [ + - ]: 398 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4497 : : end do
4498 : : ! Add rhog1(G=0)
4499 : 199 : rhog1_g0 = zero
4500 [ + - ]: 199 : if (has_rhog1_g0(jj)) then
4501 [ - + ]: 199 : NCF_CHECK(nf90_get_var(units(ii), nctk_idname(units(ii), "rhog1_g0"), rhog1_g0))
4502 : : end if
4503 [ + - ]: 80 : else if (any(fform == den1_fforms)) then
4504 : : ! v below should read as rho
4505 [ - + ]: 80 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_density", v1_varid))
4506 [ + + ]: 160 : do ispden=1,hdr1%nspden
4507 [ + + + + : 880 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4508 [ + - ]: 160 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4509 : : end do
4510 : : else
4511 : 0 : ABI_ERROR(sjoin("Don't know how to handle fform:", itoa(fform)))
4512 : : end if
4513 [ + - ]: 279 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4514 : : end if
4515 : :
4516 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4517 : 0 : close(units(ii))
4518 : : else
4519 [ - + ]: 279 : NCF_CHECK(nf90_close(units(ii)))
4520 : : end if
4521 : :
4522 [ - + ]: 296 : ABI_FREE(v1)
4523 : : end do ! nperts
4524 : :
4525 : 17 : close(ount)
4526 : :
4527 [ + + ]: 296 : do ii=1,size(hdr1_list)
4528 : 296 : call hdr1_list(ii)%free()
4529 : : end do
4530 [ + - + + : 296 : ABI_FREE(hdr1_list)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + ]
4531 : :
4532 : 17 : write(std_out,"(a,i0,a)")" Merged successfully ", nfiles, " files"
4533 : :
4534 : : ! List available perturbations.
4535 : 17 : call dvdb%init(dvdb_filepath, gpu_option0, xmpi_comm_self)
4536 [ + + ]: 34 : call dvdb%print([std_out], "", 0)
4537 : 17 : call dvdb%list_perts([-1, -1, -1], npert_miss)
4538 : 17 : call dvdb%free()
4539 : :
4540 : 17 : return
4541 : :
4542 : : ! Handle Fortran IO error
4543 : : 10 continue
4544 : 0 : ABI_ERROR(sjoin("Error while merging files", ch10, msg))
4545 : :
4546 [ - + - + : 17 : end subroutine dvdb_merge_files
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
4547 : : !!***
4548 : :
4549 : : !!****f* m_dvdb/calc_eiqr
4550 : : !! NAME
4551 : : !! calc_eiqr
4552 : : !!
4553 : : !! FUNCTION
4554 : : !! Compute e^{iq.r} for nrpt R-points.
4555 : : !!
4556 : : !! INPUTS
4557 : : !!
4558 : : !! OUTPUT
4559 : : !!
4560 : : !! SOURCE
4561 : :
4562 : 5596 : subroutine calc_eiqr(qpt, nrpt, rpt, eiqr)
4563 : :
4564 : : !Arguments -------------------------------
4565 : : !scalars
4566 : : integer,intent(in) :: nrpt
4567 : : !arrays
4568 : : real(dp),intent(in) :: qpt(3), rpt(3, nrpt)
4569 : : real(dp),intent(out) :: eiqr(2, nrpt)
4570 : :
4571 : : !Local variables -------------------------
4572 : : !scalars
4573 : : integer :: ir
4574 : : real(dp) :: qr
4575 : : ! *********************************************************************
4576 : :
4577 : : !$OMP PARALLEL DO PRIVATE(qr)
4578 [ + + ]: 222124 : do ir=1,nrpt
4579 [ + + ]: 866112 : qr = two_pi * dot_product(qpt, rpt(:,ir))
4580 : 222124 : eiqr(1, ir) = cos(qr); eiqr(2, ir) = sin(qr)
4581 : : end do
4582 : :
4583 : 5596 : end subroutine calc_eiqr
4584 : : !!***
4585 : :
4586 : : !----------------------------------------------------------------------
4587 : :
4588 : : !!****f* m_dvdb/dvdb_check_fform
4589 : : !! NAME
4590 : : !! dvdb_check_fform
4591 : : !!
4592 : : !! FUNCTION
4593 : : !! Check the value of fform. Return exit status and error message.
4594 : : !!
4595 : : !! INPUTS
4596 : : !! fform=Value read from the header
4597 : : !! mode="merge_dvdb" to check the value of fform when we are merging POT1 files
4598 : : !! "read_dvdb" when we are reading POT1 files from a DVDB file.
4599 : : !!
4600 : : !! OUTPUT
4601 : : !! errmsg=String with error message if ierr /= 0
4602 : : !!
4603 : : !! SOURCE
4604 : :
4605 : 12349 : integer function dvdb_check_fform(fform, mode, errmsg) result(ierr)
4606 : :
4607 : : !Arguments ------------------------------------
4608 : : integer,intent(in) :: fform
4609 : : character(len=*),intent(in) :: mode
4610 : : character(len=*),intent(out) :: errmsg
4611 : : ! *************************************************************************
4612 : :
4613 : 12349 : ierr = 0
4614 : :
4615 : : ! Here I made a mistake because 102 corresponds to GS potentials
4616 : : ! as a consequence DVDB files generated with version <= 8.1.6
4617 : : ! contain list of potentials with fform = 102.
4618 : : !
4619 : : ! In GWPT, one may want to use DRHODB as DVDB. For this, here I
4620 : : ! also allow merging and reading first order density with fform = 54.
4621 : : !
4622 : : !integer :: fform_rho=54
4623 : : !integer :: fform_pot=102
4624 : : !integer :: fform_pot=109
4625 : : !integer :: fform_pot=111
4626 : :
4627 : 12349 : if (fform == 0) then
4628 [ # # # # ]: 0 : errmsg = "fform == 0! Either corrupted/nonexistent file or IO error"
4629 : 0 : ierr = 42; return
4630 : : end if
4631 : :
4632 : 279 : select case (mode)
4633 : : case ("merge_dvdb")
4634 [ + + - + ]: 279 : if (all(fform /= [54, 109, 111])) then
4635 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `merge_dvdb` mode")
4636 : 0 : ierr = 1; return
4637 : : end if
4638 : :
4639 : : case ("read_dvdb")
4640 [ + + - + ]: 12070 : if (all(fform /= [54, 102, 109, 111])) then
4641 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `read_dvdb` mode")
4642 : 0 : ierr = 1; return
4643 : : end if
4644 : :
4645 : : case default
4646 [ # # # # ]: 0 : errmsg = sjoin("Invalid mode:", mode)
4647 [ + + - ]: 12349 : ierr = -1; return
4648 : : end select
4649 : :
4650 [ - + ]: 12349 : end function dvdb_check_fform
4651 : : !!***
4652 : :
4653 : : !!****f* m_dvdb/dvdb_test_v1rsym
4654 : : !! NAME
4655 : : !! dvdb_test_v1rsym
4656 : : !!
4657 : : !! FUNCTION
4658 : : !! Debugging tool used to check whether the DFPT potentials in real space fulfill
4659 : : !! the correct symmetries on the real space FFT mesh.
4660 : : !!
4661 : : !! INPUTS
4662 : : !! db_path=Filename
4663 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 to disable it.
4664 : : !! comm=MPI communicator.
4665 : : !!
4666 : : !! OUTPUT
4667 : : !! Only writing.
4668 : : !!
4669 : : !! SOURCE
4670 : :
4671 : 0 : subroutine dvdb_test_v1rsym(db_path, symv1scf, comm)
4672 : :
4673 : : !Arguments ------------------------------------
4674 : : character(len=*),intent(in) :: db_path
4675 : : integer,intent(in) :: symv1scf, comm
4676 : :
4677 : : !Local variables-------------------------------
4678 : : !scalars
4679 : : integer,parameter :: rfmeth2=2, syuse0=0, gpu_option0 = 0
4680 : : integer :: iqpt,idir,ipert,nsym1,cplex,v1pos, isym,nfft,ifft,ifft_rot,ispden
4681 : : real(dp) :: max_err,re,im,vre,vim !,pre,pim
4682 : : character(len=500) :: msg
4683 : : logical :: isok
4684 [ # # # # : 0 : type(dvdb_t),target :: db
# # # # #
# # # # #
# # # # #
# # # #
# ]
4685 : : type(crystal_t),pointer :: cryst
4686 : : !arrays
4687 : : integer :: ngfft(18)
4688 : 0 : integer,allocatable :: symafm1(:),symrel1(:,:,:),irottb(:,:)
4689 : : real(dp) :: qpt(3)
4690 : 0 : real(dp),allocatable :: tnons1(:,:),v1scf(:,:)
4691 : : ! *************************************************************************
4692 : :
4693 : 0 : call db%init(db_path, gpu_option0, comm)
4694 : 0 : db%debug = .True.
4695 : 0 : db%symv1 = symv1scf
4696 [ # # ]: 0 : call db%print([std_out], "", 0)
4697 : : !call db%list_perts([-1,-1,-1], npert_miss)
4698 : :
4699 : 0 : call ngfft_seq(ngfft, db%ngfft3_v1(:,1))
4700 [ # # ]: 0 : nfft = product(ngfft(1:3))
4701 : 0 : call db%open_read(ngfft, comm)
4702 : :
4703 : 0 : cryst => db%cryst
4704 [ # # # # : 0 : ABI_MALLOC(symafm1, (cryst%nsym))
# # # # #
# # # ]
4705 [ # # # # : 0 : ABI_MALLOC(symrel1, (3,3,cryst%nsym))
# # # # #
# # # ]
4706 [ # # # # : 0 : ABI_MALLOC(tnons1, (3,cryst%nsym))
# # # # #
# # # ]
4707 : :
4708 [ # # ]: 0 : do iqpt=1,db%nqpt
4709 : 0 : qpt = db%qpts(:, iqpt)
4710 [ # # ]: 0 : do ipert=1,db%natom
4711 [ # # ]: 0 : do idir=1,3
4712 [ # # ]: 0 : v1pos = db%pos_dpq(idir, ipert, iqpt); if (v1pos == 0) cycle
4713 : :
4714 : : ! Determines the set of symmetries that leaves the perturbation invariant.
4715 : : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
4716 : : cryst%symafm,symafm1,db%symq_table(:,:,:,iqpt),cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,&
4717 : 0 : tnons1,unit=dev_null)
4718 : :
4719 : 0 : cplex = db%cplex_v1(v1pos)
4720 [ # # ]: 0 : ngfft(1:3) = db%ngfft3_v1(:, v1pos)
4721 [ # # ]: 0 : nfft = product(ngfft(:3))
4722 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex*nfft, db%nspden))
# # # # #
# # # # #
# # ]
4723 : :
4724 [ # # ]: 0 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) /= 0) then
4725 : 0 : ABI_ERROR(msg)
4726 : : end if
4727 : :
4728 [ # # # # : 0 : ABI_MALLOC(irottb, (nfft,nsym1))
# # # # #
# # # # #
# # ]
4729 : 0 : call rotate_fft_mesh(nsym1,symrel1,tnons1,ngfft,irottb,isok)
4730 [ # # ]: 0 : if (.not. isok) then
4731 : 0 : ABI_WARNING("Real space FFT mesh is not compatible with symmetries!")
4732 : : end if
4733 : :
4734 : 0 : max_err = zero
4735 [ # # ]: 0 : do isym=1,nsym1
4736 [ # # ]: 0 : do ispden=1,db%nspden
4737 [ # # ]: 0 : do ifft=1,nfft
4738 : 0 : ifft_rot = irottb(ifft, isym)
4739 : : !pre = cos(two_pi * dot_product(qpt, tnons1(:,isym)))
4740 : : !pim = -sin(two_pi * dot_product(qpt, tnons1(:,isym)))
4741 [ # # ]: 0 : if (cplex == 2) then
4742 : 0 : re = v1scf(2*ifft_rot-1, ispden)
4743 : 0 : im = v1scf(2*ifft_rot , ispden)
4744 : : !vre = re * pre - im * pim
4745 : : !vim = re * pim + im * pre
4746 : 0 : vre = re; vim = im
4747 : :
4748 : 0 : re = v1scf(2*ifft-1, ispden) - vre
4749 : 0 : im = v1scf(2*ifft , ispden) - vim
4750 : : else
4751 : 0 : re = v1scf(ifft, ispden) - v1scf(ifft_rot, ispden)
4752 : 0 : im = zero
4753 : : end if
4754 : : !if (sqrt(re**2 + im**2) > tol6) write(std_out,*)"ifft,isym,err: ",ifft,isym,sqrt(re**2 + im**2)
4755 : 0 : max_err = max(max_err, sqrt(re**2 + im**2))
4756 : : end do
4757 : : end do
4758 : : end do
4759 [ # # ]: 0 : if (nsym1>1) then
4760 : 0 : write(std_out,"(3(a,i2),a,i2,a,es16.8)")"For iqpt= ",iqpt,&
4761 : 0 : ", idir= ",idir,", ipert= ",ipert,", nsym= ",nsym1,", max_err= ",max_err
4762 : : end if
4763 : :
4764 [ # # ]: 0 : ABI_FREE(irottb)
4765 [ # # ]: 0 : ABI_FREE(v1scf)
4766 : : end do
4767 : : end do
4768 : :
4769 : : end do ! iqpt
4770 : :
4771 [ # # ]: 0 : ABI_FREE(symafm1)
4772 [ # # ]: 0 : ABI_FREE(symrel1)
4773 [ # # ]: 0 : ABI_FREE(tnons1)
4774 : :
4775 : 0 : call db%free()
4776 : :
4777 [ # # # # : 0 : end subroutine dvdb_test_v1rsym
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4778 : : !!***
4779 : :
4780 : : !----------------------------------------------------------------------
4781 : :
4782 : : !!****f* m_dvdb/dvdb_test_v1complete
4783 : : !! NAME
4784 : : !! dvdb_test_v1complete
4785 : : !!
4786 : : !! FUNCTION
4787 : : !! Debugging tool used to test the symmetrization of the DFPT potentials.
4788 : : !! Assumes DVDB file containing all 3*natom perturbations (either generated with nsym == 1 or
4789 : : !! via other specialized variables e.g. prepgkk)
4790 : : !!
4791 : : !! INPUTS
4792 : : !! db_path=Filename of the DVDB file.
4793 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 ti disable it.
4794 : : !! dump_path=File used to dump potentials (empty string to disable output)
4795 : : !! comm=MPI communicator.
4796 : : !!
4797 : : !! OUTPUT
4798 : : !! Only writing.
4799 : : !!
4800 : : !! SOURCE
4801 : :
4802 : 0 : subroutine dvdb_test_v1complete(dvdb_filepath, symv1scf, dump_path, comm)
4803 : :
4804 : : !Arguments ------------------------------------
4805 : : character(len=*),intent(in) :: dvdb_filepath,dump_path
4806 : : integer,intent(in) :: symv1scf, comm
4807 : :
4808 : : !Local variables-------------------------------
4809 : : !scalars
4810 : : integer,parameter :: master = 0, gpu_option0 = 0
4811 : : integer :: iqpt,pcase,idir,ipert,cplex,nfft,ispden,timerev_q,ifft,unt,my_rank, ncid
4812 : : integer :: i1,i2,i3,n1,n2,n3,id1,id2,id3,cnt, npert_miss
4813 : : integer :: ncerr
4814 : : character(len=500) :: msg
4815 : : type(crystal_t),pointer :: cryst
4816 [ # # # # : 0 : type(dvdb_t),target :: dvdb
# # # # #
# # # # #
# # # # #
# # # #
# ]
4817 : : type(vdiff_t) :: vd
4818 : : !arrays
4819 : : integer :: ngfft(18), rfdir(3)
4820 : 0 : integer,allocatable :: pflag(:,:), pertsy(:,:),rfpert(:),symq(:,:,:)
4821 : : real(dp) :: qpt(3)
4822 : 0 : real(dp),allocatable :: file_v1scf(:,:,:,:),symm_v1scf(:,:,:,:), work2(:,:,:,:)
4823 : : ! *************************************************************************
4824 : :
4825 : 0 : my_rank = xmpi_comm_rank(comm)
4826 : :
4827 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
4828 : 0 : dvdb%debug = .false.
4829 : 0 : dvdb%symv1 = symv1scf
4830 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
4831 : 0 : call dvdb%list_perts([-1,-1,-1], npert_miss)
4832 : :
4833 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
4834 [ # # ]: 0 : nfft = product(ngfft(1:3))
4835 : 0 : call dvdb%open_read(ngfft, comm)
4836 : :
4837 : 0 : cryst => dvdb%cryst
4838 : :
4839 : 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
4840 : 0 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
4841 : :
4842 [ # # # # : 0 : ABI_MALLOC(pflag, (3, dvdb%natom))
# # # # #
# # # ]
4843 : :
4844 : : ! Initialize the list of perturbations rfpert and rdfir
4845 : : ! WARNING: Only phonon perturbations are considered for the time being.
4846 [ # # # # : 0 : ABI_MALLOC(rfpert,(dvdb%mpert))
# # # # #
# # # ]
4847 [ # # # # : 0 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
# # ]
4848 [ # # # # : 0 : ABI_MALLOC(symq, (4,2,cryst%nsym))
# # # # #
# # # ]
4849 [ # # # # : 0 : ABI_MALLOC(pertsy, (3,dvdb%mpert))
# # # # #
# # # ]
4850 : :
4851 : 0 : unt = -1; ncid = nctk_noid
4852 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
4853 : 0 : write(std_out,"(a)")sjoin("Will write potentials to:", dump_path)
4854 [ # # ]: 0 : if (endswith(dump_path, ".nc")) then
4855 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
4856 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
4857 : : ncerr = nctk_def_dims(ncid, [&
4858 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
4859 : : nctkdim_t("natom3", cryst%natom * 3), nctkdim_t("mpert", dvdb%mpert), nctkdim_t("nqpt", dvdb%nqpt)], &
4860 [ # # ]: 0 : defmode=.True.)
4861 [ # # ]: 0 : NCF_CHECK(ncerr)
4862 [ # # # # : 0 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "symv1scf"]))
# # ]
4863 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
4864 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("origin_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4865 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("recons_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4866 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("pertsy_qpt", "int", "three, mpert, nqpt")))
4867 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
4868 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
4869 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
4870 [ # # # # ]: 0 : "symv1scf"], [symv1scf])
4871 [ # # ]: 0 : NCF_CHECK(ncerr)
4872 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
4873 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
4874 : : else
4875 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
4876 : 0 : ABI_ERROR(msg)
4877 : : end if
4878 : : end if
4879 : : end if
4880 : :
4881 [ # # # # : 0 : ABI_CALLOC(work2, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4882 : :
4883 : : ! loop over the q-points available in the dvdb (likely qpts in the IBZ)
4884 : : ! For each q-point, use symmetries to reconstruct all 3*natom perts for the independent ones
4885 : : ! and compare with the corresponding results available in the DVDB file
4886 : :
4887 [ # # ]: 0 : do iqpt=1,dvdb%nqpt
4888 [ # # ]: 0 : qpt = dvdb%qpts(:,iqpt)
4889 : :
4890 : : ! Examine the symmetries of the q wavevector
4891 : 0 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=dvdb%prtvol)
4892 : :
4893 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4894 : : ! 0 for non-target perturbations
4895 : : ! 1 for basis perturbations
4896 : : ! -1 for perturbations that can be found from basis perturbations
4897 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
4898 : 0 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4899 : :
4900 : : ! Read all potentials (here we assume that all perturbations are available in the DVDB)
4901 [ # # ]: 0 : call dvdb%readsym_allv1(iqpt, cplex, nfft, ngfft, file_v1scf, dvdb%comm)
4902 : :
4903 : : ! Copy basis perturbations in symm_v1scf and set pflag
4904 [ # # # # : 0 : ABI_MALLOC(symm_v1scf, (cplex, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4905 [ # # # # : 0 : symm_v1scf = huge(one); pflag = 0
# # # # #
# # # ]
4906 [ # # ]: 0 : do pcase=1,3*dvdb%cryst%natom
4907 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4908 [ # # ]: 0 : if (pertsy(idir, ipert) == 1) then
4909 [ # # # # : 0 : symm_v1scf(:,:,:,pcase) = file_v1scf(:,:,:,pcase)
# # ]
4910 : 0 : pflag(idir,ipert) = 1
4911 : : end if
4912 : : end do
4913 : :
4914 : : ! Complete potentials by symmetry.
4915 : 0 : call v1phq_complete(cryst,qpt,ngfft,cplex,nfft,dvdb%nspden,dvdb%nsppol,dvdb%mpi_enreg,dvdb%symv1,pflag,symm_v1scf)
4916 : :
4917 [ # # ]: 0 : if (ncid /= nctk_noid) then
4918 [ # # # # : 0 : work2 = zero
# # # # ]
4919 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = file_v1scf(1,:,:,:)
# # # # ]
4920 [ # # # # : 0 : if (cplex == 2) work2 = file_v1scf
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4921 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "origin_v1scf"), work2, start=[1,1,1,1,iqpt])
4922 [ # # ]: 0 : NCF_CHECK(ncerr)
4923 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = symm_v1scf(1,:,:,:)
# # # # ]
4924 [ # # # # : 0 : if (cplex == 2) work2 = symm_v1scf
# # # # #
# # # # #
# # # # #
# # # ]
4925 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "recons_v1scf"), work2, start=[1,1,1,1,iqpt])
4926 [ # # ]: 0 : NCF_CHECK(ncerr)
4927 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "pertsy_qpt"), pertsy, start=[1,1,iqpt]))
# # ]
4928 : : end if
4929 : :
4930 : : ! Compare potentials.
4931 [ # # ]: 0 : if (iqpt == 1) cnt = 0
4932 [ # # ]: 0 : do pcase=1,3*cryst%natom
4933 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4934 [ # # ]: 0 : if (pflag(idir,ipert) /= 2) cycle
4935 : 0 : cnt = cnt+1
4936 : :
4937 [ # # ]: 0 : do ispden=1,dvdb%nspden
4938 : : !write(std_out,"(5(a,i0),3a,es12.4)")"For cnt: ",cnt ,", iqpt: ", iqpt, ", idir: ", idir, &
4939 : : ! ", ipert: ", ipert, ", ispden: ", ispden, ", qpt: ", trim(ktoa(qpt)) ,", max_err: ", &
4940 : : ! maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4941 : : !write(std_out,"(a,es10.3)")" max(abs(f1-f2))", maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4942 : 0 : call vd%eval(cplex,nfft,file_v1scf(:,:,ispden,pcase),symm_v1scf(:,:,ispden,pcase),cryst%ucvol, unit=std_out)
4943 : :
4944 : : ! Debug: write potentials to file.
4945 [ # # ]: 0 : if (unt /= -1) then
4946 : 0 : write(unt,*)"# count:", cnt
4947 [ # # # # ]: 0 : write(unt,*)"# q-point:", trim(ktoa(qpt)), ", iqpt: ", trim(itoa(iqpt))
4948 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
4949 : 0 : write(unt,*)"# file_v1scf, symmetrized_v1scf, diff"
4950 [ # # ]: 0 : if (cplex == 1) then
4951 [ # # ]: 0 : do i3=1,n3
4952 [ # # ]: 0 : do i2=1,n2
4953 [ # # ]: 0 : do i1=1,n1
4954 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4955 : : write(unt,"(3i3,3(es12.4,2x))") &
4956 : 0 : i1,i2,i3, &
4957 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4958 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase)
4959 : : end do
4960 : : end do
4961 : : end do
4962 : : else
4963 [ # # ]: 0 : do i3=1,n3
4964 [ # # ]: 0 : do i2=1,n2
4965 [ # # ]: 0 : do i1=1,n1
4966 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4967 : : write(unt, "(3i3,6(es12.4,2x))") &
4968 : 0 : i1,i2,i3, &
4969 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4970 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase), &
4971 : 0 : file_v1scf(2,ifft,ispden,pcase), symm_v1scf(2,ifft,ispden,pcase), &
4972 : 0 : file_v1scf(2,ifft,ispden,pcase) - symm_v1scf(2,ifft,ispden,pcase)
4973 : : end do
4974 : : end do
4975 : : end do
4976 : : end if
4977 : 0 : write(unt,*)
4978 : 0 : write(unt,*)
4979 : : end if
4980 : :
4981 : : end do
4982 : : !write(std_out,*)""
4983 : : end do
4984 : :
4985 [ # # ]: 0 : ABI_FREE(symm_v1scf)
4986 [ # # ]: 0 : ABI_FREE(file_v1scf)
4987 : : end do
4988 : :
4989 [ # # ]: 0 : ABI_FREE(work2)
4990 [ # # ]: 0 : ABI_FREE(pflag)
4991 [ # # ]: 0 : ABI_FREE(rfpert)
4992 [ # # ]: 0 : ABI_FREE(symq)
4993 [ # # ]: 0 : ABI_FREE(pertsy)
4994 : :
4995 : 0 : call dvdb%free()
4996 : :
4997 [ # # ]: 0 : if (unt /= -1) close(unt)
4998 [ # # ]: 0 : if (ncid /= nctk_noid) then
4999 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5000 : : end if
5001 : :
5002 [ # # # # : 0 : end subroutine dvdb_test_v1complete
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5003 : : !!***
5004 : :
5005 : : !----------------------------------------------------------------------
5006 : :
5007 : : !!****f* m_dvdb/dvdb_write_v1qavg
5008 : : !! NAME
5009 : : !! dvdb_write_v1qavg
5010 : : !!
5011 : : !! FUNCTION
5012 : : !! Computes the average over the unit cell of the periodic part of the DFPT potentials
5013 : : !! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
5014 : : !! Results are stored in the V1QAVG netcdf file. Two options are available:
5015 : : !!
5016 : : !! eph_task = -15 --> Use list of q-points found in the DVDB file. Mainly used to plot the average
5017 : : !! along a q-path. The procedure required to generate a DVDB with a q-path is rather lengthy
5018 : : !! as it requires several phonon calculations with WKQ followed by a merge of the POT files.
5019 : : !!
5020 : : !! eph_task = +15 --> Assume DVDB file with q-mesh (dvdb_ngqpt), use Fourier interpolation
5021 : : !! to interpolate potentials along the path specified by ph_qpath and ph_nqpath.
5022 : : !!
5023 : : !! INPUTS
5024 : : !! dtset<dataset_type>= Input variables.
5025 : : !! out_ncpath=Filename for output netcdf file.
5026 : : !!
5027 : : !! OUTPUT
5028 : : !! Only writing.
5029 : : !!
5030 : : !! SOURCE
5031 : :
5032 : 2 : subroutine dvdb_write_v1qavg(dvdb, dtset, out_ncpath)
5033 : :
5034 : : !Arguments ------------------------------------
5035 : : class(dvdb_t),target,intent(inout) :: dvdb
5036 : : type(dataset_type),target,intent(in) :: dtset
5037 : : character(len=*),intent(in) :: out_ncpath
5038 : :
5039 : : !Local variables-------------------------------
5040 : : !scalars
5041 : : integer,parameter :: master = 0
5042 : : integer :: nfft, iq, cplex, ispden, comm_rpt, my_rank, idir, ipert, ipc, imyp
5043 : : integer :: n1, n2, n3, unt, this_nqpt, interpolated
5044 : : integer :: i1, i2, i3, ifft, ig, ngsmall, ii, qptopt
5045 : : integer :: ncid, ncerr
5046 : : real(dp) :: gsq_max, g2
5047 : : !type(vdiff_t) :: vd_max
5048 : : logical :: write_v1r
5049 : : character(len=500) :: msg
5050 : : character(len=fnlen) :: dump_path
5051 : : !arrays
5052 : : integer :: ngfft(18), units(2)
5053 : 2 : integer, allocatable :: gfft(:,:),ig2ifft(:), gsmall(:,:)
5054 : : real(dp) :: dvdb_qdamp(1)
5055 : : real(dp) :: vals2(2)
5056 : 2 : real(dp),pointer :: this_qpts(:,:)
5057 : 2 : real(dp),allocatable :: file_v1r(:,:,:,:),long_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5058 : 2 : real(dp),allocatable :: maxw(:,:), all_rpt(:,:), all_rmod(:), workg(:,:), work_gsmall(:,:)
5059 : : ! *************************************************************************
5060 : :
5061 : 4 : my_rank = xmpi_comm_rank(dvdb%comm)
5062 [ + + ]: 6 : units = [std_out, ab_out]
5063 : :
5064 : 2 : call wrtout(units, " Computing average over the unit cell of the periodic part of the DFPT potentials", newlines=2)
5065 [ + + ]: 4 : call dvdb%print([std_out], "", 0)
5066 : :
5067 : : ! Define FFT mesh
5068 [ + + ]: 38 : ngfft = dvdb%ngfft
5069 [ + + ]: 8 : nfft = product(ngfft(1:3))
5070 : 2 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
5071 : :
5072 : : ! Get list of G-vectors in FFT mesh.
5073 [ - + + - : 6 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5074 : 2 : call get_gfft(ngfft, [zero, zero, zero], dvdb%cryst%gmet, gsq_max, gfft)
5075 [ - + + - : 6 : ABI_MALLOC(workg, (2, nfft))
+ - + - -
+ - + ]
5076 : :
5077 : : ! Select G-vectors in small sphere (ratio of gsq_max)
5078 [ + + ]: 6 : do ii=1,2
5079 [ + + ]: 4 : if (ii == 2) then
5080 [ - + + - : 6 : ABI_MALLOC(ig2ifft, (ngsmall))
+ - + - -
+ - + -
+ ]
5081 : : end if
5082 : 4 : ngsmall = 0
5083 [ + + ]: 16390 : do ig=1,nfft
5084 : : ! Don't include (2pi)**2 to be consistent with get_gfft
5085 [ + + + + : 327680 : g2 = dot_product(gfft(:,ig), matmul(dvdb%cryst%gmet, gfft(:, ig)))
+ + + - +
+ ]
5086 [ + + ]: 16388 : if (g2 <= gsq_max * 0.01_dp) then
5087 : 108 : ngsmall = ngsmall + 1
5088 [ + + ]: 108 : if (ii == 2) ig2ifft(ngsmall) = ig
5089 : : end if
5090 : : end do
5091 : : end do
5092 : 2 : write(std_out, *)"Found ngsmall", ngsmall
5093 : :
5094 : : !call ig2fft_sphere(dvdb%cryst%gmet, gfft, ig2ifft)
5095 [ - + + - : 6 : ABI_MALLOC(gsmall, (3, ngsmall))
+ - + - -
+ - + -
+ ]
5096 [ + + ]: 56 : do ig=1,ngsmall
5097 [ + + ]: 218 : gsmall(:, ig) = gfft(:, ig2ifft(ig))
5098 : : end do
5099 [ - + + - : 6 : ABI_MALLOC(work_gsmall, (2, ngsmall))
+ - + - -
+ - + -
+ ]
5100 : :
5101 [ - + + - : 10 : ABI_MALLOC(long_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - + -
+ - - + -
+ - + ]
5102 [ - + + - : 8 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - - +
- + - + ]
5103 : :
5104 : 2 : unt = -1; dump_path = ""
5105 : : !dump_path = "V1QAVG.dat"
5106 [ - + - - ]: 2 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5107 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
5108 : 0 : ABI_ERROR(msg)
5109 : : end if
5110 : 0 : write(std_out,"(a)")sjoin(" Will write potentials in text format to:", dump_path)
5111 : : end if
5112 : :
5113 : : ! Select list of q-points depending on eph_task (either from DVDB file or interpolated)
5114 : 2 : write_v1r = .False.
5115 [ + + ]: 2 : if (dtset%eph_task == -15) then
5116 : 1 : call wrtout(units, " Using list of q-points found in the DVDB file")
5117 : 1 : this_nqpt = dvdb%nqpt
5118 : 1 : this_qpts => dvdb%qpts
5119 : 1 : interpolated = 0
5120 : :
5121 [ + - ]: 1 : else if (dtset%eph_task == +15) then
5122 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
5123 : 1 : call wrtout(units, msg)
5124 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "When eph_task = +15, ph_qpath must be given in input.")
5125 : 1 : this_nqpt = dtset%ph_nqpath
5126 : 1 : this_qpts => dtset%ph_qpath(:, 1:this_nqpt)
5127 : 1 : comm_rpt = xmpi_comm_self
5128 [ - + ]: 1 : qptopt = dtset%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5129 : 1 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfft, ngfft, comm_rpt)
5130 : 1 : interpolated = 1
5131 : 1 : write_v1r = dtset%prtpot > 0
5132 : : else
5133 : 0 : ABI_ERROR(sjoin("Invalid value for eph_task:", itoa(dtset%eph_task)))
5134 : : end if
5135 : :
5136 : 2 : call wrtout(units, sjoin(ch10, "- Results stored in: ", out_ncpath))
5137 : 2 : call wrtout(units, " Use `abiopen.py out_V1QAVG.nc -e` to visualize results")
5138 : :
5139 [ + - ]: 2 : if (my_rank == master) then
5140 [ - + ]: 2 : NCF_CHECK(nctk_open_create(ncid, out_ncpath, xmpi_comm_self))
5141 [ - + ]: 2 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5142 : : ncerr = nctk_def_dims(ncid, [ &
5143 : : nctkdim_t("nspden", dvdb%nspden), nctkdim_t("natom", dvdb%natom3 / 3), nctkdim_t("nqpt", this_nqpt), &
5144 [ + + ]: 12 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("ngsmall", ngsmall)], defmode=.True.)
5145 [ - + ]: 2 : NCF_CHECK(ncerr)
5146 : :
5147 [ + + ]: 2 : if (interpolated == 1) then
5148 : : ! Define arrays for Max_r |W(R, r)|
5149 [ + + - + : 3 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nrpt", dvdb%nrtot), nctkdim_t("nfft", nfft)]))
- - ]
5150 : : ncerr = nctk_def_arrays(ncid, [ &
5151 : : nctkarr_t("ngqpt", "int", "three"), nctkarr_t("rpt", "dp", "three, nrpt"), nctkarr_t("rmod", "dp", "nrpt"), &
5152 : : nctkarr_t("ngfft", "int", "three"), &
5153 : : nctkarr_t("maxw", "dp", "nrpt, natom3") &
5154 [ + + ]: 6 : ])
5155 [ - + ]: 1 : NCF_CHECK(ncerr)
5156 : : end if
5157 : :
5158 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5159 [ + + ]: 10 : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"])
5160 [ - + ]: 2 : NCF_CHECK(ncerr)
5161 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5162 [ + + ]: 12 : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield", "dvdb_add_lr"])
5163 [ - + ]: 2 : NCF_CHECK(ncerr)
5164 [ + + - + : 4 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"]))
- - ]
5165 : : ncerr = nctk_def_arrays(ncid, [ &
5166 : : nctkarr_t("v1scf_avg", "dp", "two, nspden, three, natom, nqpt"), &
5167 : : nctkarr_t("v1lr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5168 : : nctkarr_t("v1scfmlr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5169 : : nctkarr_t("v1scfmlr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5170 : : nctkarr_t("v1scf_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5171 : : nctkarr_t("v1lr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5172 : : nctkarr_t("gsmall", "int", "three, ngsmall"), &
5173 : : nctkarr_t("v1scf_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5174 : : nctkarr_t("v1lr_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5175 : : nctkarr_t("qpoints", "dp", "three, nqpt") &
5176 [ + + ]: 22 : ])
5177 [ - + ]: 2 : NCF_CHECK(ncerr)
5178 : :
5179 [ - + ]: 2 : if (write_v1r) then
5180 : : ncerr = nctk_def_arrays(ncid, [ &
5181 : : nctkarr_t("v1r_interpolated", "dp", "two, nfft, nspden, natom3"), &
5182 : : nctkarr_t("v1r_lrmodel", "dp", "two, nfft, nspden, natom3") &
5183 [ # # ]: 0 : ])
5184 [ # # ]: 0 : NCF_CHECK(ncerr)
5185 : : end if
5186 : :
5187 [ - + ]: 2 : NCF_CHECK(nctk_set_datamode(ncid))
5188 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpoints"), this_qpts))
5189 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5190 : : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"], &
5191 [ + + + + ]: 18 : [dtset%symdynmat, dvdb%symv1, dtset%dvdb_add_lr, interpolated])
5192 [ - + ]: 2 : NCF_CHECK(ncerr)
5193 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5194 : : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield"], &
5195 [ + + + + ]: 18 : l2int([dvdb%has_dielt, dvdb%has_zeff, dvdb%has_quadrupoles, dvdb%has_efield]))
5196 [ - + ]: 2 : NCF_CHECK(ncerr)
5197 [ + + ]: 4 : dvdb_qdamp = dvdb%qdamp
5198 [ + + - + : 4 : NCF_CHECK(nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"], dvdb_qdamp))
- - ]
5199 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "gsmall"), gsmall))
5200 : : end if
5201 : :
5202 [ + + ]: 10 : do iq=1,this_nqpt
5203 : :
5204 [ + + ]: 8 : if (interpolated == 0) then
5205 [ - + ]: 3 : call wrtout(std_out, sjoin(" Treating qpt:", ktoa(this_qpts(:,iq))))
5206 : :
5207 : : ! Read data from DVDB file, reconstruct all 3*natom perturbations in tmp_v1r.
5208 [ - + - + : 3 : ABI_CHECK(dvdb%findq(this_qpts(:, iq)) /= -1, sjoin("Cannot find q-point:", ktoa(this_qpts(:, iq)), "in DVDB"))
- - ]
5209 [ - + - + ]: 3 : call dvdb%readsym_allv1(dvdb%findq(this_qpts(:, iq)), cplex, nfft, ngfft, tmp_v1r, xmpi_comm_self)
5210 : :
5211 : : ! Transfer data to file_v1r taking into account my_npert
5212 [ + + ]: 21 : do imyp=1,dvdb%my_npert
5213 : 18 : ipc = dvdb%my_pinfo(3, imyp)
5214 [ + + ]: 21 : if (cplex == 1) then
5215 [ + + + + ]: 24588 : file_v1r(1,:,:,imyp) = tmp_v1r(1,:,:,ipc)
5216 [ + + + + ]: 24588 : file_v1r(2,:,:,imyp) = zero
5217 : : else
5218 [ + + + + : 147480 : file_v1r(:,:,:,imyp) = tmp_v1r(:,:,:,ipc)
+ + ]
5219 : : end if
5220 : : end do
5221 [ - + ]: 3 : ABI_FREE(tmp_v1r)
5222 : :
5223 : : else
5224 : : ! Interpolate my_npert potentials for this q-point.
5225 [ - + ]: 5 : call wrtout(std_out, sjoin(" Interpolating qpt:", ktoa(this_qpts(:,iq))))
5226 [ - + ]: 5 : call dvdb%ftinterp_qpt(this_qpts(:, iq), nfft, ngfft, file_v1r, comm_rpt) !, add_lr=?)
5227 : 5 : cplex = 2
5228 : : end if
5229 : :
5230 : : ! Compute the periodic part of the LR term (note add_qphase = 0 because we want the periodic part)
5231 [ + + ]: 56 : do imyp=1,dvdb%my_npert
5232 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5233 : : ! The LR model is spin-independent: same value for the diagonal components, zero for the off-diagonal ones.
5234 [ + + + + : 589920 : long_v1r(:,:,:,imyp) = zero
+ + ]
5235 [ - + ]: 48 : call dvdb%get_v1r_long_range(this_qpts(:,iq), idir, ipert, nfft, ngfft, long_v1r(:,:,1,imyp), add_qphase=0)
5236 [ - + ]: 56 : do ispden=2,min(dvdb%nspden, 2)
5237 [ - - - - ]: 48 : long_v1r(:,:,ispden,imyp) = long_v1r(:,:,1,imyp)
5238 : : end do
5239 : : end do
5240 : :
5241 : : ! Compute average and write to file.
5242 [ + - ]: 8 : if (my_rank /= master) cycle
5243 : :
5244 [ - + ]: 8 : if (write_v1r .and. iq == 1) then
5245 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_interpolated"), file_v1r))
5246 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_lrmodel"), long_v1r))
5247 : : end if
5248 : :
5249 [ + + ]: 58 : do imyp=1,dvdb%my_npert
5250 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5251 [ + + ]: 104 : do ispden=1,dvdb%nspden
5252 : :
5253 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp), dim=2) / nfft
5254 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_avg"), vals2, &
5255 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5256 [ - + ]: 48 : NCF_CHECK(ncerr)
5257 : :
5258 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp)), dim=2) / nfft
5259 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_abs_avg"), vals2, &
5260 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5261 [ - + ]: 48 : NCF_CHECK(ncerr)
5262 : :
5263 [ + + + + ]: 393360 : vals2 = sum(long_v1r(:,:,ispden,imyp), dim=2) / nfft
5264 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_avg"), vals2, &
5265 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5266 [ - + ]: 48 : NCF_CHECK(ncerr)
5267 [ + + + + ]: 393360 : vals2 = sum(abs(long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5268 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_abs_avg"), vals2, &
5269 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5270 [ - + ]: 48 : NCF_CHECK(ncerr)
5271 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp), dim=2) / nfft
5272 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_avg"), vals2, &
5273 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5274 [ - + ]: 48 : NCF_CHECK(ncerr)
5275 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5276 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_abs_avg"), vals2, &
5277 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5278 [ - + ]: 48 : NCF_CHECK(ncerr)
5279 : :
5280 : : ! Compute G-components of DFPT potentials and LR model for G in small-sphere and save results to disk
5281 : 48 : call fourdp(2, workg, file_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5282 [ + + ]: 1344 : do ig=1,ngsmall
5283 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5284 : : end do
5285 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_gsmall"), work_gsmall, &
5286 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5287 [ - + ]: 48 : NCF_CHECK(ncerr)
5288 : :
5289 : 48 : call fourdp(2, workg, long_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5290 [ + + ]: 1344 : do ig=1,ngsmall
5291 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5292 : : end do
5293 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_gsmall"), work_gsmall, &
5294 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5295 [ - + ]: 48 : NCF_CHECK(ncerr)
5296 : :
5297 : : ! Debugging section.
5298 : : !write(std_out, "(a)")"--- !DVDB_LONGRANGE_DIFF"
5299 : : !write(std_out,"(3a)")" qpoint: ", trim(ktoa(this_qpts(:,iq))), ","
5300 : : !write(std_out,"(a,i0,a)")" iq: ", iq, ","
5301 : : !write(std_out,"(2(a,i0))")" idir: ", idir, ", ipert:", ipert
5302 : : !write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5303 : : !call call vd%eval(2, nfft, file_v1r(:,:,ispden,imyp), long_v1r(:,:,ispden,imyp), &
5304 : : ! dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out))
5305 : : !write(std_out,"(a)")"..."
5306 : :
5307 : : ! Debug: write potentials to file.
5308 [ - + ]: 96 : if (unt /= -1) then
5309 [ # # # # : 0 : write(unt,*)"# q-point:", trim(ktoa(this_qpts(:,iq))), ", iq: ", trim(itoa(iq))
# # ]
5310 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
5311 : 0 : write(unt,*)"# file_v1r, long_v1r, diff"
5312 : :
5313 [ # # ]: 0 : if (cplex == 1) then
5314 [ # # ]: 0 : do i3=1,n3
5315 [ # # ]: 0 : do i2=1,n2
5316 [ # # ]: 0 : do i1=1,n1
5317 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5318 : : write(unt,"(3(i0,1x),3(es12.4,2x))") &
5319 : 0 : i1,i2,i3, &
5320 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5321 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp)
5322 : : end do
5323 : : end do
5324 : : end do
5325 : : else
5326 [ # # ]: 0 : do i3=1,n3
5327 [ # # ]: 0 : do i2=1,n2
5328 [ # # ]: 0 : do i1=1,n1
5329 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5330 : : write(unt, "(3(i0,1x),6(es12.4,2x))") &
5331 : 0 : i1,i2,i3, &
5332 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5333 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp), &
5334 : 0 : file_v1r(2,ifft,ispden,imyp), long_v1r(2,ifft,ispden,imyp), &
5335 : 0 : file_v1r(2,ifft,ispden,imyp) - long_v1r(2,ifft,ispden,imyp)
5336 : : end do
5337 : : end do
5338 : : end do
5339 : : end if
5340 : 0 : write(unt,*)
5341 : 0 : write(unt,*)
5342 : : end if
5343 : :
5344 : : end do
5345 : : end do
5346 : : !write(std_out,*)" "
5347 : : end do ! iq
5348 : :
5349 [ - + ]: 2 : ABI_FREE(long_v1r)
5350 [ - + ]: 2 : ABI_FREE(file_v1r)
5351 [ - + ]: 2 : ABI_FREE(workg)
5352 [ - + ]: 2 : ABI_FREE(gfft)
5353 [ - + ]: 2 : ABI_FREE(ig2ifft)
5354 [ - + ]: 2 : ABI_FREE(gsmall)
5355 [ - + ]: 2 : ABI_FREE(work_gsmall)
5356 : :
5357 [ + + ]: 2 : if (interpolated == 1) then
5358 : : ! Compute max_r |W(R,r)| and write data to file.
5359 [ - + - + : 1 : call dvdb%get_maxw(dtset%ddb_ngqpt, all_rpt, all_rmod, maxw)
- + ]
5360 [ + - ]: 1 : if (my_rank == master) then
5361 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), dtset%ddb_ngqpt))
5362 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rpt"), all_rpt))
5363 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rmod"), all_rmod))
5364 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5365 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "maxw"), maxw))
5366 : : end if
5367 [ - + ]: 1 : ABI_FREE(all_rpt)
5368 [ - + ]: 1 : ABI_FREE(all_rmod)
5369 [ - + ]: 1 : ABI_FREE(maxw)
5370 : : end if
5371 : :
5372 [ + - ]: 2 : if (my_rank == master) then
5373 [ - + ]: 2 : NCF_CHECK(nf90_close(ncid))
5374 : : end if
5375 : :
5376 [ - + - + : 4 : end subroutine dvdb_write_v1qavg
- + - + -
+ - + - +
- + ]
5377 : : !!***
5378 : :
5379 : : !----------------------------------------------------------------------
5380 : :
5381 : : !!****f* m_dvdb/dvdb_test_ftinterp
5382 : : !! NAME
5383 : : !! dvdb_test_ftinterp
5384 : : !!
5385 : : !! FUNCTION
5386 : : !! Debugging tool used to test the Fourier interpolation of the DFPT potentials.
5387 : : !!
5388 : : !! INPUTS
5389 : : !! dvdb_filepath=Filename
5390 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equat to ddb_ngqpt)
5391 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5392 : : !! qdamp=Defines exponential damping in LR potential
5393 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5394 : : !! prtvol=Verbosity level.
5395 : : !! coarse_ngqpt(3)= Coarse q-mesh used to analyze the accuracy of the FT interpolation
5396 : : !! Must be divisor of dvdb_ngqpt. Use 0 to disable the test.
5397 : : !! comm=MPI communicator.
5398 : : !!
5399 : : !! OUTPUT
5400 : : !! Only writing.
5401 : : !!
5402 : : !! SOURCE
5403 : :
5404 : 0 : subroutine dvdb_test_ftinterp(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5405 : : ddb_filepath, prtvol, coarse_ngqpt, dump_path, comm)
5406 : :
5407 : : !Arguments ------------------------------------
5408 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5409 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5410 : : real(dp),intent(in) :: dvdb_qdamp
5411 : : integer,intent(in) :: dvdb_ngqpt(3), coarse_ngqpt(3)
5412 : :
5413 : : !Local variables-------------------------------
5414 : : !scalars
5415 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0
5416 : : integer :: nfft, iq, cplex, mu, ispden, comm_rpt, iblock_dielt, iblock_dielt_zeff, my_rank, ierr
5417 : : integer :: ncid, ncerr
5418 : : logical :: autotest
5419 [ # # # # : 0 : type(dvdb_t) :: dvdb, coarse_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5420 : : type(vdiff_t) :: vd_max, vd
5421 : 0 : type(ddb_type) :: ddb
5422 : : character(len=fnlen) :: coarse_fname
5423 : : !arrays
5424 : : integer :: ngfft(18)
5425 : 0 : real(dp),allocatable :: file_v1r(:,:,:,:),intp_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5426 : : ! *************************************************************************
5427 : :
5428 : 0 : my_rank = xmpi_comm_rank(comm)
5429 : :
5430 : 0 : write(std_out,"(a)")sjoin(" Testing Fourier interpolation of V1(r) with ngqpt:", ltoa(dvdb_ngqpt))
5431 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5432 : 0 : write(std_out,"(a)")sjoin(" Reading Zeff and eps_inf from DDB file:", ddb_filepath)
5433 : 0 : write(std_out,"(a)")sjoin(" dvdb_add_lr set to:", itoa(dvdb_add_lr))
5434 : : end if
5435 : :
5436 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5437 : 0 : dvdb%debug = .False.
5438 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5439 : 0 : dvdb%symv1 = symv1
5440 : 0 : dvdb%add_lr = dvdb_add_lr
5441 : 0 : dvdb%qdamp = dvdb_qdamp
5442 : 0 : dvdb%rspace_cell = rspace_cell
5443 : :
5444 : : !call dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5445 : :
5446 : 0 : iblock_dielt = 0; iblock_dielt_zeff = 0
5447 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5448 : 0 : call dvdb%load_ddb(chneut2, prtvol, comm, ddb_filepath=ddb_filepath)
5449 : : else
5450 : 0 : dvdb%add_lr = 0
5451 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5452 : : end if
5453 : :
5454 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5455 : :
5456 : : ! Define FFT mesh for real space representation.
5457 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5458 [ # # ]: 0 : nfft = product(ngfft(1:3))
5459 : 0 : call dvdb%open_read(ngfft, comm)
5460 : :
5461 [ # # # # : 0 : ABI_MALLOC(intp_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5462 [ # # # # : 0 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5463 : :
5464 : : ! Prepare FT interpolation.
5465 : 0 : comm_rpt = xmpi_comm_self
5466 : :
5467 : : ! Optionally dump ab-initio and interpolated V1(r) to a netcdf file for post-processing in python.
5468 : 0 : ncid = nctk_noid
5469 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5470 : 0 : write(std_out,"(a)")sjoin(" Will write ab-initio and interpolated potentials to:", dump_path)
5471 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5472 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5473 : : ncerr = nctk_def_dims(ncid, [ &
5474 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5475 [ # # ]: 0 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nqpt", dvdb%nqpt)], defmode=.True.)
5476 [ # # ]: 0 : NCF_CHECK(ncerr)
5477 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
5478 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
5479 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5480 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5481 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5482 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_ngqpt", "int", "three")))
5483 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5484 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5485 : : end if
5486 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5487 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
5488 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5489 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5490 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_ngqpt"), coarse_ngqpt))
5491 : : end if
5492 : : end if
5493 : :
5494 : 0 : autotest = .True.
5495 : : if (autotest) then
5496 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5497 : :
5498 : : ! First step: Use FT interpolation to get q-points in the initial ab-initio mesh.
5499 : : ! We should get the same result...
5500 [ # # ]: 0 : do iq=1,dvdb%nqpt
5501 : : ! Read data from DVDB file and store it in file_v1r
5502 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5503 : :
5504 [ # # ]: 0 : if (cplex == 1) then
5505 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5506 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5507 : : else
5508 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5509 : : end if
5510 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5511 : :
5512 : : ! Interpolate data at the same q-point.
5513 : 0 : call dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5514 : :
5515 : 0 : write(std_out,"(a)")sjoin("=== For q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5516 [ # # ]: 0 : do mu=1,dvdb%natom3
5517 [ # # ]: 0 : do ispden=1,dvdb%nspden
5518 : 0 : write(std_out, "(a)")"--- !DVDB_SELF_DIFF"
5519 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5520 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5521 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5522 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5523 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5524 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5525 : 0 : write(std_out,"(a)")"..."
5526 : : !do ifft=1,nfft
5527 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5528 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5529 : : !end do
5530 : : end do
5531 : : end do
5532 : :
5533 [ # # ]: 0 : if (ncid /= nctk_noid) then
5534 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5535 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5536 : : end if
5537 : :
5538 : 0 : write(std_out,*)" "
5539 : : end do ! iq
5540 : :
5541 : 0 : write(std_out, "(/, a)")" Max values over q-points and perturbations"
5542 : 0 : call vd_max%print()
5543 [ # # ]: 0 : ABI_FREE(dvdb%wsr)
5544 : : end if
5545 : :
5546 : : ! Now downsample the q-mesh, build real-space representation with coarse q-mesh and
5547 : : ! compare with ab-intio values in the initial dvdb.
5548 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5549 [ # # ]: 0 : write(std_out, "(/, 2a)")" Downsampling Q-mesh using coarse_ngqpt:", trim(ltoa(coarse_ngqpt))
5550 : :
5551 [ # # ]: 0 : coarse_fname = strcat(dvdb_filepath, "_COARSE")
5552 : 0 : call dvdb%qdownsample(coarse_fname, qptopt1, coarse_ngqpt, comm)
5553 : :
5554 : 0 : call coarse_dvdb%init(coarse_fname, gpu_option0, comm)
5555 : 0 : call coarse_dvdb%open_read(ngfft, comm)
5556 : : !call coarse_dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5557 : :
5558 : 0 : coarse_dvdb%debug = dvdb%debug
5559 : 0 : coarse_dvdb%symv1 = dvdb%symv1
5560 : 0 : coarse_dvdb%add_lr = dvdb%add_lr
5561 : 0 : coarse_dvdb%has_dielt = dvdb%has_dielt
5562 : 0 : coarse_dvdb%has_zeff = dvdb%has_zeff
5563 : 0 : coarse_dvdb%has_quadrupoles = dvdb%has_quadrupoles
5564 : 0 : coarse_dvdb%has_efield = dvdb%has_efield
5565 [ # # # # ]: 0 : coarse_dvdb%dielt = dvdb%dielt
5566 [ # # # # : 0 : coarse_dvdb%zeff = dvdb%zeff
# # # # #
# # # # #
# # # # #
# # # ]
5567 [ # # # # : 0 : coarse_dvdb%zeff_raw = dvdb%zeff_raw
# # # # #
# # # # #
# # # # #
# # # ]
5568 [ # # # # : 0 : coarse_dvdb%qstar = dvdb%qstar
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5569 : 0 : coarse_dvdb%qdamp = dvdb%qdamp
5570 : : !call coarse_dvdb%print()
5571 : :
5572 : : ! Prepare FT interpolation using coarse q-mesh.
5573 : 0 : call coarse_dvdb%ftinterp_setup(coarse_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5574 : :
5575 [ # # ]: 0 : do iq=1,dvdb%nqpt
5576 : : ! Read data from DVDB file and store it in file_v1r
5577 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5578 : :
5579 [ # # ]: 0 : if (cplex == 1) then
5580 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5581 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5582 : : else
5583 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5584 : : end if
5585 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5586 : :
5587 : : ! Interpolate data at the same q-point using the coarse Q-mesh
5588 : 0 : call coarse_dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5589 : :
5590 : 0 : write(std_out,"(a)")sjoin("=== For COARSE q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5591 [ # # ]: 0 : do mu=1,dvdb%natom3
5592 [ # # ]: 0 : do ispden=1,dvdb%nspden
5593 : 0 : write(std_out, "(a)")"--- !DVDB_COARSE_DIFF"
5594 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5595 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5596 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5597 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5598 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5599 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5600 : 0 : write(std_out,"(a)")"..."
5601 : : !do ifft=1,nfft
5602 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5603 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5604 : : !end do
5605 : : end do
5606 : : end do
5607 : :
5608 [ # # ]: 0 : if (ncid /= nctk_noid) then
5609 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5610 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5611 : : end if
5612 : :
5613 : 0 : write(std_out,*)" "
5614 : : end do ! iq
5615 : :
5616 : 0 : write(std_out, "(/, a)")" COARSE DVDB: Max values over q-points and perturbations"
5617 : 0 : call vd_max%print()
5618 : 0 : call coarse_dvdb%free()
5619 [ # # ]: 0 : if (my_rank == master) call delete_file(coarse_fname, ierr)
5620 : : end if
5621 : :
5622 [ # # ]: 0 : ABI_FREE(intp_v1r)
5623 [ # # ]: 0 : ABI_FREE(file_v1r)
5624 : :
5625 [ # # ]: 0 : if (ncid /= nctk_noid) then
5626 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5627 : : end if
5628 : :
5629 : 0 : call dvdb%free()
5630 : 0 : call ddb%free()
5631 : :
5632 [ # # # # : 0 : end subroutine dvdb_test_ftinterp
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5633 : : !!***
5634 : :
5635 : : !----------------------------------------------------------------------
5636 : :
5637 : : !!****f* m_dvdb/dvdb_test_symcheck
5638 : : !! NAME
5639 : : !! dvdb_test_symcheck
5640 : : !!
5641 : : !! FUNCTION
5642 : : !! Debugging tool: checks whether Fourier-interpolating the DFPT potential independently
5643 : : !! at q_source and at q_target = I(itimrev) S(isym) q_source (for every symmetry of the
5644 : : !! crystal) gives results consistent with each other via the exact rotation formula
5645 : : !! implemented in v1phq_rotate. This isolates the Fourier-interpolation machinery
5646 : : !! (dvdb_ftinterp_qpt) from gstore_symmetrize: no e-ph coupling / m_gstore.F90 code is
5647 : : !! involved at all. q_source need not be on the native ab-initio q-mesh.
5648 : : !!
5649 : : !! INPUTS
5650 : : !! dvdb_filepath=Filename
5651 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equal to ddb_ngqpt)
5652 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5653 : : !! qdamp=Defines exponential damping in LR potential
5654 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5655 : : !! prtvol=Verbosity level.
5656 : : !! qpt_source(3)=Source q-point (reduced coordinates, arbitrary, need not be on the ab-initio mesh).
5657 : : !! comm=MPI communicator.
5658 : : !!
5659 : : !! OUTPUT
5660 : : !! Only writing.
5661 : : !!
5662 : : !! SOURCE
5663 : :
5664 : 0 : subroutine dvdb_test_symcheck(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5665 : : ddb_filepath, prtvol, qpt_source, dump_path, comm)
5666 : :
5667 : : !Arguments ------------------------------------
5668 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5669 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5670 : : real(dp),intent(in) :: dvdb_qdamp
5671 : : integer,intent(in) :: dvdb_ngqpt(3)
5672 : : real(dp),intent(in) :: qpt_source(3)
5673 : :
5674 : : !Local variables-------------------------------
5675 : : !scalars
5676 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0, cplex2 = 2
5677 : : integer :: nfft, isym, itimrev, tsign, mu, ispden, comm_rpt, iat, my_rank, ncid, ncerr
5678 [ # # # # : 0 : type(dvdb_t) :: dvdb
# # # # #
# # # # #
# # # # #
# # # #
# ]
5679 : : type(vdiff_t) :: vd_max, vd
5680 : : !arrays
5681 : : integer :: ngfft(18), g0q(3)
5682 : : real(dp) :: qpt_target(3)
5683 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5684 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5685 : : ! *************************************************************************
5686 : :
5687 : 0 : my_rank = xmpi_comm_rank(comm)
5688 : :
5689 : 0 : write(std_out,"(2a)")" Testing cross-q-point symmetry consistency of the FT interpolation of V1(r)", ch10
5690 : 0 : write(std_out,"(a)")sjoin(" q_source: ", ktoa(qpt_source))
5691 : :
5692 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5693 : 0 : dvdb%debug = .False.
5694 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5695 : 0 : dvdb%symv1 = symv1
5696 : 0 : dvdb%add_lr = dvdb_add_lr
5697 : 0 : dvdb%qdamp = dvdb_qdamp
5698 : 0 : dvdb%rspace_cell = rspace_cell
5699 : :
5700 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5701 : 0 : call dvdb%load_ddb(chneut2, prtvol, comm, ddb_filepath=ddb_filepath)
5702 : : else
5703 : 0 : dvdb%add_lr = 0
5704 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5705 : : end if
5706 : :
5707 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5708 : :
5709 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5710 [ # # ]: 0 : nfft = product(ngfft(1:3))
5711 : 0 : call dvdb%open_read(ngfft, comm)
5712 : :
5713 : 0 : comm_rpt = xmpi_comm_self
5714 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5715 : :
5716 [ # # # # : 0 : ABI_MALLOC(v1r_source, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5717 [ # # # # : 0 : ABI_MALLOC(v1r_target, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5718 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5719 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5720 : :
5721 : : ! Interpolate once at q_source (this itself is a genuine off-grid interpolation if q_source
5722 : : ! is not on the coarse ab-initio mesh).
5723 : 0 : call dvdb%ftinterp_qpt(qpt_source, nfft, ngfft, v1r_source, dvdb%comm_rpt)
5724 : :
5725 : : ! Optionally dump v1r_target (independent re-interpolation at q_target) and v1r_predicted
5726 : : ! (rotated prediction from q_source) to a netcdf file for post-processing in python.
5727 : 0 : ncid = nctk_noid
5728 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5729 : 0 : write(std_out,"(a)")sjoin(" Will write target and predicted potentials to:", dump_path)
5730 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5731 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5732 : : ncerr = nctk_def_dims(ncid, [ &
5733 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5734 : : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nsym", dvdb%cryst%nsym), nctkdim_t("ntimrev", 2)], &
5735 [ # # ]: 0 : defmode=.True.)
5736 [ # # ]: 0 : NCF_CHECK(ncerr)
5737 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_source", "dp", "three")))
5738 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_target", "dp", "three, ntimrev, nsym")))
5739 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_target", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5740 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_predicted", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5741 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5742 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_source"), qpt_source))
5743 : : end if
5744 : :
5745 : 0 : g0q = 0
5746 [ # # ]: 0 : do isym=1,dvdb%cryst%nsym
5747 [ # # ]: 0 : do itimrev=1,2
5748 : 0 : tsign = 3 - 2*itimrev
5749 [ # # # # : 0 : qpt_target = tsign * matmul(dvdb%cryst%symrec(:,:,isym), qpt_source)
# # # # #
# # # ]
5750 : :
5751 : : ! Independent, direct interpolation at the target q (no symmetry involved at all).
5752 : 0 : call dvdb%ftinterp_qpt(qpt_target, nfft, ngfft, v1r_target, dvdb%comm_rpt)
5753 : :
5754 : : ! Predicted potential at q_target obtained by ROTATING the q_source interpolation
5755 : : ! with the exact same formula gstore_symmetrize/v1phq_rotate uses to expand IBZ->BZ.
5756 : : call v1phq_rotate(dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5757 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5758 : :
5759 [ # # ]: 0 : if (ncid /= nctk_noid) then
5760 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_target"), qpt_target, start=[1,itimrev,isym]))
# # ]
5761 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_target"), v1r_target, start=[1,1,1,1,itimrev,isym]))
# # ]
5762 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_predicted"), v1r_predicted, start=[1,1,1,1,itimrev,isym]))
# # ]
5763 : : end if
5764 : :
5765 [ # # ]: 0 : do mu=1,dvdb%natom3
5766 : 0 : iat = (mu - 1) / 3 + 1
5767 [ # # ]: 0 : do ispden=1,dvdb%nspden
5768 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5769 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5770 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5771 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5772 : : end do
5773 : : end do
5774 : :
5775 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK"
5776 : 0 : write(std_out,"(a,i0,a)")" isym: ", isym, ","
5777 : 0 : write(std_out,"(a,i0,a)")" itimrev: ", itimrev, ","
5778 [ # # ]: 0 : write(std_out,"(3a)")" qpt_target: ", trim(ktoa(qpt_target)), ","
5779 : 0 : call vd_max%print()
5780 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5781 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5782 : : end do
5783 : 0 : write(std_out,"(a)")"..."
5784 : : end do ! itimrev
5785 : : end do ! isym
5786 : :
5787 [ # # ]: 0 : ABI_FREE(v1r_source)
5788 [ # # ]: 0 : ABI_FREE(v1r_target)
5789 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5790 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5791 : :
5792 [ # # ]: 0 : if (ncid /= nctk_noid) then
5793 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5794 : : end if
5795 : :
5796 : 0 : call dvdb%free()
5797 : :
5798 [ # # # # : 0 : end subroutine dvdb_test_symcheck
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5799 : : !!***
5800 : :
5801 : : !----------------------------------------------------------------------
5802 : :
5803 : : !!****f* m_dvdb/dvdb_test_symcheck_native
5804 : : !! NAME
5805 : : !! dvdb_test_symcheck_native
5806 : : !!
5807 : : !! FUNCTION
5808 : : !! Debugging tool: like dvdb_test_symcheck but operates on TWO LITERAL, independently
5809 : : !! DFPT-computed q-points already present in the DVDB (no Fourier interpolation involved
5810 : : !! at all -- no ftinterp_setup/ftinterp_qpt call anywhere). Reads q_source and q_target
5811 : : !! directly via readsym_allv1, predicts q_target from q_source via v1phq_rotate, and
5812 : : !! compares against q_target's own literal data. Isolates v1phq_rotate/rotate_fqg
5813 : : !! completely from the W(R,r) real-space Fourier-interpolation machinery.
5814 : : !!
5815 : : !! INPUTS
5816 : : !! dvdb_filepath=Filename (must contain BOTH q_source and q_target as literal,
5817 : : !! fully-available (3*natom perturbations) q-points, e.g. produced with nsym 1).
5818 : : !! sym_dvdb_filepath=Filename of a DIFFERENT DVDB (or any file crystal_from_file can read) that
5819 : : !! carries the crystal's TRUE, full symmetry table (dvdb_filepath's own nsym is typically 1,
5820 : : !! since that's what forces every requested perturbation/q to be explicitly, independently
5821 : : !! computed in the first place -- so its own %cryst cannot be used to look up isym > 1).
5822 : : !! qpt_source(3), qpt_target(3)=The two q-points (reduced coordinates), assumed related by
5823 : : !! the given isym/itimrev/g0q.
5824 : : !! isym, itimrev, g0q(3)=Symmetry indices such that qpt_target = I(itimrev) S(isym) qpt_source + g0q.
5825 : : !! comm=MPI communicator.
5826 : : !!
5827 : : !! OUTPUT
5828 : : !! Only writing.
5829 : : !!
5830 : : !! SOURCE
5831 : :
5832 : 0 : subroutine dvdb_test_symcheck_native(dvdb_filepath, sym_dvdb_filepath, qpt_source, qpt_target, &
5833 : : isym, itimrev, g0q, comm)
5834 : :
5835 : : !Arguments ------------------------------------
5836 : : character(len=*),intent(in) :: dvdb_filepath, sym_dvdb_filepath
5837 : : integer,intent(in) :: comm, isym, itimrev
5838 : : integer,intent(in) :: g0q(3)
5839 : : real(dp),intent(in) :: qpt_source(3), qpt_target(3)
5840 : :
5841 : : !Local variables-------------------------------
5842 : : !scalars
5843 : : integer,parameter :: gpu_option0 = 0, cplex2 = 2
5844 : : integer :: nfft, mu, ispden, iq_source, iq_target, iat
5845 [ # # # # : 0 : type(dvdb_t) :: dvdb, sym_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5846 : : type(vdiff_t) :: vd_max, vd
5847 : : !arrays
5848 : : integer :: ngfft(18)
5849 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5850 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5851 : : ! *************************************************************************
5852 : :
5853 : 0 : write(std_out,"(2a)")" Testing v1phq_rotate against TWO LITERAL, non-interpolated q-points", ch10
5854 [ # # ]: 0 : write(std_out,"(2a)")" q_source: ", trim(ktoa(qpt_source))
5855 [ # # ]: 0 : write(std_out,"(2a)")" q_target: ", trim(ktoa(qpt_target))
5856 : :
5857 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5858 : 0 : dvdb%debug = .False.
5859 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5860 : :
5861 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5862 [ # # ]: 0 : nfft = product(ngfft(1:3))
5863 : 0 : call dvdb%open_read(ngfft, comm)
5864 : :
5865 : : ! Load a SEPARATE dvdb just to get the crystal's true, full symmetry table (dvdb_filepath's
5866 : : ! own %cryst normally has nsym=1, see docstring above).
5867 : 0 : call sym_dvdb%init(sym_dvdb_filepath, gpu_option0, comm)
5868 : 0 : write(std_out,"(a,i0,a,i0)")" sym_dvdb nsym: ", sym_dvdb%cryst%nsym, " dvdb (literal) nsym: ", dvdb%cryst%nsym
5869 : :
5870 : 0 : iq_source = dvdb%findq(qpt_source)
5871 : 0 : iq_target = dvdb%findq(qpt_target)
5872 [ # # ]: 0 : ABI_CHECK(iq_source /= -1, "qpt_source not found in DVDB!")
5873 [ # # ]: 0 : ABI_CHECK(iq_target /= -1, "qpt_target not found in DVDB!")
5874 : :
5875 : 0 : call dvdb%readsym_allv1(iq_source, mu, nfft, ngfft, v1r_source, comm) ! mu reused as cplex out-arg
5876 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_source")
5877 : 0 : call dvdb%readsym_allv1(iq_target, mu, nfft, ngfft, v1r_target, comm)
5878 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_target")
5879 : :
5880 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5881 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5882 : :
5883 : : call v1phq_rotate(sym_dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5884 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5885 : :
5886 : 0 : call sym_dvdb%free()
5887 : :
5888 [ # # ]: 0 : do mu=1,dvdb%natom3
5889 : 0 : iat = (mu - 1) / 3 + 1
5890 [ # # ]: 0 : do ispden=1,dvdb%nspden
5891 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5892 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5893 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5894 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5895 : : end do
5896 : : end do
5897 : :
5898 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK_NATIVE"
5899 : 0 : call vd_max%print()
5900 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5901 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5902 : : end do
5903 : 0 : write(std_out,"(a)")"..."
5904 : :
5905 [ # # ]: 0 : ABI_FREE(v1r_source)
5906 [ # # ]: 0 : ABI_FREE(v1r_target)
5907 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5908 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5909 : :
5910 : 0 : call dvdb%free()
5911 : :
5912 [ # # # # : 0 : end subroutine dvdb_test_symcheck_native
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5913 : : !!***
5914 : :
5915 : : !----------------------------------------------------------------------
5916 : :
5917 : : !!****f* m_dvdb/dvdb_get_v1r_long_range
5918 : : !! NAME
5919 : : !! dvdb_get_v1r_long_range
5920 : : !!
5921 : : !! FUNCTION
5922 : : !! Compute the long-range part of the phonon potential
5923 : : !! due to the Born effective charges, PRL 115, 176401 (2015) [[cite:Verdi2015]].
5924 : : !!
5925 : : !! V^L_{iatom,idir}(r) = i (4pi/vol) sum_G (q+G) . Zeff_{iatom,idir}
5926 : : !! e^{i (q+G).(r - tau_{iatom})} / ((q+G) . dielt . (q+G))
5927 : : !!
5928 : : !! where Zeff and dielt are the Born effective charge tensor and the dielectric tensor in cart coords,
5929 : : !! tau is the atom position, and vol is the volume of the unit cell.
5930 : : !! Note that internally the tensors are stored in Cartesian coordinates while in output we need
5931 : : !! the contribution due to the displacement of the iatom-sublattice along the reduced direction idir
5932 : : !! hence we need to perform some tensor gymnastics to go from Cart to reduced.
5933 : : !!
5934 : : !! INPUTS
5935 : : !! db = the DVDB object.
5936 : : !! qpt = the q-point in reduced coordinates.
5937 : : !! idir = direction index.
5938 : : !! iatom = atom index.
5939 : : !! nfft = number of fft points.
5940 : : !! ngfft(18) = FFT mesh.
5941 : : !! [add_qphase]=By default, the routine returns the LR potential with the e^{iqr} phase.
5942 : : !! Use add_qphase = 0 to get the lattice-periodic part.
5943 : : !!
5944 : : !! OUTPUT
5945 : : !! v1r_lr = dipole potential
5946 : : !!
5947 : : !! SOURCE
5948 : :
5949 : 22234 : subroutine dvdb_get_v1r_long_range(db, qpt, idir, iatom, nfft, ngfft, v1r_lr, add_qphase)
5950 : :
5951 : : !Arguments ------------------------------------
5952 : : !scalars
5953 : : class(dvdb_t),intent(in) :: db
5954 : : integer,intent(in) :: idir, iatom, nfft
5955 : : integer,optional,intent(in) :: add_qphase
5956 : : !arrays
5957 : : integer,intent(in) :: ngfft(18)
5958 : : real(dp),intent(in) :: qpt(3)
5959 : : real(dp),intent(out) :: v1r_lr(2,nfft)
5960 : :
5961 : : !Local variables-------------------------------
5962 : : !scalars
5963 : : integer :: n1, n2, n3, nfftot, ig, iphase, ii, jj, kk, ll, mm, ifft, ispden
5964 : : real(dp) :: fac, qGZ, qGS, denom, denom_inv, qtau, re, im, phre, phim, qg_mod, gsq_max
5965 : : real(dp),parameter :: tol_denom = tol8
5966 : : !arrays
5967 : 22234 : integer, allocatable :: gfft(:,:)
5968 : : real(dp) :: gprimd(3,3), rprimd(3,3), dielt_red(3,3)
5969 : : real(dp) :: qG_red(3), qG_cart(3), Zstar(3), Sstar(3,3), tau_red(3)
5970 : 22234 : real(dp), allocatable :: v1G_lr(:,:), v1G_lr33(:,:,:,:), workr(:,:)
5971 : : ! *************************************************************************
5972 : :
5973 : : ! Return immediately if metals by
5974 : : !if (db%has_zeff .or. db%has_quadrupoles) then
5975 : :
5976 [ + + ]: 22234 : iphase = 1; if (present(add_qphase)) iphase = add_qphase
5977 : :
5978 : : ! Make sure FFT parallelism is not used
5979 [ + + ]: 88936 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
5980 [ - + ]: 22234 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
5981 : :
5982 : : ! Allocate memory
5983 [ - + + - : 66702 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5984 [ - + + - : 66702 : ABI_MALLOC(v1G_lr, (2, nfft))
+ - + - -
+ - + ]
5985 : :
5986 : : ! Reciprocal and real space primitive vectors
5987 [ + + + + : 555850 : gprimd = db%cryst%gprimd; rprimd = db%cryst%rprimd
+ + + + ]
5988 : :
5989 : : ! Prefactor
5990 : 22234 : fac = four_pi / db%cryst%ucvol
5991 : :
5992 : : ! Transform the Born effective charge tensor from Cartesian to reduced coordinates
5993 : : ! and select the relevant direction.
5994 [ + - + - : 689254 : Zstar = matmul(transpose(gprimd), matmul(db%zeff(:,:,iatom), rprimd(:,idir))) * two_pi
+ - - + -
+ + + + +
+ + + - +
- + - +
+ ]
5995 : :
5996 [ - + ]: 22234 : if (db%has_quadrupoles) then
5997 : : ! Transform Qstar from Cartesian to reduced coordinates and select the relevant direction.
5998 : 0 : Sstar = zero
5999 [ # # ]: 0 : do ii=1,3
6000 [ # # ]: 0 : do jj=1,3
6001 [ # # ]: 0 : do kk=1,3
6002 [ # # ]: 0 : do ll=1,3
6003 [ # # ]: 0 : do mm=1,3
6004 : : Sstar(ii,jj) = Sstar(ii,jj) + &
6005 : 0 : gprimd(mm,jj) * gprimd(ll,ii) * db%qstar(mm,ll,kk,iatom) * rprimd(kk,idir) * two_pi ** 2
6006 : : end do
6007 : : end do
6008 : : end do
6009 : : end do
6010 : : end do
6011 : : end if
6012 : :
6013 : : ! Transform the dielectric tensor from Cartesian to reduced coordinates.
6014 : : ! q_cart e_cart q_cart = q_red (G^t e_cart G) q_red
6015 [ + + + + : 2023294 : dielt_red = matmul(transpose(gprimd), matmul(db%dielt, gprimd)) * two_pi ** 2
+ + + + +
+ + + + +
+ + ]
6016 : :
6017 : : ! Atom position
6018 [ + + ]: 88936 : tau_red = db%cryst%xred(:,iatom)
6019 : :
6020 : : ! Get the set of G vectors
6021 : : ! TODO: May use zero-padded FFT with small G-sphere
6022 : 22234 : call get_gfft(ngfft, qpt, db%cryst%gmet, gsq_max, gfft)
6023 : :
6024 : : ! Compute the long-range potential in G-space due to Z* and Q* (if present)
6025 [ + + + + ]: 336598582 : v1G_lr = zero
6026 [ - + - - ]: 22234 : if (db%has_zeff .or. db%has_quadrupoles) then
6027 : :
6028 [ + + ]: 112214350 : do ig=1,nfft
6029 : : ! (q + G)
6030 [ + + ]: 448768464 : qG_red = qpt + gfft(:,ig)
6031 [ + + + + : 1795073856 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
+ + ]
6032 [ + + ]: 448768464 : qG_mod = sqrt(sum(qG_cart ** 2))
6033 : : ! (q + G) . Zeff(:,idir,iatom)
6034 [ + + ]: 448768464 : qGZ = dot_product(qG_red, Zstar)
6035 : : ! (q + G) . dielt . (q + G)
6036 [ + + + + : 1795073856 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
+ + ]
6037 : : ! Avoid (q + G) = 0
6038 [ + + ]: 112192116 : if (denom < tol_denom) cycle
6039 : 112191608 : denom_inv = one / denom
6040 : : ! HM hard cutoff, in this case qdamp takes the meaning of an energy cutoff in Hartree (hardcoded to 1 for the moment)
6041 : : !if (half*qG_mod**2 > 1) cycle
6042 [ + - ]: 112191608 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6043 : 112191608 : qGS = zero
6044 [ - + ]: 112191608 : if (db%has_quadrupoles) then
6045 [ # # ]: 0 : do ii=1,3
6046 [ # # ]: 0 : do jj=1,3
6047 : 0 : qGS = qGS + qG_red(ii) * qG_red(jj) * Sstar(ii,jj) / two
6048 : : end do
6049 : : end do
6050 : : end if
6051 : :
6052 : : ! Phase factor exp(-i (q+G) . tau)
6053 [ + + ]: 448766432 : qtau = - two_pi * dot_product(qG_red, tau_red)
6054 : 112191608 : phre = cos(qtau); phim = sin(qtau)
6055 : : !phre = one; phim = zero
6056 : :
6057 : 112191608 : re = +fac * qGS * denom_inv !re = zero
6058 : 112191608 : im = fac * qGZ * denom_inv
6059 : 112191608 : v1G_lr(1,ig) = phre * re - phim * im
6060 : 112213842 : v1G_lr(2,ig) = phim * re + phre * im
6061 : : end do
6062 : : end if
6063 : :
6064 : : ! FFT to get the long-range potential in r-space
6065 : 22234 : call fourdp(2, v1G_lr, v1r_lr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6066 : :
6067 [ - + ]: 22234 : if (db%has_efield) then
6068 : : ! Add term due to Electric field.
6069 : : ! TODO: Change API to account for ispden/isppol. return nspden LR part
6070 : : ! although only the electric field part depends on nsppden.
6071 : : !v1r_lr = zero ! Comment this line to have only efield contribution
6072 [ # # ]: 0 : ABI_CHECK(db%nspden == 1, "nspden != 1 not coded")
6073 : 0 : ispden = 1
6074 [ # # # # : 0 : ABI_CALLOC(v1G_lr33, (3, 3, 2, nfft))
# # # # #
# # # # #
# # # # #
# ]
6075 [ # # ]: 0 : do ig=1,nfft
6076 : : !if (ig > 1) cycle
6077 : : ! (q + G)
6078 [ # # ]: 0 : qG_red = qpt + gfft(:,ig)
6079 [ # # # # : 0 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
# # ]
6080 [ # # ]: 0 : qG_mod = sqrt(sum(qG_cart ** 2))
6081 : : ! (q + G) . Zeff(:,idir,iatom)
6082 : : !qGZ = dot_product(qG_red, Zstar)
6083 : : ! (q + G) . dielt . (q + G)
6084 [ # # # # : 0 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
# # ]
6085 : : ! Avoid (q + G) = 0
6086 [ # # ]: 0 : if (denom < tol_denom) cycle
6087 : 0 : denom_inv = one / denom
6088 [ # # ]: 0 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6089 : 0 : fac = (four_pi / db%cryst%ucvol) * denom_inv !* qGZ
6090 : : ! Phase factor exp(-i (q+G) . tau)
6091 [ # # ]: 0 : qtau = - two_pi * dot_product(qG_red, tau_red)
6092 : 0 : phre = cos(qtau); phim = sin(qtau)
6093 : : !phre = one; phim = zero
6094 : :
6095 [ # # ]: 0 : do ii=1,3
6096 [ # # ]: 0 : do jj=1,3
6097 : 0 : v1G_lr33(ii, jj, 1, ig) = fac * phre * qG_red(ii) * qG_red(jj)
6098 : 0 : v1G_lr33(ii, jj, 2, ig) = fac * phim * qG_red(ii) * qG_red(jj)
6099 : : end do
6100 : : end do
6101 : : end do ! ig
6102 : :
6103 [ # # # # : 0 : ABI_MALLOC(workr, (2, nfft))
# # # # ]
6104 [ # # ]: 0 : do ii=1,3
6105 [ # # ]: 0 : do jj=1,3
6106 [ # # # # : 0 : v1G_lr = v1G_lr33(ii, jj, :, :)
# # ]
6107 : 0 : call fourdp(2, v1G_lr, workr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6108 : : ! Two pi comes for qpt but we should check whether the gradient wrt E-field is in gprimd or 2pi gprimd coordinates.
6109 : : ! MG: Remove two_pi factor because jump discontinuity in the real part for G != 0 are overestimated.
6110 [ # # ]: 0 : do ifft=1,nfft
6111 : : !v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) * two_pi
6112 [ # # ]: 0 : v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) ! * two_pi
6113 : : end do
6114 : : end do
6115 : : end do
6116 : :
6117 [ # # ]: 0 : ABI_FREE(workr)
6118 [ # # ]: 0 : ABI_FREE(v1G_lr33)
6119 : : end if
6120 : :
6121 : : ! Multiply by exp(i q.r)
6122 [ + + ]: 22234 : if (iphase == 1) call times_eikr(qpt, ngfft, nfft, 1, v1r_lr)
6123 : :
6124 [ - + ]: 22234 : ABI_FREE(gfft)
6125 [ - + ]: 22234 : ABI_FREE(v1G_lr)
6126 : :
6127 : 22234 : end subroutine dvdb_get_v1r_long_range
6128 : : !!***
6129 : :
6130 : : !----------------------------------------------------------------------
6131 : :
6132 : : !!****f* m_dvdb/dvdb_load_ddb
6133 : : !! NAME
6134 : : !! dvdb_load_ddb
6135 : : !!
6136 : : !! FUNCTION
6137 : : !! Load information about the Born effective charges and dielectric tensor from a DDB file
6138 : : !!
6139 : : !! TODO
6140 : : !! Use this function in eph driver
6141 : :
6142 : 0 : subroutine dvdb_load_ddb(dvdb, chneut, prtvol, comm, ddb_filepath, ddb, ddb_version)
6143 : :
6144 : : !Arguments ------------------------------------
6145 : : !scalars
6146 : : class(dvdb_t),intent(inout) :: dvdb
6147 : : integer,intent(in) :: chneut, prtvol, comm
6148 : : character(len=*),optional,intent(in) :: ddb_filepath
6149 : : type(ddb_type),optional,target,intent(in) :: ddb
6150 : : integer,optional,intent(in) :: ddb_version
6151 : : ! ddb_version is required to read the quadrupoles when the ddb object is passed instead of ddb_filepath
6152 : : ! (the header is not available in this case). Quadrupoles are not read if it is not present.
6153 : :
6154 : : !Local variables ------------------------------
6155 : : integer,parameter :: master = 0, rfmeth1 = 1, selectz0 = 0
6156 : : integer :: my_rank, iblock_dielt, iblock_dielt_zeff, iblock_quadrupoles, my_ddb_version
6157 : : logical :: free_ddb
6158 : : character(len=fnlen) :: ddb_source
6159 [ # # # # : 0 : type(crystal_t) :: cryst_ddb
# # # # #
# # # # #
# # # # ]
6160 : : type(ddb_type),pointer :: ddb_ptr
6161 : 0 : type(ddb_type),target :: this_ddb
6162 [ # # # # : 0 : type(ddb_hdr_type) :: ddb_hdr
# # # # #
# # # # #
# # # # ]
6163 : : !arrays
6164 : : real(dp) :: dielt(3,3)
6165 : 0 : real(dp),allocatable :: zeff(:,:,:), zeff_raw(:,:,:)
6166 : : ! *************************************************************************
6167 : :
6168 : 0 : my_rank = xmpi_comm_rank(comm)
6169 : :
6170 [ # # ]: 0 : if (present(ddb_filepath)) then
6171 : : ! Build ddb object from file. Will release memory before returning.
6172 [ # # ]: 0 : ABI_CHECK(.not. present(ddb), "ddb argument cannot be present when ddb_filepath is used")
6173 : 0 : call this_ddb%from_file(ddb_filepath, ddb_hdr, cryst_ddb, comm, prtvol=prtvol)
6174 : 0 : call this_ddb%set_brav(dvdb%brav)
6175 : 0 : call cryst_ddb%free()
6176 : 0 : ddb_ptr => this_ddb
6177 : 0 : free_ddb = .True.
6178 [ # # ]: 0 : ddb_source = ddb_filepath
6179 : 0 : my_ddb_version = ddb_hdr%ddb_version
6180 : : else
6181 : : ! Point input ddb, won't release memory.
6182 [ # # ]: 0 : ABI_CHECK(present(ddb), "Either ddb_filepath or ddb must be present")
6183 : 0 : free_ddb = .False.
6184 : 0 : ddb_ptr => ddb
6185 : 0 : ddb_source = "input ddb object"
6186 [ # # ]: 0 : my_ddb_version = -1; if (present(ddb_version)) my_ddb_version = ddb_version
6187 : : end if
6188 : :
6189 : : ! Get dielectric Tensor
6190 : 0 : iblock_dielt = ddb_ptr%get_dielt(rfmeth1, dielt)
6191 [ # # # # ]: 0 : dvdb%dielt = dielt
6192 : :
6193 : : ! Get Dielectric Tensor and Effective Charges
6194 : : ! (initialized to one_3D and zero if the derivatives are not available in the DDB file)
6195 [ # # # # : 0 : ABI_MALLOC(zeff, (3, 3, dvdb%natom))
# # # # #
# # # ]
6196 [ # # # # : 0 : ABI_MALLOC(zeff_raw, (3, 3, dvdb%natom))
# # # # ]
6197 : 0 : iblock_dielt_zeff = ddb_ptr%get_dielt_zeff(dvdb%cryst, rfmeth1, chneut, selectz0, dielt, zeff, zeff_raw=zeff_raw)
6198 : :
6199 [ # # ]: 0 : if (my_rank == master) then
6200 [ # # ]: 0 : if (iblock_dielt_zeff == 0) then
6201 : 0 : call wrtout(ab_out, sjoin("- Cannot find dielectric tensor and Born effective charges in DDB file:", ddb_source))
6202 : 0 : call wrtout(ab_out, "Values initialized with zeros")
6203 : : else
6204 : 0 : call wrtout(ab_out, sjoin("- Found dielectric tensor and Born effective charges in DDB file:", ddb_source))
6205 : : end if
6206 : : end if
6207 : :
6208 [ # # ]: 0 : if (iblock_dielt /= 0) then
6209 : 0 : dvdb%has_dielt = .True.
6210 [ # # # # ]: 0 : dvdb%dielt = dielt
6211 : : end if
6212 [ # # ]: 0 : if (iblock_dielt_zeff /= 0) then
6213 [ # # # # : 0 : dvdb%has_zeff = .True.; dvdb%zeff = zeff; dvdb%zeff_raw = zeff_raw
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6214 : : end if
6215 [ # # # # : 0 : if (dvdb%has_dielt .and. (dvdb%has_zeff .or. dvdb%has_quadrupoles)) then
# # ]
6216 [ # # ]: 0 : if (dvdb%add_lr == 0) then
6217 : : call wrtout([std_out, ab_out], &
6218 [ # # ]: 0 : " WARNING: dvdb_add_lr set to 0. Long-range term won't be subtracted in Fourier interpolation.")
6219 : : end if
6220 : : end if
6221 : :
6222 : : ! Read the quadrupoles
6223 [ # # ]: 0 : if (my_ddb_version /= -1) then
6224 : 0 : iblock_quadrupoles = ddb_ptr%get_quadrupoles(my_ddb_version,1,BLKTYP_d3E_xx,dvdb%qstar)
6225 [ # # ]: 0 : if (iblock_quadrupoles /=0) dvdb%has_quadrupoles = .True.
6226 : : else
6227 : 0 : ABI_WARNING("ddb_version is not available --> Quadrupoles are not read from the input ddb object")
6228 : : end if
6229 : :
6230 : : ! Same treatment as in the EPH driver: dvdb_add_lr == 2 uses the dipole part only.
6231 [ # # ]: 0 : if (dvdb%add_lr == 2) then
6232 [ # # ]: 0 : if (dvdb%has_quadrupoles) call wrtout(std_out, "dvdb_add_lr == 2 --> Quadrupoles are set to zero")
6233 : 0 : dvdb%has_quadrupoles = .False.
6234 [ # # # # : 0 : dvdb%qstar = zero
# # # # ]
6235 : : end if
6236 : :
6237 [ # # ]: 0 : if (present(ddb_filepath)) call ddb_hdr%free()
6238 : :
6239 [ # # ]: 0 : ABI_FREE(zeff)
6240 [ # # ]: 0 : ABI_FREE(zeff_raw)
6241 [ # # ]: 0 : if (free_ddb) call ddb_ptr%free()
6242 : :
6243 [ # # # # : 0 : end subroutine dvdb_load_ddb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6244 : : !!***
6245 : :
6246 : : !!****f* m_dvdb/dvdb_load_efield
6247 : : !! NAME
6248 : : !! dvdb_load_efield
6249 : : !!
6250 : : !! FUNCTION
6251 : : !! Load first order derivatives wrt the electric file from files
6252 : : !!
6253 : : !! INPUTS
6254 : : !! pot_paths=List of strings with paths to POT1 files.
6255 : : !! comm=MPI communicator.
6256 : :
6257 : 0 : subroutine dvdb_load_efield(dvdb, pot_paths, comm)
6258 : :
6259 : : !Arguments ------------------------------------
6260 : : !scalars
6261 : : class(dvdb_t),intent(inout) :: dvdb
6262 : : integer,intent(in) :: comm
6263 : : character(len=*),intent(in) :: pot_paths(3)
6264 : :
6265 : : !Local variables-------------------------------
6266 : : !scalars
6267 : : integer,parameter :: pawread0 = 0, cplex1 = 1
6268 : : integer :: ii, idir, ipert, nfft
6269 : 0 : type(hdr_type) :: hdr
6270 : : !arrays
6271 : 0 : real(dp),allocatable :: v1e_red(:,:,:)
6272 : 0 : type(pawrhoij_type),allocatable :: pawrhoij(:)
6273 : : ! *************************************************************************
6274 : :
6275 [ # # # # : 0 : ABI_CHECK(all(dvdb%ngfft /= -1), "dbvd%ngfft must be defined!")
# # ]
6276 : :
6277 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6278 [ # # # # : 0 : ABI_CALLOC(v1e_red, (nfft, dvdb%nspden, 3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
6279 : :
6280 [ # # ]: 0 : do ii=1,3
6281 : : ! Read DFPT potentials due to E-field.
6282 : : ! TODO: Should implement symmetries so that only the irred pots are needed.
6283 : 0 : call wrtout(std_out, sjoin("Loading Efield DFPT potential from:", pot_paths(ii)))
6284 : : call read_rhor(pot_paths(ii), cplex1, dvdb%nspden, nfft, dvdb%ngfft, pawread0, &
6285 : 0 : dvdb%mpi_enreg, v1e_red(:,:,ii), hdr, pawrhoij, comm, allow_interp=.True., want_varname="first_order_potential")
6286 : :
6287 : : ! Consistency check: expecting E-field perturbation.
6288 : 0 : idir = mod(hdr%pertcase - 1, 3) + 1; ipert = (hdr%pertcase - idir) / 3 + 1
6289 [ # # # # : 0 : ABI_CHECK(all(abs(hdr%qptn) < tol12), sjoin("Expecting Gamma point in E-field pert, got qpt:", ktoa(hdr%qptn)))
# # ]
6290 [ # # ]: 0 : ABI_CHECK(ipert == hdr%natom + 2, sjoin("Expecting E-field perturbation, got ipert:", itoa(ipert)))
6291 [ # # ]: 0 : ABI_CHECK(idir == ii, sjoin("Expecting E-field perturbation along idir:", itoa(ii), " got idir:", itoa(idir)))
6292 : 0 : call hdr%free()
6293 : : end do
6294 : :
6295 : : ! Transfer data.
6296 [ # # # # : 0 : ABI_MALLOC(dvdb%v1r_efield, (nfft, 3, dvdb%nspden))
# # # # #
# # # # #
# # # # ]
6297 [ # # ]: 0 : do ii=1,3
6298 [ # # # # ]: 0 : dvdb%v1r_efield(:,ii,:) = v1e_red(:,:,ii)
6299 : : end do
6300 [ # # ]: 0 : ABI_FREE(v1e_red)
6301 : :
6302 : 0 : dvdb%has_efield = .True.
6303 : :
6304 [ # # # # : 0 : end subroutine dvdb_load_efield
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6305 : : !!***
6306 : :
6307 : : !----------------------------------------------------------------------
6308 : :
6309 : : !!****f* m_dvdb/dvdb_interpolate_and_write
6310 : : !! NAME
6311 : : !! dvdb_interpolate_and_write
6312 : : !!
6313 : : !! FUNCTION
6314 : : !! Interpolate the phonon potential onto a fine q-point grid
6315 : : !! and write the data in a new DVDB file.
6316 : : !!
6317 : : !! INPUTS
6318 : : !!
6319 : : !! OUTPUT
6320 : : !!
6321 : : !! SOURCE
6322 : :
6323 : 8 : subroutine dvdb_interpolate_and_write(dvdb, dtset, new_dvdb_fname, ngfft, ngfftf, cryst, &
6324 [ - + - - : 8 : ngqpt_coarse, nqshift_coarse, qshift_coarse, comm, custom_qpt)
- - ]
6325 : :
6326 : : !Arguments ------------------------------------
6327 : : !scalars
6328 : : integer,intent(in) :: nqshift_coarse, comm
6329 : : character(len=*),intent(in) :: new_dvdb_fname
6330 : : type(crystal_t),intent(in) :: cryst
6331 : : class(dvdb_t),intent(inout) :: dvdb
6332 : : type(dataset_type),intent(in) :: dtset
6333 : : !arrays
6334 : : integer,intent(in) :: ngfft(18), ngfftf(18)
6335 : : integer,intent(in) :: ngqpt_coarse(3)
6336 : : real(dp),intent(in) :: qshift_coarse(3,nqshift_coarse)
6337 : : real(dp),optional,intent(in) :: custom_qpt(:,:)
6338 : :
6339 : : !Local variables ------------------------------
6340 : : !scalars
6341 : : integer,parameter :: master=0, fform_pot=111
6342 : : integer :: my_rank,nproc,idir,ipert,iat,ipc,ispden, ierr
6343 : : integer :: cplex,db_iqpt,natom,natom3,npc,trev_q,nspden
6344 : : integer :: nqbz, nqibz, iq, ifft, nqbz_coarse
6345 : : integer :: nperts_read, nperts_interpolate, nperts
6346 : : integer :: nqpt_read, nqpt_interpolate, qptopt
6347 : : integer :: nfft,nfftf, dimv1, ount, unt, fform, ncid, ncerr
6348 : : logical :: use_netcdf
6349 : : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
6350 : : character(len=500) :: msg
6351 : : character(len=fnlen) :: tmp_fname
6352 : 8 : type(hdr_type) :: hdr_ref
6353 : : !arrays
6354 : 16 : integer :: qptrlatt(3,3), rfdir(3), symq(4,2,cryst%nsym)
6355 : 8 : integer,allocatable :: pinfo(:,:),rfpert(:),pertsy(:,:,:),iq_read(:),this_pertsy(:,:)
6356 : : real(dp) :: qpt(3), rhog1_g0(2)
6357 : 8 : real(dp),allocatable :: v1scf(:,:,:), v1scf_rpt(:,:,:,:),v1(:)
6358 : 8 : real(dp),allocatable :: wtq(:),qibz(:,:),qbz(:,:),q_interp(:,:),q_read(:,:)
6359 : : !************************************************************************
6360 : :
6361 : 8 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6362 : :
6363 : 8 : write(msg, '(2a)') " Interpolation of the electron-phonon coupling potential", ch10
6364 : 8 : call wrtout(ab_out, msg, do_flush=.True.); call wrtout(std_out, msg, do_flush=.True.)
6365 : :
6366 : 8 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6367 : :
6368 : : ! qptopt is also used to reconstruct the stars of the coarse q-mesh in dvdb_get_v1scf_rpt.
6369 [ + + ]: 8 : qptopt = 1; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
6370 : :
6371 [ + + - + ]: 8 : if (dtset%eph_task == 5 .or. present(custom_qpt)) then
6372 [ + - ]: 7 : msg = sjoin(" From coarse q-mesh:", ltoa(ngqpt_coarse), "to:", ltoa(dtset%eph_ngqpt_fine))
6373 [ + + ]: 21 : call wrtout([std_out, ab_out], msg)
6374 : : ! Setup fine q-point grid in the IBZ
6375 : : ! Generate the list of irreducible q-points in the grid
6376 : 7 : qptrlatt = 0
6377 : 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)
6378 : 7 : call wrtout(std_out, sjoin(" Generating q-IBZ for DVDB with qptopt:", itoa(qptopt)))
6379 [ - + - + : 7 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
- + ]
6380 : :
6381 [ + - ]: 1 : else if (dtset%eph_task == -5) then
6382 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
6383 [ + + ]: 3 : call wrtout([std_out, ab_out], msg)
6384 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "ph_nqpath must be specified when eph_task == -5")
6385 : 1 : nqibz = dtset%ph_nqpath
6386 [ - + + - : 3 : ABI_MALLOC(qibz, (3, nqibz))
+ - + - -
+ - + -
+ ]
6387 [ + - - + : 22 : qibz = dtset%ph_qpath(:, 1:nqibz)
- - + + +
+ ]
6388 [ - + + - : 8 : ABI_CALLOC(wtq, (nqibz))
+ - + - -
+ - + - +
+ + ]
6389 : 1 : nqbz = nqibz
6390 [ - + + - : 2 : ABI_MALLOC(qbz, (3, nqbz))
- + - + -
+ ]
6391 [ + - + - : 22 : qbz = qibz
- + - - +
+ + + ]
6392 : :
6393 : : else
6394 : 0 : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
6395 : : end if
6396 : :
6397 [ - + ]: 8 : if (present(custom_qpt)) then
6398 [ # # ]: 0 : ABI_SFREE(qibz)
6399 [ # # ]: 0 : ABI_SFREE(wtq)
6400 [ # # ]: 0 : ABI_SFREE(qbz)
6401 : 0 : nqibz = size(custom_qpt,dim=2)
6402 [ # # # # : 0 : ABI_MALLOC(qibz, (3, nqibz))
# # # # #
# # # #
# ]
6403 [ # # # # : 0 : qibz = custom_qpt
# # # # #
# # # ]
6404 [ # # # # : 0 : ABI_CALLOC(wtq, (nqibz))
# # # # #
# # # # #
# # ]
6405 : 0 : nqbz = nqibz
6406 [ # # # # : 0 : ABI_MALLOC(qbz, (3, nqbz))
# # # # #
# ]
6407 [ # # # # : 0 : qbz = qibz
# # # # #
# # # ]
6408 : : end if
6409 : :
6410 [ + + ]: 32 : nfft = product(ngfft(1:3)); nfftf = product(ngfftf(1:3))
6411 : :
6412 : : ! check that ngqpt_coarse is in DVDB.
6413 [ + + ]: 32 : nqbz_coarse = product(ngqpt_coarse) * nqshift_coarse
6414 : :
6415 : : ! ==========================================
6416 : : ! Prepare the header to write the potentials
6417 : : ! ==========================================
6418 : :
6419 : : ! Read the first header
6420 [ + - ]: 8 : if (my_rank == master) then
6421 [ - + ]: 8 : if (open_file(dvdb%path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
6422 : 0 : ABI_ERROR(msg)
6423 : : end if
6424 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%version
6425 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%numv1
6426 : :
6427 : 8 : call hdr_ref%fort_read(unt, fform)
6428 [ - + ]: 8 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
6429 : 0 : ABI_ERROR(sjoin("While reading:", dvdb%path, ch10, msg))
6430 : : end if
6431 : 8 : close(unt)
6432 : : end if
6433 : :
6434 : : ! Reset the symmetries of the header
6435 : : ! One might have disable the symmetries in the response function calculation
6436 : : ! that produced the initial set of potentials present in the DVDB.
6437 : : ! This is because the symmetry features are not used in all parts
6438 : : ! of the response function driver.
6439 : : !write(std_out,*)hdr_ref%nsym, cryst%nsym
6440 : : !ABI_CHECK(hdr_ref%nsym == cryst%nsym, "Diff nsym")
6441 [ + - ]: 8 : ABI_SFREE(hdr_ref%symrel)
6442 [ + - ]: 8 : ABI_SFREE(hdr_ref%tnons)
6443 [ + - ]: 8 : ABI_SFREE(hdr_ref%symafm)
6444 : 8 : hdr_ref%nsym = cryst%nsym
6445 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symrel, (3,3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6446 [ - + + - : 24 : ABI_MALLOC(hdr_ref%tnons, (3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6447 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symafm, (hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6448 : :
6449 [ + + + + : 5000 : hdr_ref%symrel(:,:,:) = cryst%symrel(:,:,:)
+ + ]
6450 [ + + + + ]: 1544 : hdr_ref%tnons(:,:) = cryst%tnons(:,:)
6451 [ + + ]: 392 : hdr_ref%symafm(:) = cryst%symafm(:)
6452 [ + + ]: 32 : hdr_ref%ngfft = ngfftf(1:3)
6453 : :
6454 : : ! =======================================
6455 : : ! Open DVDB and copy important dimensions
6456 : : ! =======================================
6457 : :
6458 : 8 : call dvdb%open_read(ngfftf, xmpi_comm_self)
6459 : :
6460 : : ! Besides perturbations with same q-points won't be contiguous on file --> IO is gonna be inefficient.
6461 [ + + ]: 16 : call dvdb%print([std_out], "", dtset%prtvol)
6462 : :
6463 : 8 : natom = cryst%natom
6464 : 8 : natom3 = 3 * natom
6465 : 8 : nspden = dvdb%nspden
6466 : :
6467 : : ! ==================================================
6468 : : ! Sort the q-points to read and those to interpolate
6469 : : ! and find the irreducible perturbations
6470 : : ! ==================================================
6471 [ - + + - : 24 : ABI_MALLOC(iq_read, (nqibz))
+ - + - -
+ - + ]
6472 [ - + + - : 24 : ABI_MALLOC(q_read, (3,nqibz))
+ - + - -
+ - + ]
6473 [ - + + - : 16 : ABI_MALLOC(q_interp, (3,nqibz))
- + - + ]
6474 [ - + + - : 32 : ABI_MALLOC(pertsy, (nqibz,3,dvdb%mpert))
- + + - +
- + - - +
- + ]
6475 [ - + + - : 24 : ABI_MALLOC(this_pertsy, (3,dvdb%mpert))
+ - + - -
+ - + ]
6476 [ - + + - : 24 : ABI_MALLOC(rfpert, (dvdb%mpert))
+ - + - -
+ - + ]
6477 [ + - - + : 24 : ABI_MALLOC(pinfo, (3,3*dvdb%mpert))
+ - + - +
- - + -
+ ]
6478 [ + + + + : 110 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
6479 : :
6480 [ + + + + : 2645 : pertsy = 0
+ + ]
6481 : 8 : nqpt_read = 0
6482 : 8 : nperts_read = 0
6483 : 8 : nqpt_interpolate = 0
6484 : 8 : nperts_interpolate = 0
6485 : :
6486 [ + + ]: 111 : do iq=1,nqibz
6487 [ + + ]: 412 : qpt = qibz(:,iq)
6488 : :
6489 : : ! Find the index of the q-point in the DVDB.
6490 : 103 : db_iqpt = dvdb%findq(qpt)
6491 : : !if (db_iqpt /= 1) db_iqpt = -1
6492 : :
6493 [ + + ]: 111 : if (db_iqpt /= -1) then
6494 [ + + ]: 29 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt)," found in DVDB with index ",itoa(db_iqpt)))
6495 : 29 : nqpt_read = nqpt_read + 1
6496 [ + + ]: 116 : q_read(:,nqpt_read) = qpt(:)
6497 : 29 : iq_read(nqpt_read) = db_iqpt
6498 : :
6499 : : ! Count the perturbations
6500 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6501 [ + + ]: 85 : do ipc=1,npc
6502 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6503 [ + - ]: 85 : if (iat .le. natom) nperts_read = nperts_read + 1
6504 : : end do
6505 : :
6506 : : else
6507 [ + + ]: 74 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt), "not found in DVDB. Will interpolate."))
6508 : 74 : nqpt_interpolate = nqpt_interpolate + 1
6509 [ + + ]: 296 : q_interp(:,nqpt_interpolate) = qpt(:)
6510 : :
6511 : : ! Examine the symmetries of the q wavevector
6512 : 74 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
6513 : :
6514 : : ! Find the list of irreducible perturbations for this q-point.
6515 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
6516 : 74 : this_pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
6517 [ + + + + ]: 2358 : pertsy(nqpt_interpolate,:,:) = this_pertsy
6518 : : !pertsy = 1
6519 : :
6520 [ + + ]: 201 : do iat=1,natom
6521 [ + + ]: 582 : do idir=1,3
6522 : 381 : ipert = (iat-1) * 3 + idir
6523 [ + + ]: 508 : if (pertsy(nqpt_interpolate,idir,iat) == 1) nperts_interpolate = nperts_interpolate + 1
6524 : : end do
6525 : : end do
6526 : :
6527 : : end if
6528 : : end do
6529 : :
6530 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points found in input DVDB:", itoa(nqpt_read)))
6531 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points requiring Fourier interpolation", itoa(nqpt_interpolate)))
6532 : :
6533 : : ! =================================================
6534 : : ! Open the new DVDB file and write preliminary info
6535 : : ! =================================================
6536 : 8 : nperts = nperts_read + nperts_interpolate
6537 : :
6538 [ + - ]: 8 : if (my_rank == master) then
6539 [ - + ]: 8 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6540 : 0 : ABI_ERROR(msg)
6541 : : end if
6542 [ + - ]: 8 : write(ount, err=10, iomsg=msg) dvdb_last_version
6543 [ + - ]: 8 : write(ount, err=10, iomsg=msg) nperts
6544 : : end if
6545 : :
6546 : : ! =================================================================
6547 : : ! Master reads all available perturbations and copy in the new DVDB
6548 : : ! =================================================================
6549 : :
6550 : 0 : rhog1_g0 = zero
6551 : :
6552 : : if (my_rank == master) then
6553 [ + + ]: 37 : do iq=1,nqpt_read
6554 [ + + ]: 116 : qpt = q_read(:,iq)
6555 : 29 : db_iqpt = iq_read(iq)
6556 : :
6557 : : ! Read each irreducible perturbation potentials
6558 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6559 [ - + ]: 29 : ABI_CHECK(npc /= 0, "npc == 0!")
6560 : :
6561 : : ! These arrays depend on cplex.
6562 [ - + + - : 145 : ABI_MALLOC(v1scf, (cplex, nfftf, nspden))
- + + - -
+ + - + -
+ - - + -
+ - + ]
6563 [ - + + - : 87 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6564 : :
6565 [ + + ]: 85 : do ipc=1,npc
6566 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6567 [ - + ]: 56 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfftf, ngfftf, v1scf, msg) /= 0) then
6568 : 0 : ABI_ERROR(msg)
6569 : : end if
6570 : :
6571 : : ! Write header
6572 [ + + ]: 224 : hdr_ref%qptn = qpt
6573 : 56 : hdr_ref%pertcase = ipert
6574 : 56 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6575 [ - + ]: 56 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr /= 0")
6576 : :
6577 [ + + ]: 112 : do ispden=1,nspden
6578 [ + + ]: 112 : v1 = reshape(v1scf(:,:,ispden), (/cplex*nfftf/))
6579 [ + - ]: 112 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6580 : : end do
6581 [ + - ]: 85 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6582 : : end do
6583 : :
6584 [ - + ]: 29 : ABI_FREE(v1scf)
6585 [ - + ]: 37 : ABI_FREE(v1)
6586 : : end do
6587 : : end if ! master
6588 : :
6589 : 8 : call xmpi_barrier(comm)
6590 : :
6591 : : ! ================================================================
6592 : : ! Interpolate the potential for q-points not in the original DVDB
6593 : : ! ================================================================
6594 : :
6595 : 8 : dvdb%my_nrpt = nqbz_coarse
6596 [ - + + - : 40 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2, dvdb%my_nrpt, nfftf, dvdb%nspden), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
6597 : :
6598 : 8 : cplex = 2
6599 [ - + + - : 32 : ABI_MALLOC(v1scf, (cplex,nfftf,nspden))
- + + - +
- + - - +
- + - + ]
6600 [ - + + - : 24 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6601 : :
6602 : : use_netcdf = .False.
6603 : : ! Create temporary netcdf file used to write Fortran file with contiguous perturbations.
6604 : 8 : use_netcdf = .True.
6605 [ + - ]: 8 : if (my_rank == master) then
6606 [ + - ]: 8 : tmp_fname = strcat(new_dvdb_fname, "_TEMPORARY_TRANSFER_FILE.nc")
6607 : 8 : dimv1 = cplex * nfftf
6608 [ - + ]: 8 : NCF_CHECK(nctk_open_create(ncid, tmp_fname, xmpi_comm_self))
6609 : : ncerr = nctk_def_dims(ncid, [&
6610 : : nctkdim_t("dimv1", dimv1), nctkdim_t("nspden", nspden), &
6611 : : nctkdim_t("natom", natom), nctkdim_t("nqpt_intp", nqpt_interpolate), &
6612 : : nctkdim_t("nrpt", dvdb%my_nrpt), nctkdim_t("nfft", nfftf), nctkdim_t("natom3", natom * 3) &
6613 [ + + ]: 64 : ])
6614 [ - + ]: 8 : NCF_CHECK(ncerr)
6615 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1", "dp", "dimv1, nspden, three, natom, nqpt_intp")))
6616 : : !NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1scf_rpt", "dp", "two, nrpt, nfft, nspden, natom3")))
6617 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(ncid))
6618 : : end if
6619 : :
6620 [ + + ]: 23 : do iat=1,natom
6621 [ + + ]: 68 : do idir=1,3
6622 : 45 : ipert = (iat-1) * 3 + idir
6623 : :
6624 : : ! Entry set to -1 for perturbations that can be found from basis perturbations.
6625 [ + + + + ]: 576 : if (sum(pertsy(:,idir,iat)) == -nqpt_interpolate) cycle
6626 : :
6627 : 31 : call wrtout(std_out, sjoin(" Interpolating perturbation iat, idir = ",itoa(iat), itoa(idir)), do_flush=.True.)
6628 : 31 : call cwtime(cpu, wall, gflops, "start")
6629 : :
6630 : : ! TODO: This part is slow.
6631 : : ! Compute phonon potential in real space lattice representation.
6632 : : call dvdb_get_v1scf_rpt(dvdb, cryst, ngqpt_coarse, nqshift_coarse, &
6633 : : qshift_coarse, nfftf, ngfftf, &
6634 : 31 : dvdb%my_nrpt, dvdb%nspden, ipert, v1scf_rpt, comm, qptopt=qptopt)
6635 : :
6636 : : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1scf_rpt"), v1scf_rpt, start=[1,1,1,1,ipert]))
6637 : 31 : call cwtime_report(" v1scf_rpt built", cpu, wall, gflops)
6638 : :
6639 [ + + ]: 348 : do iq=1,nqpt_interpolate
6640 [ + + ]: 317 : if (pertsy(iq,idir,iat) == -1) cycle
6641 [ + + ]: 976 : qpt = q_interp(:,iq)
6642 : :
6643 : : ! Interpolate the phonon potential
6644 : : call dvdb_get_v1scf_qpt(dvdb, cryst, qpt, nfftf, ngfftf, dvdb%my_nrpt, &
6645 : 244 : dvdb%nspden, ipert, v1scf_rpt, v1scf, comm)
6646 : :
6647 : : !call wrtout(std_out, sjoin("Writing q-point", itoa(iq)))
6648 [ + - ]: 275 : if (my_rank == master) then
6649 : : if (use_netcdf) then
6650 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6651 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6652 [ - + ]: 244 : NCF_CHECK(ncerr)
6653 : : else
6654 : : ! Master writes the file (change also qpt and ipert in hdr%)
6655 : : hdr_ref%qptn = qpt
6656 : : hdr_ref%pertcase = ipert
6657 : : call hdr_ref%fort_write(ount, fform_pot, ierr)
6658 : : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr /= 0")
6659 : :
6660 : : do ispden=1,nspden
6661 : : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6662 : : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6663 : : end do
6664 : : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6665 : : end if
6666 : : end if
6667 : : end do
6668 : :
6669 : 31 : call cwtime_report(" q-points interpolated and written to new DVDB file.", cpu, wall, gflops)
6670 [ - + ]: 122 : ABI_FREE(dvdb%my_rpt)
6671 : : end do
6672 : : end do
6673 : :
6674 [ + - ]: 8 : if (use_netcdf .and. my_rank == master) then
6675 [ + + ]: 82 : do iq=1,nqpt_interpolate
6676 [ + + ]: 296 : qpt = q_interp(:,iq)
6677 [ + + ]: 209 : do iat=1,natom
6678 [ + + ]: 582 : do idir=1,3
6679 [ + + ]: 381 : if (pertsy(iq,idir,iat) == -1) cycle
6680 : 244 : ipert = (iat-1) * 3 + idir
6681 [ + + ]: 976 : hdr_ref%qptn = qpt
6682 : 244 : hdr_ref%pertcase = ipert
6683 : 244 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6684 : : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6685 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6686 [ - + ]: 244 : NCF_CHECK(ncerr)
6687 [ + + ]: 488 : do ispden=1,nspden
6688 [ + + ]: 488 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6689 [ + - ]: 488 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6690 : : end do
6691 [ + - ]: 371 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6692 : : end do
6693 : : end do
6694 : : end do
6695 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
6696 : 8 : call delete_file(tmp_fname, ierr)
6697 : : end if
6698 : :
6699 : 8 : if (my_rank == master) close(ount)
6700 : :
6701 : : ! Free memory
6702 [ - + ]: 8 : ABI_FREE(v1scf)
6703 [ - + ]: 8 : ABI_FREE(v1)
6704 [ - + ]: 8 : ABI_FREE(v1scf_rpt)
6705 [ - + ]: 8 : ABI_FREE(qbz)
6706 [ - + ]: 8 : ABI_FREE(qibz)
6707 [ - + ]: 8 : ABI_FREE(q_interp)
6708 [ - + ]: 8 : ABI_FREE(q_read)
6709 [ - + ]: 8 : ABI_FREE(wtq)
6710 [ - + ]: 8 : ABI_FREE(iq_read)
6711 [ - + ]: 8 : ABI_FREE(pertsy)
6712 [ - + ]: 8 : ABI_FREE(this_pertsy)
6713 [ - + ]: 8 : ABI_FREE(rfpert)
6714 [ - + ]: 8 : ABI_FREE(pinfo)
6715 : :
6716 : 8 : call hdr_ref%free()
6717 : :
6718 : 8 : write(msg, '(2a)') "Interpolation of the electron-phonon coupling potential completed", ch10
6719 [ + + ]: 24 : call wrtout([std_out, ab_out], msg, do_flush=.True.)
6720 : :
6721 : 8 : call cwtime_report(" Overall time:", cpu_all, wall_all, gflops_all)
6722 : :
6723 : 8 : return
6724 : :
6725 : : ! Handle Fortran IO error
6726 : : 10 continue
6727 : 0 : ABI_ERROR(msg)
6728 : :
6729 [ - + - + : 24 : end subroutine dvdb_interpolate_and_write
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - ]
6730 : : !!***
6731 : :
6732 : : !----------------------------------------------------------------------
6733 : :
6734 : : !!****f* m_dvdb/dvdb_qdownsample
6735 : : !! NAME
6736 : : !! dvdb_qdownsample
6737 : : !!
6738 : : !! FUNCTION
6739 : : !! Downsample the q-mesh. Produce new DVDB file
6740 : : !!
6741 : : !! INPUTS
6742 : : !! new_dvdb_fname=Path of output DVDB
6743 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
6744 : : !! ngqpt(3)=Division of coarse Q-mesh
6745 : : !! comm=MPI communicator.
6746 : : !!
6747 : : !! OUTPUT
6748 : : !! Only writing
6749 : : !!
6750 : : !! SOURCE
6751 : :
6752 : 0 : subroutine dvdb_qdownsample(dvdb, new_dvdb_fname, qptopt, ngqpt, comm)
6753 : :
6754 : : !Arguments ------------------------------------
6755 : : !scalars
6756 : : integer,intent(in) :: comm
6757 : : class(dvdb_t),intent(inout) :: dvdb
6758 : : character(len=*),intent(in) :: new_dvdb_fname
6759 : : !arrays
6760 : : integer,intent(in) :: qptopt, ngqpt(3)
6761 : :
6762 : : !Local variables ------------------------------
6763 : : !scalars
6764 : : integer,parameter :: master=0, fform_pot=111
6765 : : integer :: ierr,my_rank,nproc,idir,ipert,iat,ipc,ispden
6766 : : integer :: cplex, db_iqpt, npc, nqbz, nqibz, iq, ifft, nperts_read, nfft, ount
6767 : : character(len=500) :: msg
6768 : : !arrays
6769 : : integer :: qptrlatt(3,3)
6770 : 0 : integer,allocatable :: iq_read(:), pinfo(:,:)
6771 : : real(dp) :: rhog1_g0(2)
6772 : 0 : real(dp),allocatable :: v1scf(:,:,:), v1(:), wtq(:), qibz(:,:), qbz(:,:)
6773 : : !************************************************************************
6774 : :
6775 : 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6776 [ # # ]: 0 : if (my_rank /= master) goto 20
6777 : :
6778 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6779 : :
6780 : : ! =======================
6781 : : ! Setup fine q-point grid
6782 : : ! =======================
6783 : : ! Generate the list of irreducible q-points in the coarse grid
6784 : 0 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
6785 : 0 : call kpts_ibz_from_kptrlatt(dvdb%cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
6786 : :
6787 : : ! =======================================
6788 : : ! Open DVDB and copy important dimensions
6789 : : ! =======================================
6790 : :
6791 [ # # # # : 0 : ABI_MALLOC(iq_read, (nqibz))
# # # # #
# # # ]
6792 [ # # # # : 0 : ABI_MALLOC(pinfo, (3, 3*dvdb%mpert))
# # # # #
# # # #
# ]
6793 : 0 : nperts_read = 0
6794 : :
6795 [ # # ]: 0 : do iq=1,nqibz
6796 : : ! Find the index of the q-point in the DVDB.
6797 : 0 : db_iqpt = dvdb%findq(qibz(:, iq))
6798 [ # # ]: 0 : ABI_CHECK(db_iqpt /= -1, sjoin("Q-point:", ktoa(qibz(:, iq)), "not found in DVDB!"))
6799 : 0 : iq_read(iq) = db_iqpt
6800 : :
6801 : : ! Count the number of perturbations.
6802 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6803 [ # # ]: 0 : do ipc=1,npc
6804 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6805 [ # # ]: 0 : if (iat <= dvdb%cryst%natom) nperts_read = nperts_read + 1
6806 : : end do
6807 : : end do
6808 : :
6809 : : ! =================================================
6810 : : ! Open the new DVDB file and write preliminary info
6811 : : ! =================================================
6812 : : !nperts = nperts_read + nperts_interpolate
6813 [ # # ]: 0 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6814 : 0 : ABI_ERROR(msg)
6815 : : end if
6816 [ # # ]: 0 : write(ount, err=10, iomsg=msg) dvdb_last_version
6817 [ # # ]: 0 : write(ount, err=10, iomsg=msg) nperts_read
6818 : :
6819 : : ! Read all perturbations on the coarse Q-mesh and write them to the new DVDB
6820 : 0 : rhog1_g0 = zero
6821 : :
6822 [ # # ]: 0 : do iq=1,nqibz
6823 : 0 : db_iqpt = iq_read(iq)
6824 : :
6825 : : ! Read each irreducible perturbation potentials
6826 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6827 [ # # ]: 0 : ABI_CHECK(npc /= 0, "npc == 0!")
6828 : :
6829 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex, nfft, dvdb%nspden))
# # # # #
# # # # #
# # # # #
# ]
6830 [ # # # # : 0 : ABI_MALLOC(v1, (cplex*nfft))
# # # # #
# # # ]
6831 : :
6832 [ # # ]: 0 : do ipc=1,npc
6833 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6834 [ # # ]: 0 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfft, dvdb%ngfft, v1scf, msg) /= 0) then
6835 : 0 : ABI_ERROR(msg)
6836 : : end if
6837 : :
6838 : : ! Change the header.
6839 [ # # ]: 0 : dvdb%hdr_ref%qptn = qibz(:, iq)
6840 : 0 : dvdb%hdr_ref%pertcase = ipert
6841 : :
6842 : : ! Write header
6843 : 0 : call dvdb%hdr_ref%fort_write(ount, fform_pot, ierr)
6844 [ # # ]: 0 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr /= 0")
6845 : :
6846 [ # # ]: 0 : do ispden=1,dvdb%nspden
6847 [ # # ]: 0 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfft])
6848 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
6849 : : end do
6850 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6851 : : end do
6852 : :
6853 [ # # ]: 0 : ABI_FREE(v1scf)
6854 [ # # ]: 0 : ABI_FREE(v1)
6855 : : end do
6856 : :
6857 : 0 : close(ount)
6858 : :
6859 : : ! Free memory
6860 [ # # ]: 0 : ABI_FREE(qbz)
6861 [ # # ]: 0 : ABI_FREE(qibz)
6862 [ # # ]: 0 : ABI_FREE(wtq)
6863 [ # # ]: 0 : ABI_FREE(iq_read)
6864 [ # # ]: 0 : ABI_FREE(pinfo)
6865 : :
6866 : 0 : write(msg, '(2a)') " Downsampling of the e-ph coupling potential completed", ch10
6867 : 0 : call wrtout(std_out, msg, do_flush=.True.)
6868 : :
6869 : : 20 continue
6870 : 0 : call xmpi_barrier(comm)
6871 : :
6872 : 0 : return
6873 : :
6874 : : ! Handle Fortran IO error
6875 : : 10 continue
6876 : 0 : ABI_ERROR(msg)
6877 : :
6878 [ # # # # : 0 : end subroutine dvdb_qdownsample
# # # # #
# # # #
# ]
6879 : : !!***
6880 : :
6881 [ - + - - : 38966 : end module m_dvdb
+ + - + +
- - + - +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6882 : : !!***
|
