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, get_diag
51 : : use m_matrix, only : mati3inv
52 : : use m_symtk, only : littlegroup_q
53 : : use m_geometry, only : littlegroup_pert, irreducible_set_pert, xcart2xred
54 : : use m_ifc_supercell, only : ifc_supercell_type
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 : : kptrlatt_merge_shifts
64 : : use m_spacepar, only : symrhg, setsym
65 : : use m_fourier_interpol,only : fourier_interpol_seq
66 : : use m_pawrhoij, only : pawrhoij_type
67 : : use m_dfpt_mkvxc, only : dfpt_mkvxc
68 : :
69 : : implicit none
70 : :
71 : : private
72 : : !!***
73 : :
74 : : ! Version 1: header + vscf1(r)
75 : : ! Version 2: header + vscf1(r) + record with rhog1(G=0)
76 : : integer,public,parameter :: dvdb_last_version = 2
77 : :
78 : : integer,private,parameter :: DVDB_NOMODE = 0
79 : : integer,private,parameter :: DVDB_READMODE = 1
80 : : integer,private,parameter :: DVDB_WRITEMODE = 2
81 : :
82 : : !----------------------------------------------------------------------
83 : :
84 : : !!****t* m_dvdb/dvdb_t
85 : : !! NAME
86 : : !! dvdb_t
87 : : !!
88 : : !! FUNCTION
89 : : !! Database of DFPT results. The database contains `numv1` perturbations
90 : : !! and the corresponding first order local potentials in real space on the FFT mesh.
91 : : !! Provides methods to Fourier interpolate the potentials including the
92 : : !! treatment of long-range behaviour in the FT interpolation in polar semiconductors.
93 : : !! Note that one can have different FFT meshes for the different perturbations.
94 : : !!
95 : : !! NOTES
96 : : !! natom, nspden, nspinor, and usepaw are global variables in the sense that it is not possible to add
97 : : !! new entries to the database if these dimensions differ from the global ones.
98 : : !!
99 : : !! SOURCE
100 : :
101 : : type,public :: dvdb_t
102 : :
103 : : integer :: fh
104 : : ! file handle
105 : : ! Fortran unit number if iomode==IO_MODE_FORTRAN
106 : : ! MPI file handler if iomode==IO_MODE_MPI
107 : :
108 : : integer :: fform
109 : : ! File format
110 : :
111 : : integer :: comm
112 : : ! Global MPI communicator used for IO.
113 : :
114 : : integer :: gpu_option = 0
115 : : ! Input variable
116 : :
117 : : integer :: comm_rpt = xmpi_comm_self
118 : : ! MPI communicator used to distributed R-points.
119 : :
120 : : integer :: nprocs_rpt = 1
121 : : ! Number of cpus for parallelism over R-points.
122 : :
123 : : integer :: me_rpt = 0
124 : : ! My rank in comm_rpt.
125 : :
126 : : integer :: comm_pert = xmpi_comm_self
127 : : ! MPI communicator for parallelism over atomic perturbations.
128 : :
129 : : integer :: nprocs_pert = 1
130 : : ! Number of cpus for parallelism over atomic perturbations.
131 : :
132 : : integer :: me_pert = 0
133 : : ! My rank in comm over atomic perturbations.
134 : :
135 : : integer :: my_npert
136 : : ! Number of atomic perturbations or phonon modes treated by this MPI rank
137 : :
138 : : integer,allocatable :: my_pinfo(:,:)
139 : : ! my_pinfo(3, my_npert)
140 : : ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
141 : : ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
142 : : ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
143 : :
144 : : integer,allocatable :: pert_table(:,:)
145 : : ! pert_table(2, natom3)
146 : : ! pert_table(1, npert): rank of the processor treating this atomic perturbation.
147 : : ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
148 : :
149 : : integer :: version
150 : : ! File format version read from file.
151 : :
152 : : integer :: iomode = IO_MODE_FORTRAN
153 : : ! Method used to access the DVDB file:
154 : : ! IO_MODE_FORTRAN for usual Fortran IO routines
155 : : ! IO_MODE_MPI if MPI/IO routines.
156 : :
157 : : integer :: rw_mode = DVDB_NOMODE
158 : : ! (Read|Write) mode
159 : :
160 : : integer :: current_fpos
161 : : ! The current position of the file pointer used for sequential access with Fortran-IO
162 : :
163 : : integer :: numv1
164 : : ! Number of v1 potentials present in file.
165 : :
166 : : integer :: nqpt
167 : : ! Number of q-points (usually the IBZ)
168 : :
169 : : integer :: natom
170 : : ! Number of atoms
171 : :
172 : : integer :: natom3
173 : : ! 3 * natom
174 : :
175 : : integer :: nspden
176 : : ! Number of spin density components
177 : :
178 : : integer :: nsppol
179 : : ! Number of spin polarizations.
180 : :
181 : : integer :: nspinor
182 : : ! Number of spinor components.
183 : :
184 : : integer :: usepaw
185 : : ! 1 if PAW calculation, 0 otherwise
186 : :
187 : : integer :: mpert
188 : : ! Maximum number of perturbations
189 : :
190 : : integer :: my_nrpt = 0
191 : : ! Number of real space points used for Fourier interpolation treated by this MPI rank.
192 : :
193 : : integer :: nrtot = 0
194 : : ! Total Number of real space points used for Fourier interpolation.
195 : :
196 : : integer :: prtvol = 0
197 : : ! Verbosity level
198 : :
199 : : integer :: brav = 1
200 : : ! Option for the sampling of the BZ (input variable, the same option is stored in ifc_t)
201 : :
202 : : real(dp) :: qdamp = 0.1_dp
203 : : ! Exponential damping used in the Fourier transform of the long-range potentials
204 : : ! Use negative value to deactivate damping.
205 : :
206 : : logical :: debug = .False.
207 : : ! Debug flag
208 : :
209 : : logical :: has_dielt = .False.
210 : : ! True if the dielectric tensor is available.
211 : :
212 : : logical :: has_zeff = .False.
213 : : ! True if Born effective charges are available.
214 : :
215 : : logical :: has_quadrupoles = .False.
216 : : ! True if quadrupoles are available.
217 : :
218 : : logical :: has_efield = .False.
219 : : ! True if electric field perturbations are available.
220 : :
221 : : integer :: add_lr = 1
222 : : ! Flag defining the treatment of the long range component in the interpolation of the DFPT potentials.
223 : : !
224 : : ! 0 --> No treatment
225 : : ! 1 --> Remove LR model when building W(R,r). Add it back after W(R,r) --> v(q) Fourier interpolation
226 : : ! This is the standard approach for polar materials.
227 : : ! -1 --> Remove LR model when building W(R,r). DO NOT reintroduce it after Fourier interpolation.
228 : : ! This procedure should be used for homopolar materials with (spurious) non-zero BECS
229 : : ! in order to remove the long range component from the DFPT potentials.
230 : : ! 2 --> Similar to 1 but include only the dipole part. Q* are set to zero even if the DDB file contains them.
231 : : ! 4,5,6,7 --> Use model for the LR part only.
232 : : ! 4: Use dipole + quadrupole part (if available)
233 : : ! 5: Use dipole part only.
234 : : ! 6: Use quadrupole part only.
235 : : ! 7: Use electric field only.
236 : :
237 : : integer :: symv1 = 0
238 : : ! Flag for the symmetrization of v1 potentials.
239 : : ! 0 --> No symmetrization
240 : : ! 1 --> Symmetrization in real space
241 : : ! 2 --> Call v1phq_complete after interpolation of the potentials in ftinterp_qpt
242 : :
243 : : integer :: rspace_cell = 0
244 : : ! 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)
245 : : ! 0 --> Use unit supercell for R space. All weights set to 1.
246 : : ! 1 --> Use Wigner-Seitz super cell and atom dependent weights (same algo as for dynmat)
247 : :
248 : : character(len=fnlen) :: path = ABI_NOFILE
249 : : ! File name of the DVDB file.
250 : :
251 : : real(dp) :: dielt(3, 3) = zero
252 : : ! Dielectric tensor in Cartesian coordinates.
253 : : ! Used to deal with the long-range component in the Fourier interpolation.
254 : :
255 : : integer,allocatable :: pos_dpq(:,:,:)
256 : : ! pos_dpq(3, mpert, nqpt)
257 : : ! The position of the (idir, ipert, iqpt) potential in the file (in units of POT1 blocks)
258 : : ! 0 if the corresponding entry is not available.
259 : :
260 : : integer,allocatable :: cplex_v1(:)
261 : : ! cplex_v1(numv1)
262 : : ! The value of cplex for each v1(cplex*nfft, nspden) potential
263 : : ! 2 if the potential is complex, 1 if real (q==Gamma)
264 : :
265 : : integer,allocatable :: symq_table(:,:,:,:)
266 : : ! symq(4,2,nsym,nqpt)
267 : : ! Table computed by littlegroup_q for all q-points found in the DVDB.
268 : : ! three first numbers define the G vector;
269 : : ! fourth number is zero if the q-vector is not preserved, is 1 otherwise
270 : : ! second index is one without time-reversal symmetry, two with time-reversal symmetry
271 : :
272 : : integer :: ngfft(18) = -1
273 : : ! Info on the FFT to be used for the potentials.
274 : :
275 : : integer,allocatable :: iv_pinfoq(:,:)
276 : : !iv_pinfoq(4, numv1)
277 : : ! iv_pinfoq(1, iv1) gives the `idir` index of the iv1 potential
278 : : ! iv_pinfoq(2, iv1) gives the `ipert` index of the iv1 potential
279 : : ! iv_pinfoq(3, iv1) gives `pertcase`=idir + (ipert-1)*3
280 : : ! iv_pinfoq(4, iv1) gives the `iqpt` index of the iv1 potential
281 : :
282 : : integer,allocatable :: ngfft3_v1(:,:)
283 : : ! ngfft3_v1(3, numv1)
284 : : ! The FFT mesh used for each v1 potential (the one used to store data in the file).
285 : :
286 : : integer,allocatable :: my_irpt2tot(:)
287 : : ! Mapping my_irpt index to full list of R-points.
288 : :
289 : : real(dp),allocatable :: qpts(:,:)
290 : : ! qpts(3,nqpt)
291 : : ! List of q-points in reduced coordinates.
292 : :
293 : : real(dp),allocatable :: my_rpt(:,:)
294 : : ! my_rpt(3, my_nrpt)
295 : : ! Real space points for Fourier interpolation (MPI distributed if nprocs_rpt > 1)
296 : :
297 : : real(kind=sp),allocatable :: wsr(:,:,:,:,:)
298 : : ! DFPT potential in the real space supercell representation.
299 : : ! wsr(1, my_nrpt, nfft, nspden, my_npert)
300 : : ! NOTE kind=sp to save memory as much as possible.
301 : : !
302 : : ! TODO: Use MPI shared window
303 : :
304 : : real(dp),allocatable :: my_wratm(:,:)
305 : : ! my_wratm(my_nrpt, minatom:maxatom)
306 : : ! Weight for the FT associated to the atom and the R vector.
307 : :
308 : : real(dp),allocatable :: rhog1_g0(:,:)
309 : : ! rhog1_g0(2, numv1)
310 : : ! G=0 component of rhog1. Used to treat the long range component in (polar) semiconductors.
311 : : ! NB: For the time being, this quantity is not used. Long range term is treated with Verdi's model and quadrupoles
312 : :
313 : : real(dp),allocatable :: zeff(:,:,:)
314 : : ! zeff(3, 3, natom)
315 : : ! Effective charges on each atom, versus electric field and atomic displacement in Cartesian coordinates.
316 : : ! Used to deal with the long-range component in the Fourier interpolation.
317 : :
318 : : real(dp),allocatable :: zeff_raw(:,:,:)
319 : : ! Raw Effective charges i.e. values before enforcing the charge-neutrality condition.
320 : :
321 : : real(dp),allocatable :: qstar(:,:,:,:)
322 : : ! qstar(3, 3, 3, natom)
323 : : ! dynamical quadrupole in Cartesian coordinates.
324 : : ! First two dimension are associated to the q-point, then atomic perturbation in Cart coords.
325 : :
326 : : real(dp),allocatable :: v1r_efield(:,:,:)
327 : : ! v1r_efield(nfft, 3, nspden)
328 : : ! First order potentials due to the three different directions of the electric field perturbation.
329 : : ! Potentials are in r-space
330 : :
331 : : type(crystal_t) :: cryst
332 : : ! Crystalline structure read from the the DVDB file.
333 : :
334 : : type(hdr_type) :: hdr_ref
335 : : ! Header associated to the first potential in the DVDB. Used to backspace.
336 : : ! Gives the number of Fortran records required to backspace the header
337 : : ! Assume all headers with same fform and same basic dimensions e.g. npsp
338 : :
339 : : type(mpi_type) :: mpi_enreg
340 : : ! Internal object used to call fourdp and other GS/DFPT routines
341 : :
342 : : contains
343 : :
344 : : procedure :: init => dvdb_init !
345 : : ! Create new object.
346 : :
347 : : procedure :: open_read => dvdb_open_read
348 : : ! Open the file in read-only mode.
349 : :
350 : : procedure :: close => dvdb_close
351 : : ! Close the DVDB file.
352 : :
353 : : procedure :: free => dvdb_free
354 : : ! Release the memory allocated and close the file.
355 : :
356 : : procedure :: has_fields => dvdb_has_fields
357 : : ! Check whether the DVDB database stores first-order potentials or first-order densities
358 : :
359 : : procedure :: print => dvdb_print
360 : : ! Print info on object.
361 : :
362 : : procedure :: findq => dvdb_findq
363 : : ! Returns the index of the q-point.
364 : :
365 : : procedure :: find_qpts => dvdb_find_qpts
366 : : ! Returns the index of a list of q-points.
367 : :
368 : : procedure :: need_ftinterp => dvdb_need_ftinterp
369 : : ! Check whether input list of q-points requires Fourier interpolation.
370 : :
371 : : procedure :: set_pert_distrib => dvdb_set_pert_distrib
372 : : ! Activate parallelism over perturbations
373 : :
374 : : procedure :: read_onev1 => dvdb_read_onev1
375 : : ! Read and return the DFPT potential for given (idir, ipert, iqpt).
376 : :
377 : : procedure :: readsym_allv1 => dvdb_readsym_allv1
378 : : ! Read and return all the 3*natom DFPT potentials (either from file or symmetrized)
379 : :
380 : : procedure :: readsym_qbz => dvdb_readsym_qbz
381 : : ! Reconstruct the DFPT potential for a q-point in the BZ from its symmetrical image in the IBZ.
382 : :
383 : : procedure :: read_vxc1_qbz => dvdb_read_vxc1_qbz
384 : : ! Compute the first-order change of exchange-correlation potential
385 : : ! for a q-point in the BZ starting from its symmetrical image in the IBZ.
386 : :
387 : : procedure :: list_perts => dvdb_list_perts
388 : : ! Check if all the (phonon) perts are available taking into account symmetries.
389 : :
390 : : procedure :: ftinterp_setup => dvdb_ftinterp_setup
391 : : ! Prepare the internal tables for Fourier interpolation.
392 : :
393 : : procedure :: get_maxw => dvdb_get_maxw
394 : : ! Compute max_r |W(R,r)|
395 : :
396 : : procedure :: ftinterp_qpt => dvdb_ftinterp_qpt
397 : : ! Fourier interpolation of potentials for given q-point
398 : :
399 : : procedure :: get_ftqbz => dvdb_get_ftqbz
400 : : ! Retrieve Fourier interpolated potential for a given q-point in the BZ.
401 : : ! Use cache to reduce number of slow FTs.
402 : :
403 : : procedure :: get_vxc1_ftqbz => dvdb_get_vxc1_ftqbz
404 : : ! Retrieve Fourier interpolated first-order change of exchange-correlation
405 : : ! potential v1xc for a given q-point in the BZ.
406 : :
407 : : procedure :: get_v1r_long_range => dvdb_get_v1r_long_range
408 : : ! Long-range part of the phonon potential
409 : :
410 : : procedure :: load_ddb => dvdb_load_ddb
411 : : ! Load information about the Born effective charges and dielectric tensor from a DDB file
412 : :
413 : : procedure :: interpolate_v1scf => dvdb_interpolate_v1scf
414 : : ! Fourier interpolation of the phonon potentials
415 : :
416 : : procedure :: get_v1scf_rpt => dvdb_get_v1scf_rpt
417 : : ! Fourier transform of the phonon potential from qpt to R
418 : :
419 : : procedure :: get_v1scf_qpt => dvdb_get_v1scf_qpt
420 : : ! Fourier transform of the phonon potential from R to qpt
421 : :
422 : : procedure :: load_efield => dvdb_load_efield
423 : : ! Load the potential due to the Electric field.
424 : :
425 : : procedure :: interpolate_and_write => dvdb_interpolate_and_write
426 : : ! Interpolate the phonon potentials and write a new DVDB file.
427 : :
428 : : procedure :: qdownsample => dvdb_qdownsample
429 : : ! Downsample the q-mesh. Produce new DVDB file
430 : :
431 : : procedure :: write_v1qavg => dvdb_write_v1qavg
432 : : ! Computes the average over the unit cell of the periodic part of the DFPT potentials
433 : : ! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
434 : :
435 : : end type dvdb_t
436 : :
437 : : ! Utilities
438 : : public :: dvdb_merge_files ! Merge a list of POT1 files.
439 : :
440 : : ! Debugging tools. These functions are interfaced with mrgdv. Use mrgdv --help to access the documentation
441 : : public :: dvdb_test_v1rsym ! Check symmetries in real-space of the DFPT potentials.
442 : : public :: dvdb_test_v1complete ! Test the symmetrization of the DFPT potentials.
443 : : public :: dvdb_test_ftinterp ! Test the Fourier interpolation of DFPT potentials.
444 : : public :: dvdb_test_symcheck ! Test cross-q-point symmetry consistency of the FT interpolation.
445 : : public :: dvdb_test_symcheck_native ! Same test but on two literal, non-interpolated q-points.
446 : :
447 : : !----------------------------------------------------------------------
448 : :
449 : 80 : integer,private,parameter :: pot1_fforms(2) = [109, 111], den1_fforms(1) = [54]
450 : :
451 : : contains
452 : : !!***
453 : :
454 : : !----------------------------------------------------------------------
455 : :
456 : : !!****f* m_dvdb/dvdb_init
457 : : !! NAME
458 : : !! dvdb_init
459 : : !!
460 : : !! FUNCTION
461 : : !! Initialize the object from file. This is a COLLECTIVE procedure that must be called
462 : : !! by each process in the MPI communicator comm.
463 : : !! We don't pass dtset because in mrgdvd, we need to build an instance and dtset is not available there.
464 : : !!
465 : : !! INPUTS
466 : : !! path=DVDB Filename.
467 : : !! comm=MPI communicator.
468 : : !!
469 : : !! SOURCE
470 : :
471 : 116 : subroutine dvdb_init(new, path, gpu_option, comm)
472 : :
473 : : !Arguments ------------------------------------
474 : : !scalars
475 : : class(dvdb_t),intent(out) :: new
476 : : character(len=*),intent(in) :: path
477 : : integer,intent(in) :: gpu_option, comm
478 : :
479 : : !Local variables-------------------------------
480 : : !scalars
481 : : integer,parameter :: master = 0
482 : : integer :: iv1,ii,ierr,unt,fform,nqpt,iq,iq_found,cplex,trev_q
483 : : integer :: idir,ipert,my_rank, nprocs, iatom, pertcase
484 : : real(dp) :: cpu, wall, gflops
485 : : character(len=500) :: msg
486 : 116 : type(hdr_type) :: hdr1
487 : : !arrays
488 : 116 : integer,allocatable :: tmp_pos(:,:,:)
489 : : real(dp) :: tsec(2)
490 : 116 : real(dp),allocatable :: tmp_qpts(:,:)
491 : : !************************************************************************
492 : :
493 : : ! Keep track of total time spent.
494 : 116 : call timab(1800, 1, tsec)
495 : :
496 : 116 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
497 [ - + ]: 116 : new%path = path; new%comm = comm; new%iomode = IO_MODE_FORTRAN
498 : 116 : new%gpu_option = gpu_option
499 : :
500 : 116 : call wrtout(std_out, sjoin("- Analyzing DVDB file: ", path, "..."))
501 : 116 : call cwtime(cpu, wall, gflops, "start")
502 : :
503 : : ! Master reads the header and builds useful tables
504 [ + - ]: 116 : if (my_rank == master) then
505 : :
506 [ - + ]: 116 : if (open_file(path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
507 : 0 : ABI_ERROR(msg)
508 : : end if
509 [ + - ]: 116 : read(unt, err=10, iomsg=msg) new%version
510 [ + - ]: 116 : read(unt, err=10, iomsg=msg) new%numv1
511 : :
512 : : ! Get important dimensions from the first header and rewind the file.
513 : 116 : call new%hdr_ref%fort_read(unt, new%fform)
514 [ - + ]: 116 : if (dvdb_check_fform(new%fform, "read_dvdb", msg) /= 0) then
515 : 0 : ABI_ERROR(sjoin("While reading:", path, ch10, msg))
516 : : end if
517 [ - + ]: 116 : if (new%debug) call new%hdr_ref%echo(new%fform, 4, unit=std_out)
518 : :
519 : 116 : rewind(unt)
520 [ + - ]: 116 : read(unt, err=10, iomsg=msg)
521 [ + - ]: 116 : read(unt, err=10, iomsg=msg)
522 : :
523 : : ! The code below must be executed by the other procs if MPI.
524 : 116 : new%natom = new%hdr_ref%natom
525 : 116 : new%natom3 = 3 * new%hdr_ref%natom
526 : 116 : new%nspden = new%hdr_ref%nspden
527 : 116 : new%nsppol = new%hdr_ref%nsppol
528 : 116 : new%nspinor = new%hdr_ref%nspinor
529 : 116 : new%usepaw = new%hdr_ref%usepaw
530 [ - + ]: 116 : ABI_CHECK(new%usepaw == 0, "PAW not yet supported")
531 : :
532 : : ! TODO: Write function to return mpert from natom!
533 : 116 : new%mpert = new%natom + 6
534 : :
535 [ - + + - : 348 : ABI_MALLOC(tmp_qpts, (3, new%numv1))
+ - + - -
+ - + ]
536 [ - + + - : 464 : ABI_MALLOC(tmp_pos, (3, new%mpert, new%numv1))
- + + - +
- + - - +
- + ]
537 [ + + + + : 67979 : tmp_pos = 0
+ + ]
538 : :
539 [ - + + - : 348 : ABI_MALLOC(new%cplex_v1, (new%numv1))
+ - + - -
+ - + -
+ ]
540 [ - + + - : 348 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
+ - + - -
+ - + -
+ ]
541 [ - + + - : 348 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
+ - + - -
+ - + -
+ ]
542 [ - + + - : 348 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
+ - + - -
+ - + -
+ ]
543 : :
544 : 116 : nqpt = 0
545 [ + + ]: 2195 : do iv1=1,new%numv1
546 : 2079 : call hdr1%fort_read(unt, fform)
547 [ - + ]: 2079 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
548 : 0 : ABI_ERROR(sjoin("While reading hdr of v1 potential of index:", itoa(iv1), ch10, msg))
549 : : end if
550 : :
551 : : ! Save cplex and FFT mesh associated to this perturbation.
552 [ + + ]: 2079 : cplex = 2; if (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14) cplex = 1
553 : 2079 : new%cplex_v1(iv1) = cplex
554 [ + + ]: 8316 : new%ngfft3_v1(:, iv1) = hdr1%ngfft(:3)
555 : :
556 : : ! Skip the records with v1.
557 [ + + ]: 4158 : do ii=1,hdr1%nspden
558 [ + - ]: 4158 : read(unt, err=10, iomsg=msg)
559 : : end do
560 : : ! Read rhog1_g0 (if available)
561 [ + + ]: 6237 : new%rhog1_g0(:, iv1) = zero
562 [ + - + - ]: 2079 : if (new%version > 1) read(unt, err=10, iomsg=msg) new%rhog1_g0(:, iv1)
563 : :
564 : : ! Check whether this q-point is already in the list.
565 : : ! Assume qpoints are grouped so invert the iq loop for better performance.
566 : : ! This is gonna be slow if lots of q-points and perturbations are not grouped.
567 : 2079 : iq_found = 0
568 [ + + ]: 4629 : do iq=nqpt,1,-1
569 [ + + + + : 9353 : if (all(abs(hdr1%qptn - tmp_qpts(:,iq)) < tol14)) then
+ + ]
570 : : iq_found = iq; exit
571 : : end if
572 : : end do
573 : :
574 : : ! pertcase = idir + (ipert-1)*3 where ipert=iatom in the interesting cases
575 : 2079 : idir = mod(hdr1%pertcase-1, 3) + 1
576 : 2079 : ipert = (hdr1%pertcase - idir) / 3 + 1
577 : :
578 : : ! Increment nqpt is new q-points and update tmp_pos
579 [ + + ]: 2079 : if (iq_found == 0) then
580 : 682 : nqpt = nqpt + 1
581 [ + + ]: 2728 : tmp_qpts(:, nqpt) = hdr1%qptn
582 : : iq_found = nqpt
583 : : end if
584 : 2079 : tmp_pos(idir, ipert, iq_found) = iv1
585 [ + + ]: 10395 : new%iv_pinfoq(:,iv1) = [idir, ipert, hdr1%pertcase, iq_found]
586 : :
587 : 2195 : call hdr1%free()
588 : : end do
589 : :
590 : : ! Allocate arrays with correct nqpt dimension
591 : 116 : new%nqpt = nqpt
592 [ - + + - : 348 : ABI_MALLOC(new%qpts, (3, nqpt))
+ - + - -
+ - + -
+ ]
593 [ - + + + : 2960 : new%qpts = tmp_qpts(:,1:nqpt)
+ + ]
594 [ - + ]: 116 : ABI_FREE(tmp_qpts)
595 : :
596 [ - + + - : 464 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, nqpt))
- + + - +
- + - - +
- + - + ]
597 [ + - - + : 22342 : new%pos_dpq = tmp_pos(:, :, 1:nqpt)
- - + + +
+ + + ]
598 [ - + ]: 116 : ABI_FREE(tmp_pos)
599 : :
600 : 116 : close(unt)
601 : : end if
602 : :
603 : : ! Master broadcasts data.
604 [ - + ]: 116 : if (xmpi_comm_size(comm) > 1) then
605 : 0 : call xmpi_bcast(new%version, master, comm, ierr)
606 : 0 : call xmpi_bcast(new%fform, master, comm, ierr)
607 : 0 : call xmpi_bcast(new%numv1, master, comm, ierr)
608 : 0 : call xmpi_bcast(new%nqpt, master, comm, ierr)
609 : 0 : call new%hdr_ref%bcast(master, my_rank, comm)
610 : :
611 : 0 : new%natom = new%hdr_ref%natom
612 : 0 : new%natom3 = 3 * new%hdr_ref%natom
613 : 0 : new%nspden = new%hdr_ref%nspden
614 : 0 : new%nsppol = new%hdr_ref%nsppol
615 : 0 : new%nspinor = new%hdr_ref%nspinor
616 : 0 : new%usepaw = new%hdr_ref%usepaw
617 : 0 : new%mpert = new%natom + 6
618 : :
619 [ # # ]: 0 : if (my_rank /= master) then
620 [ # # # # : 0 : ABI_MALLOC(new%cplex_v1, (new%numv1))
# # # # #
# # # #
# ]
621 [ # # # # : 0 : ABI_MALLOC(new%ngfft3_v1, (3, new%numv1))
# # # # #
# # # #
# ]
622 [ # # # # : 0 : ABI_MALLOC(new%iv_pinfoq, (4, new%numv1))
# # # # #
# # # #
# ]
623 [ # # # # : 0 : ABI_MALLOC(new%qpts, (3, new%nqpt))
# # # # #
# # # #
# ]
624 [ # # # # : 0 : ABI_MALLOC(new%pos_dpq, (3, new%mpert, new%nqpt))
# # # # #
# # # # #
# # # # ]
625 [ # # # # : 0 : ABI_MALLOC(new%rhog1_g0, (2, new%numv1))
# # # # #
# # # #
# ]
626 : : end if
627 : :
628 : 0 : call xmpi_bcast(new%cplex_v1, master, comm, ierr)
629 : 0 : call xmpi_bcast(new%ngfft3_v1, master, comm, ierr)
630 : 0 : call xmpi_bcast(new%iv_pinfoq, master, comm, ierr)
631 : 0 : call xmpi_bcast(new%qpts, master, comm, ierr)
632 : 0 : call xmpi_bcast(new%pos_dpq, master, comm, ierr)
633 : 0 : call xmpi_bcast(new%rhog1_g0, master, comm, ierr)
634 : : end if
635 : :
636 : : ! Init crystal_t from the hdr read from file.
637 [ - + - + : 116 : new%cryst = new%hdr_ref%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
638 : 116 : new%my_npert = new%natom3
639 : :
640 : : ! Init tables assuming no MPI distribution of perturbations.
641 [ - + + - : 348 : ABI_MALLOC(new%my_pinfo, (3, new%natom3))
+ - + - -
+ - + -
+ ]
642 [ - + + - : 348 : ABI_MALLOC(new%pert_table, (2, new%natom3))
+ - + - -
+ - + -
+ ]
643 [ + + ]: 337 : do iatom=1,new%natom
644 [ + + ]: 1000 : do idir=1,3
645 : 663 : pertcase = idir + (iatom-1) * 3
646 [ + + ]: 2652 : new%my_pinfo(:, pertcase) = [idir, iatom, pertcase]
647 [ + + ]: 2210 : new%pert_table(:, pertcase) = [xmpi_comm_self, pertcase]
648 : : end do
649 : : end do
650 : :
651 : : ! Init Born effective charges
652 [ - + + - : 3221 : ABI_CALLOC(new%zeff, (3, 3, new%natom))
+ - + - -
+ - + - +
+ + + + +
+ ]
653 [ - + + - : 3105 : ABI_CALLOC(new%zeff_raw, (3, 3, new%natom))
- + - + -
+ + + + +
+ + ]
654 [ - + + - : 9188 : ABI_CALLOC(new%qstar, (3, 3, 3, new%natom))
+ - + - -
+ - + - +
+ + + + +
+ + + ]
655 : :
656 : : ! Internal MPI_type needed for calling fourdp!
657 : 116 : call initmpi_seq(new%mpi_enreg)
658 : :
659 : : ! Precompute symq_table for all q-points in the DVDB.
660 [ - + + - : 313282 : ABI_ICALLOC(new%symq_table, (4, 2, new%cryst%nsym, new%nqpt))
- + + - +
- + - - +
- + - + +
+ + + + +
+ + ]
661 [ + + ]: 798 : do iq=1,new%nqpt
662 [ - + ]: 682 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
663 : : call littlegroup_q(new%cryst%nsym, new%qpts(:,iq), new%symq_table(:,:,:,iq), &
664 : 798 : new%cryst%symrec, new%cryst%symafm, trev_q, prtvol=0)
665 : : end do
666 : 116 : call xmpi_sum(new%symq_table, comm, ierr)
667 : :
668 : 116 : call cwtime_report("- dvdb_init", cpu, wall, gflops)
669 : 116 : call timab(1800, 2, tsec)
670 : :
671 : 116 : return
672 : :
673 : : ! Handle Fortran IO error
674 : : 10 continue
675 : 0 : ABI_ERROR(sjoin("Error while reading:", path, ch10, msg))
676 : :
677 [ + - - + : 464 : end subroutine dvdb_init
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - ]
678 : : !!***
679 : :
680 : : !----------------------------------------------------------------------
681 : :
682 : : !!****f* m_dvdb/dvdb_open_read
683 : : !! NAME
684 : : !! dvdb_open_read
685 : : !!
686 : : !! FUNCTION
687 : : !! Open the file in read-only mode.
688 : : !!
689 : : !! INPUTS
690 : : !! ngfft(18)=Info on the FFT mesh used for the DFPT potentials. Note that ngfft
691 : : !! is the mesh used by the parent. In principle, it can differ from the one
692 : : !! found in the file. In this case a Fourier interpolation is required.
693 : : !! comm=MPI communicator
694 : : !!
695 : : !! SOURCE
696 : :
697 : 95 : subroutine dvdb_open_read(db, ngfft, comm)
698 : :
699 : : !Arguments ------------------------------------
700 : : !scalars
701 : : integer,intent(in) :: comm
702 : : class(dvdb_t),intent(inout) :: db
703 : : !arrays
704 : : integer,intent(in) :: ngfft(18)
705 : :
706 : : !Local variables-------------------------------
707 : : !scalars
708 : : integer :: nprocs, unt, ii
709 : : character(len=500) :: msg
710 : : !arrays
711 : : character(len=fnlen) :: pot_paths(3)
712 : : !************************************************************************
713 : :
714 [ - + ]: 95 : if (db%rw_mode /= DVDB_NOMODE) then
715 : 0 : ABI_ERROR("DVDB should be in DVDB_NOMODE when open_read is called.")
716 : : end if
717 : 95 : db%rw_mode = DVDB_READMODE
718 : :
719 : 95 : nprocs = xmpi_comm_size(comm)
720 : :
721 : : ! Initialize tables to call fourdp in sequential
722 [ + + ]: 1805 : db%ngfft = ngfft
723 : 95 : call db%mpi_enreg%distribfft%init_seq('c', ngfft(2), ngfft(3), 'all')
724 : 95 : call db%mpi_enreg%distribfft%init_seq('f', ngfft(2), ngfft(3), 'all')
725 : :
726 : : ! Open the file.
727 : 190 : select case (db%iomode)
728 : : case (IO_MODE_FORTRAN)
729 [ - + ]: 95 : if (open_file(db%path, msg, newunit=db%fh, form="unformatted", status="old", action="read") /= 0) then
730 : 0 : ABI_ERROR(msg)
731 : : end if
732 [ + - ]: 95 : read(db%fh, err=10, iomsg=msg)
733 [ + - ]: 95 : read(db%fh, err=10, iomsg=msg)
734 : 95 : db%current_fpos = 1
735 : :
736 : : case (IO_MODE_MPI)
737 : 0 : ABI_ERROR("MPI not coded")
738 : :
739 : : case default
740 [ + - - ]: 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
741 : : end select
742 : :
743 : : ! Read potentials induced by electric fields
744 : : ! This requires ngfft so for the time being we call it here.
745 : : ! I should try to add efield perturbations to DVDB but then I also have to handle symmetrization wrt idir!
746 [ - + ]: 95 : if (file_exists("__EFIELD_POTS__")) then
747 : 0 : call wrtout(std_out, " Reading Efield potentials from EFIELD_POTS")
748 [ # # ]: 0 : if (open_file("__EFIELD_POTS__", msg, newunit=unt, form="formatted") /= 0) then
749 : 0 : ABI_ERROR(msg)
750 : : end if
751 [ # # ]: 0 : do ii=1,3
752 : 0 : read(unt, "(a)") pot_paths(ii)
753 : : end do
754 : 0 : close(unt)
755 : 0 : call db%load_efield(pot_paths, comm)
756 : : end if
757 : :
758 : 95 : return
759 : :
760 : : ! Handle Fortran IO error
761 : : 10 continue
762 : 0 : ABI_ERROR(sjoin("Error while reading", db%path, ch10, msg))
763 : :
764 : : end subroutine dvdb_open_read
765 : : !!***
766 : :
767 : : !----------------------------------------------------------------------
768 : :
769 : : !!****f* m_dvdb/dvdb_close
770 : : !! NAME
771 : : !! dvdb_close
772 : : !!
773 : : !! FUNCTION
774 : : !! Close the file
775 : : !!
776 : : !! SOURCE
777 : :
778 : 95 : subroutine dvdb_close(db)
779 : :
780 : : !Arguments ------------------------------------
781 : : class(dvdb_t),intent(inout) :: db
782 : : !************************************************************************
783 : :
784 : 190 : select case (db%iomode)
785 : : case (IO_MODE_FORTRAN)
786 : 95 : close(db%fh)
787 : : case default
788 [ + - ]: 95 : ABI_ERROR(sjoin("Unsupported iomode:", itoa(db%iomode)))
789 : : end select
790 : :
791 : 95 : db%rw_mode = DVDB_NOMODE
792 : :
793 : 95 : end subroutine dvdb_close
794 : : !!***
795 : :
796 : : !----------------------------------------------------------------------
797 : :
798 : : !!****f* m_dvdb/dvdb_free
799 : : !! NAME
800 : : !! dvdb_free
801 : : !!
802 : : !! FUNCTION
803 : : !! Close the file and release the memory allocated.
804 : : !!
805 : : !! SOURCE
806 : :
807 : 235 : subroutine dvdb_free(db)
808 : :
809 : : !Arguments ------------------------------------
810 : : class(dvdb_t),target,intent(inout) :: db
811 : :
812 : : !Local variables-------------------------------
813 : 235 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
814 : : !************************************************************************
815 : :
816 : : ! integer arrays
817 : 116 : ABI_SFREE(db%my_pinfo)
818 [ + + ]: 235 : ABI_SFREE(db%pert_table)
819 [ + + ]: 235 : ABI_SFREE(db%pos_dpq)
820 [ + + ]: 235 : ABI_SFREE(db%cplex_v1)
821 [ + + ]: 235 : ABI_SFREE(db%symq_table)
822 [ + + ]: 235 : ABI_SFREE(db%iv_pinfoq)
823 [ + + ]: 235 : ABI_SFREE(db%ngfft3_v1)
824 [ + + ]: 235 : ABI_SFREE(db%my_irpt2tot)
825 : :
826 : : ! real arrays
827 [ + + ]: 235 : ABI_SFREE(db%qpts)
828 [ + + ]: 235 : ABI_SFREE(db%my_rpt)
829 : :
830 [ + + ]: 235 : ABI_SFREE(db%my_wratm)
831 [ + + ]: 235 : ABI_SFREE(db%rhog1_g0)
832 [ + + ]: 235 : ABI_SFREE(db%zeff)
833 [ + + ]: 235 : ABI_SFREE(db%zeff_raw)
834 [ + + ]: 235 : ABI_SFREE(db%qstar)
835 [ - + ]: 235 : ABI_SFREE(db%v1r_efield)
836 : :
837 : : ! Deallocate GPU arrays
838 : 235 : wsr_ptr => db%wsr
839 : : #ifdef HAVE_OPENMP_OFFLOAD
840 : : !$OMP TARGET EXIT DATA MAP(delete:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
841 : : #endif
842 [ + + ]: 235 : ABI_SFREE(db%wsr)
843 : :
844 : : ! types
845 : 235 : call db%hdr_ref%free()
846 : 235 : call db%cryst%free()
847 : 235 : call destroy_mpi_enreg(db%mpi_enreg)
848 : :
849 : : ! Close the file but only if we have performed IO.
850 [ + + ]: 235 : if (db%rw_mode == DVDB_NOMODE) return
851 : 95 : call db%close()
852 : :
853 [ + + ]: 235 : end subroutine dvdb_free
854 : : !!***
855 : :
856 : : !!****f* m_dvdb/dvdb_has_fields
857 : : !! NAME
858 : : !! dvdb_has_fields
859 : : !!
860 : : !! FUNCTION
861 : : !! Check whether the database stores first-order potentials (pot1) or first-order densities (den1)
862 : : !!
863 : : !! SOURCE
864 : :
865 : 182 : logical function dvdb_has_fields(db, choice, msg) result(ok)
866 : :
867 : : !Arguments ------------------------------------
868 : : class(dvdb_t),intent(in) :: db
869 : : character(len=*),intent(in) :: choice
870 : : character(len=*),intent(out) :: msg
871 : : !************************************************************************
872 : :
873 : : ! See m_hdr, more specifically all_abifiles for the correspondence between data and fform.
874 : 182 : msg = ""
875 : 176 : select case (choice)
876 : : case ("pot1")
877 : 176 : ok = any(db%fform == pot1_fforms)
878 [ - + - - : 176 : if (.not. ok) msg = sjoin("expecting first order potentials with headform in", ltoa(pot1_fforms), "but got", itoa(db%fform))
- - ]
879 : : case ("den1")
880 : 6 : ok = any(db%fform == den1_fforms)
881 [ - + - - : 6 : if (.not. ok) msg = sjoin("expecting first order densities with headform in", ltoa(den1_fforms), "but got", itoa(db%fform))
- - ]
882 : : case default
883 [ + + - ]: 182 : ABI_ERROR(sjoin("Invalid choice:", choice))
884 : : end select
885 : :
886 [ + - ]: 182 : end function dvdb_has_fields
887 : : !!***
888 : :
889 : : !----------------------------------------------------------------------
890 : :
891 : : !!****f* m_dvdb/dvdb_print
892 : : !! NAME
893 : : !! dvdb_print
894 : : !!
895 : : !! FUNCTION
896 : : !! Print info on the object.
897 : : !!
898 : : !! INPUTS
899 : : !! units=Unit numbers for output.
900 : : !! header=Header string
901 : : !! prtvol=verbosity level
902 : : !!
903 : : !! SOURCE
904 : :
905 : 380 : subroutine dvdb_print(db, units, header, prtvol)
906 : :
907 : : !Arguments ------------------------------------
908 : : !scalars
909 : : class(dvdb_t),intent(in) :: db
910 : : integer,intent(in) :: units(:), prtvol
911 : : character(len=*),intent(in) :: header
912 : :
913 : : !Local variables-------------------------------
914 : : integer :: iv1,iq,idir,ipert,iatom
915 : : character(len=5000) :: msg
916 : : ! *************************************************************************
917 : :
918 [ + + ]: 190 : if (len_trim(header) == 0) then
919 : 85 : msg = ' ==== Info on the dvdb% object ==== '
920 : : else
921 [ + - + - ]: 105 : msg = ' ==== '//trim(adjustl(header))//' ==== '
922 : : end if
923 : 190 : call wrtout(units, msg)
924 : :
925 : 190 : call wrtout(units, sjoin(" DVDB version:", itoa(db%version)))
926 : 190 : call wrtout(units, sjoin(" File path:", db%path))
927 : 190 : call wrtout(units, sjoin(" Number of v1scf potentials:", itoa(db%numv1)))
928 : 190 : call wrtout(units, sjoin(" Number of q-points in DVDB: ", itoa(db%nqpt)))
929 : 190 : call wrtout(units, sjoin("-P Number of CPUs for parallelism over perturbations:", itoa(db%nprocs_pert)))
930 : 190 : call wrtout(units, sjoin("-P Number of perturbations treated by this CPU:", itoa(db%my_npert)))
931 : 190 : call wrtout(units, sjoin(" Option for symmetrization of v1scf(r):", itoa(db%symv1)))
932 : 190 : call wrtout(units, " List of q-points: min(10, nqpt)")
933 [ + + ]: 1238 : do iq=1,min(db%nqpt, 10)
934 : 1238 : call wrtout(units, sjoin("[", itoa(iq),"]", ktoa(db%qpts(:,iq))))
935 : : end do
936 [ + + ]: 190 : if (db%nqpt > 10) call wrtout(units, "...")
937 : :
938 : 190 : call wrtout(units, sjoin(" Have dielectric tensor:", yesno(db%has_dielt)))
939 : 190 : call wrtout(units, sjoin(" Have Born effective charges:", yesno(db%has_zeff)))
940 : 190 : call wrtout(units, sjoin(" Have quadrupoles:", yesno(db%has_quadrupoles)))
941 : 190 : call wrtout(units, sjoin(" Have electric field:", yesno(db%has_efield)))
942 : 190 : call wrtout(units, sjoin(" Treatment of long-range part in V1scf (add_lr):", itoa(db%add_lr)))
943 : 190 : write(msg,"(a, f6.1)")" Damping factor for Gaussian filter (qdamp):", db%qdamp
944 : 190 : call wrtout(units, msg)
945 : :
946 [ + + ]: 190 : if (db%has_dielt) then
947 : 82 : write(msg, '(a,3(a,3es16.6))') ' Dielectric tensor in Cart coords:', ch10, &
948 : 82 : db%dielt(1,1), db%dielt(1,2), db%dielt(1,3), ch10, &
949 : 82 : db%dielt(2,1), db%dielt(2,2), db%dielt(2,3), ch10, &
950 : 164 : db%dielt(3,1), db%dielt(3,2), db%dielt(3,3)
951 : 82 : call wrtout(units, msg)
952 : : end if
953 : :
954 [ + + ]: 190 : if (db%has_zeff) then
955 : 82 : call print_zeff(units, db%cryst, db%zeff, title=' Born effectives charges in Cart coords:')
956 : : !call print_zeff(units, db%zeff_raw, db%cryst, title=' Born effectives charges before chneut: ')
957 : : end if
958 : :
959 [ + + ]: 190 : if (db%has_quadrupoles) then
960 : 2 : call wrtout(units, ' Dynamical Quadrupoles in Cartesian Coordinates:')
961 [ + + ]: 6 : do iatom=1,db%natom
962 [ + + ]: 18 : do idir=1,3
963 : 12 : write(msg,'(2(a,i0), 3(a,3es16.6))')' Q* for iatom: ', iatom, ' idir: ', idir, ch10, &
964 : 12 : db%qstar(1,1,idir,iatom), db%qstar(1,2,idir,iatom), db%qstar(1,3,idir,iatom), ch10, &
965 : 12 : db%qstar(2,1,idir,iatom), db%qstar(2,2,idir,iatom), db%qstar(2,3,idir,iatom), ch10, &
966 : 24 : db%qstar(3,1,idir,iatom), db%qstar(3,2,idir,iatom), db%qstar(3,3,idir,iatom)
967 : 16 : call wrtout(units, msg)
968 : : end do
969 : : end do
970 : :
971 : 2 : call wrtout(units, " Dynamical quadrupoles sum rule: \sum_\iatom Q_{beta,gamma}{iatom,idir} = 0 for nonpolar materials")
972 [ + + ]: 8 : do idir=1,3
973 : 6 : write(msg,'(a,i0,a,3(a,3es16.6))')" Sum rule for idir: ", idir, ch10, ch10, &
974 [ + + + + : 42 : sum(db%qstar(1,1,idir,:)), sum(db%qstar(1,2,idir,:)), sum(db%qstar(1,3,idir,:)), ch10, &
+ + ]
975 [ + + + + : 42 : sum(db%qstar(2,1,idir,:)), sum(db%qstar(2,2,idir,:)), sum(db%qstar(2,3,idir,:)), ch10, &
+ + ]
976 [ + + + + : 48 : sum(db%qstar(3,1,idir,:)), sum(db%qstar(3,2,idir,:)), sum(db%qstar(3,3,idir,:))
+ + ]
977 : 8 : call wrtout(units, msg)
978 : : end do
979 : : end if
980 : :
981 [ - + + + ]: 380 : if (prtvol > 0) then
982 : 43 : call db%cryst%print(header="Crystal structure in DVDB file")
983 : 43 : call wrtout(units, "FFT mesh for potentials on file:")
984 : 43 : call wrtout(units, "q-point, idir, ipert, ngfft(:3)")
985 [ + + ]: 517 : do iv1=1,db%numv1
986 : 474 : idir = db%iv_pinfoq(1, iv1); ipert = db%iv_pinfoq(2, iv1); iq = db%iv_pinfoq(4, iv1)
987 : 517 : call wrtout(units, sjoin(ktoa(db%qpts(:,iq)), itoa(idir), itoa(ipert), ltoa(db%ngfft3_v1(:,iv1))))
988 : : end do
989 : : end if
990 : :
991 : : contains
992 : :
993 [ - + ]: 82 : subroutine print_zeff(units, cryst, zeff, title)
994 : :
995 : : !Arguments ------------------------------------
996 : : !scalars
997 : : integer,intent(in) :: units(:)
998 : : type(crystal_t),intent(in) :: cryst
999 : : real(dp),intent(in) :: zeff(3,3,cryst%natom)
1000 : : character(len=*),optional,intent(in) :: title
1001 : :
1002 : : !Local variables-------------------------------
1003 : : integer :: iatom
1004 : : character(len=5000) :: msg
1005 : : ! *************************************************************************
1006 : :
1007 [ + - ]: 82 : if (present(title)) then
1008 [ + - ]: 82 : call wrtout(units, trim(title))
1009 : : else
1010 : 0 : call wrtout(units, ' Born effectives charges in Cartesian coordinates: ')
1011 : : end if
1012 : :
1013 [ + + ]: 246 : do iatom=1,cryst%natom
1014 : 164 : write(msg, '(a,i0,1x,2a,3(a,3es16.6),a)')' iatom: ', iatom, ", type: ", cryst%symbol_iatom(iatom), ch10, &
1015 : 164 : zeff(1,1,iatom), zeff(1,2,iatom), zeff(1,3,iatom), ch10, &
1016 : 164 : zeff(2,1,iatom), zeff(2,2,iatom), zeff(2,3,iatom), ch10, &
1017 : 328 : zeff(3,1,iatom), zeff(3,2,iatom), zeff(3,3,iatom), ch10
1018 : 246 : call wrtout(units, msg)
1019 : : end do
1020 : :
1021 : 82 : write(msg,'(2a,3(a,3es16.6),a)')ch10,' Fulfillment of charge neutrality, \sum_{atom} Z^*_{ij,atom} = 0', ch10, &
1022 [ + + + + : 738 : sum(zeff(1,1,:)), sum(zeff(1,2,:)), sum(zeff(1,3,:)), ch10, &
+ + ]
1023 [ + + + + : 738 : sum(zeff(2,1,:)), sum(zeff(2,2,:)), sum(zeff(2,3,:)), ch10, &
+ + ]
1024 [ + + + + : 820 : sum(zeff(3,1,:)), sum(zeff(3,2,:)), sum(zeff(3,3,:)), ch10
+ + ]
1025 : 82 : call wrtout(units, msg)
1026 : :
1027 : 82 : end subroutine print_zeff
1028 : :
1029 : : end subroutine dvdb_print
1030 : : !!***
1031 : :
1032 : : !----------------------------------------------------------------------
1033 : :
1034 : : !!****f* m_dvdb/dvdb_get_pinfo
1035 : : !! NAME
1036 : : !! dvdb_get_pinfo
1037 : : !!
1038 : : !! FUNCTION
1039 : : !! Return information on the perturbations available for a given q-point index.
1040 : : !!
1041 : : !! INPUTS
1042 : : !! iqpt=Index of the q-point
1043 : : !!
1044 : : !! OUTPUT
1045 : : !! nperts=Number of perturbations found.
1046 : : !! cplex=2 if potentials are complex, 1 for real
1047 : : !! pinfo(3,3*db%mpert)=Array with info on the perturbations present on file
1048 : : !! pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
1049 : : !! pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
1050 : : !! pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
1051 : : !!
1052 : : !! SOURCE
1053 : :
1054 : 1718 : integer function dvdb_get_pinfo(db, iqpt, cplex, pinfo) result(nperts)
1055 : :
1056 : : !Arguments ------------------------------------
1057 : : !scalars
1058 : : type(dvdb_t),intent(in) :: db
1059 : : integer,intent(in) :: iqpt
1060 : : integer,intent(out) :: cplex
1061 : : !arrays
1062 : : integer,intent(out) :: pinfo(3,3*db%mpert)
1063 : :
1064 : : !Local variables-------------------------------
1065 : : !scalars
1066 : : integer :: idir,ipert,iv1
1067 : : ! *************************************************************************
1068 : :
1069 : : ! Get the number of perturbations computed for this iqpt
1070 [ + + + + ]: 165374 : pinfo = 0; cplex = 0; nperts = 0
1071 [ + + ]: 5048 : do ipert=1,db%natom ! selects atomic perturbations only.
1072 [ + + ]: 15038 : do idir=1,3
1073 : 9990 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1074 [ + + ]: 13320 : if (iv1 /= 0) then
1075 : 5416 : nperts = nperts + 1
1076 [ + + ]: 21664 : pinfo(:, nperts) = [idir, ipert, idir + (ipert-1)*3]
1077 [ + + ]: 5416 : if (cplex == 0) cplex = db%cplex_v1(iv1)
1078 [ - + ]: 5416 : ABI_CHECK_IEQ(cplex, db%cplex_v1(iv1), "cplex should be constant for given q!")
1079 : : end if
1080 : : end do
1081 : : end do
1082 : :
1083 : 1718 : end function dvdb_get_pinfo
1084 : : !!***
1085 : :
1086 : : !----------------------------------------------------------------------
1087 : :
1088 : : !!****f* m_dvdb/dvdb_read_onev1
1089 : : !! NAME
1090 : : !! dvdb_read_onev1
1091 : : !!
1092 : : !! FUNCTION
1093 : : !! Read the DFPT potential for the specified (idir, ipert, iqpt).
1094 : : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1095 : : !! get the index from the q-point in reduced coordinates.
1096 : : !!
1097 : : !! INPUTS
1098 : : !! idir=Direction of the perturbation
1099 : : !! ipert=Perturbation type.
1100 : : !! iqpt=Index of the q-point in dvdb%qpts
1101 : : !! cplex=1 if real, 2 if complex potentials.
1102 : : !! nfft=Number of fft-points treated by this processors
1103 : : !! ngfft(18)=contain all needed information about 3D FFT.
1104 : : !!
1105 : : !! OUTPUT
1106 : : !! ierr=Non-zero if error.
1107 : : !! v1scf(cplex*nfft, nspden)=DFT potential associated to (idir, ipert, iqpt).
1108 : : !! msg=String with error message if ierr /= 0.
1109 : : !!
1110 : : !! SOURCE
1111 : :
1112 : 5360 : integer function dvdb_read_onev1(db, idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) result(ierr)
1113 : :
1114 : : !Arguments ------------------------------------
1115 : : !scalars
1116 : : integer,intent(in) :: idir,ipert,iqpt,cplex,nfft
1117 : : character(len=*),intent(out) :: msg
1118 : : class(dvdb_t),intent(inout) :: db
1119 : : !arrays
1120 : : integer,intent(in) :: ngfft(18)
1121 : : real(dp),intent(out) :: v1scf(cplex*nfft,db%nspden)
1122 : :
1123 : : !Local variables-------------------------------
1124 : : !scalars
1125 : : integer,save :: enough = 0
1126 : : integer :: iv1,ispden,nfftot_file,nfftot_out,ifft
1127 : : !arrays
1128 : : integer :: ngfft_in(18),ngfft_out(18)
1129 : 5360 : real(dp),allocatable :: v1r_file(:,:)
1130 : : ! *************************************************************************
1131 : :
1132 : : ! Consistency checks
1133 : 5360 : ierr = 1
1134 : 5360 : iv1 = db%pos_dpq(idir,ipert,iqpt)
1135 : :
1136 : 5360 : if (iv1 == 0) then
1137 : 0 : write(msg,"(3(a,i0))")"Cannot find idir: ",idir,", ipert: ",ipert,", iqpt:",iqpt
1138 : 0 : return
1139 : : end if
1140 : :
1141 [ - + ]: 5360 : if (cplex /= db%cplex_v1(iv1)) then
1142 : 0 : write(msg,"(2(a,i0))")"Wrong cplex. Expecting: ",db%cplex_v1(iv1),", received: ",cplex
1143 : 0 : return
1144 : : end if
1145 : :
1146 : : ! Find (idir, ipert, iqpt) and skip the header.
1147 : 5360 : call dvdb_seek(db, idir, ipert, iqpt)
1148 : 5360 : ierr = my_hdr_skip(db%fh, idir, ipert, db%qpts(:,iqpt), msg)
1149 [ - + ]: 5360 : if (ierr /= 0) then
1150 [ # # # # ]: 0 : msg = sjoin("In my_hdr_skip:", msg)
1151 : 0 : return
1152 : : end if
1153 : :
1154 : : ! Read v1 from file.
1155 [ + + ]: 21440 : nfftot_out = product(ngfft(:3)); nfftot_file = product(db%ngfft3_v1(:3, iv1))
1156 : :
1157 [ + + + + : 16244 : if (all(ngfft(:3) == db%ngfft3_v1(:3, iv1))) then
+ + ]
1158 [ + + ]: 7256 : do ispden=1,db%nspden
1159 [ + - ]: 7256 : read(db%fh, err=10, iomsg=msg) (v1scf(ifft, ispden), ifft=1,cplex*nfftot_file)
1160 : : end do
1161 : : else
1162 : : ! The FFT mesh used in the caller differ from the one found in the DVDB --> Fourier interpolation
1163 [ + + ]: 1732 : if (enough == 0) ABI_COMMENT("Performing FFT interpolation of DFPT potentials as input ngfft differs from ngfft_file.")
1164 : 1732 : enough = enough + 1
1165 [ - + + - : 6928 : ABI_MALLOC(v1r_file, (cplex*nfftot_file, db%nspden))
- + + - +
- + - - +
- + ]
1166 [ + + ]: 3464 : do ispden=1,db%nspden
1167 [ + - ]: 3464 : read(db%fh, err=10, iomsg=msg) (v1r_file(ifft, ispden), ifft=1,cplex*nfftot_file)
1168 : : end do
1169 : :
1170 : : ! Call fourier_interpol_seq to get v1scf on the ngfft mesh.
1171 : 1732 : ngfft_in = ngfft; ngfft_out = ngfft
1172 [ + + + + ]: 12124 : ngfft_in(1:3) = db%ngfft3_v1(1:3, iv1); ngfft_out(1:3) = ngfft(1:3)
1173 [ + + + + ]: 12124 : ngfft_in(4:6) = ngfft_in(1:3); ngfft_out(4:6) = ngfft_out(1:3)
1174 [ + + + + ]: 36372 : ngfft_in(9:18) = 0; ngfft_out(9:18) = 0
1175 : 1732 : ngfft_in(10) = 1; ngfft_out(10) = 1
1176 : :
1177 : 1732 : call fourier_interpol_seq(cplex, db%nspden, nfftot_file, ngfft_in, nfft, ngfft, v1r_file, v1scf)
1178 [ - + ]: 1732 : ABI_FREE(v1r_file)
1179 : : end if
1180 : :
1181 : : ! Skip record with rhog1_g0 (if present)
1182 [ + - + - ]: 5360 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
1183 : :
1184 : 5360 : db%current_fpos = db%current_fpos + 1
1185 : : !write(std_out, *)"incr current_fpos", db%current_fpos
1186 : :
1187 : 5360 : return
1188 : :
1189 : : ! Handle Fortran IO error
1190 : : 10 continue
1191 : 0 : ierr = 1
1192 [ # # # # ]: 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
1193 : :
1194 [ - + - + ]: 10720 : end function dvdb_read_onev1
1195 : : !!***
1196 : :
1197 : : !----------------------------------------------------------------------
1198 : :
1199 : : !!****f* m_dvdb/dvdb_readsym_allv1
1200 : : !! NAME
1201 : : !! dvdb_readsym_allv1
1202 : : !!
1203 : : !! FUNCTION
1204 : : !! Read all 3*natom DFPT potentials for the given iqpt (only atomic perturbations).
1205 : : !!
1206 : : !! The routine will:
1207 : : !!
1208 : : !! 1) Reconstruct the potentials by symmetry if the DVDB contains less than 3*natom potentials.
1209 : : !! 2) interpolate the data if the input FFT mesh defined by `ngfft` differs
1210 : : !! from the one used to store data in the file.
1211 : : !!
1212 : : !! Note that iqpt is the index in dvdb%qpts. Use dvdb_findq to
1213 : : !! get the index from the q-point in reduced coordinates.
1214 : : !!
1215 : : !! INPUTS
1216 : : !! iqpt=Index of the q-point in dvdb%qpts
1217 : : !! nfft=Number of fft-points treated by this processors
1218 : : !! ngfft(18)=contain all needed information about 3D FFT
1219 : : !! comm=MPI communicator
1220 : : !!
1221 : : !! OUTPUT
1222 : : !! cplex=1 if real, 2 if complex.
1223 : : !! v1scf(cplex, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
1224 : : !!
1225 : : !! SOURCE
1226 : :
1227 : 1660 : subroutine dvdb_readsym_allv1(db, iqpt, cplex, nfft, ngfft, v1scf, comm)
1228 : :
1229 : : !Arguments ------------------------------------
1230 : : !scalars
1231 : : integer,intent(in) :: iqpt,nfft,comm
1232 : : integer,intent(out) :: cplex
1233 : : class(dvdb_t),intent(inout) :: db
1234 : : !arrays
1235 : : integer,intent(in) :: ngfft(18)
1236 : : real(dp) ABI_ASYNC ,allocatable,intent(out) :: v1scf(:,:,:,:)
1237 : :
1238 : : !Local variables-------------------------------
1239 : : !scalars
1240 : : integer,parameter :: master=0
1241 : : integer :: ipc,npc,idir,ipert,pcase,my_rank,nproc,ierr,mu
1242 : : character(len=500) :: msg
1243 : : !arrays
1244 : 1660 : integer :: pinfo(3,3*db%mpert),pflag(3, db%natom)
1245 : : real(dp) :: tsec(2)
1246 : 1660 : integer,allocatable :: requests(:)
1247 : : ! *************************************************************************
1248 : :
1249 : : ! Keep track of total time spent.
1250 : 1660 : call timab(1805, 1, tsec)
1251 : :
1252 : 1660 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
1253 : :
1254 : : ! Get number of perturbations computed for this iqpt as well as cplex.
1255 : 1660 : npc = dvdb_get_pinfo(db, iqpt, cplex, pinfo)
1256 [ - + ]: 1660 : ABI_CHECK(npc /= 0, "npc == 0!")
1257 : :
1258 [ - + + - : 9960 : ABI_MALLOC_OR_DIE(v1scf, (cplex, nfft, db%nspden, 3*db%natom), ierr)
- + + - -
+ + - + -
- + + - +
- + - + -
+ - - + +
- - + ]
1259 : :
1260 : : ! Master read all available perturbations and broadcasts data (non-blocking to overlap IO and MPI)
1261 [ - + + - : 4980 : ABI_MALLOC(requests, (npc))
+ - + - -
+ - + ]
1262 : :
1263 [ + + ]: 6964 : do ipc=1,npc
1264 : 5304 : idir = pinfo(1,ipc); ipert = pinfo(2,ipc); pcase = pinfo(3, ipc)
1265 [ + - ]: 5304 : if (my_rank == master) then
1266 [ - + ]: 5304 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf(:,:,:,pcase), msg) /= 0) then
1267 : 0 : ABI_ERROR(msg)
1268 : : end if
1269 : : end if
1270 [ - + ]: 6964 : if (nproc > 1) call xmpi_ibcast(v1scf(:,:,:,pcase), master, comm, requests(ipc), ierr)
1271 : : end do
1272 : :
1273 [ - + ]: 1660 : if (nproc > 1) call xmpi_waitall(requests, ierr)
1274 [ - + ]: 1660 : ABI_FREE(requests)
1275 : :
1276 : : ! Return if all perts are available.
1277 [ + + ]: 1660 : if (npc == 3*db%natom) then
1278 [ + + ]: 380 : if (db%symv1==1) then
1279 [ - + ]: 16 : if (db%debug) write(std_out,*)"Potentials are available but will call v1phq_symmetrize because of symv1"
1280 [ + + ]: 112 : do mu=1,db%natom3
1281 : : !if (mod(mu, nproc) /= my_rank) cycle ! MPI parallelism.
1282 : 96 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1283 : : call v1phq_symmetrize(db%cryst,idir,ipert,db%symq_table(:,:,:,iqpt),ngfft,cplex,nfft,&
1284 : 112 : db%nspden,db%nsppol,db%mpi_enreg,v1scf(:,:,:,mu))
1285 : : !call MPI_Ibcast(void *buffer, int count, MPI_Datatype datatype, int root, MPI_Comm comm, MPI_Request *request)
1286 : : end do
1287 : : end if
1288 [ - + ]: 380 : if (db%debug) write(std_out,*)"All perts available. Returning"
1289 : 380 : call timab(1805, 2, tsec)
1290 : : return
1291 : : end if
1292 : :
1293 : : ! Perturbation are missing and we have to reconstruct them by symmetry.
1294 : : ! This is the common case when DFPT calculations are done for independent perturbations only.
1295 [ - + ]: 1280 : if (db%debug) write(std_out,*)sjoin("Will use symmetries to recostruct:", itoa(3*db%natom - npc), "perturbations")
1296 : :
1297 : : ! 0 if pert is not available.
1298 : : ! 1 if pert is on file.
1299 : : ! 2 if pert has been reconstructed by symmetry.
1300 [ + + + + ]: 11240 : pflag = 0
1301 [ + + ]: 4364 : do ipc=1,npc
1302 : 4364 : pflag(pinfo(1,ipc), pinfo(2,ipc)) = 1
1303 : : end do
1304 : :
1305 : 1280 : call v1phq_complete(db%cryst,db%qpts(:,iqpt),ngfft,cplex,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,v1scf)
1306 : :
1307 : 1280 : call timab(1805, 2, tsec)
1308 : :
1309 : : end subroutine dvdb_readsym_allv1
1310 : : !!***
1311 : :
1312 : : !----------------------------------------------------------------------
1313 : :
1314 : : !!****f* m_dvdb/dvdb_readsym_qbz
1315 : : !! NAME
1316 : : !! dvdb_readsym_qbz
1317 : : !!
1318 : : !! FUNCTION
1319 : : !! This is the MAIN ENTRY POINT for client code.
1320 : : !! Reconstruct the DFPT potential for a q-point in the BZ starting
1321 : : !! from its symmetrical image in the IBZ.
1322 : : !!
1323 : : !! INPUTS
1324 : : !! cryst<crystal_t>=crystal structure parameters
1325 : : !! qbz(3)=Q-point in BZ.
1326 : : !! qbz2db(6)=Symmetry mapping qbz --> DVDB qpoints produced using the SYMREC convention.
1327 : : !! Note that qbz2db(1) should give the index in the set of q-points in the DVDB
1328 : : !! that is not necessarily ORDERED as the IBZ computed by the Abinit routines.
1329 : : !! nfft=Number of fft-points treated by this processors
1330 : : !! ngfft(18)=contain all needed information about 3D FFT
1331 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations.
1332 : : !!
1333 : : !! OUTPUT
1334 : : !! cplex=1 if real, 2 if complex.
1335 : : !! v1scf(cplex, nfft, nspden, db%my_npert)= v1scf potentials on the real-space FFT mesh
1336 : : !! for the db%my_npert perturbations treated by this MPI rank.
1337 : : !!
1338 : : !! SOURCE
1339 : :
1340 : 1285 : subroutine dvdb_readsym_qbz(db, cryst, qbz, qbz2db, cplex, nfft, ngfft, v1scf, comm)
1341 : :
1342 : : !Arguments ------------------------------------
1343 : : !scalars
1344 : : class(dvdb_t),intent(inout) :: db
1345 : : integer,intent(in) :: nfft,comm
1346 : : integer,intent(out) :: cplex
1347 : : type(crystal_t),intent(in) :: cryst
1348 : : !arrays
1349 : : real(dp),intent(in) :: qbz(3)
1350 : : integer,intent(in) :: ngfft(18), qbz2db(6)
1351 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
1352 : :
1353 : : !Local variables-------------------------------
1354 : : !scalars
1355 : : integer :: db_iqpt, itimrev, isym, imyp
1356 : : logical :: isirr_q
1357 : : !arrays
1358 : : integer :: g0q(3)
1359 : : real(dp) :: tsec(2)
1360 : 1285 : real(dp) ABI_ASYNC, allocatable :: work(:,:,:,:), work2(:,:,:,:)
1361 : : ! *************************************************************************
1362 : :
1363 : : ABI_UNUSED(qbz(1))
1364 : :
1365 : : ! Keep track of total time spent.
1366 : 1285 : call timab(1802, 1, tsec)
1367 : :
1368 : 1285 : db_iqpt = qbz2db(1)
1369 : :
1370 : : ! IS(q_dvdb) + g0q = q_bz
1371 [ + + ]: 5140 : isym = qbz2db(2); itimrev = qbz2db(6) + 1; g0q = qbz2db(3:5)
1372 [ + + + + : 4731 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
1373 : :
1374 : : ! Read the dvscf potentials in the IBZ for all 3*natom perturbations.
1375 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
1376 [ - + ]: 1285 : call db%readsym_allv1(db_iqpt, cplex, nfft, ngfft, v1scf, comm)
1377 : :
1378 [ + + ]: 1285 : if (.not. isirr_q) then
1379 : : ! Must rotate db_iqpt to get potential for qpoint in the BZ.
1380 : : ! Be careful with the shape of output v1scf because the routine returns db%my_npert potentials.
1381 : :
1382 [ + - ]: 702 : if (db%my_npert == db%natom3) then
1383 [ - + + - : 4212 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%natom3))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1384 [ + - + - : 154012518 : work = v1scf
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
1385 : : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1386 : 702 : db%nspden, db%mpi_enreg, work, v1scf, db%comm_pert)
1387 [ - + ]: 702 : ABI_FREE(work)
1388 : :
1389 : : else
1390 : : ! Parallelism over perturbations.
1391 [ # # # # : 0 : ABI_MALLOC(work2, (cplex, nfft, db%nspden, db%natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1392 : :
1393 : : ! All 3 natom have been read in v1scf by dvdb_readsym_allv1
1394 : : call v1phq_rotate(cryst, db%qpts(:, db_iqpt), isym, itimrev, g0q, ngfft, cplex, nfft, &
1395 : 0 : db%nspden, db%mpi_enreg, v1scf, work2, db%comm_pert)
1396 : :
1397 : : ! Reallocate v1scf with my_npert and extract data from work2.
1398 [ # # # # : 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1399 [ # # ]: 0 : do imyp=1,db%my_npert
1400 [ # # # # : 0 : v1scf(:,:,:,imyp) = work2(:,:,:,db%my_pinfo(3, imyp))
# # ]
1401 : : end do
1402 [ # # ]: 0 : ABI_FREE(work2)
1403 : : end if
1404 : :
1405 : : else
1406 : : ! Handle potentials read from file in case of parallelism over perturbations.
1407 [ - + ]: 583 : if (db%my_npert /= db%natom3) then
1408 [ # # # # : 0 : ABI_MALLOC(work, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1409 [ # # ]: 0 : do imyp=1,db%my_npert
1410 [ # # # # : 0 : work(:,:,:,imyp) = v1scf(:,:,:,db%my_pinfo(3, imyp))
# # ]
1411 : : end do
1412 : :
1413 [ # # # # : 0 : ABI_REMALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1414 [ # # # # : 0 : v1scf = work
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1415 [ # # ]: 0 : ABI_FREE(work)
1416 : : end if
1417 : : end if ! not isirr_q
1418 : :
1419 : 1285 : call timab(1802, 2, tsec)
1420 : :
1421 [ - + - + ]: 1285 : end subroutine dvdb_readsym_qbz
1422 : : !!***
1423 : :
1424 : : !----------------------------------------------------------------------
1425 : :
1426 : : !!****f* m_dvdb/dvdb_read_vxc1_qbz
1427 : : !! NAME
1428 : : !! dvdb_read_vxc1_qbz
1429 : : !!
1430 : : !! FUNCTION
1431 : : !! Compute the first-order change of the exchange-correlation potential
1432 : : !! for a q-point in the BZ starting from its symmetrical image in the IBZ.
1433 : : !!
1434 : : !! INPUTS
1435 : : !! cryst<crystal_t>=crystal structure parameters
1436 : : !! dtset<dataset_type>=All input variables for this dataset
1437 : : !! qbz(3)=Q-point in BZ.
1438 : : !! mapc_qq2dvdb(6)=Symmetry mapping qbz, see m_kpts.f for a description
1439 : : !! nfft=Number of fft-points treated by this processors
1440 : : !! ngfft(18)=contain all needed information about 3D FFT
1441 : : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
1442 : : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
1443 : : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
1444 : : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
1445 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
1446 : : !!
1447 : : !! OUTPUT
1448 : : !! drho_cplex=1 if real, 2 if complex.
1449 : : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
1450 : : !! for the db%my_npert perturbations treated by this MPI rank.
1451 : : !!
1452 : : !! SOURCE
1453 : :
1454 : 80 : subroutine dvdb_read_vxc1_qbz(db, dtset, cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, nkxc, kxc, &
1455 : : vxc1, non_magnetic_xc, usexcnhat, comm)
1456 : :
1457 : : !Arguments ------------------------------------
1458 : : !scalars
1459 : : class(dvdb_t),intent(inout) :: db
1460 : : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
1461 : : integer,intent(out) :: drho_cplex
1462 : : real(dp),intent(in) :: qbz(3)
1463 : : type(dataset_type),intent(in) :: dtset
1464 : : type(crystal_t),intent(in) :: cryst
1465 : : logical,intent(in) :: non_magnetic_xc
1466 : : !arrays
1467 : : integer,intent(in) :: ngfft(18), mapc_qq2dvdb(6)
1468 : : real(dp),intent(in) :: kxc(nfft,nkxc)
1469 : : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
1470 : :
1471 : : !Local variables-------------------------------
1472 : : !scalars
1473 : : integer :: option,imyp
1474 : : !arrays
1475 : 80 : real(dp),allocatable :: rho1(:,:,:,:)
1476 : : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
1477 : : ! *************************************************************************
1478 : :
1479 : : ! Get rho1(cplex, nfftf, nspden, my_npert))
1480 : 80 : call db%readsym_qbz(cryst, qbz, mapc_qq2dvdb, drho_cplex, nfft, ngfft, rho1, comm)
1481 : :
1482 : 80 : option=2 ! if 2, treat only density change
1483 [ - + + - : 480 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1484 [ + + ]: 560 : do imyp=1,db%my_npert
1485 : : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
1486 : : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp), &
1487 : 560 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
1488 : : end do
1489 [ - + ]: 80 : ABI_FREE(rho1)
1490 : :
1491 : 80 : end subroutine dvdb_read_vxc1_qbz
1492 : : !!***
1493 : :
1494 : : !----------------------------------------------------------------------
1495 : :
1496 : : !!****f* m_dvdb/v1phq_complete
1497 : : !! NAME
1498 : : !! v1phq_complete
1499 : : !!
1500 : : !! FUNCTION
1501 : : !! Use the symmetries of the little group of the q-point to reconstruct
1502 : : !! the first order potentials starting from an initial irreducible set.
1503 : : !!
1504 : : !! INPUTS
1505 : : !! cryst<crystal_t>=crystal structure parameters
1506 : : !! qpt(3)=q-point in reduced coordinates.
1507 : : !! ngfft(18)=Info of FFT grid.
1508 : : !! cplex=1 if real potentials (qpt==gamma), 2 if complex
1509 : : !! nfft=(effective) number of FFT grid points (for this proc).
1510 : : !! nspden=number of spin-density components
1511 : : !! nsppol=Number of independent spin polarizations
1512 : : !! mpi_enreg=information about MPI parallelization
1513 : : !! symv1=If 1, the new potentials are symmetrized using the set of symmetries that leaves the
1514 : : !! perturbation invariant.
1515 : : !!
1516 : : !! SIDE EFFECTS
1517 : : !! pflag(3,natom)= For each atomic perturbation:
1518 : : !! 0 if pert is not available. 1 if pert is available. 2 if pert has been reconstructed by symmetry.
1519 : : !! Initialized by the caller. Changed in output.
1520 : : !! v1scf(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials.
1521 : : !! in input: filled with the irreducible potentials (corresponding pflag set to 1)
1522 : : !! output: Contains full set of perturbations.
1523 : : !!
1524 : : !! SOURCE
1525 : :
1526 : 1280 : subroutine v1phq_complete(cryst,qpt,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,symv1,pflag,v1scf)
1527 : :
1528 : : !Arguments ------------------------------------
1529 : : !scalars
1530 : : integer,intent(in) :: cplex,nfft,nspden,nsppol
1531 : : integer,intent(in) :: symv1
1532 : : type(crystal_t),intent(in) :: cryst
1533 : : type(MPI_type),intent(in) :: mpi_enreg
1534 : : !arrays
1535 : : integer,intent(in) :: ngfft(18)
1536 : : integer,intent(inout) :: pflag(3, cryst%natom)
1537 : : real(dp),intent(in) :: qpt(3)
1538 : : real(dp),intent(inout) :: v1scf(cplex*nfft,nspden,3*cryst%natom)
1539 : :
1540 : : !Local variables-------------------------------
1541 : : !scalars
1542 : : integer,parameter :: syuse0=0,rfmeth2=2,tim_fourdp0=0
1543 : : integer :: idir,ipert,tsign,isym_eq,itirev_eq,ipert_eq !,itirev
1544 : : integer :: pcase,trev_q,idir_eq,pcase_eq,ispden,cnt
1545 : : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot
1546 : : real(dp) :: arg
1547 : : logical :: has_phase
1548 : : logical,parameter :: debug=.False.
1549 : : character(len=500) :: msg
1550 : : !integer,save :: enough=0
1551 : : !arrays
1552 : : integer :: symrel_eq(3,3),symrec_eq(3,3),g0_qpt(3),l0(3),tsm1g(3) !symm(3,3),
1553 : 2560 : integer :: symq(4,2,cryst%nsym)
1554 : : real(dp) :: phnon1(2),tnon(3)
1555 : 1280 : real(dp),allocatable :: workg(:,:), workg_eq(:,:),v1g(:,:,:)
1556 : : ! *************************************************************************
1557 : :
1558 [ + + ]: 5120 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
1559 [ - + ]: 1280 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
1560 : 1280 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
1561 : :
1562 [ - + + - : 5120 : ABI_MALLOC(v1g, (2,nfft,nspden))
- + + - +
- + - - +
- + ]
1563 [ - + + - : 3840 : ABI_MALLOC(workg_eq, (2, nfft))
+ - + - -
+ - + ]
1564 [ - + + - : 2560 : ABI_MALLOC(workg, (2, nfft))
- + - + ]
1565 : :
1566 : : ! Examine the symmetries of the q wavevector
1567 : 1280 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
1568 : :
1569 : : pcase_loop: &
1570 [ + + ]: 8750 : do pcase=1,3*cryst%natom
1571 : 7470 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
1572 [ + + ]: 7470 : if (pflag(idir, ipert) /= 0) cycle ! This pcase is available
1573 : :
1574 : : ! Find symmetry which links to the perturbation requested (pcase)
1575 : 4386 : call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1576 : : !if (isym_eq == -1) then
1577 : : ! call find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0=.true.)
1578 : : !end if
1579 : :
1580 [ + - ]: 4386 : if (isym_eq == -1) then
1581 : : if (debug) write(std_out,*)"Cannot find isym eq for idir, ipert:", idir,ipert
1582 : : cycle pcase_loop
1583 : : end if
1584 : :
1585 : : ! set flag since we will reconstruct pcase from isym_eq.
1586 : 4386 : pflag(idir, ipert) = 2
1587 : :
1588 [ + + + + ]: 57018 : symrel_eq = cryst%symrel(:,:,isym_eq)
1589 [ + + + + ]: 57018 : symrec_eq = cryst%symrec(:,:,isym_eq)
1590 : 4386 : tsign = 3-2*itirev_eq
1591 : :
1592 : : ! Phase due to L0 + R^{-1}tau
1593 [ + + ]: 17544 : l0 = cryst%indsym(1:3,isym_eq,ipert)
1594 : :
1595 [ + + + + : 122808 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym_eq))
+ + + + +
- + + ]
1596 [ + + + + ]: 10615 : has_phase = any(abs(tnon) > tol12)
1597 : : ! FIXME
1598 : : !ABI_CHECK(.not. has_phase, "has phase must be tested")
1599 : : !if (has_phase) then
1600 : : ! enough = enough + 1
1601 : : ! if (enough == 1) ABI_WARNING("has phase must be tested")
1602 : : !end if
1603 : :
1604 [ + + + + ]: 156331938 : workg = zero
1605 : :
1606 : : ! Reconstruct DFPT potential. Final results stored in v1g.
1607 : : if (debug) write(std_out,*)"Reconstructing idir:", idir, ", ipert:", ipert
1608 [ + + + + : 156336324 : v1g = zero; cnt = 0
+ + ]
1609 [ + + ]: 17544 : do idir_eq=1,3
1610 [ + + ]: 13158 : if (symrec_eq(idir, idir_eq) == 0) cycle
1611 : 5792 : cnt = cnt + 1
1612 : 5792 : pcase_eq = idir_eq + (ipert_eq-1)*3
1613 : : if (debug) write(std_out,*) "idir_eq: ", idir_eq, ", ipert_eq: ", ipert_eq, ", tsign: ", tsign
1614 : :
1615 [ - + ]: 5792 : if (pflag(idir_eq, ipert_eq) == 0) then
1616 : 0 : write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1617 : 0 : ABI_ERROR(msg)
1618 : : end if
1619 : :
1620 : : !if (pflag(idir_eq, ipert_eq) == 0) then
1621 : : ! write(msg, *)"pflag for idir_eq, ipert_eq", idir_eq, ipert_eq, "cannot be zero"
1622 : : ! ABI_ERROR(msg)
1623 : : !end if
1624 : :
1625 [ + + ]: 15970 : do ispden=1,nspden
1626 : : ! Get symmetric perturbation in G-space in workg_eq array.
1627 : 5792 : call fourdp(cplex,workg_eq,v1scf(:,ispden,pcase_eq),-1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1628 : : !call zerosym(workg_eq,cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1629 : :
1630 : : !call rotate_fqg(itirev_eq,symrec_eq,qpt,tnon,ngfft,nfft,nspden,workg_eq,workg)
1631 : 5792 : ind1=0
1632 [ + + ]: 125902 : do i3=1,n3
1633 : : ! Get location of G vector (grid point) centered at 0 0 0
1634 : 120110 : l3 = i3-(i3/id3)*n3-1
1635 [ + + ]: 2853400 : do i2=1,n2
1636 : 2727498 : l2 = i2-(i2/id2)*n2-1
1637 [ + + ]: 71026750 : do i1=1,n1
1638 : 68179142 : ind1=ind1+1
1639 : :
1640 : 68179142 : l1 = i1-(i1/id1)*n1-1
1641 : :
1642 : : ! Get rotated G vector Gj for each symmetry element
1643 : : ! -- here we use the TRANSPOSE of symrel_eq; assuming symrel_eq expresses
1644 : : ! the rotation in real space, the transpose is then appropriate
1645 : : ! for G space symmetrization (p. 1172d,e of notes, 2 June 1995).
1646 : 68179142 : j1 = tsign * (symrel_eq(1,1)*l1+symrel_eq(2,1)*l2+symrel_eq(3,1)*l3)
1647 : 68179142 : j2 = tsign * (symrel_eq(1,2)*l1+symrel_eq(2,2)*l2+symrel_eq(3,2)*l3)
1648 : 68179142 : j3 = tsign * (symrel_eq(1,3)*l1+symrel_eq(2,3)*l2+symrel_eq(3,3)*l3)
1649 : :
1650 : : ! FIXME :TO BE CLARIFIED:
1651 : : ! We are not working on the G-sphere thus SG may be outside
1652 : : ! of the box. This check is not done in irrzg!!!
1653 : : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
1654 [ + + + + : 68179142 : (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. &
+ + + - +
+ + + ]
1655 : : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
1656 : : !write(std_out,*)"got it"
1657 [ + + ]: 50844369 : workg(:, ind1) = zero; cycle
1658 : : end if
1659 : :
1660 [ + + ]: 204924076 : tsm1g = [j1,j2,j3] ! +- S^{-1} G
1661 : :
1662 : : ! Map into [0,n-1] and then add 1 for array index in [1,n]
1663 : 51231019 : k1=1+mod(n1+mod(j1,n1),n1)
1664 : 51231019 : k2=1+mod(n2+mod(j2,n2),n2)
1665 : 51231019 : k3=1+mod(n3+mod(j3,n3),n3)
1666 : :
1667 : : ! Get linear index of rotated point Gj
1668 : 51231019 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
1669 : :
1670 [ + + ]: 51231019 : if (has_phase) then
1671 : : ! compute exp(-2*Pi*I*G dot tau) using original G
1672 : : ! NB: this phase is same as that in irrzg and phnons1, and corresponds
1673 : : ! to complex conjugate of phase from G to Gj;
1674 : : ! we use it immediately below, to go _to_ workg_eq(ind1)
1675 [ + + ]: 114836952 : arg = two_pi * dot_product(qpt + tsm1g, tnon)
1676 : 28709238 : phnon1(1) = cos(arg); phnon1(2) = -sin(arg)
1677 : :
1678 : : ! rho(Strans*G)=exp(2*Pi*I*(G) dot tau_S) rho(G)
1679 : 28709238 : workg(1, ind1) = phnon1(1) * workg_eq(1, ind2) - phnon1(2) * workg_eq(2, ind2)
1680 : 28709238 : workg(2, ind1) = phnon1(1) * workg_eq(2, ind2) + phnon1(2) * workg_eq(1, ind2)
1681 : : else
1682 : 22521781 : workg(1, ind1) = workg_eq(1, ind2)
1683 : 22521781 : workg(2, ind1) = workg_eq(2, ind2)
1684 : : end if
1685 : :
1686 : : ! Take complex conjugate if time-reversal is used.
1687 [ + + ]: 53958517 : if (tsign == -1) workg(2, ind1) = -workg(2, ind1)
1688 : : end do
1689 : : end do
1690 : : end do
1691 : :
1692 [ + + + + ]: 204556376 : v1g(:,:,ispden) = v1g(:,:,ispden) + workg * symrec_eq(idir, idir_eq)
1693 : : end do ! ispden
1694 : : end do ! idir_eq
1695 : : !if (debug) write(std_out,*)"Used ",cnt," equivalent perturbations"
1696 : :
1697 : : ! Get potential in real space (results in v1scf)
1698 [ + + ]: 8772 : do ispden=1,nspden
1699 : : !call zerosym(v1g(:,:,ispden),cplex,n1,n2,n3,comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
1700 : 4386 : call fourdp(cplex,v1g(:,:,ispden),v1scf(:,ispden,pcase),+1,mpi_enreg,nfft,1,ngfft,tim_fourdp0)
1701 : :
1702 : : ! IS(q) = q + G0
1703 : : ! we want q so we have to multiply by exp(iG0r) in real space.
1704 [ + + + + : 16731 : if (any(g0_qpt /= 0)) then
+ + ]
1705 [ - + ]: 1802 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1706 : : if (debug) write(std_out,*)"Found not zero g0_qpt", g0_qpt ! for idir: ", idir, ", ipert: ", ipert
1707 : 1802 : call times_eigr(g0_qpt, ngfft, nfft, 1, v1scf(:,ispden,pcase))
1708 : : end if
1709 : : end do
1710 : :
1711 [ + + ]: 5666 : if (symv1 == 1) then
1712 : : if (debug) write(std_out,*)" Calling v1phq_symmetrize"
1713 : 376 : call v1phq_symmetrize(cryst,idir,ipert,symq,ngfft,cplex,nfft,nspden,nsppol,mpi_enreg,v1scf(:,:,pcase))
1714 : : end if
1715 : : end do pcase_loop
1716 : :
1717 [ - + ]: 1280 : ABI_FREE(v1g)
1718 [ - + ]: 1280 : ABI_FREE(workg)
1719 [ - + ]: 1280 : ABI_FREE(workg_eq)
1720 : :
1721 : : ! Handle possible error.
1722 [ + + + + : 11240 : if (any(pflag == 0)) then
+ - - + ]
1723 [ # # ]: 0 : write(std_out,"(2a)")"The following perturbations cannot be recostructed by symmetry for q-point: ",trim(ktoa(qpt))
1724 [ # # ]: 0 : do ipert=1,cryst%natom
1725 [ # # ]: 0 : do idir=1,3
1726 [ # # ]: 0 : if (pflag(idir, ipert) == 0) write(std_out,"(2(a,i0))")"idir= ",idir,", ipert= ",ipert
1727 : : end do
1728 : : end do
1729 : : write(msg,"(5a)")&
1730 : 0 : "Cannot recostruct all 3*natom atomic perturbations from file",ch10,&
1731 : 0 : "This usually happens when the DVDB does not contain all the independent perturbations for this q-point",ch10,&
1732 : 0 : "See above message for further information."
1733 : 0 : ABI_ERROR(msg)
1734 : : end if
1735 : :
1736 : 1280 : end subroutine v1phq_complete
1737 : : !!***
1738 : :
1739 : : !----------------------------------------------------------------------
1740 : :
1741 : : !!****f* m_dvdb/find_symeq
1742 : : !! NAME
1743 : : !! find_symeq
1744 : : !!
1745 : : !! FUNCTION
1746 : : !! Find symmetry which links to the perturbation specified by (idir, ipert)
1747 : : !!
1748 : : !! INPUTS
1749 : : !! cryst<crystal_t>=crystal structure parameters
1750 : : !! idir=Direction of the perturbation
1751 : : !! ipert=Perturbation type.
1752 : : !! symq(4,2,nsym)=Table produced by littlegroup_q for this q-point.
1753 : : !! pflag(3,natom)= For each atomic perturbation:
1754 : : !! 0 if pert is not available. 1 if pert is available. 2 if pert can been reconstructed by symmetry.
1755 : : !!
1756 : : !! OUTPUT
1757 : : !! ipert_eq
1758 : : !! isym_eq
1759 : : !! itirev_eq
1760 : : !! g0_qpt(3)
1761 : : !!
1762 : : !! SOURCE
1763 : :
1764 : 4386 : subroutine find_symeq(cryst, idir, ipert, symq, pflag, ipert_eq, isym_eq, itirev_eq, g0_qpt, allow_g0)
1765 : :
1766 : : !Arguments ------------------------------------
1767 : : !scalars
1768 : : integer,intent(in) :: idir,ipert
1769 : : integer,intent(out) :: ipert_eq,isym_eq,itirev_eq
1770 : : type(crystal_t),intent(in) :: cryst
1771 : : logical,optional :: allow_g0
1772 : : !arrays
1773 : : integer,intent(in) :: symq(4,2,cryst%nsym),pflag(3,cryst%natom)
1774 : : integer,intent(out) :: g0_qpt(3)
1775 : :
1776 : : !Local variables-------------------------------
1777 : : !scalars
1778 : : logical :: do_allow_g0
1779 : : integer :: isym,idir_eq,ip,itirev
1780 : : ! *************************************************************************
1781 : :
1782 : 4386 : isym_eq = -1; ipert_eq = -1
1783 [ + - ]: 4386 : do_allow_g0 = .true.; if (present(allow_g0)) do_allow_g0 = allow_g0
1784 : :
1785 : : symloop: &
1786 [ + - ]: 4687 : do itirev=1,2
1787 : 4687 : itirev_eq = itirev
1788 [ + + ]: 54562 : do isym=1,cryst%nsym
1789 : :
1790 : : ! Check that isym preserves the q-point
1791 : : ! The condition is
1792 : : !
1793 : : ! $q = O S(q) - G$
1794 : : !
1795 : : ! with O being either the identity or the time reversal symmetry (= inversion in reciprocal space)
1796 : : ! and G being a primitive vector of the reciprocal lattice.
1797 : :
1798 : : !if (symq(4,itirev,isym) /= 1 .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1799 [ + + ]: 49875 : if (symq(4,itirev,isym) /= 1) cycle ! .or. any(symq(1:3,itirev,isym) /= 0)) cycle
1800 [ + + + + : 60918 : if (any(symq(1:3,itirev,isym) /= 0) .and. .not. do_allow_g0) cycle
- + ]
1801 [ + + ]: 72440 : g0_qpt = symq(1:3,itirev,isym)
1802 : :
1803 : : ! indsym map is computed in symatm.
1804 [ + + ]: 46354 : do ip=1,cryst%natom
1805 : : !if (.not. cryst%indsym(4,isym,ip) == ipert) cycle
1806 [ + + ]: 32329 : if (.not. cryst%indsym(4,isym,ipert) == ip) cycle
1807 : 18110 : isym_eq = isym; ipert_eq = ip
1808 [ + + ]: 72440 : do idir_eq=1,3
1809 [ + + + + : 54330 : if (idir_eq == idir .and. ip == ipert .and. cryst%symrec(idir,idir_eq,isym) /= 0) isym_eq = -1
+ + ]
1810 [ + + + + ]: 72440 : if (cryst%symrec(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1811 : : !if (cryst%symrel(idir,idir_eq,isym) /= 0 .and. pflag(idir_eq, ip) == 0) then
1812 : : !if (idir_eq == idir .and. ip == ipert) cycle
1813 : 16209 : isym_eq = -1
1814 : : end if
1815 : : end do
1816 [ + + ]: 63599 : if (isym_eq /= -1) exit symloop
1817 : : end do
1818 : : end do
1819 : : end do symloop
1820 : :
1821 [ - + ]: 4386 : if (isym_eq == -1) then
1822 : 0 : ipert_eq = -1; itirev_eq = -1
1823 : : end if
1824 : :
1825 : 4386 : end subroutine find_symeq
1826 : : !!***
1827 : :
1828 : : !----------------------------------------------------------------------
1829 : :
1830 : : !!****f* m_dvdb/v1phq_rotate
1831 : : !! NAME
1832 : : !! v1phq_rotate
1833 : : !!
1834 : : !! FUNCTION
1835 : : !! Reconstruct all the DFPT potential for a q-point in the BZ (qpt_bz) starting from its symmetrical image in the IBZ (q_ibz)
1836 : : !!
1837 : : !! INPUTS
1838 : : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1839 : : !! cryst<crystal_t>=crystal structure parameters
1840 : : !! isym, itimrev, g0q: Symmetry indices and umklapp. The q-point in the BZ is given by:
1841 : : !!
1842 : : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
1843 : : !!
1844 : : !! where S is symrec(:,:,isym)
1845 : : !! ngfft=array of dimensions for different FFT grids
1846 : : !! ngfft(18)=contain all needed information about 3D FFT.
1847 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
1848 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
1849 : : !! nspden=number of spin-density components
1850 : : !! mpi_enreg=information about MPI parallelization
1851 : : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
1852 : : !! for the irreducible q-point `qpt_ibz`
1853 : : !! comm: MPI communicator to distribute natom3 * nspden FFT calls
1854 : : !!
1855 : : !! OUTPUT
1856 : : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
1857 : : !!
1858 : : !! SOURCE
1859 : :
1860 : 2050 : subroutine v1phq_rotate(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
1861 : 2050 : mpi_enreg, v1r_qibz, v1r_qbz, comm)
1862 : :
1863 : : !Arguments ------------------------------------
1864 : : !scalars
1865 : : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, comm
1866 : : type(crystal_t),intent(in) :: cryst
1867 : : type(MPI_type),intent(in) :: mpi_enreg
1868 : : !arrays
1869 : : integer,intent(in) :: g0q(3),ngfft(18)
1870 : : real(dp),intent(in) :: qpt_ibz(3)
1871 : : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
1872 : : real(dp) ABI_ASYNC, intent(out) :: v1r_qbz(cplex*nfft,nspden,3*cryst%natom)
1873 : :
1874 : : !Local variables-------------------------------
1875 : : !scalars
1876 : : integer,parameter :: tim_fourdp0 = 0
1877 : : !integer,save :: enough = 0
1878 : : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,my_rank,nproc,ierr,root
1879 : : !arrays
1880 : : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
1881 : : real(dp) :: tnon(3), tsec(2)
1882 : 2050 : real(dp) ABI_ASYNC, allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
1883 : 4100 : integer :: requests(nspden, 3*cryst%natom), requests_v1r_qbz(3*cryst%natom)
1884 : 4100 : logical :: requests_v1g_qibz_done(nspden, 3*cryst%natom)
1885 : : ! *************************************************************************
1886 : :
1887 : : ! Keep track of total time spent.
1888 : 2050 : call timab(1804, 1, tsec)
1889 : :
1890 [ - + ]: 2050 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
1891 : :
1892 : 2050 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1893 : 2050 : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
1894 : :
1895 : : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
1896 [ + - - + : 10250 : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
1897 [ + + + + ]: 25612 : requests_v1g_qibz_done = .False.
1898 : : cnt = 0
1899 [ + + ]: 13831 : do mu=1,natom3
1900 [ + + ]: 25612 : do ispden=1,nspden
1901 : 11781 : cnt = cnt + 1; root = mod(cnt, nproc)
1902 [ + - ]: 11781 : if (root == my_rank) then ! Non-blocking
1903 : 11781 : call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1904 : : end if
1905 : 23562 : call xmpi_ibcast(v1g_qibz(:,ispden,mu), root, comm, requests(ispden, mu), ierr)
1906 : : end do
1907 : : end do
1908 : :
1909 [ - + + - : 8200 : ABI_MALLOC(workg, (2*nfft, nspden))
- + + - +
- + - - +
- + - + ]
1910 [ - + + - : 6150 : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
- + + - -
+ - + -
+ ]
1911 : :
1912 [ + + + + ]: 26650 : symrec_eq = cryst%symrec(:,:,isym)
1913 : : ! Compute sm1 = symrec_eq^{-1}
1914 [ + + + + : 51250 : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
+ + + + ]
1915 : :
1916 : : ! For each perturbation (idir, ipert, qpt_bz), rotate the symmetrical potentials at (idir_eq, ipert_eq, q_ibz)
1917 : : ! computed in g-space and take linear combinations using symrec_eq(idir, idir_eq).
1918 : : ! Finally, perform g -- >r FFTs of the potentials at qpt_bz and multiply by e^{-ig0.r} to account for umklapp.
1919 : :
1920 : : ! See Eq C2 in [[cite:Brunin2020b]] 10.1103/PhysRevB.102.094308
1921 [ + + ]: 13831 : do mu=1,natom3
1922 : 11781 : root = mod(mu, nproc)
1923 : : ! MPI parallelism.
1924 [ + - ]: 11781 : if (root == my_rank) then
1925 : 11781 : idir = mod(mu-1, 3) + 1; ipert = (mu - idir) / 3 + 1
1926 : :
1927 : : ! Phase due to L0 + R^{-1} tau where R is a symrel operation hence R^{-1} = symrec_eq^T
1928 [ + + ]: 47124 : l0 = cryst%indsym(1:3,isym,ipert)
1929 [ + + + + : 329868 : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
+ + + + +
- + + ]
1930 : : !if (.not. all(abs(tnon) < tol12)) then
1931 : : ! enough = enough + 1
1932 : : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
1933 : : !end if
1934 : :
1935 : 11781 : ipert_eq = cryst%indsym(4, isym, ipert)
1936 : :
1937 [ + + + + ]: 236947674 : v1g_mu = zero; cnt = 0
1938 [ + + ]: 47124 : do idir_eq=1,3
1939 [ + + ]: 35343 : if (symrec_eq(idir, idir_eq) == 0) cycle
1940 : 18377 : mu_eq = idir_eq + (ipert_eq - 1) * 3
1941 : 18377 : cnt = cnt + 1
1942 : :
1943 : : ! Wait for request before operating on v1g_qibz
1944 [ + + + + : 24973 : if (.not. all(requests_v1g_qibz_done(:, mu_eq))) then
+ + ]
1945 [ + + ]: 23562 : do ispden=1,nspden
1946 : 11781 : call xmpi_wait(requests(ispden, mu_eq), ierr)
1947 : 23562 : requests_v1g_qibz_done(ispden, mu_eq) = .True.
1948 : : end do
1949 : : end if
1950 : :
1951 : : ! Rotate in G-space: output in workg
1952 : 18377 : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
1953 : : ! And accumulate in v1g_mu
1954 [ + - + - : 367576854 : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
- + - - +
+ + + ]
1955 : : end do ! idir_eq
1956 : :
1957 [ - + ]: 11781 : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
1958 : :
1959 : : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
1960 [ + + ]: 23562 : do ispden=1,nspden
1961 : 11781 : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, mu), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
1962 [ + + ]: 58905 : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, mu))
1963 : : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,mu))
1964 : : end do
1965 : :
1966 : : end if ! root == myrank
1967 : :
1968 : 13831 : call xmpi_ibcast(v1r_qbz(:,:,mu), root, comm, requests_v1r_qbz(mu), ierr)
1969 : : end do ! mu
1970 : :
1971 : : ! Release all requests
1972 : 2050 : call xmpi_waitall(requests, ierr)
1973 : 2050 : call xmpi_waitall(requests_v1r_qbz, ierr)
1974 : :
1975 [ - + ]: 2050 : ABI_FREE(workg)
1976 [ - + ]: 2050 : ABI_FREE(v1g_mu)
1977 [ - + ]: 2050 : ABI_FREE(v1g_qibz)
1978 : :
1979 : 2050 : call timab(1804, 2, tsec)
1980 : :
1981 [ - + - + : 2050 : end subroutine v1phq_rotate
- + ]
1982 : : !!***
1983 : :
1984 : : !----------------------------------------------------------------------
1985 : :
1986 : : !!****f* m_dvdb/v1phq_rotate_myperts
1987 : : !! NAME
1988 : : !! v1phq_rotate_myperts
1989 : : !!
1990 : : !! FUNCTION
1991 : : !! Reconstruct all the DFPT potential for a q-point in the BZ starting from its symmetrical image in the IBZ.
1992 : : !!
1993 : : !! INPUTS
1994 : : !! cryst<crystal_t>=crystal structure parameters
1995 : : !! qpt_ibz(3)=q-point in the IBZ in reduced coordinates.
1996 : : !! ngfft=array of dimensions for different FFT grids
1997 : : !! isym, itimrev, g0q:
1998 : : !! qpt_bz = I(itimrev) S(isym) q_ibz + g0q
1999 : : !! ngfft(18)=contain all needed information about 3D FFT.
2000 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2001 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2002 : : !! nspden=number of spin-density components
2003 : : !! mpi_enreg=information about MPI parallelization
2004 : : !! v1r_qibz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space
2005 : : !! for the irreducible q-point `qpt_ibz`
2006 : : !!
2007 : : !! OUTPUT
2008 : : !! v1r_qbz(cplex*nfft,nspden,3*cryst%natom)=Array with first order potentials in real space for the q-point in the BZ
2009 : : !!
2010 : : !! SOURCE
2011 : :
2012 : : subroutine v1phq_rotate_myperts(cryst, qpt_ibz, isym, itimrev, g0q, ngfft, cplex, nfft, nspden, &
2013 : : mpi_enreg, my_npert, my_pinfo, v1r_qibz, v1r_qbz)
2014 : :
2015 : : !Arguments ------------------------------------
2016 : : !scalars
2017 : : integer,intent(in) :: isym, itimrev, cplex, nfft, nspden, my_npert
2018 : : type(crystal_t),intent(in) :: cryst
2019 : : type(MPI_type),intent(in) :: mpi_enreg
2020 : : !arrays
2021 : : integer,intent(in) :: g0q(3), ngfft(18), my_pinfo(3, my_npert)
2022 : : real(dp),intent(in) :: qpt_ibz(3)
2023 : : real(dp),intent(inout) :: v1r_qibz(cplex*nfft,nspden,3*cryst%natom)
2024 : : real(dp),intent(out) :: v1r_qbz(cplex*nfft,nspden,my_npert)
2025 : :
2026 : : !Local variables-------------------------------
2027 : : !scalars
2028 : : integer,parameter :: tim_fourdp0 = 0
2029 : : !integer,save :: enough = 0
2030 : : integer :: natom3,mu,ispden,idir,ipert,idir_eq,ipert_eq,mu_eq,cnt,tsign,imyp !ierr,
2031 : : !arrays
2032 : : integer :: symrec_eq(3,3),sm1(3,3),l0(3) !g0_qpt(3), symrel_eq(3,3),
2033 : : logical :: fourdp_done(3*cryst%natom)
2034 : : real(dp) :: tnon(3), tsec(2)
2035 : : real(dp), allocatable :: v1g_qibz(:,:,:),workg(:,:),v1g_mu(:,:)
2036 : : ! *************************************************************************
2037 : :
2038 : : ! Keep track of total time spent.
2039 : : call timab(1804, 1, tsec)
2040 : :
2041 : : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
2042 : :
2043 : : natom3 = 3 * cryst%natom; tsign = 3-2*itimrev
2044 : :
2045 : : ! Compute IBZ potentials in G-space. Results stored in v1g_qibz(G)
2046 : : fourdp_done = .False.
2047 : : ABI_MALLOC(v1g_qibz, (2*nfft, nspden, natom3))
2048 : : !do mu=1,natom3
2049 : : ! do ispden=1,nspden
2050 : : ! call fourdp(cplex, v1g_qibz(:,ispden,mu), v1r_qibz(:,ispden,mu), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2051 : : ! end do
2052 : : !end do
2053 : :
2054 : : ABI_MALLOC(workg, (2*nfft, nspden))
2055 : : ABI_MALLOC(v1g_mu, (2*nfft, nspden))
2056 : :
2057 : : symrec_eq = cryst%symrec(:,:,isym)
2058 : : call mati3inv(symrec_eq, sm1); sm1 = transpose(sm1)
2059 : :
2060 : : ! For each perturbation treated by this MPI proc
2061 : : do imyp=1,my_npert
2062 : : idir = my_pinfo(1, imyp); ipert = my_pinfo(2, imyp); mu = my_pinfo(3, imyp)
2063 : :
2064 : : ! Phase due to L0 + R^{-1}tau
2065 : : l0 = cryst%indsym(1:3,isym,ipert)
2066 : : tnon = l0 + matmul(transpose(symrec_eq), cryst%tnons(:,isym))
2067 : : !if (.not. all(abs(tnon) < tol12)) then
2068 : : ! enough = enough + 1
2069 : : ! if (enough == 1) ABI_WARNING("tnon must be tested!")
2070 : : !end if
2071 : :
2072 : : ipert_eq = cryst%indsym(4, isym, ipert)
2073 : :
2074 : : v1g_mu = zero; cnt = 0
2075 : : do idir_eq=1,3
2076 : : if (symrec_eq(idir, idir_eq) == 0) cycle
2077 : : mu_eq = idir_eq + (ipert_eq - 1) * 3
2078 : : cnt = cnt + 1
2079 : :
2080 : : if (.not. fourdp_done(mu_eq)) then
2081 : : do ispden=1,nspden
2082 : : call fourdp(cplex, v1g_qibz(:,ispden,mu_eq), v1r_qibz(:,ispden,mu_eq), -1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2083 : : end do
2084 : : fourdp_done(mu_eq) = .True.
2085 : : end if
2086 : :
2087 : : ! Rotate in G-space and accumulate in workg
2088 : : call rotate_fqg(itimrev, sm1, qpt_ibz, tnon, ngfft, nfft, nspden, v1g_qibz(:,:,mu_eq), workg)
2089 : : v1g_mu = v1g_mu + workg * symrec_eq(idir, idir_eq)
2090 : : end do ! idir_eq
2091 : :
2092 : : ABI_CHECK(cnt /= 0, "cnt should not be zero!")
2093 : :
2094 : : ! Transform to real space and take into account a possible shift. Results are stored in v1r_qbz.
2095 : : do ispden=1,nspden
2096 : : call fourdp(cplex, v1g_mu(:, ispden), v1r_qbz(:, ispden, imyp), +1, mpi_enreg, nfft, 1, ngfft, tim_fourdp0)
2097 : : call times_eigr(-g0q, ngfft, nfft, 1, v1r_qbz(:, ispden, imyp))
2098 : : !call times_eigr(tsign * g0q, ngfft, nfft, 1, v1r_qbz(:,ispden,imyp))
2099 : : end do
2100 : :
2101 : : end do ! imyp
2102 : :
2103 : : ABI_FREE(workg)
2104 : : ABI_FREE(v1g_mu)
2105 : : ABI_FREE(v1g_qibz)
2106 : :
2107 : : call timab(1804, 2, tsec)
2108 : :
2109 : : end subroutine v1phq_rotate_myperts
2110 : : !!***
2111 : :
2112 : : !!****f* m_dvdb/v1phq_symmetrize
2113 : : !! NAME
2114 : : !! v1phq_symmetrize
2115 : : !!
2116 : : !! FUNCTION
2117 : : !! Enforce spatial-symmetry on the DFPT potential.
2118 : : !!
2119 : : !! INPUTS
2120 : : !! cryst<crystal_t>=crystal structure parameters
2121 : : !! idir=Direction of the perturbation
2122 : : !! ipert=Perturbation type.
2123 : : !! symq(4,2,nsym)= Table computed by littlegroup_q.
2124 : : !! three first numbers define the G vector;
2125 : : !! fourth number is zero if the q-vector is not preserved, is 1 otherwise
2126 : : !! second index is one without time-reversal symmetry, two with time-reversal symmetry
2127 : : !! ngfft=array of dimensions for different FFT grids
2128 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2129 : : !! nfft=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
2130 : : !! nspden=number of spin-density components
2131 : : !! mpi_enreg=information about MPI parallelization
2132 : : !!
2133 : : !! SIDE EFFECTS
2134 : : !! v1r(cplex*nfft,nspden)=Array with first order potentials in real space. Symmetrized in output.
2135 : : !!
2136 : : !! SOURCE
2137 : :
2138 : 1718 : subroutine v1phq_symmetrize(cryst, idir, ipert, symq, ngfft, cplex, nfft, nspden, nsppol, mpi_enreg, v1r)
2139 : :
2140 : : !Arguments ------------------------------------
2141 : : !scalars
2142 : : integer,intent(in) :: idir, ipert, cplex, nfft, nspden, nsppol
2143 : : type(crystal_t),intent(in) :: cryst
2144 : : type(MPI_type),intent(in) :: mpi_enreg
2145 : : !arrays
2146 : : integer,intent(in) :: symq(4,2,cryst%nsym),ngfft(18)
2147 : : real(dp),intent(inout) :: v1r(cplex*nfft,nspden)
2148 : :
2149 : : !Local variables-------------------------------
2150 : : integer,parameter :: syuse0 = 0, rfmeth2 = 2, iscf1 = 1
2151 : : integer :: nsym1, nfftot
2152 : : !arrays
2153 : 3436 : integer :: symafm1(cryst%nsym),symrel1(3,3,cryst%nsym),symrc1(3,3,cryst%nsym)
2154 : 1718 : integer,allocatable :: irrzon1(:,:,:),indsy1(:,:,:)
2155 : 0 : real(dp) :: tnons1(3,cryst%nsym)
2156 : 1718 : real(dp),allocatable :: phnons1(:,:,:),v1g(:,:)
2157 : : ! *************************************************************************
2158 : :
2159 [ - + ]: 1718 : if (cryst%nsym == 1) return
2160 : :
2161 [ + + ]: 6872 : nfftot = product(ngfft(1:3))
2162 [ - + ]: 1718 : ABI_CHECK(nfft == nfftot, "MPI-FFT not coded")
2163 : :
2164 : : ! Symmetrize (copied from dfpt_looppert)
2165 : : ! Determines the set of symmetries that leaves the perturbation invariant.
2166 : : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
2167 : 1718 : cryst%symafm,symafm1,symq,cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,tnons1,unit=dev_null)
2168 : :
2169 : : ! Set up corresponding symmetry data
2170 [ - + + - : 6872 : ABI_MALLOC(irrzon1, (nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4)))
- + + - +
- + - - +
- + ]
2171 [ - + + - : 6872 : ABI_MALLOC(phnons1, (2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4)))
- + + - +
- + - - +
- + ]
2172 [ - + + - : 6872 : ABI_MALLOC(indsy1,(4,nsym1,cryst%natom))
- + + - +
- + - - +
- + ]
2173 : :
2174 : : call setsym(indsy1,irrzon1,iscf1,cryst%natom,nfft,ngfft,nspden,nsppol,&
2175 : 1718 : nsym1,phnons1,symafm1,symrc1,symrel1,tnons1,cryst%typat,cryst%xred)
2176 : :
2177 : : !if (psps%usepaw==1) then
2178 : : ! ! Allocate/initialize only zarot in pawang1 datastructure
2179 : : ! call pawang_init(pawang1,0,0,pawang%l_max-1,0,0,nsym1,0,0,0,0)
2180 : : ! call setsym_ylm(gprimd,pawang1%l_max-1,pawang1%nsym,0,rprimd,symrc1,pawang1%zarot)
2181 : : !end if
2182 : :
2183 : : ! FIXME Be careful here because symrhg was written for densities!
2184 [ + - - + ]: 1718 : ABI_CHECK(nsppol == 1 .and. nspden == 1, "symrhg was written for densities, not for potentials")
2185 : :
2186 [ - + + - : 5154 : ABI_MALLOC(v1g, (2,nfft))
+ - + - -
+ - + ]
2187 : : call symrhg(cplex,cryst%gprimd,irrzon1,mpi_enreg,nfft,nfftot,ngfft,nspden,nsppol,nsym1,&
2188 : 1718 : phnons1,v1g,v1r,cryst%rprimd,symafm1,symrel1,tnons1)
2189 : :
2190 [ - + ]: 1718 : ABI_FREE(irrzon1)
2191 [ - + ]: 1718 : ABI_FREE(phnons1)
2192 [ - + ]: 1718 : ABI_FREE(indsy1)
2193 [ - + ]: 1718 : ABI_FREE(v1g)
2194 : :
2195 : : end subroutine v1phq_symmetrize
2196 : : !!***
2197 : :
2198 : : !----------------------------------------------------------------------
2199 : :
2200 : : !!****f* m_dvdb/rotate_fqg
2201 : : !! NAME
2202 : : !! rotate_fqg
2203 : : !!
2204 : : !! FUNCTION
2205 : : !! Rotate density/potential infg_q(g) in g-space to obtain outfg_{ISq}(g)
2206 : : !!
2207 : : !! INPUTS
2208 : : !! itirev=2 if time-reversal symmetry should be used, 1 otherwise.
2209 : : !! symm(3,3)=Symmetry operation S in reciprocal space.
2210 : : !! NB: symm usually corresponds to the inverso of one of the symrec operations.
2211 : : !! qpt(3)=q-point in the IBZ (this is the q-point associated to infg)
2212 : : !! tnon(3)=Fractional translation associate the the symmetry operation.
2213 : : !! ngfft(18)=contain all needed information about 3D FFT.
2214 : : !! nfft=Number of fft-points treated by this processors
2215 : : !! nspden=number of spin-density components
2216 : : !! infg(2,nfft,nspden)=Input array in g-space on the FFT box.
2217 : : !!
2218 : : !! OUTPUTS
2219 : : !! outfg(2,nfft,nspden)= Input array in g-space on the FFT box. In pseudo-equation:
2220 : : !!
2221 : : !! outfg(g) = infg(IS G) e^{-i(IS^{-1} G)} exp(2*pi*I*(G) dot tau_S) rho(IS^{-1} G)
2222 : : !!
2223 : : !! SOURCE
2224 : :
2225 : 18377 : subroutine rotate_fqg(itirev, symm, qpt, tnon, ngfft, nfft, nspden, infg, outfg)
2226 : :
2227 : : !Arguments ------------------------------------
2228 : : !scalars
2229 : : integer,intent(in) :: itirev,nfft,nspden
2230 : : !arrays
2231 : : integer,intent(in) :: symm(3,3),ngfft(18)
2232 : : real(dp),intent(in) :: qpt(3),tnon(3)
2233 : : real(dp),intent(in) :: infg(2,nfft,nspden)
2234 : : real(dp),intent(out) :: outfg(2,nfft,nspden)
2235 : :
2236 : : !Local variables-------------------------------
2237 : : !scalars
2238 : : integer :: i1,i2,i3,id1,id2,id3,n1,n2,n3,ind1,ind2,j1,j2,j3,l1,l2,l3,k1,k2,k3,nfftot,isp,tsign
2239 : : real(dp) :: arg
2240 : : logical :: has_phase
2241 : : !arrays
2242 : : integer :: tsg(3)
2243 : : real(dp) :: phnon1(2), tsec(2)
2244 : : ! *************************************************************************
2245 : :
2246 : : ! Keep track of total time spent.
2247 : 18377 : call timab(1803, 1, tsec)
2248 : :
2249 [ + + ]: 73508 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
2250 [ - + ]: 18377 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
2251 : 18377 : id1 = n1/2+2; id2 = n2/2+2; id3=n3/2+2
2252 : :
2253 [ - + ]: 18377 : ABI_CHECK(any(itirev == [1, 2]), "Wrong itirev")
2254 [ + + + + ]: 53619 : tsign = 3-2*itirev; has_phase = any(abs(tnon) > tol12)
2255 : :
2256 : : !outfg = zero
2257 : :
2258 [ + + ]: 36754 : do isp=1,nspden
2259 : : ind1 = 0
2260 [ + + ]: 376070 : do i3=1,n3
2261 : : ! Get location of G vector (grid point) centered at 0 0 0
2262 : 339316 : l3 = i3-(i3/id3)*n3-1
2263 [ + + ]: 7781485 : do i2=1,n2
2264 : 7423792 : l2 = i2-(i2/id2)*n2-1
2265 [ + + ]: 191509596 : do i1=1,n1
2266 : 183746488 : ind1 = ind1 + 1
2267 : : !ind1 = 1 + i1 + (i2-1)*n1 + (i3-1)*n1*n2
2268 : : !if (mod(ind1, nprocs) /= my_rank) cycle
2269 : :
2270 : 183746488 : l1 = i1-(i1/id1)*n1-1
2271 : :
2272 : : ! Get rotated G vector: IS(G)
2273 : 183746488 : j1 = tsign * (symm(1,1)*l1+symm(1,2)*l2+symm(1,3)*l3)
2274 : 183746488 : j2 = tsign * (symm(2,1)*l1+symm(2,2)*l2+symm(2,3)*l3)
2275 : 183746488 : j3 = tsign * (symm(3,1)*l1+symm(3,2)*l2+symm(3,3)*l3)
2276 : :
2277 : : ! FIXME :TO BE CLARIFIED:
2278 : : ! We are not working on the G-sphere thus SG may be outside
2279 : : ! of the box. This check is not done in irrzg!!!
2280 : : if ( (j1 > n1/2 .or. j1 < -(n1-1)/2) .or. &
2281 [ + + + + : 183746488 : (j2 > n2/2 .or. j1 < -(n2-1)/2) .or. &
+ + + - +
+ + + ]
2282 : : (j3 > n3/2 .or. j3 < -(n3-1)/2) ) then
2283 : : !write(std_out,*)"outsize box!"
2284 [ + + ]: 176108448 : outfg(:,ind1,isp) = zero
2285 : : cycle
2286 : : end if
2287 : :
2288 [ + + ]: 500174688 : tsg = [j1,j2,j3] ! IS^{-1} G
2289 : :
2290 : : ! Map into [0,n-1] and then add 1 for array index in [1, n]
2291 : 125043672 : k1=1+mod(n1+mod(j1,n1),n1)
2292 : 125043672 : k2=1+mod(n2+mod(j2,n2),n2)
2293 : 125043672 : k3=1+mod(n3+mod(j3,n3),n3)
2294 : :
2295 : : ! Get linear index of rotated point Gj
2296 : 125043672 : ind2 = k1+n1*((k2-1)+n2*(k3-1))
2297 : :
2298 : : ! TODO: Here I believe there are lots of cache misses, should perform low-level profiling
2299 : : ! OMP perhaps can accelerate this part but mind false sharing...
2300 [ + + ]: 125043672 : if (has_phase) then
2301 : : ! compute exp(-2*pi*I*G dot tau_S) using original G
2302 [ + + ]: 240549132 : arg = two_pi * dot_product(qpt + tsg, tnon)
2303 : 60137283 : phnon1(1) = cos(arg); phnon1(2) =-sin(arg)
2304 : :
2305 : : ! rho(Strans*G)=exp(2*pi*IG dot tau_S) rho(G)
2306 : 60137283 : outfg(1, ind1, isp) = phnon1(1) * infg(1, ind2, isp) - phnon1(2) * infg(2, ind2, isp)
2307 : 60137283 : outfg(2, ind1, isp) = phnon1(1) * infg(2, ind2, isp) + phnon1(2) * infg(1, ind2, isp)
2308 : : else
2309 : 64906389 : outfg(1, ind1, isp) = infg(1, ind2, isp)
2310 : 64906389 : outfg(2, ind1, isp) = infg(2, ind2, isp)
2311 : : end if
2312 : :
2313 : : ! Take complex conjugate if time-reversal is used.
2314 [ + + ]: 132467464 : if (tsign == -1) outfg(2, ind1, isp) = -outfg(2, ind1, isp)
2315 : : end do
2316 : : end do
2317 : : end do
2318 : : end do ! isp
2319 : :
2320 : : !call xmpi_sum(comm, outfg, ierr)
2321 : 18377 : call timab(1803, 2, tsec)
2322 : :
2323 : 18377 : end subroutine rotate_fqg
2324 : : !!***
2325 : :
2326 : : !----------------------------------------------------------------------
2327 : :
2328 : : !!****f* m_dvdb/dvdb_ftinterp_setup
2329 : : !! NAME
2330 : : !! dvdb_ftinterp_setup
2331 : : !!
2332 : : !! FUNCTION
2333 : : !! Precompute the wsr array with the DFPT potential in the supercell
2334 : : !! required for the Fourier interpolation.
2335 : : !! This is a collective routine that should be called by all procs inside db%comm.
2336 : : !!
2337 : : !! \begin{equation}
2338 : : !! \label{eq:dfpt_pot_realspace}
2339 : : !! W_{\kappa\alpha}(\rr,\RR) = \dfrac{1}{N_\qq} \sum_\qq e^{-i\qq\cdot(\RR - \rr)}\,
2340 : : !! \partial_{\kappa\alpha\qq}{v^{\text{scf}}}(\rr)
2341 : : !! \end{equation}
2342 : : !!
2343 : : !! INPUTS
2344 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
2345 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
2346 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
2347 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
2348 : : !! nfft=Number of fft-points treated by this processors
2349 : : !! ngfft(18)=contain all needed information about 3D FFT
2350 : : !! comm_rpt = MPI communicator used to distribute R-lattice points.
2351 : : !!
2352 : : !! SOURCE
2353 : :
2354 : 36 : subroutine dvdb_ftinterp_setup(db, ngqpt, qptopt, nqshift, qshift, nfft, ngfft, comm_rpt)
2355 : :
2356 : : !Arguments ------------------------------------
2357 : : !scalars
2358 : : class(dvdb_t),target,intent(inout) :: db
2359 : : integer,intent(in) :: qptopt,nqshift,nfft,comm_rpt
2360 : : !arrays
2361 : : integer,intent(in) :: ngqpt(3), ngfft(18)
2362 : : real(dp),intent(in) :: qshift(3,nqshift)
2363 : :
2364 : : !Local variables-------------------------------
2365 : : !scalars
2366 : : integer,parameter :: master=0
2367 : : integer :: iq_ibz,nqibz,iq_bz,nqbz !, timerev_q
2368 : : integer :: ii,jj,cplex_qibz,ispden,imyp,irpt,idir,ipert,ipc, iqst, itimrev, isym
2369 : : integer :: ifft, ierr, my_rstart, my_rstop, iatom
2370 : : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
2371 : : logical :: isirr_q
2372 : : character(len=500) :: msg
2373 : : !arrays
2374 : : integer :: g0q(3)
2375 : : !integer :: symq(4,2,db%cryst%nsym)
2376 : 36 : integer,allocatable :: indqq(:,:), iperm(:), nqsts(:), iqs_dvdb(:), all_cell(:,:)
2377 : : real(dp) :: qpt_bz(3)
2378 : 36 : real(dp),allocatable :: qibz(:,:), qbz(:,:), emiqr(:,:), all_rpt(:,:), all_wghatm(:,:,:)
2379 : 36 : real(dp),allocatable :: v1r_qibz(:,:,:,:), v1r_qbz(:,:,:,:), v1r_lr(:,:,:)
2380 : 36 : real(kind=sp), contiguous, pointer :: wsr_ptr(:,:,:,:,:)
2381 : : logical,parameter :: DEBUG_WSR_IMAG = .False.
2382 : 36 : real(dp),allocatable :: wsi_diag(:,:,:,:)
2383 : : ! *************************************************************************
2384 : :
2385 : : ! Set communicator for R-point parallelism.
2386 : : ! Note that client code is responsible for calling the interpolation routine dvdb_get_ftqbz (R -> q)
2387 : : ! with all procs inside comm_rpt to avoid MPI deadlocks.
2388 : 36 : db%comm_rpt = comm_rpt; db%nprocs_rpt = xmpi_comm_size(db%comm_rpt); db%me_rpt = xmpi_comm_rank(db%comm_rpt)
2389 : :
2390 [ - + ]: 36 : if (db%add_lr >= 4) then
2391 : 0 : call wrtout(std_out, " Skipping construction of W(R,r) because add_lr >= 4. Will use LR part only!")
2392 : 0 : return
2393 : : end if
2394 : :
2395 : 36 : call cwtime(cpu_all, wall_all, gflops_all, "start")
2396 : :
2397 : : call wrtout(std_out, sjoin(ch10, "Building W(R,r) using q-mesh ngqpt: ", ltoa(ngqpt), &
2398 : 36 : ", with nprocs_rpt:", itoa(db%nprocs_rpt)), do_flush=.True.)
2399 : 36 : call wrtout(std_out, sjoin(" Using Gaussian filter with qdamp: ", ftoa(db%qdamp, fmt="(f6.1)")))
2400 : 36 : call wrtout(std_out, "")
2401 : 36 : call wrtout(std_out, " Note: this part may take some time depending on the number of MPI procs, ngqpt and nfft points.")
2402 : 36 : call wrtout(std_out, " Use boxcutmin < 2.0 (> 1.1) to decrease nfft, reduce memory requirements and speedup the calculation.")
2403 : : !call wrtout(std_out, " Q-mesh shifts:")
2404 : : !do ii=1,nqshift
2405 : : ! call wrtout(std_out, ltoa(qshift(:, ii)))
2406 : : !end do
2407 : :
2408 : : call prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2409 : 36 : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm)
2410 : :
2411 : 36 : nqibz = size(qibz, dim=2); nqbz = size(qbz, dim=2); db%nrtot = size(all_rpt, dim=2)
2412 : :
2413 : : ! Distribute R-points inside comm_rpt.
2414 : 36 : call xmpi_split_work(db%nrtot, db%comm_rpt, my_rstart, my_rstop)
2415 : :
2416 : : ! Select my_rpoints.
2417 : : ! Use REMALLOC so that we can call this routine multiple times i.e. for changing add_lr
2418 : 36 : db%my_nrpt = my_rstop - my_rstart + 1
2419 [ - + ]: 36 : ABI_CHECK(db%my_nrpt /= 0, "my_nrpt == 0!")
2420 : :
2421 [ - + - + : 108 : ABI_REMALLOC(db%my_rpt, (3, db%my_nrpt))
+ - + - +
- - + - +
- + ]
2422 [ + - + - : 5036 : db%my_rpt = all_rpt(:, my_rstart:my_rstop)
- + - - +
+ + + ]
2423 [ - + - + : 108 : ABI_REMALLOC(db%my_irpt2tot, (db%my_nrpt))
+ - + - +
- - + - +
- + ]
2424 [ + + ]: 1277 : do irpt=1,db%my_nrpt
2425 : 1277 : db%my_irpt2tot(irpt) = my_rstart + (irpt - 1)
2426 : : end do
2427 : :
2428 : : ! Copy weights for the atoms treated by this proc.
2429 [ + + + + ]: 462 : ii = minval(db%my_pinfo(2,:)); jj = maxval(db%my_pinfo(2,:))
2430 [ - + - + : 144 : ABI_REMALLOC(db%my_wratm, (db%my_nrpt, ii:jj))
+ - - + +
- + - + -
- + - + -
+ ]
2431 [ + + + + ]: 2581 : db%my_wratm = one
2432 [ - + ]: 36 : if (db%rspace_cell == 1) then
2433 [ # # ]: 0 : do iatom=1,db%cryst%natom
2434 [ # # # # ]: 0 : if (iatom >= ii .and. iatom <= jj) db%my_wratm(:, iatom) = all_wghatm(iatom, iatom, my_rstart:my_rstop)
2435 : : end do
2436 : : end if
2437 : :
2438 : 36 : write(std_out, "(a, i0)")" Using rspace_cell method for integration weights: ", db%rspace_cell
2439 : 36 : write(std_out, "(a, i0)")" Total number of R-points in real-space big box: ", db%nrtot
2440 : 36 : write(std_out, "(a, i0)")" Number of R-points treated by this MPI rank: ", db%my_nrpt
2441 : 36 : write(std_out, "(a, 3(i0, 1x))")" ngfft: ", ngfft(1:3)
2442 : 36 : write(std_out, "(a, i0)")" dvdb_add_lr: ", db%add_lr
2443 : :
2444 : : ! Allocate potential in the supercell. Memory is MPI-distributed over my_nrpt and my_npert
2445 : : call wrtout(std_out, sjoin(" Memory required for W(R,r): ", &
2446 : 36 : ftoa(two * db%my_nrpt * nfft * db%nspden * db%my_npert * sp * b2Mb, fmt="f8.1"), "[Mb] <<< MEM"))
2447 : :
2448 : : ABI_SFREE(all_cell)
2449 [ - + ]: 36 : ABI_SFREE(all_wghatm)
2450 [ - + ]: 36 : ABI_FREE(all_rpt)
2451 : :
2452 [ - + + - : 108 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
2453 [ - + + - : 180 : ABI_MALLOC(v1r_qbz, (2, nfft, db%nspden, db%natom3))
- + + - -
+ + - + -
+ - - + -
+ ]
2454 [ - + + - : 8410533 : ABI_CALLOC(v1r_lr, (2, nfft, db%my_npert))
- + + - +
- + - - +
- + + + +
+ + + ]
2455 : :
2456 [ - + ]: 36 : ABI_SFREE(db%wsr)
2457 [ - + + - : 216 : ABI_MALLOC_OR_DIE(db%wsr, (1, db%my_nrpt, nfft, db%nspden, db%my_npert), ierr)
- + + - -
+ + - - +
+ - + - +
- + - + -
- + + - -
+ ]
2458 [ + + + + : 138868110 : db%wsr = zero
+ + + + +
+ ]
2459 : :
2460 : : if (DEBUG_WSR_IMAG) then
2461 : : ABI_MALLOC(wsi_diag, (db%my_nrpt, nfft, db%nspden, db%my_npert))
2462 : : wsi_diag = zero
2463 : : end if
2464 : :
2465 : : ! TODO: Parallelize this part over q-points using comm_rpt. For the time being only pert parallelism.
2466 : 36 : iqst = 0
2467 [ + + ]: 237 : do iq_ibz=1,nqibz
2468 : 201 : call cwtime(cpu, wall, gflops, "start")
2469 : : !
2470 : : ! Here all procs get all potentials for this IBZ q-point on the real-space FFT mesh.
2471 : : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
2472 : : ! Note that here we need all 3*natom perturbations because of v1phq_rotate.
2473 [ - + ]: 201 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, db%comm)
2474 : :
2475 : : ! Reconstruct by symmetry the potentials for the star of this q-point,
2476 : : ! perform slow FT and accumulate in wsr. Be careful with the gamma point.
2477 [ + + ]: 1442 : do ii=1,nqsts(iq_ibz)
2478 : 1241 : iqst = iqst + 1
2479 : : !if (mod(ii, nproc) /= my_rank) cycle ! MPI parallelism.
2480 : 1241 : iq_bz = iperm(iqst)
2481 [ - + ]: 1241 : ABI_CHECK(iq_ibz == indqq(1, iq_bz), "iq_ibz !/ indqq(1)")
2482 [ + + ]: 4964 : qpt_bz = qbz(:, iq_bz)
2483 : : !if (all(abs(qpt_bz) < tol12)) cycle
2484 : : ! IS(q_ibz) + g0q = q_bz
2485 [ + + ]: 4964 : isym = indqq(2, iq_bz); itimrev = indqq(6, iq_bz) + 1; g0q = indqq(3:5, iq_bz)
2486 [ + + + + : 4182 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
2487 : : !write(std_out, *)"qbz", trim(ktoa(qpt_bz)), " --> qibz ", trim(ktoa(qibz(:,iq_ibz)))
2488 : : !write(std_out, *)"via isym, itimrev, g0q:", isym, itimrev, g0q
2489 : :
2490 : : ! Compute long-range part of the coupling potential at qpt_bz.
2491 [ + + ]: 1241 : if (db%add_lr /= 0) then
2492 [ + + ]: 7959 : do imyp=1,db%my_npert
2493 : 6822 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2494 : 7959 : call db%get_v1r_long_range(qpt_bz, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
2495 : : end do
2496 : : end if
2497 : :
2498 [ + + ]: 1442 : if (cplex_qibz == 1) then
2499 : : ! Gamma point.
2500 [ - + ]: 36 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
2501 [ + + + - : 144 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
- + ]
2502 : :
2503 [ + + ]: 36 : if (db%add_lr /= 0) then
2504 : : ! Subtract the long-range part of the potential.
2505 [ + + ]: 161 : do imyp=1,db%my_npert
2506 : 138 : ipc = db%my_pinfo(3, imyp)
2507 [ + + ]: 299 : do ispden=1,db%nspden
2508 [ + + ]: 961668 : v1r_qibz(1, :, ispden, ipc) = v1r_qibz(1, :, ispden, ipc) - v1r_lr(1, :, imyp)
2509 : : end do
2510 : : end do
2511 : : end if
2512 : :
2513 : : ! Slow FT.
2514 [ + + ]: 249 : do imyp=1,db%my_npert
2515 : 213 : ipc = db%my_pinfo(3, imyp)
2516 [ + + ]: 462 : do ispden=1,db%nspden
2517 [ + + ]: 2803818 : do ifft=1,nfft
2518 [ + + ]: 70835733 : do irpt=1,db%my_nrpt
2519 : : db%wsr(1, irpt, ifft, ispden, imyp) = db%wsr(1, irpt, ifft, ispden, imyp) + &
2520 : 70835520 : v1r_qibz(1, ifft, ispden, ipc)
2521 : : end do
2522 : : end do
2523 : : end do
2524 : : end do
2525 : :
2526 : : else
2527 : : ! q /= Gamma. Get the periodic part of the potential in BZ (v1r_qbz)
2528 [ + + ]: 1205 : if (isirr_q) then
2529 [ + - + - : 33744234 : v1r_qbz = v1r_qibz
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
2530 : : else
2531 : : call v1phq_rotate(db%cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
2532 : 1040 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
2533 : : end if
2534 : :
2535 : : ! Multiply by e^{iqpt_bz.r}
2536 : 1205 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden * db%natom3, v1r_qbz)
2537 : :
2538 [ + + ]: 1205 : if (db%add_lr /= 0) then
2539 : : ! Subtract the long-range part of the potential.
2540 [ + + ]: 7798 : do imyp=1,db%my_npert
2541 : 6684 : ipc = db%my_pinfo(3, imyp)
2542 [ + + ]: 14482 : do ispden=1,db%nspden
2543 [ + + + + ]: 157017576 : v1r_qbz(:, :, ispden, ipc) = v1r_qbz(:, :, ispden, ipc) - v1r_lr(:, :, imyp)
2544 : : end do
2545 : : end do
2546 : : end if
2547 : :
2548 : : ! Compute FT phases for this qpt_bz.
2549 [ + + ]: 4820 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
2550 : :
2551 : : ! Slow FT.
2552 [ + + ]: 8414 : do imyp=1,db%my_npert
2553 : 7209 : ipc = db%my_pinfo(3, imyp)
2554 [ + + ]: 15623 : do ispden=1,db%nspden
2555 [ + + ]: 65243154 : do ifft=1,nfft
2556 : : db%wsr(1, :, ifft, ispden, imyp) = db%wsr(1, :, ifft, ispden, imyp) &
2557 : : + emiqr(1, :) * v1r_qbz(1, ifft, ispden, ipc) &
2558 [ + + ]: 3408342336 : - emiqr(2, :) * v1r_qbz(2, ifft, ispden, ipc)
2559 : :
2560 : 7209 : if (DEBUG_WSR_IMAG) then
2561 : : wsi_diag(:, ifft, ispden, imyp) = wsi_diag(:, ifft, ispden, imyp) &
2562 : : + emiqr(1, :) * v1r_qbz(2, ifft, ispden, ipc) &
2563 : : + emiqr(2, :) * v1r_qbz(1, ifft, ispden, ipc)
2564 : : end if
2565 : : end do
2566 : :
2567 : : !call zgerc(db%my_nrpt, nfft, cone, emiqr, 1, v1r_qbz(:,:,ispden,ipc), 1, &
2568 : : ! db%wsr(:,:,:,ispden,imyp), db%my_nrpt)
2569 : :
2570 : : end do ! ispden
2571 : : end do ! imyp
2572 : : end if
2573 : :
2574 : : end do ! iqst
2575 : :
2576 : 201 : write(msg,'(2(a,i0),a)') " IBZ q-point [", iq_ibz, "/", nqibz, "]"
2577 : 201 : call cwtime_report(msg, cpu, wall, gflops)
2578 [ - + ]: 438 : ABI_FREE(v1r_qibz)
2579 : : end do ! iq_ibz
2580 : :
2581 [ - + ]: 36 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
2582 : 36 : call wrtout(std_out, ch10//ch10)
2583 : :
2584 [ - + ]: 36 : ABI_FREE(iperm)
2585 [ - + ]: 36 : ABI_FREE(emiqr)
2586 [ - + ]: 36 : ABI_FREE(qibz)
2587 [ - + ]: 36 : ABI_FREE(qbz)
2588 [ - + ]: 36 : ABI_FREE(indqq)
2589 [ - + ]: 36 : ABI_FREE(iqs_dvdb)
2590 [ - + ]: 36 : ABI_FREE(nqsts)
2591 [ - + ]: 36 : ABI_FREE(v1r_qbz)
2592 [ - + ]: 36 : ABI_FREE(v1r_lr)
2593 : :
2594 : : !call xmpi_sum(db%wsr, db%comm, ierr)
2595 [ + + + + : 138868110 : db%wsr = db%wsr / nqbz
+ + + + +
+ ]
2596 : :
2597 : : if (DEBUG_WSR_IMAG) then
2598 : : wsi_diag = wsi_diag / nqbz
2599 : : write(std_out, "(a)")" --- DEBUG_WSR_IMAG: discarded Im[W(R,r)] vs kept Re[W(R,r)], per perturbation (imyp) ---"
2600 : : do imyp=1,db%my_npert
2601 : : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2602 : : write(std_out, "(a,i0,a,i0,a,i0,a,es12.4,a,es12.4)") &
2603 : : " imyp=", imyp, " idir=", idir, " ipert=", ipert, &
2604 : : " max|Im[wsr]|=", maxval(abs(wsi_diag(:,:,:,imyp))), &
2605 : : " max|Re[wsr]|=", maxval(abs(real(db%wsr(1,:,:,:,imyp), kind=dp)))
2606 : : end do
2607 : : ABI_FREE(wsi_diag)
2608 : : end if
2609 : :
2610 : 36 : wsr_ptr => db%wsr
2611 : : #ifdef HAVE_OPENMP_OFFLOAD
2612 : : ! Upload wsr array to GPU
2613 : : !$OMP TARGET ENTER DATA MAP(to:wsr_ptr) IF (db%gpu_option==ABI_GPU_OPENMP)
2614 : : #endif
2615 : :
2616 : 36 : call cwtime_report(" Construction of W(R,r)", cpu_all, wall_all, gflops_all)
2617 : :
2618 [ - + - + : 144 : end subroutine dvdb_ftinterp_setup
- + - + -
+ - + - +
- + - + ]
2619 : : !!***
2620 : :
2621 : : !----------------------------------------------------------------------
2622 : :
2623 : : !!****f* m_dvdb/dvdb_get_maxw
2624 : : !! NAME
2625 : : !! dvdb_get_maxw
2626 : : !!
2627 : : !! FUNCTION
2628 : : !! Compute max_r |W(R,r)|
2629 : : !!
2630 : : !! INPUTS
2631 : : !!
2632 : : !! FUNCTION
2633 : :
2634 : 1 : subroutine dvdb_get_maxw(db, ngqpt, all_rpt, all_rmod, maxw)
2635 : :
2636 : : !Arguments ------------------------------------
2637 : : !scalars
2638 : : class(dvdb_t),intent(in) :: db
2639 : : integer,intent(in) :: ngqpt(3)
2640 : : real(dp),allocatable,intent(out) :: maxw(:,:), all_rpt(:,:), all_rmod(:)
2641 : :
2642 : : !Local variables-------------------------------
2643 : : !scalars
2644 : : integer :: imyp, ipc, irpt, irpt_tot, ifft, nfft, ispden, ierr, ii
2645 : : real(dp) :: phre
2646 : : !arrays
2647 : 1 : integer,allocatable :: iperm_irpt(:)
2648 : : real(dp) :: sc_rprimd(3,3)
2649 : : ! *************************************************************************
2650 : :
2651 [ - + ]: 1 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
2652 : :
2653 : 1 : nfft = size(db%wsr, dim=3)
2654 [ - + + - : 58 : ABI_CALLOC(maxw, (db%nrtot, db%natom3))
- + + - +
- + - - +
- + - + +
+ + + ]
2655 : :
2656 : : ! Need all RPTs to sort output.
2657 [ - + + - : 35 : ABI_CALLOC(all_rpt, (3, db%nrtot))
+ - + - -
+ - + - +
+ + + + ]
2658 [ + + ]: 9 : do irpt=1,db%my_nrpt
2659 : 8 : irpt_tot = db%my_irpt2tot(irpt)
2660 [ + + ]: 33 : all_rpt(:, irpt_tot) = db%my_rpt(:, irpt)
2661 : : end do
2662 : 1 : call xmpi_sum(all_rpt, db%comm_rpt, ierr)
2663 : :
2664 [ + + ]: 7 : do imyp=1,db%my_npert
2665 : 6 : ipc = db%my_pinfo(3, imyp)
2666 [ + + ]: 55 : do irpt=1,db%my_nrpt
2667 : 48 : irpt_tot = db%my_irpt2tot(irpt)
2668 : 48 : phre = zero
2669 [ + + ]: 96 : do ispden=1,db%nspden
2670 [ + + ]: 196704 : do ifft=1,nfft
2671 : 196656 : phre = max(phre, real(db%wsr(1,irpt,ifft,ispden,imyp), kind=dp) ** 2) ! + db%wsr(2,irpt,ifft,ispden,imyp) ** 2)
2672 : : end do
2673 : : end do
2674 : 54 : maxw(irpt_tot, ipc) = sqrt(phre)
2675 : : end do
2676 : : end do
2677 : :
2678 : : ! Handle parallelism
2679 [ - + ]: 1 : if (db%nprocs_rpt /= 1) call xmpi_sum(maxw, db%comm_rpt, ierr)
2680 [ - + ]: 1 : if (db%nprocs_pert /= 1) call xmpi_sum(maxw, db%comm_pert, ierr)
2681 : :
2682 : 1 : sc_rprimd(:, 1) = ngqpt(1) * db%cryst%rprimd(:, 1)
2683 : : sc_rprimd(:, 2) = ngqpt(2) * db%cryst%rprimd(:, 2)
2684 : : sc_rprimd(:, 3) = ngqpt(3) * db%cryst%rprimd(:, 3)
2685 [ - + ]: 1 : call sort_rpts(db%nrtot, all_rpt, db%cryst%rmet, iperm_irpt, rmod=all_rmod)
2686 : :
2687 : : ! Sort output results by |R|.
2688 [ + - + + : 66 : all_rpt = all_rpt(:, iperm_irpt(:))
+ + + - -
+ - - + +
+ + ]
2689 [ + + ]: 7 : do ii=1,db%natom3
2690 [ + - + + : 103 : maxw(:, ii) = maxw(iperm_irpt(:), ii)
+ + ]
2691 : : end do
2692 : :
2693 [ - + ]: 1 : ABI_FREE(iperm_irpt)
2694 : :
2695 : 1 : end subroutine dvdb_get_maxw
2696 : : !!***
2697 : :
2698 : : !----------------------------------------------------------------------
2699 : :
2700 : : !!****f* m_dvdb/prepare_ftinterp
2701 : : !! NAME
2702 : : !! prepare_ftinterp
2703 : : !!
2704 : : !! FUNCTION
2705 : : !! Helper function used to prepare the Fourier interpolation of the DFPT potentials.
2706 : :
2707 : 36 : subroutine prepare_ftinterp(db, ngqpt, qptopt, nqshift, qshift, &
2708 : : qibz, qbz, indqq, iperm, nqsts, iqs_dvdb, all_rpt, all_wghatm)
2709 : :
2710 : : !Arguments ------------------------------------
2711 : : !scalars
2712 : : integer,intent(in) :: nqshift, qptopt
2713 : : class(dvdb_t),target,intent(in) :: db
2714 : : !arrays
2715 : : integer,intent(in) :: ngqpt(3)
2716 : : real(dp),intent(in) :: qshift(3,nqshift)
2717 : : integer,allocatable,intent(out) :: indqq(:,:), nqsts(:), iqs_dvdb(:), iperm(:)
2718 : : real(dp),allocatable,intent(out) :: all_rpt(:,:), all_wghatm(:,:,:)
2719 : : real(dp),allocatable,intent(out) :: qibz(:,:),qbz(:,:)
2720 : :
2721 : : !Local variables-------------------------------
2722 : : !scalars
2723 : : integer :: iq_ibz,nqibz,iq_bz,nqbz,ii,iq_dvdb
2724 : : integer :: iqst,nqst,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3, nrtot
2725 : : integer :: irpt, all_nrpt
2726 : : logical :: found
2727 : : character(len=500) :: msg
2728 : : type(crystal_t),pointer :: cryst
2729 : 36 : type(krank_t) :: qrank
2730 : 36 : type(ifc_supercell_type) :: SC
2731 : : !arrays
2732 : : integer :: qptrlatt(3,3), sc_qptrlatt(3,3)
2733 : 36 : integer,allocatable :: bz2ibz_sort(:),all_cell(:,:)
2734 : 36 : logical,allocatable :: keep_rpt(:)
2735 : : real(dp) :: shift(3), sc_matrix(3,3)
2736 : 36 : real(dp),allocatable :: wtq(:),all_rcart(:,:),all_wg_full(:,:,:)
2737 : : ! *************************************************************************
2738 : :
2739 : 36 : cryst => db%cryst
2740 : :
2741 : : ! Generate q-mesh: find BZ, IBZ and the corresponding weights from ngqpt.
2742 : 36 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3)
2743 : 36 : qptrlatt = 0; qptrlatt(1, 1) = ngqpt(1); qptrlatt(2, 2) = ngqpt(2); qptrlatt(3, 3) = ngqpt(3)
2744 : :
2745 [ - + ]: 36 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
2746 [ + + + - : 144 : ABI_CHECK(all(qshift(:, 1) == zero), "qshift != 0 not supported")
- + ]
2747 : :
2748 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nqshift, qshift, &
2749 [ - + - + ]: 36 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
2750 : :
2751 [ + + - + ]: 144 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
2752 : :
2753 : 72 : select case (db%rspace_cell)
2754 : : case (0)
2755 : : ! Generate q-mesh
2756 : : #if 1
2757 [ - + ]: 36 : ABI_FREE(qbz)
2758 [ - + + - : 108 : ABI_MALLOC(qbz, (3, nqbz))
+ - + - -
+ - + ]
2759 : 36 : ii = 0
2760 [ + + ]: 143 : do iz=0,nq3-1
2761 [ + + ]: 494 : do iy=0,nq2-1
2762 [ + + ]: 1699 : do ix=0,nq1-1
2763 : 1241 : ii = ii + 1
2764 [ + + ]: 4964 : qbz(:, ii) = [ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)]
2765 [ + + ]: 5315 : call wrap2_pmhalf([ix / dble(nq1), iy / dble(nq2), iz / dble(nq3)], qbz(:,ii), shift)
2766 : : end do
2767 : : end do
2768 : : end do
2769 : : #endif
2770 : :
2771 : : ! Compute real-space points in the supercell
2772 : : ! Use the following indexing (N means ngfft on the adequate direction)
2773 : : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
2774 : : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
2775 : 36 : nrtot = nqbz
2776 [ - + + - : 5036 : ABI_CALLOC(all_rpt, (3, nrtot))
- + - + -
+ + + +
+ ]
2777 : 36 : ii = 0
2778 [ + + ]: 143 : do iz=1,nq3
2779 : 107 : r3 = ig2gfft(iz, nq3)
2780 [ + + ]: 494 : do iy=1,nq2
2781 : 351 : r2 = ig2gfft(iy, nq2)
2782 [ + + ]: 1699 : do ix=1,nq1
2783 : 1241 : r1 = ig2gfft(ix, nq1)
2784 : 1241 : ii = ii + 1
2785 [ + + ]: 5315 : all_rpt(:, ii) = [r1, r2, r3]
2786 : : end do
2787 : : end do
2788 : : end do
2789 : :
2790 : : case (1)
2791 : : ! Use Wigner-Seitz cell: build the Born-von Karman supercell dual to the q-mesh directly
2792 : : ! from an ifc_supercell_type instance, the same construction ifc_init uses, rather than
2793 : : ! going through the brav-specific make_bigbox/wght9 pair (via canat9/get_bigbox_and_weights).
2794 : : !
2795 : : ! Note: qptrlatt is the plain diag(ngqpt) matrix built above for the (already brav-independent)
2796 : : ! q-point sampling itself; the real-space box below is built dual to that very same lattice, so
2797 : : ! db%brav plays no role here (the historical code's use of db%brav to pick a centered/halved
2798 : : ! real-space box was inconsistent with the always-diagonal q-mesh used above, and is not
2799 : : ! reproduced -- no test exercises db%brav/=1 for this rspace_cell=1 path).
2800 : :
2801 : : ! Merge the nqshift q-mesh shifts into a single, finer qptrlatt (a no-op here since
2802 : : ! nqshift==1 is enforced above).
2803 : 0 : call kptrlatt_merge_shifts(qptrlatt, nqshift, qshift, sc_qptrlatt)
2804 : : ! Rows of the supercell matrix are the supercell vectors, columns of qptrlatt.
2805 [ # # # # ]: 0 : sc_matrix = real(transpose(sc_qptrlatt), kind=dp)
2806 : 0 : call SC%init(cryst, sc_matrix)
2807 : :
2808 : : ! Explicit list of R vectors in the Wigner-Seitz cell of the supercell for each atom pair,
2809 : : ! with 1/N weights for N tied images.
2810 : 0 : call SC%calc_ws_wghatm(tol8, all_nrpt, all_cell, all_wg_full)
2811 : 0 : call SC%free()
2812 : :
2813 : : ! In principle one may have N_R that depends on iatom to minimize memory: keep only the
2814 : : ! R-points needed for objects that depend on a single atomic index, i.e. those for which
2815 : : ! the sum of the diagonal (same-atom) weights is not negligible.
2816 [ # # # # : 0 : ABI_MALLOC(keep_rpt, (all_nrpt))
# # # # #
# # # ]
2817 [ # # ]: 0 : do irpt=1,all_nrpt
2818 [ # # # # ]: 0 : keep_rpt(irpt) = sum(abs(get_diag(all_wg_full(:,:,irpt)))) >= tol20
2819 : : end do
2820 [ # # # # ]: 0 : nrtot = count(keep_rpt)
2821 : :
2822 [ # # # # : 0 : ABI_MALLOC(all_rcart, (3, nrtot))
# # # # #
# # # ]
2823 [ # # # # : 0 : ABI_MALLOC(all_wghatm, (cryst%natom, cryst%natom, nrtot))
# # # # #
# # # # #
# # # # #
# # # ]
2824 : 0 : ii = 0
2825 [ # # ]: 0 : do irpt=1,all_nrpt
2826 [ # # ]: 0 : if (.not. keep_rpt(irpt)) cycle
2827 : 0 : ii = ii + 1
2828 [ # # # # : 0 : all_rcart(:,ii) = matmul(cryst%rprimd, real(all_cell(:,irpt), kind=dp))
# # # # #
# ]
2829 [ # # # # ]: 0 : all_wghatm(:,:,ii) = all_wg_full(:,:,irpt)
2830 : : end do
2831 [ # # ]: 0 : ABI_FREE(keep_rpt)
2832 [ # # ]: 0 : ABI_FREE(all_cell)
2833 [ # # ]: 0 : ABI_FREE(all_wg_full)
2834 : :
2835 [ # # # # : 0 : ABI_MALLOC(all_rpt, (3, nrtot))
# # # # #
# ]
2836 : 0 : call xcart2xred(nrtot, cryst%rprimd, all_rcart, all_rpt)
2837 [ # # ]: 0 : ABI_FREE(all_rcart)
2838 : :
2839 : : case default
2840 [ + - - ]: 36 : ABI_ERROR(sjoin("Wrong rspace_cell:", itoa(db%rspace_cell)))
2841 : : end select
2842 : :
2843 : : ! Find correspondence BZ --> IBZ. Note:
2844 : : ! - q --> -q symmetry is always used for phonons.
2845 : : ! - we use symrec instead of symrel
2846 : :
2847 [ - + + - : 108 : ABI_MALLOC(indqq, (6, nqbz))
+ - + - -
+ - + -
+ ]
2848 : 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2849 : :
2850 [ - + ]: 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2851 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2852 : : end if
2853 : :
2854 : 36 : call qrank%free()
2855 : :
2856 : : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
2857 [ - + + - : 108 : ABI_MALLOC(iperm, (nqbz))
+ - + - -
+ - + -
+ ]
2858 [ - + + - : 72 : ABI_MALLOC(bz2ibz_sort, (nqbz))
- + - + ]
2859 [ - + + + : 3795 : iperm = [(ii, ii=1,nqbz)]
+ - + + +
- - + - -
+ + ]
2860 [ + - - + : 1313 : bz2ibz_sort = indqq(1, :)
- - + + ]
2861 : 36 : call sort_int(nqbz, bz2ibz_sort, iperm)
2862 : :
2863 : : ! Reconstruct the IBZ according to what is present in the DVDB.
2864 [ - + + - : 108 : ABI_MALLOC(nqsts, (nqibz))
+ - + - -
+ - + -
+ ]
2865 [ - + + - : 72 : ABI_MALLOC(iqs_dvdb, (nqibz))
- + - + -
+ ]
2866 [ + + ]: 237 : iqs_dvdb = -1
2867 : :
2868 : : iqst = 0
2869 [ + + ]: 237 : do iq_ibz=1,nqibz
2870 : : ! In each q-point star, count the number of q-points and find the one present in the DVDB.
2871 : 201 : nqst = 0
2872 : 201 : found = .false.
2873 [ + + ]: 1442 : do ii=iqst+1,nqbz
2874 [ + + ]: 1406 : if (bz2ibz_sort(ii) /= iq_ibz) exit
2875 : 1241 : nqst = nqst + 1
2876 : 1241 : iq_bz = iperm(ii)
2877 [ + + ]: 1442 : if (.not. found) then
2878 : 671 : iq_dvdb = db%findq(qbz(:,iq_bz))
2879 [ + + ]: 671 : if (iq_dvdb /= -1) then
2880 [ + + ]: 804 : qibz(:,iq_ibz) = qbz(:,iq_bz)
2881 : 201 : iqs_dvdb(iq_ibz) = iq_dvdb
2882 : 201 : found = .true.
2883 : : end if
2884 : : end if
2885 : : end do
2886 : :
2887 : : ! Check that nqst has been counted properly.
2888 [ + - - + ]: 201 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst + 1) == iq_ibz, "Wrong iqst")
2889 [ - + ]: 201 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
2890 : 0 : write(msg, "(a,i0,a,f5.2)")"Error in q-point star or q-weights. nqst:", nqst, "wtq * nqbz = ", wtq(iq_ibz) * nqbz
2891 : 0 : ABI_ERROR(msg)
2892 : : end if
2893 : :
2894 : : ! Check that the q-point has been found in DVDB.
2895 [ - + ]: 201 : ABI_CHECK(found, sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
2896 : :
2897 : 201 : iqst = iqst + nqst
2898 : 237 : nqsts(iq_ibz) = nqst
2899 : : end do
2900 : :
2901 [ - + ]: 36 : ABI_FREE(wtq)
2902 [ - + ]: 36 : ABI_FREE(bz2ibz_sort)
2903 : :
2904 : : ! Redo the mapping with the new IBZ
2905 : 36 : call qrank%from_kptrlatt(nqibz, qibz, qptrlatt, compute_invrank=.False.)
2906 : :
2907 [ - + ]: 36 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, indqq) /= 0) then
2908 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map qBZ --> qIBZ")
2909 : : end if
2910 : 36 : call qrank%free()
2911 : :
2912 [ - + - + : 36 : end subroutine prepare_ftinterp
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
2913 : : !!***
2914 : :
2915 : : !----------------------------------------------------------------------
2916 : :
2917 : : !!****f* m_dvdb/dvdb_ftinterp_qpt
2918 : : !! NAME
2919 : : !! dvdb_ftinterp_qpt
2920 : : !!
2921 : : !! FUNCTION
2922 : : !! Fourier interpolation of potentials for a given q-point
2923 : : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
2924 : : !!
2925 : : !! \begin{equation}
2926 : : !! \partial v^{scf}_{\tilde\qq\kappa\alpha}(\rr) \approx \sum_\RR e^{+i\tilde{\qq}\cdot(\RR - \rr)} W_{\kappa\alpha}(\rr,\RR).
2927 : : !! \end{equation
2928 : : !!
2929 : : !! INPUTS
2930 : : !! qpt(3)=q-point in reduced coordinates (arbitrary point in the BZ).
2931 : : !! nfft=Number of FFT-points treated by this processors.
2932 : : !! ngfft(18)=contain all needed information about 3D FFT.
2933 : : !! comm=MPI communicator for R-points.
2934 : : !! [add_lr]= If present, use this value for the LR treatment instead of dv%add_lr
2935 : : !!
2936 : : !! OUTPUT
2937 : : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point (periodic part)
2938 : : !!
2939 : : !! SOURCE
2940 : :
2941 : 3762 : subroutine dvdb_ftinterp_qpt(db, qpt, nfft, ngfft, ov1r, comm_rpt, add_lr)
2942 : :
2943 : : !Arguments ------------------------------------
2944 : : !scalars
2945 : : integer,intent(in) :: nfft, comm_rpt
2946 : : integer,optional,intent(in) :: add_lr
2947 : : class(dvdb_t),intent(inout) :: db
2948 : : !arrays
2949 : : integer,intent(in) :: ngfft(18)
2950 : : real(dp),intent(in) :: qpt(3)
2951 : : real(dp),intent(out) :: ov1r(2, nfft, db%nspden, db%my_npert)
2952 : :
2953 : : !Local variables-------------------------------
2954 : : !scalars
2955 : : integer,parameter :: cplex2 = 2
2956 : : integer :: ispden, imyp, idir, ipert, timerev_q, ierr, my_add_lr !, ifft, ir
2957 : : !real(dp) :: qmod
2958 : : !real(sp) :: beta_sp !, wr !,wi
2959 : : logical :: prev_has_zeff, prev_has_quadrupoles, prev_has_efield
2960 : : !arrays
2961 [ + - ]: 3762 : integer :: symq(4,2,db%cryst%nsym), rfdir(3)
2962 : 3762 : integer,allocatable :: pertsy(:,:), rfpert(:), pflag(:,:)
2963 : : !real(dp) :: qcart(3)
2964 : 3762 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:,:)
2965 : 3762 : real(sp),allocatable :: weiqr_sp(:,:), ov1r_sp(:, :), eiqr_sp(:,:)
2966 : : ! *************************************************************************
2967 : :
2968 [ - + ]: 3762 : my_add_lr = db%add_lr; if (present(add_lr)) my_add_lr = add_lr
2969 : :
2970 : : !qcart = two_pi * matmul(db%cryst%gprimd, qpt)
2971 : : !qmod = sqrt(dot_product(qcart, qcart))
2972 : :
2973 [ - + ]: 3762 : if (my_add_lr >= 4) then
2974 : : ! Use LR part only and return immediately.
2975 [ # # ]: 0 : if (my_add_lr > 4) then
2976 : 0 : prev_has_zeff = db%has_zeff
2977 : 0 : prev_has_quadrupoles = db%has_quadrupoles
2978 : 0 : prev_has_efield = db%has_efield
2979 : 0 : db%has_zeff = .False.
2980 : 0 : db%has_quadrupoles = .False.
2981 : 0 : db%has_efield = .False.
2982 [ # # ]: 0 : if (my_add_lr == 5 .and. prev_has_zeff) db%has_zeff = .True.
2983 [ # # ]: 0 : if (my_add_lr == 6 .and. prev_has_quadrupoles) db%has_quadrupoles = .True.
2984 [ # # ]: 0 : if (my_add_lr == 7 .and. prev_has_efield) db%has_efield = .True.
2985 : : end if
2986 : :
2987 [ # # # # : 0 : ov1r = zero
# # # # ]
2988 [ # # ]: 0 : do imyp=1,db%my_npert
2989 : 0 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
2990 : 0 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, ov1r(:, :, 1, imyp))
2991 : : ! Remove the phase to get the lattice-periodic part.
2992 [ # # ]: 0 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, 1, imyp))
2993 [ # # # # : 0 : if (db%nspden /= 1) ov1r(:, :, 2, imyp) = ov1r(:, :, 1, imyp)
# # ]
2994 : : end do
2995 : :
2996 [ # # ]: 0 : if (my_add_lr > 4) then
2997 : : ! Restore input flags.
2998 : 0 : db%has_zeff = prev_has_zeff
2999 : 0 : db%has_quadrupoles = prev_has_quadrupoles
3000 : 0 : db%has_efield = prev_has_efield
3001 : : end if
3002 : :
3003 : 0 : return
3004 : : end if
3005 : :
3006 [ - + ]: 3762 : ABI_CHECK(allocated(db%wsr), "wsr is not allocated (call dvdb_ftinterp_setup)")
3007 : :
3008 : : ! Examine the symmetries of the q-wavevector
3009 : 3762 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
3010 : :
3011 : : ! Compute long-range part of the coupling potential.
3012 [ + + ]: 3762 : if (my_add_lr > 0) then
3013 : : !call wrtout(std_out, "dvdb_ftinterp_qpt: Computing long-range part of the coupling potential.")
3014 [ - + + - : 10056 : ABI_MALLOC(v1r_lr, (2, nfft, db%my_npert))
- + + - +
- + - - +
- + ]
3015 [ + + ]: 17598 : do imyp=1,db%my_npert
3016 : 15084 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
3017 : 17598 : call db%get_v1r_long_range(qpt, idir, ipert, nfft, ngfft, v1r_lr(:,:,imyp))
3018 : : end do
3019 : : end if
3020 : :
3021 : : ! Compute e^{iq.R} FT phases for this q-point.
3022 [ - + + - : 11286 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
3023 : 3762 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
3024 : :
3025 : : ! Interpolate potentials (results in ov1r)
3026 [ - + - - : 3762 : if (db%nprocs_rpt > 1) ov1r = zero
- - - - -
- ]
3027 [ - + + - : 11286 : ABI_MALLOC(ov1r_sp, (2, nfft))
+ - + - -
+ - + ]
3028 : :
3029 [ - + + - : 11286 : ABI_MALLOC(weiqr_sp, (db%my_nrpt, 2))
+ - + - -
+ - + ]
3030 [ - + + - : 7524 : ABI_MALLOC(eiqr_sp, (db%my_nrpt, 2))
- + - + ]
3031 [ - + + + : 275908 : eiqr_sp = transpose(eiqr)
+ + ]
3032 : :
3033 [ + + ]: 23778 : do imyp=1,db%my_npert
3034 : 20016 : idir = db%my_pinfo(1, imyp); ipert = db%my_pinfo(2, imyp)
3035 : :
3036 [ + + ]: 782148 : weiqr_sp(:, 1) = db%my_wratm(:, ipert) * eiqr_sp(:, 1)
3037 [ + + ]: 782148 : weiqr_sp(:, 2) = db%my_wratm(:, ipert) * eiqr_sp(:, 2)
3038 : :
3039 [ + + ]: 40032 : do ispden=1,db%nspden
3040 : :
3041 : : ! We need to compute: sum_R W(R, r) e^{iq.R} with W real matrix.
3042 : : ! Use BLAS2 to compute ov1r = W (x + iy) but need to handle kind conversion as ov1r is double-precision
3043 : : ! NB: Can use MKL BLAS-like extensions to perform 2 matrix-vector operations:
3044 : : ! call dgem2vu(m, n, alpha, a, lda, x1, incx1, x2, incx2, beta, y1, incy1, y2, incy2)
3045 : : ! unfortunately the API does not support transa so one has to transport db%wsr.
3046 : : ! Alternatively, compute all my_npert with ZGEMM (more memory but it should be more efficient).
3047 : :
3048 : : !select case (db%gpu_option)
3049 : : !case (ABI_GPU_DISABLED)
3050 : : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,1), 1, &
3051 : 20016 : zero_sp, ov1r_sp(1,1), 2)
3052 : : call SGEMV("T", db%my_nrpt, nfft, one_sp, db%wsr(1,1,1,ispden,imyp), db%my_nrpt, weiqr_sp(1,2), 1, &
3053 : 20016 : zero_sp, ov1r_sp(2,1), 2)
3054 : : !case (ABI_GPU_OPENMP)
3055 : : ! TODO
3056 : : !case default
3057 : : ! ABI_ERROR(sjoin("ftinterp_qpt: unsupported gpu_option:", itoa(db%gpu_option)))
3058 : : !end select
3059 : :
3060 [ + + + + ]: 406968624 : ov1r(:, :, ispden, imyp) = ov1r_sp(:, :)
3061 : :
3062 : : ! Add the long-range part of the potential
3063 [ + + ]: 20016 : if (my_add_lr > 0) then
3064 : : !call wrtout(std_out, "Adding the long-range part of the potential")
3065 [ + + + + ]: 164629692 : ov1r(:, :, ispden, imyp) = ov1r(:, :, ispden, imyp) + v1r_lr(:, :, imyp)
3066 : : end if
3067 : :
3068 : : ! Remove the phase to get the lattice-periodic part.
3069 [ + + ]: 80064 : call times_eikr(-qpt, ngfft, nfft, 1, ov1r(:, :, ispden, imyp))
3070 : :
3071 : : ! Need to collect results if R-points are distributed (TODO Non-blocking API?)
3072 [ - + ]: 40032 : if (db%nprocs_rpt > 1) call xmpi_sum(ov1r(:,:,ispden,imyp), comm_rpt, ierr)
3073 : : end do ! ispden
3074 : :
3075 : : ! Be careful with Gamma-point and cplex!
3076 [ + + ]: 23778 : if (db%symv1 == 1) then !(.and. receiver == -1 .or. receiver == db%comm_rpt%my_rank)
3077 : : call v1phq_symmetrize(db%cryst, idir, ipert, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, &
3078 : 1218 : db%mpi_enreg, ov1r(:,:,:,imyp))
3079 : : end if
3080 : : end do ! imyp
3081 : :
3082 [ - + ]: 3762 : ABI_FREE(ov1r_sp)
3083 : :
3084 [ - + ]: 3762 : if (db%symv1 == 2) then
3085 : : ! Symmetrize potentials (this part is seldom executed)
3086 : : ! Initialize the list of perturbations rfpert and rdfir
3087 : : ! WARNING: Only phonon perturbations are considered for the time being.
3088 [ # # # # : 0 : ABI_MALLOC(rfpert, (db%mpert))
# # # # #
# # # ]
3089 [ # # # # : 0 : rfpert = 0; rfpert(1:db%cryst%natom) = 1; rfdir = 1
# # ]
3090 [ # # # # : 0 : ABI_MALLOC(pertsy, (3, db%mpert))
# # # # #
# # # ]
3091 [ # # # # : 0 : ABI_MALLOC(pflag, (3, db%natom))
# # # # #
# # # ]
3092 : :
3093 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
3094 : : ! 0 for non-target perturbations
3095 : : ! 1 for basis perturbations
3096 : : ! -1 for perturbations that can be found from basis perturbations
3097 : : call irreducible_set_pert(db%cryst%indsym,db%mpert,db%cryst%natom,db%cryst%nsym,&
3098 : 0 : pertsy,rfdir,rfpert,symq,db%cryst%symrec,db%cryst%symrel)
3099 : :
3100 [ # # # # ]: 0 : pflag = 0
3101 [ # # ]: 0 : do imyp=1,3*db%cryst%natom
3102 : 0 : idir = mod(imyp-1, 3) + 1; ipert = (imyp - idir) / 3 + 1
3103 [ # # ]: 0 : if (pertsy(idir, ipert) == 1) pflag(idir,ipert) = 1
3104 : : end do
3105 : :
3106 : : ! Complete potentials
3107 : 0 : call v1phq_complete(db%cryst,qpt,ngfft,cplex2,nfft,db%nspden,db%nsppol,db%mpi_enreg,db%symv1,pflag,ov1r)
3108 : :
3109 [ # # ]: 0 : ABI_FREE(pertsy)
3110 [ # # ]: 0 : ABI_FREE(rfpert)
3111 [ # # ]: 0 : ABI_FREE(pflag)
3112 : : endif
3113 : :
3114 : : ! Set imaginary part to zero if gamma point.
3115 [ + + + + : 6133032 : if (sum(qpt**2) < tol14) ov1r(2, :, :, :) = zero
+ + + + +
+ ]
3116 : :
3117 [ - + ]: 3762 : ABI_FREE(eiqr)
3118 [ - + ]: 3762 : ABI_FREE(weiqr_sp)
3119 [ + + ]: 3762 : ABI_SFREE(v1r_lr)
3120 [ + - ]: 3762 : ABI_SFREE(eiqr_sp)
3121 : :
3122 : 3762 : end subroutine dvdb_ftinterp_qpt
3123 : : !!***
3124 : :
3125 : : !----------------------------------------------------------------------
3126 : :
3127 : : !!****f* m_dvdb/dvdb_get_ftqbz
3128 : : !! NAME
3129 : : !! dvdb_get_ftqbz
3130 : : !!
3131 : : !! FUNCTION
3132 : : !! Fourier interpolation of potentials for a given q-point in the BZ (qbz).
3133 : : !! Internal tables must be prepared in advance by calling `dvdb_ftinterp_setup`.
3134 : : !!
3135 : : !! INPUTS
3136 : : !! qbz(3)= q-point in the BZ in reduced coordinates.
3137 : : !! nfft=Number of fft-points treated by this processors
3138 : : !! ngfft(18)=contain all needed information about 3D FFT
3139 : : !!
3140 : : !! OUTPUT
3141 : : !! ov1r(2*nfft, nspden, my_npert)=Interpolated DFPT potentials at the given q-point.
3142 : : !!
3143 : : !! SOURCE
3144 : :
3145 : 3757 : subroutine dvdb_get_ftqbz(db, qbz, cplex, nfft, ngfft, v1scf, comm)
3146 : :
3147 : : !Arguments ------------------------------------
3148 : : !scalars
3149 : : class(dvdb_t),intent(inout) :: db
3150 : : integer,intent(in) :: nfft, comm
3151 : : integer,intent(out) :: cplex
3152 : : !arrays
3153 : : integer,intent(in) :: ngfft(18)
3154 : : real(dp),intent(in) :: qbz(3)
3155 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3156 : :
3157 : : !Local variables-------------------------------
3158 : : real(dp) :: tsec(2)
3159 : : ! *************************************************************************
3160 : :
3161 : : ABI_UNUSED(comm)
3162 : :
3163 : : ! Keep track of total time spent.
3164 : 3757 : call timab(1809, 1, tsec)
3165 : :
3166 : : ! Interpolate the dvscf potentials directly in the **BZ** for my_npert perturbations.
3167 : : ! This is possible only if all procs inside comm_rpt call this routine else deadlock
3168 : : ! Note that cplex is always set to 2 here
3169 : 3757 : cplex = 2
3170 [ - + + - : 18785 : ABI_MALLOC(v1scf, (cplex, nfft, db%nspden, db%my_npert))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3171 : 3757 : call db%ftinterp_qpt(qbz, nfft, ngfft, v1scf, db%comm_rpt)
3172 : 3757 : call timab(1809, 2, tsec)
3173 : :
3174 : 3757 : end subroutine dvdb_get_ftqbz
3175 : : !!***
3176 : :
3177 : : !----------------------------------------------------------------------
3178 : :
3179 : : !!****f* m_dvdb/dvdb_get_vxc1_ftqbz
3180 : : !! NAME
3181 : : !! dvdb_get_vxc1_ftqbz
3182 : : !!
3183 : : !! FUNCTION
3184 : : !! Fourier interpolation of the first-order change of exchange-correlation potential
3185 : : !! for a given q-point in the BZ (qbz).
3186 : : !!
3187 : : !! INPUTS
3188 : : !! cryst<crystal_t>=crystal structure parameters
3189 : : !! dtset<dataset_type>=All input variables for this dataset
3190 : : !! qbz(3)=Q-point in BZ
3191 : : !! nfft=Number of fft-points treated by this processors
3192 : : !! ngfft(18)=contain all needed information about 3D FFT
3193 : : !! nkxc=second dimension of the array kxc, see rhohxc.f for a description
3194 : : !! kxc(nfftf,nkxc)=second derivative of the exchange-correlation functional
3195 : : !! non_magnetic_xc=true if density/potential is handled as non-magnetic
3196 : : !! usexcnhat=0, the exchange-correlation potential does not include the compensation charge density
3197 : : !! comm=MPI communicator (either xmpi_comm_self or comm for perturbations
3198 : : !!
3199 : : !! OUTPUT
3200 : : !! drho_cplex=1 if real, 2 if complex.
3201 : : !! vxc1(drho_cplex, nfft, nspden, db%my_npert)= vxc1 potentials on the real-space FFT mesh
3202 : : !! for the db%my_npert perturbations treated by this MPI rank.
3203 : : !!
3204 : : !! SOURCE
3205 : :
3206 : 0 : subroutine dvdb_get_vxc1_ftqbz(db, dtset, cryst, qbz, drho_cplex, nfft, ngfft, nkxc, kxc, &
3207 : : vxc1, non_magnetic_xc, usexcnhat, comm)
3208 : :
3209 : : !Arguments ------------------------------------
3210 : : !scalars
3211 : : class(dvdb_t),intent(inout) :: db
3212 : : integer,intent(in) :: nfft, nkxc, usexcnhat, comm
3213 : : integer,intent(out) :: drho_cplex
3214 : : real(dp),intent(in) :: qbz(3)
3215 : : type(dataset_type),intent(in) :: dtset
3216 : : type(crystal_t),intent(in) :: cryst
3217 : : logical,intent(in) :: non_magnetic_xc
3218 : : !arrays
3219 : : integer,intent(in) :: ngfft(18)
3220 : : real(dp),intent(in) :: kxc(nfft,nkxc)
3221 : : real(dp),allocatable,intent(out) :: vxc1(:,:,:,:)
3222 : :
3223 : : !Local variables-------------------------------
3224 : : !scalars
3225 : : integer :: option,imyp
3226 : : !arrays
3227 : 0 : real(dp),allocatable :: rho1(:,:,:,:)
3228 : : real(dp) :: dum_nhat(0), dum_xccc3d1(0)
3229 : : ! *************************************************************************
3230 : :
3231 : : ! Get rho1(cplex, nfftf, nspden, my_npert))
3232 : 0 : call db%get_ftqbz(qbz, drho_cplex, nfft, ngfft, rho1, comm)
3233 : :
3234 : 0 : option = 2 ! if 2, treat only density change
3235 : : !option = 1 ! if 1, treat both density change and XC core correction
3236 [ # # # # : 0 : ABI_MALLOC(vxc1, (drho_cplex, nfft, dtset%nspden, db%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3237 : :
3238 [ # # ]: 0 : do imyp=1,db%my_npert
3239 : : call dfpt_mkvxc(drho_cplex,dtset%ixc,kxc,db%mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,&
3240 : : nkxc,non_magnetic_xc,dtset%nspden,0,option,qbz,rho1(:,:,:,imyp),&
3241 : 0 : cryst%rprimd,usexcnhat,vxc1(:,:,:,imyp),dum_xccc3d1)
3242 : : end do
3243 : :
3244 [ # # ]: 0 : ABI_FREE(rho1)
3245 : :
3246 : 0 : end subroutine dvdb_get_vxc1_ftqbz
3247 : : !!***
3248 : :
3249 : : !----------------------------------------------------------------------
3250 : :
3251 : : !!****f* m_dvdb/dvdb_get_v1scf_rpt
3252 : : !! NAME
3253 : : !! dvdb_get_v1scf_rpt
3254 : : !!
3255 : : !! FUNCTION
3256 : : !! Compute the phonon perturbation potential in real space lattice representation.
3257 : : !! This routine is meant to replace dvdb_ftinterp_setup
3258 : : !! and performs the potential interpolation one perturbation at a time.
3259 : : !!
3260 : : !! INPUTS
3261 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3262 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3263 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3264 : : !! nfft=Number of fft-points treated by this processors
3265 : : !! ngfft(18)=contain all needed information about 3D FFT
3266 : : !! nrpt=Number of R-points = number of q-points in the full BZ
3267 : : !! nspden=Number of spin densities.
3268 : : !! ipert=index of the perturbation to be treated [1,natom3]
3269 : : !! comm=MPI communicator
3270 : : !!
3271 : : !! OUTPUT
3272 : : !! v1scf_rpt(2,nrpt,nfft,nspden)
3273 : : !!
3274 : : !! SOURCE
3275 : :
3276 : 31 : subroutine dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3277 : 31 : nrpt, nspden, ipert, v1scf_rpt, comm)
3278 : :
3279 : : !Arguments ------------------------------------
3280 : : !scalars
3281 : : integer,intent(in) :: nqshift,nfft,nrpt,nspden,ipert,comm
3282 : : class(dvdb_t),target,intent(inout) :: db
3283 : : !arrays
3284 : : integer,intent(in) :: ngqpt(3),ngfft(18)
3285 : : real(dp),intent(in) :: qshift(3,nqshift)
3286 : : real(dp),intent(out) :: v1scf_rpt(2,nrpt,nfft,nspden)
3287 : : type(crystal_t),intent(in) :: cryst
3288 : :
3289 : : !Local variables-------------------------------
3290 : : !scalars
3291 : : integer,parameter :: sppoldbl1=1, timrev1=1
3292 : : integer :: my_qptopt,iq_ibz,nqibz,iq_bz,nqbz
3293 : : integer :: ii,iq_dvdb,cplex_qibz,ispden,irpt,idir,iat
3294 : : integer :: iqst,nqst,itimrev,tsign,isym,ix,iy,iz,nq1,nq2,nq3,r1,r2,r3
3295 : : integer :: nproc,my_rank,ifft,cnt,ierr
3296 : : character(len=500) :: msg
3297 : : real(dp) :: dksqmax, cpu, wall, gflops
3298 : : logical :: isirr_q, found
3299 : : !arrays
3300 : : integer :: qptrlatt(3,3),g0q(3)
3301 : 31 : integer,allocatable :: indqq(:,:),iperm(:),bz2ibz_sort(:),nqsts(:),iqs_dvdb(:)
3302 : : real(dp) :: qpt_bz(3),shift(3)
3303 : 31 : real(dp),allocatable :: qibz(:,:),qbz(:,:),wtq(:),emiqr(:,:)
3304 : 31 : real(dp),allocatable :: v1r_qibz(:,:,:,:),v1r_qbz(:,:,:,:), v1r_lr(:,:)
3305 : : ! *************************************************************************
3306 : :
3307 : : !ABI_ERROR("Legacy code!")
3308 : :
3309 : 31 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3310 : :
3311 : 31 : nq1 = ngqpt(1); nq2 = ngqpt(2); nq3 = ngqpt(3); my_qptopt = 1 !; if (present(qptopt)) my_qptopt = qptopt
3312 : :
3313 : : ! Generate the q-mesh by finding the IBZ and the corresponding weights.
3314 : 31 : qptrlatt = 0
3315 [ + + ]: 124 : do ii=1,3
3316 : 124 : qptrlatt(ii,ii) = ngqpt(ii)
3317 : : end do
3318 : :
3319 : : ! Get IBZ and BZ.
3320 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, &
3321 : 31 : nqibz, qibz, wtq, nqbz, qbz) ! new_kptrlatt, new_shiftk)
3322 : :
3323 : : !write(std_out,*)"Irreducible q-points:"
3324 : : !do iq_ibz=1,nqibz; write(std_out,*)trim(ktoa(qibz(:,iq_ibz))),wtq(iq_ibz)*nqbz; end do
3325 [ + + - + ]: 124 : ABI_CHECK(nqbz == product(ngqpt) * nqshift, "nqbz /= product(ngqpt) * nqshift")
3326 [ - + ]: 31 : ABI_CHECK(nqbz == nrpt, "nqbz /= nrpt")
3327 : :
3328 : 31 : db%my_nrpt = nqbz
3329 : :
3330 [ - + ]: 31 : ABI_CHECK(nspden == db%nspden, "nspden /= db%nspden")
3331 : :
3332 : : ! We want a gamma centered q-mesh for FFT.
3333 [ - + ]: 31 : ABI_CHECK(nqshift == 1, "nshift > 1 not supported")
3334 [ + + + - : 124 : ABI_CHECK(all(qshift(:,1) == zero), "qshift != 0 not supported")
- + ]
3335 : :
3336 [ - + ]: 31 : ABI_FREE(qbz)
3337 [ - + + - : 93 : ABI_MALLOC(qbz, (3, nqbz))
+ - + - -
+ - + ]
3338 : 31 : ii = 0
3339 [ + + ]: 99 : do iz=0,nq3-1
3340 [ + + ]: 259 : do iy=0,nq2-1
3341 [ + + ]: 644 : do ix=0,nq1-1
3342 : 416 : ii = ii + 1
3343 [ + + ]: 1664 : qbz(:, ii) = [ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)]
3344 [ + + ]: 1824 : call wrap2_pmhalf([ix/dble(nq1), iy/dble(nq2), iz/dble(nq3)], qbz(:,ii), shift)
3345 : : end do
3346 : : end do
3347 : : end do
3348 : :
3349 : : ! Compute real-space points.
3350 : : ! Use the following indexing (N means ngfft of the adequate direction)
3351 : : ! 0 1 2 3 ... N/2 -(N-1)/2 ... -1 <= gc
3352 : : ! 1 2 3 4 ....N/2+1 N/2+2 ... N <= index ig
3353 [ - + + - : 93 : ABI_MALLOC(db%my_rpt, (3, db%my_nrpt))
+ - + - -
+ - + -
+ ]
3354 : 31 : ii = 0
3355 [ + + ]: 99 : do iz=1,nq3
3356 : 68 : r3 = ig2gfft(iz,nq3)
3357 [ + + ]: 259 : do iy=1,nq2
3358 : 160 : r2 = ig2gfft(iy,nq2)
3359 [ + + ]: 644 : do ix=1,nq1
3360 : 416 : r1 = ig2gfft(ix,nq1)
3361 : 416 : ii = ii + 1
3362 [ + + ]: 1824 : db%my_rpt(:,ii) = [r1, r2, r3]
3363 : : end do
3364 : : end do
3365 : : end do
3366 : :
3367 : : ! Find correspondence BZ --> IBZ. Note:
3368 : : ! q --> -q symmetry is always used for phonons.
3369 : : ! we use symrec instead of symrel
3370 [ - + + - : 93 : ABI_MALLOC(indqq, (nqbz*sppoldbl1,6))
+ - + - -
+ - + ]
3371 : : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,&
3372 : 31 : sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.)
3373 : :
3374 : : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3375 : : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3376 : : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3377 : : !call qrank%free()
3378 : :
3379 [ - + ]: 31 : if (dksqmax > tol12) then
3380 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3381 : : end if
3382 : :
3383 : : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
3384 [ - + + - : 93 : ABI_MALLOC(iperm, (nqbz))
+ - + - -
+ - + ]
3385 [ - + + - : 62 : ABI_MALLOC(bz2ibz_sort, (nqbz))
- + - + ]
3386 [ - + + + : 1310 : iperm = [(ii, ii=1,nqbz)]
+ - + + +
- - + - -
+ + ]
3387 [ - + + + ]: 478 : bz2ibz_sort = indqq(:,1)
3388 : 31 : call sort_int(nqbz, bz2ibz_sort, iperm)
3389 : :
3390 : : ! Reconstruct the IBZ according to what is present in the DVDB.
3391 [ - + + - : 93 : ABI_MALLOC(nqsts, (nqibz))
+ - + - -
+ - + ]
3392 [ - + + - : 62 : ABI_MALLOC(iqs_dvdb, (nqibz))
- + - + ]
3393 [ - + + - : 93 : ABI_MALLOC(v1r_lr, (2,nfft))
+ - + - -
+ - + ]
3394 : :
3395 : 31 : iqst = 0
3396 [ + + ]: 139 : do iq_ibz=1,nqibz
3397 : : ! In each q-point star, count the number of q-points and find the one present in DVDB.
3398 : 108 : nqst = 0
3399 : 108 : found = .false.
3400 [ + + ]: 524 : do ii=iqst+1,nqbz
3401 [ + + ]: 493 : if (bz2ibz_sort(ii) /= iq_ibz) exit
3402 : 416 : nqst = nqst + 1
3403 : :
3404 : 416 : iq_bz = iperm(ii)
3405 [ + + ]: 524 : if (.not. found) then
3406 : 317 : iq_dvdb = db%findq(qbz(:,iq_bz))
3407 [ + + ]: 317 : if (iq_dvdb /= -1) then
3408 [ + + ]: 432 : qibz(:,iq_ibz) = qbz(:,iq_bz)
3409 : 108 : iqs_dvdb(iq_ibz) = iq_dvdb
3410 : 108 : found = .true.
3411 : : end if
3412 : : end if
3413 : : end do
3414 : :
3415 : : ! Check that nqst has been counted properly.
3416 [ + - - + ]: 108 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst+1) == iq_ibz, "Wrong iqst")
3417 [ - + ]: 108 : if (abs(nqst - wtq(iq_ibz) * nqbz) > tol12) then
3418 : 0 : write(std_out,*)nqst, wtq(iq_ibz) * nqbz
3419 : 0 : ABI_ERROR("Error in counting q-point star or in the weights.")
3420 : : end if
3421 : :
3422 : : ! Check that the q-point has been found in DVDB.
3423 [ - + ]: 108 : if (.not. found) then
3424 : 0 : ABI_ERROR(sjoin("Cannot find symmetric q-point of:", ktoa(qibz(:,iq_ibz)), "in DVDB file"))
3425 : : end if
3426 : : !write(std_out,*)sjoin("qpt irred:",ktoa(qibz(:,iq_ibz)))
3427 : :
3428 : 108 : iqst = iqst + nqst
3429 : 139 : nqsts(iq_ibz) = nqst
3430 : : end do
3431 : :
3432 : : ! Redo the mapping with the new IBZ
3433 : : call listkk(dksqmax,cryst%gmet,indqq,qibz,qbz,nqibz,nqbz,cryst%nsym,&
3434 : 31 : sppoldbl1,cryst%symafm,cryst%symrec,timrev1,comm,use_symrec=.True.)
3435 : :
3436 : : !call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
3437 : : !call qrank%get_mapping(new%nqbz, new%qbz, dksqmax, cryst%gmet, temp, &
3438 : : ! cryst%nsym, cryst%symafm, cryst%symrec, 1, use_symrec=.True.)
3439 : : !call qrank%free()
3440 : :
3441 [ - + ]: 31 : if (dksqmax > tol12) then
3442 : 0 : ABI_BUG("Something wrong in the generation of the q-points in the BZ! Cannot map BZ --> IBZ")
3443 : : end if
3444 : :
3445 [ - + + - : 93 : ABI_MALLOC(emiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
3446 [ + + + + : 11230149 : v1scf_rpt = zero
+ + + + ]
3447 : :
3448 [ - + + - : 155 : ABI_MALLOC_OR_DIE(v1r_qbz, (2, nfft, db%nspden, db%natom3), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
3449 : : !v1r_qbz = huge(one)
3450 : :
3451 : 31 : iqst = 0
3452 : 31 : call cwtime(cpu, wall, gflops, "start")
3453 [ + + ]: 139 : do iq_ibz=1,nqibz
3454 : :
3455 : : ! Get potentials for this IBZ q-point on the real-space FFT mesh.
3456 : : ! This call allocates v1r_qibz(cplex_qibz, nfft, nspden, 3*natom)
3457 [ - + ]: 108 : call db%readsym_allv1(iqs_dvdb(iq_ibz), cplex_qibz, nfft, ngfft, v1r_qibz, comm)
3458 : :
3459 : : ! Reconstruct by symmetry the potentials for the star of this q-point, perform FT and accumulate
3460 : : ! Be careful with the gamma point.
3461 [ + + ]: 524 : do ii=1,nqsts(iq_ibz)
3462 : 416 : iqst = iqst + 1
3463 : 416 : iq_bz = iperm(iqst)
3464 [ - + ]: 416 : ABI_CHECK(iq_ibz == indqq(iq_bz,1), "iq_ibz !/ ind qq(1)")
3465 [ + + ]: 1664 : isym = indqq(iq_bz,2); itimrev = indqq(iq_bz,6) + 1; g0q = indqq(iq_bz,3:5) ! IS(q_ibz) + g0q = q_bz
3466 : 416 : tsign = 3-2*itimrev
3467 : :
3468 [ + + ]: 1664 : qpt_bz = qbz(:, iq_bz)
3469 : : !write(std_out,*)" treating:",trim(ktoa(qpt_bz))
3470 [ + + + + : 1681 : isirr_q = (isym == 1 .and. itimrev == 1 .and. all(g0q == 0))
+ + - + ]
3471 : : !ABI_CHECK(all(g0q == 0), "g0q /= 0")
3472 : :
3473 : : ! Compute long-range part of the coupling potential
3474 : : !call cwtime(cpu, wall, gflops, "start")
3475 [ + + + + ]: 10816136 : v1r_lr = zero; cnt = 0
3476 [ + + ]: 416 : if (db%add_lr /= 0) then
3477 : 128 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3478 : 128 : call db%get_v1r_long_range(qpt_bz, idir, iat, nfft, ngfft, v1r_lr)
3479 : : end if
3480 : : !call cwtime_report(" dvdb_get_v1r_long_range", cpu, wall, gflops)
3481 : :
3482 [ + + ]: 524 : if (cplex_qibz == 1) then
3483 : : ! Gamma point.
3484 [ - + ]: 31 : ABI_CHECK(nqsts(iq_ibz) == 1, "cplex_qibz == 1 and nq nqst /= 1 (should be gamma)")
3485 [ + + + - : 124 : ABI_CHECK(all(g0q == 0), "gamma point with g0q /= 0")
- + ]
3486 : :
3487 : : ! Subtract the long-range part of the potential
3488 [ + + ]: 31 : if (db%add_lr /= 0) then
3489 [ + + ]: 32 : do ispden=1,db%nspden
3490 [ + + ]: 159090 : v1r_qibz(1,:,ispden,ipert) = v1r_qibz(1,:,ispden,ipert) - v1r_lr(1,:)
3491 : : end do
3492 : : end if
3493 : :
3494 : : ! SLOW FT.
3495 : : !call cwtime(cpu, wall, gflops, "start")
3496 : 31 : cnt = 0
3497 [ + + ]: 62 : do ispden=1,db%nspden
3498 [ + + ]: 478 : do irpt=1,db%my_nrpt
3499 : : ! MPI-parallelism
3500 [ + - ]: 416 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
3501 [ + + ]: 3605687 : do ifft=1,nfft
3502 : : v1scf_rpt(1,irpt,ifft,ispden) = v1scf_rpt(1,irpt,ifft,ispden) + &
3503 : 3605656 : v1r_qibz(1, ifft, ispden, ipert)
3504 : : end do
3505 : : end do
3506 : : end do
3507 : : !call cwtime_report(" slow fft", cpu, wall, gflops)
3508 : :
3509 : : else
3510 : : ! q /= Gamma
3511 : : ! Get the periodic part of the potential in BZ (v1r_qbz)
3512 [ + + ]: 385 : if (isirr_q) then
3513 : : !write(std_out,*)sjoin("qpt irred:",ktoa(qpt_bz))
3514 [ + - + - : 15058132 : v1r_qbz = v1r_qibz
+ - + - -
+ - - - -
- - - - -
- + + + +
+ + + + ]
3515 : : else
3516 : : !call cwtime(cpu, wall, gflops, "start")
3517 : : call v1phq_rotate(cryst, qibz(:,iq_ibz), isym, itimrev, g0q, &
3518 : 308 : ngfft, cplex_qibz, nfft, db%nspden, db%mpi_enreg, v1r_qibz, v1r_qbz, xmpi_comm_self)
3519 : : end if
3520 : :
3521 : : ! Multiply by e^{iqpt_bz.r}
3522 : 385 : call times_eikr(qpt_bz, ngfft, nfft, db%nspden*db%natom3, v1r_qbz)
3523 : :
3524 : : ! Subtract the long-range part of the potential
3525 [ + + ]: 385 : if (db%add_lr /= 0) then
3526 [ + + ]: 224 : do ispden=1,db%nspden
3527 [ + + ]: 1113518 : v1r_qbz(1,:,ispden,ipert) = v1r_qbz(1,:,ispden,ipert) - v1r_lr(1,:)
3528 [ + + ]: 1113630 : v1r_qbz(2,:,ispden,ipert) = v1r_qbz(2,:,ispden,ipert) - v1r_lr(2,:)
3529 : : end do
3530 : : end if
3531 : :
3532 : : ! Compute FT phases for this qpt_bz.
3533 [ + + ]: 1540 : call calc_eiqr(-qpt_bz, db%my_nrpt, db%my_rpt, emiqr)
3534 : :
3535 : : ! SLOW FT.
3536 : : !call cwtime_report(" phases", cpu, wall, gflops)
3537 : 385 : cnt = 0
3538 [ + + ]: 770 : do ispden=1,db%nspden
3539 [ + + ]: 3191643 : do ifft=1,nfft
3540 [ + - ]: 3190873 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
3541 : :
3542 : : v1scf_rpt(1,:,ifft,ispden) = v1scf_rpt(1,:,ifft,ispden) &
3543 : : + emiqr(1,:) * v1r_qbz(1, ifft, ispden, ipert) &
3544 [ + + ]: 47007009 : - emiqr(2,:) * v1r_qbz(2, ifft, ispden, ipert)
3545 : :
3546 : : v1scf_rpt(2,:,ifft,ispden) = v1scf_rpt(2,:,ifft,ispden) &
3547 : : + emiqr(1,:) * v1r_qbz(2, ifft, ispden, ipert) &
3548 [ + + ]: 47007394 : + emiqr(2,:) * v1r_qbz(1, ifft, ispden, ipert)
3549 : : end do
3550 : : end do
3551 : : !call cwtime_report(" slow fft", cpu, wall, gflops)
3552 : : end if
3553 : :
3554 : : end do ! iqst
3555 : :
3556 : 108 : write(msg,'(2(a,i0),a)') " q-point [",iq_ibz,"/",nqibz,"]"
3557 : 108 : call cwtime_report(msg, cpu, wall, gflops)
3558 : :
3559 [ - + ]: 139 : ABI_FREE(v1r_qibz)
3560 : : end do ! iq_ibz
3561 [ - + ]: 31 : ABI_CHECK(iqst == nqbz, "iqst /= nqbz")
3562 : :
3563 [ + + + + : 11230149 : v1scf_rpt = v1scf_rpt / nqbz
+ + + + ]
3564 : 31 : call xmpi_sum(v1scf_rpt, comm, ierr)
3565 : :
3566 [ - + ]: 31 : ABI_FREE(emiqr)
3567 [ - + ]: 31 : ABI_FREE(qibz)
3568 [ - + ]: 31 : ABI_FREE(wtq)
3569 [ - + ]: 31 : ABI_FREE(qbz)
3570 [ - + ]: 31 : ABI_FREE(indqq)
3571 [ - + ]: 31 : ABI_FREE(iperm)
3572 [ - + ]: 31 : ABI_FREE(bz2ibz_sort)
3573 [ - + ]: 31 : ABI_FREE(iqs_dvdb)
3574 [ - + ]: 31 : ABI_FREE(nqsts)
3575 [ - + ]: 31 : ABI_FREE(v1r_qbz)
3576 [ - + ]: 31 : ABI_FREE(v1r_lr)
3577 : :
3578 [ - + ]: 62 : end subroutine dvdb_get_v1scf_rpt
3579 : : !!***
3580 : :
3581 : : !----------------------------------------------------------------------
3582 : :
3583 : : !!****f* m_dvdb/dvdb_get_v1scf_qpt
3584 : : !! NAME
3585 : : !! dvdb_get_v1scf_qpt
3586 : : !!
3587 : : !! FUNCTION
3588 : : !! Fourier interpolation of potentials for a given q-point
3589 : : !! This routine is meant to replace dvdb_ftinterp_qpt
3590 : : !! by performing the interpolation one perturbation at a time.
3591 : : !!
3592 : : !! INPUTS
3593 : : !! qpt(3)=q-point in reduced coordinates.
3594 : : !! nfft=Number of fft-points treated by this processors
3595 : : !! ngfft(18)=contain all needed information about 3D FFT
3596 : : !! nrpt=Number of R-points = number of q-points in the full BZ
3597 : : !! nspden=Number of spin densities.
3598 : : !! ipert=index of the perturbation to be treated [1,natom3]
3599 : : !! v1scf_rpt(2,nrpt,nfft,nspden)=phonon perturbation potential in real space lattice representation.
3600 : : !! comm=MPI communicator
3601 : : !!
3602 : : !! OUTPUT
3603 : : !! v1scf_qpt(2*nfft, nspden)=Interpolated DFPT potentials at the given q-point.
3604 : : !!
3605 : : !! SOURCE
3606 : :
3607 : 244 : subroutine dvdb_get_v1scf_qpt(db, cryst, qpt, nfft, ngfft, nrpt, nspden, &
3608 : 244 : ipert, v1scf_rpt, v1scf_qpt, comm)
3609 : :
3610 : : !Arguments ------------------------------------
3611 : : !scalars
3612 : : integer,intent(in) :: nfft,nrpt,nspden,ipert,comm
3613 : : class(dvdb_t),intent(in) :: db
3614 : : type(crystal_t),intent(in) :: cryst
3615 : : !arrays
3616 : : integer,intent(in) :: ngfft(18)
3617 : : real(dp),intent(in) :: qpt(3)
3618 : : real(dp),intent(in) :: v1scf_rpt(2,nrpt,nfft,db%nspden)
3619 : : real(dp),intent(out) :: v1scf_qpt(2,nfft,db%nspden)
3620 : :
3621 : : !Local variables-------------------------------
3622 : : !scalars
3623 : : integer,parameter :: cplex2=2
3624 : : integer :: ir,ispden,ifft,idir,iat,timerev_q,nproc,my_rank,cnt,ierr
3625 : : real(dp) :: wr,wi
3626 : : !arrays
3627 : 488 : integer :: symq(4,2,db%cryst%nsym)
3628 : 244 : real(dp),allocatable :: eiqr(:,:), v1r_lr(:,:)
3629 : : ! *************************************************************************
3630 : :
3631 : : !ABI_ERROR("Legacy code!")
3632 : :
3633 : : ABI_UNUSED(cryst%natom)
3634 : : ABI_UNUSED(nspden)
3635 : :
3636 : 244 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3637 : :
3638 [ - + + - : 732 : ABI_MALLOC(v1r_lr, (2,nfft))
+ - + - -
+ - + ]
3639 : :
3640 : : ! Examine the symmetries of the q wavevector
3641 : 244 : call littlegroup_q(db%cryst%nsym, qpt, symq, db%cryst%symrec, db%cryst%symafm, timerev_q, prtvol=db%prtvol)
3642 : :
3643 : : ! Compute FT phases for this q-point.
3644 [ - + + - : 732 : ABI_MALLOC(eiqr, (2, db%my_nrpt))
+ - + - -
+ - + ]
3645 : 244 : call calc_eiqr(qpt, db%my_nrpt, db%my_rpt, eiqr)
3646 : :
3647 : 244 : idir = mod(ipert-1, 3) + 1; iat = (ipert - idir) / 3 + 1
3648 : :
3649 : : ! Compute long-range part of the coupling potential
3650 [ + + + + ]: 10437202 : v1r_lr = zero; cnt = 0
3651 [ + + ]: 244 : if (db%add_lr > 0) call db%get_v1r_long_range(qpt, idir, iat, nfft, ngfft, v1r_lr)
3652 : :
3653 : : ! TODO: If high-symmetry q-points, one could save flops by FFT interpolating the independent
3654 : : ! TODO: Use ZGEMM with MPI
3655 : : ! perturbations and then rotate ...
3656 [ + + + + : 10437446 : v1scf_qpt = zero; cnt = 0
+ + ]
3657 [ + + ]: 488 : do ispden=1,db%nspden
3658 [ + + ]: 3479230 : do ifft=1,nfft
3659 [ + - ]: 3478986 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI-parallelism
3660 : :
3661 [ + + ]: 36342810 : do ir=1,db%my_nrpt
3662 : 32863824 : wr = v1scf_rpt(1, ir,ifft,ispden)
3663 : 32863824 : wi = v1scf_rpt(2, ir,ifft,ispden)
3664 : 32863824 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + wr*eiqr(1,ir) - wi * eiqr(2,ir)
3665 : 36342810 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + wr*eiqr(2,ir) + wi * eiqr(1,ir)
3666 : : end do
3667 : :
3668 : : ! Add the long-range part of the potential
3669 [ + + ]: 3478986 : if (db%add_lr > 0) then
3670 : 2555380 : v1scf_qpt(1,ifft,ispden) = v1scf_qpt(1,ifft,ispden) + v1r_lr(1,ifft)
3671 : 2555380 : v1scf_qpt(2,ifft,ispden) = v1scf_qpt(2,ifft,ispden) + v1r_lr(2,ifft)
3672 : : end if
3673 [ - + ]: 3479230 : if (db%add_lr == 4) then
3674 : 0 : v1scf_qpt(1,ifft,ispden) = v1r_lr(1,ifft)
3675 : 0 : v1scf_qpt(2,ifft,ispden) = v1r_lr(2,ifft)
3676 : : end if
3677 : : end do ! ifft
3678 : :
3679 : 244 : call xmpi_sum(v1scf_qpt(:,:,ispden), comm, ierr)
3680 : :
3681 : : ! Remove the phase.
3682 [ + + ]: 1220 : call times_eikr(-qpt, ngfft, nfft, 1, v1scf_qpt(:,:,ispden))
3683 : : end do
3684 : :
3685 : : ! Be careful with gamma and cplex!
3686 [ + + ]: 244 : if (db%symv1 == 1) then
3687 : 28 : call v1phq_symmetrize(db%cryst, idir, iat, symq, ngfft, cplex2, nfft, db%nspden, db%nsppol, db%mpi_enreg, v1scf_qpt)
3688 : : end if
3689 : :
3690 [ - + ]: 244 : ABI_FREE(eiqr)
3691 [ - + ]: 244 : ABI_FREE(v1r_lr)
3692 : :
3693 : 244 : end subroutine dvdb_get_v1scf_qpt
3694 : : !!***
3695 : :
3696 : : !----------------------------------------------------------------------
3697 : :
3698 : : !!****f* m_dvdb/dvdb_interpolate_v1scf
3699 : : !! NAME
3700 : : !! dvdb_interpolate_v1scf
3701 : : !!
3702 : : !! FUNCTION
3703 : : !! Interpolate the phonon perturbation potential.
3704 : : !! This routine is meant to replace dvdb_ftinterp_setup and dvdb_ftinterp_qpt.
3705 : : !! It performs the interpolation one perturbation at a time.
3706 : : !!
3707 : : !! INPUTS
3708 : : !! ngqpt(3)=Divisions of the ab-initio q-mesh.
3709 : : !! nqshift=Number of shifts used to generated the ab-initio q-mesh.
3710 : : !! qshift(3,nqshift)=The shifts of the ab-initio q-mesh.
3711 : : !! nfft=Number of fft-points treated by this processors
3712 : : !! ngfft(18)=contain all needed information about 3D FFT
3713 : : !! nfftf=Number of fft-points on the fine grid for interpolated potential
3714 : : !! ngfftf(18)=information on 3D FFT for interpolated potential
3715 : : !! comm=MPI communicator
3716 : : !!
3717 : : !! OUTPUT
3718 : : !! v1scf(2, nfft, nspden, 3*natom)= v1scf potentials on the real-space FFT mesh for the 3*natom perturbations.
3719 : : !!
3720 : : !! SOURCE
3721 : :
3722 : 0 : subroutine dvdb_interpolate_v1scf(db, cryst, qpt, ngqpt, nqshift, qshift, &
3723 : : nfft, ngfft, nfftf, ngfftf, v1scf, comm)
3724 : :
3725 : : !Arguments ------------------------------------
3726 : : !scalars
3727 : : integer,intent(in) :: nqshift,nfft,nfftf,comm
3728 : : class(dvdb_t),target,intent(inout) :: db
3729 : : !arrays
3730 : : real(dp),intent(in) :: qpt(3)
3731 : : integer,intent(in) :: ngqpt(3),ngfft(18),ngfftf(18)
3732 : : real(dp),intent(in) :: qshift(3,nqshift)
3733 : : real(dp),allocatable,intent(out) :: v1scf(:,:,:,:)
3734 : : type(crystal_t),intent(in) :: cryst
3735 : :
3736 : : !Local variables-------------------------------
3737 : : !scalars
3738 : : integer :: ipert, nqbz, ierr, nproc, my_rank
3739 : : !real(dp) :: work_size
3740 : : !arrays
3741 : 0 : real(dp),allocatable :: v1scf_rpt(:,:,:,:)
3742 : : ! *************************************************************************
3743 : :
3744 : 0 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3745 : :
3746 [ # # ]: 0 : nqbz = product(ngqpt) * nqshift
3747 : 0 : db%my_nrpt = nqbz
3748 : :
3749 [ # # # # : 0 : ABI_MALLOC_OR_DIE(v1scf, (2,nfftf,db%nspden,db%natom3), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
3750 [ # # # # : 0 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2,db%my_nrpt,nfft,db%nspden), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
3751 : :
3752 [ # # ]: 0 : do ipert=1,db%natom3
3753 : 0 : write(std_out, "(a,i4,a,i4,a)") " Interpolating potential for perturbation ", ipert, " / ", db%natom3, ch10
3754 : :
3755 : : ! FIXME I think this should be ngfftf and not ngfft
3756 : : ! Also, other calls to dvdb_ftinterp_setup should use ngfftf.
3757 : : call dvdb_get_v1scf_rpt(db, cryst, ngqpt, nqshift, qshift, nfft, ngfft, &
3758 : 0 : db%my_nrpt, db%nspden, ipert, v1scf_rpt, comm)
3759 : :
3760 : : call dvdb_get_v1scf_qpt(db, cryst, qpt, nfftf, ngfftf, db%my_nrpt, db%nspden, &
3761 : 0 : ipert, v1scf_rpt, v1scf(:,:,:,ipert), comm)
3762 : :
3763 [ # # ]: 0 : ABI_FREE(db%my_rpt)
3764 : : end do
3765 : :
3766 [ # # ]: 0 : ABI_FREE(v1scf_rpt)
3767 : :
3768 : 0 : end subroutine dvdb_interpolate_v1scf
3769 : : !!***
3770 : :
3771 : : !----------------------------------------------------------------------
3772 : :
3773 : : !!****f* m_dvdb/dvdb_findq
3774 : : !! NAME
3775 : : !! dvdb_findq
3776 : : !!
3777 : : !! FUNCTION
3778 : : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3779 : : !! Returns -1 if not found.
3780 : : !!
3781 : : !! INPUTS
3782 : : !! qpt(3)=q-point in reduced coordinates.
3783 : : !! [qtol]=Optional tolerance for q-point comparison.
3784 : : !! For each reduced direction the absolute difference between the coordinates must be less that qtol
3785 : : !!
3786 : : !! SOURCE
3787 : :
3788 : 6172 : integer pure function dvdb_findq(db, qpt, qtol) result(iqpt)
3789 : :
3790 : : !Arguments ------------------------------------
3791 : : !scalars
3792 : : real(dp),optional,intent(in) :: qtol
3793 : : class(dvdb_t),intent(in) :: db
3794 : : !arrays
3795 : : real(dp),intent(in) :: qpt(3)
3796 : :
3797 : : !Local variables-------------------------------
3798 : : !scalars
3799 : : integer :: iq
3800 : : real(dp) :: my_qtol
3801 : : ! *************************************************************************
3802 : :
3803 [ - + ]: 6172 : my_qtol = tol6; if (present(qtol)) my_qtol = qtol
3804 : 6172 : iqpt = -1
3805 [ + + ]: 45711 : do iq=1,db%nqpt
3806 [ + + + + : 55309 : if (all(abs(db%qpts(:, iq) - qpt) < my_qtol)) then
+ + ]
3807 : : iqpt = iq; exit
3808 : : end if
3809 : : end do
3810 : :
3811 : 6172 : end function dvdb_findq
3812 : : !!***
3813 : :
3814 : : !----------------------------------------------------------------------
3815 : :
3816 : : !!****f* m_dvdb/dvdb_find_qpts
3817 : : !! NAME
3818 : : !! dvdb_find_qpts
3819 : : !!
3820 : : !! FUNCTION
3821 : : !! Find the index of the q-point in db%qpts. Non zero umklapp vectors are not allowed.
3822 : : !! Returns -1 if not found.
3823 : : !!
3824 : : !! INPUTS
3825 : : !! nqpt: Number of q-points
3826 : : !! qpt(3,nqpt): q-point in reduced coordinates.
3827 : : !! comm: MPI communicator
3828 : : !!
3829 : : !! OUTPUT
3830 : : !! iq2dvdb(nqpt): index of q-points in dvdb%qpts. Set to -1 if not found
3831 : : !! ierr= Number of points **not** found
3832 : : !!
3833 : : !! SOURCE
3834 : :
3835 : 61 : integer function dvdb_find_qpts(db, nqpt, qpts, iq2dvdb, comm) result(notfound)
3836 : :
3837 : : !Arguments ------------------------------------
3838 : : !scalars
3839 : : class(dvdb_t),intent(in) :: db
3840 : : integer,intent(in) :: nqpt, comm
3841 : : !arrays
3842 : : real(dp),intent(in) :: qpts(3, nqpt)
3843 : : integer,intent(out) :: iq2dvdb(nqpt)
3844 : :
3845 : : !Local variables-------------------------------
3846 : : !scalars
3847 : : integer :: iq, my_rank, nprocs, ierr
3848 : : ! *************************************************************************
3849 : :
3850 : 61 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
3851 : :
3852 [ + + ]: 4070 : iq2dvdb = 0
3853 [ + + ]: 4070 : do iq=1,nqpt
3854 [ - + ]: 4009 : if (mod(iq, nprocs) /= my_rank) cycle ! MPI parallelism
3855 : 4070 : iq2dvdb(iq) = db%findq(qpts(:, iq))
3856 : : end do
3857 : :
3858 : 61 : call xmpi_sum(iq2dvdb, comm, ierr)
3859 [ + + + + ]: 4070 : notfound = count(iq2dvdb == -1)
3860 : :
3861 : 61 : end function dvdb_find_qpts
3862 : : !!***
3863 : :
3864 : : !----------------------------------------------------------------------
3865 : :
3866 : : !!****f* m_dvdb/dvdb_need_ftinterp
3867 : : !! NAME
3868 : : !! dvdb_need_ftinterp
3869 : : !!
3870 : : !! FUNCTION
3871 : : !! Check whether input list of q-points requires Fourier interpolation.
3872 : : !!
3873 : : !! INPUTS
3874 : : !! nqpt: Number of q-points
3875 : : !! qpt(3,nqpt): q-point in reduced coordinates.
3876 : : !!
3877 : : !! OUTPUT
3878 : : !! qmap_symrec(6, nqpt)
3879 : : !! need_ftinterp
3880 : : !!
3881 : : !! SOURCE
3882 : :
3883 : 7 : subroutine dvdb_need_ftinterp(db, nqpt, qpts, qptopt, qmap_symrec, need_ftinterp)
3884 : :
3885 : : !Arguments ------------------------------------
3886 : : !scalars
3887 : : class(dvdb_t),intent(in) :: db
3888 : : integer,intent(in) :: nqpt, qptopt
3889 : : logical,intent(out) :: need_ftinterp
3890 : : !arrays
3891 : : real(dp),intent(in) :: qpts(3, nqpt)
3892 : : integer,allocatable,intent(out) :: qmap_symrec(:,:)
3893 : :
3894 : : !Local variables-------------------------------
3895 : : !scalars
3896 : : integer :: iq, iq_ibz, db_iqpt, qtimrev
3897 : 7 : type(krank_t) :: qrank
3898 : : !arrays
3899 : : real(dp) :: qq_ibz(3)
3900 : : ! *************************************************************************
3901 : :
3902 : 7 : need_ftinterp = .False.
3903 : 7 : call qrank%init(db%nqpt, db%qpts, compute_invrank=.False.)
3904 : :
3905 : 7 : qtimrev = kpts_timrev_from_kptopt(qptopt)
3906 [ - + + - : 21 : ABI_MALLOC(qmap_symrec, (6, nqpt))
+ - + - -
+ - + -
+ ]
3907 : :
3908 [ + + ]: 7 : if (kpts_map("symrec", qtimrev, db%cryst, qrank, nqpt, qpts, qmap_symrec) /= 0) then
3909 : : ! There's at least on-qpoint in qpts that is not the IBZ image of db%qpts.
3910 : 5 : need_ftinterp = .True.; call qrank%free()
3911 : 5 : return
3912 : : end if
3913 : :
3914 : : ! All the IBZ images must be in the DVDB
3915 [ + + ]: 14 : do iq=1,nqpt
3916 : 12 : iq_ibz = qmap_symrec(1, iq)
3917 [ + + ]: 48 : qq_ibz = db%qpts(:, iq_ibz)
3918 : 12 : db_iqpt = db%findq(qq_ibz)
3919 [ - + ]: 14 : if (db_iqpt == -1) then
3920 : 0 : need_ftinterp = .True.; exit
3921 : : end if
3922 : : end do
3923 : :
3924 : 2 : call qrank%free()
3925 : :
3926 [ - + - + : 7 : end subroutine dvdb_need_ftinterp
- + - + -
+ - + ]
3927 : : !!***
3928 : :
3929 : : !!****f* m_dvdb/dvdb_set_pert_distrib
3930 : : !! NAME
3931 : : !! dvdb_set_pert_distrib
3932 : : !!
3933 : : !! FUNCTION
3934 : : !! Activate MPI distribution of the 3*natom perturbations.
3935 : : !!
3936 : : !! INPUTS
3937 : : !! my_npert=Number of perturbations treated by this rank
3938 : : !! natom3= 3 * natom
3939 : : !! my_pinfo(3, my_npert)
3940 : : !! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
3941 : : !! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
3942 : : !! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
3943 : : !! pert_table(2, natom3)
3944 : : !! pert_table(1, npert): rank of the processor treating this atomic perturbation.
3945 : : !! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
3946 : : !! comm_pert=MPI communicator used to distribute the 3*natom perturbations
3947 : : !!
3948 : : !! SOURCE
3949 : :
3950 : 0 : subroutine dvdb_set_pert_distrib(self, my_npert, natom3, my_pinfo, pert_table, comm_pert)
3951 : :
3952 : : !Arguments ------------------------------------
3953 : : !scalars
3954 : : class(dvdb_t),intent(inout) :: self
3955 : : integer,intent(in) :: my_npert, natom3, comm_pert
3956 : : !arrays
3957 : : integer,intent(in) :: my_pinfo(3,my_npert), pert_table(2,natom3)
3958 : : ! *************************************************************************
3959 : :
3960 : 0 : self%comm_pert = comm_pert
3961 : 0 : self%nprocs_pert = xmpi_comm_size(comm_pert)
3962 : 0 : self%me_pert = xmpi_comm_rank(comm_pert)
3963 : 0 : self%my_npert = my_npert
3964 : :
3965 [ # # ]: 0 : ABI_SFREE(self%my_pinfo)
3966 [ # # ]: 0 : ABI_SFREE(self%pert_table)
3967 [ # # ]: 0 : call alloc_copy(my_pinfo, self%my_pinfo)
3968 [ # # ]: 0 : call alloc_copy(pert_table, self%pert_table)
3969 : :
3970 [ # # ]: 0 : if (self%debug) then
3971 : 0 : write(std_out, *)"Activating perturbation over perturbations:"
3972 : 0 : write(std_out, *)"nprocs_pert: ", self%nprocs_pert
3973 : 0 : write(std_out, *)"my_pinfo: ",self%my_pinfo
3974 : 0 : write(std_out, *)"pert_table: ",self%pert_table
3975 : : end if
3976 : :
3977 : 0 : end subroutine dvdb_set_pert_distrib
3978 : : !!***
3979 : :
3980 : : !!****f* m_dvdb/dvdb_seek
3981 : : !! NAME
3982 : : !! dvdb_seek
3983 : : !!
3984 : : !! FUNCTION
3985 : : !! Move the internal file pointer so that it points to the
3986 : : !! block with (idir, ipert, iqpt). Needed only if dvdb%iomode==IO_MODE_FORTRAN
3987 : : !!
3988 : : !! INPUTS
3989 : : !! idir,ipert,iqpt = (direction, perturbation, q-point) indices
3990 : : !!
3991 : : !! SIDE EFFECTS
3992 : : !! db<type(dvdb_t)>: modifies db%current_fpos.
3993 : : !!
3994 : : !! SOURCE
3995 : :
3996 : 5360 : subroutine dvdb_seek(db, idir, ipert, iqpt)
3997 : :
3998 : : !Arguments ------------------------------------
3999 : : integer,intent(in) :: idir, ipert, iqpt
4000 : : type(dvdb_t),intent(inout) :: db
4001 : :
4002 : : !Local variables-------------------------------
4003 : : integer :: pos_now,pos_wanted,ii,ispden,nn,ierr
4004 : : real(dp),parameter :: fake_qpt(3)=zero
4005 : : character(len=500) :: msg
4006 : : ! *************************************************************************
4007 : :
4008 [ + - ]: 5360 : if (db%iomode == IO_MODE_FORTRAN) then
4009 : 5360 : pos_now = db%current_fpos
4010 : 5360 : pos_wanted = db%pos_dpq(idir,ipert,iqpt)
4011 [ - + ]: 5360 : ABI_CHECK(pos_wanted /= 0, "pos_wanted cannot be zero!")
4012 : :
4013 : : ! Optimal access.
4014 [ + + ]: 6416 : if (pos_now == pos_wanted) return
4015 : :
4016 [ + + ]: 1056 : if (pos_wanted < pos_now) then
4017 : : ! Backspace previous records and header
4018 : : ! but only if nn <= pos_wanted else rewind file and skip pos_wanted potentials (should be faster)
4019 : 850 : nn = pos_now - pos_wanted
4020 [ + + ]: 850 : if (nn <= pos_wanted) then
4021 [ + + ]: 3594 : do ii=1,nn
4022 : : !write(std_out, *)"backspacing"
4023 [ + - + - ]: 2974 : if (db%version > 1) backspace(unit=db%fh, err=10, iomsg=msg)
4024 [ + + ]: 5948 : do ispden=1,db%nspden
4025 [ + - ]: 5948 : backspace(unit=db%fh, err=10, iomsg=msg)
4026 : : end do
4027 : 2974 : ierr = db%hdr_ref%backspace(db%fh, msg)
4028 [ + - ]: 3594 : if (ierr /= 0) goto 10
4029 : : end do
4030 : 620 : db%current_fpos = pos_wanted; return
4031 : : else
4032 : : ! rewind the file and read it from the beginning
4033 [ - + ]: 230 : if (dvdb_rewind(db, msg) /= 0) then
4034 : 0 : ABI_ERROR(msg)
4035 : : end if
4036 : : nn = pos_wanted
4037 : : end if
4038 : :
4039 : : else
4040 : 206 : nn = pos_wanted - pos_now + 1
4041 : : end if
4042 : :
4043 [ + + ]: 4943 : do ii=1,nn-1
4044 : : !write(std_out,*)"in seek with ii: ",ii,"pos_wanted: ",pos_wanted
4045 [ - + ]: 4507 : if (my_hdr_skip(db%fh, -1, -1, fake_qpt, msg) /= 0) then
4046 : 0 : ABI_ERROR(msg)
4047 : : end if
4048 : : ! Skip the records with v1.
4049 [ + + ]: 9014 : do ispden=1,db%nspden
4050 [ + - ]: 9014 : read(db%fh, err=10, iomsg=msg)
4051 : : end do
4052 : : ! Skip record with rhog1_g0 (if present)
4053 [ + - + - ]: 4943 : if (db%version > 1) read(db%fh, err=10, iomsg=msg)
4054 : : end do
4055 : :
4056 : 436 : db%current_fpos = pos_wanted
4057 : :
4058 : : else
4059 : 0 : ABI_ERROR("Should not be called when iomode /= IO_MODE_FORTRAN")
4060 : : end if
4061 : :
4062 : 0 : return
4063 : :
4064 : : ! Handle Fortran IO error
4065 : : 10 continue
4066 : 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4067 : :
4068 : : end subroutine dvdb_seek
4069 : : !!***
4070 : :
4071 : : !----------------------------------------------------------------------
4072 : :
4073 : : !!****f* m_dvdb/dvdb_rewind
4074 : : !! NAME
4075 : : !! dvdb_rewind
4076 : : !!
4077 : : !! FUNCTION
4078 : : !! Rewind the file and move to the first header. Needed only if dvdb%iomode==IO_MODE_FORTRAN
4079 : : !! Return exit code and error message in msg if ierr != 0.
4080 : : !!
4081 : : !! SOURCE
4082 : :
4083 : 230 : integer function dvdb_rewind(db, msg) result(ierr)
4084 : :
4085 : : !Arguments ------------------------------------
4086 : : type(dvdb_t),intent(inout) :: db
4087 : : character(len=*),intent(out) :: msg
4088 : : ! *************************************************************************
4089 : :
4090 : 230 : ierr = 0
4091 : 230 : if (db%iomode == IO_MODE_FORTRAN) then
4092 [ + - ]: 230 : rewind(db%fh, err=10, iomsg=msg)
4093 [ + - ]: 230 : read(db%fh, err=10, iomsg=msg) ! version
4094 [ + - ]: 230 : read(db%fh, err=10, iomsg=msg) ! numv1
4095 : 230 : db%current_fpos = 1
4096 : :
4097 : : else
4098 : 0 : ierr = -1
4099 [ # # # # ]: 0 : msg = "should not be called when iomode /= IO_MODE_FORTRAN"
4100 : : end if
4101 : :
4102 : : return
4103 : :
4104 : : ! Handle Fortran IO error
4105 : : 10 continue
4106 : 0 : ierr = 1
4107 [ # # # # ]: 0 : msg = sjoin("Error while reading", db%path, ch10, msg)
4108 : :
4109 [ + - ]: 230 : end function dvdb_rewind
4110 : : !!***
4111 : :
4112 : : !----------------------------------------------------------------------
4113 : :
4114 : : !!****f* m_dvdb/my_hdr_skip
4115 : : !! NAME
4116 : : !! my_hdr_skip
4117 : : !!
4118 : : !! FUNCTION
4119 : : !! Skip the header without rewinding the file. Return exit code.
4120 : : !!
4121 : : !! NOTES
4122 : : !! Because hdr_skip rewinds the file and I'm not gonna change that ugly code.
4123 : : !!
4124 : : !! SOURCE
4125 : :
4126 : 9867 : integer function my_hdr_skip(unit, idir, ipert, qpt, msg) result(ierr)
4127 : :
4128 : : !Arguments ------------------------------------
4129 : : !scalars
4130 : : integer,intent(in) :: unit,idir,ipert
4131 : : real(dp),intent(in) :: qpt(3)
4132 : : character(len=500),intent(out) :: msg
4133 : :
4134 : : !Local variables-------------------------------
4135 : : integer :: fform
4136 : 9867 : type(hdr_type) :: tmp_hdr
4137 : : !************************************************************************
4138 : :
4139 : 9867 : ierr = 0; msg = ""
4140 : 9867 : call tmp_hdr%fort_read(unit, fform)
4141 : 9867 : ierr = dvdb_check_fform(fform, "read_dvdb", msg)
4142 [ + - ]: 9867 : if (ierr /= 0) return
4143 : :
4144 [ + + + - ]: 9867 : if (idir /= -1 .and. ipert /= -1) then
4145 : : if (idir /= mod(tmp_hdr%pertcase-1, 3) + 1 .or. &
4146 [ + + + - : 21440 : ipert /= (tmp_hdr%pertcase - idir) / 3 + 1 .or. &
+ - + - -
+ ]
4147 : : any(abs(qpt - tmp_hdr%qptn) > tol14)) then
4148 : 0 : msg = "Perturbation index on file does not match the one expected by the caller"
4149 : 0 : ierr = -1
4150 : : end if
4151 : : end if
4152 : :
4153 : 9867 : call tmp_hdr%free()
4154 : :
4155 [ - + - + : 9867 : end function my_hdr_skip
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - ]
4156 : : !!***
4157 : :
4158 : : !----------------------------------------------------------------------
4159 : :
4160 : : !!****f* m_dvdb/dvdb_list_perts
4161 : : !! NAME
4162 : : !! dvdb_list_perts
4163 : : !!
4164 : : !! FUNCTION
4165 : : !! Given a q-point mesh, this routine checks if all the (phonon) perturbations
4166 : : !! are available taking into account symmetries.
4167 : : !!
4168 : : !! INPUTS
4169 : : !! ngqpt(3)=Q-mesh divisions. If all(ngqpt == -1), the list of q-points in the DVDB
4170 : : !! (i.e. db%qpts) is analyzed instead of the q-points generated from ngqpt.
4171 : : !! [unit]=Unit number for output. Default `std_out`.
4172 : : !!
4173 : : !! OUTPUT
4174 : : !! npert_miss = Number of missing perturbations.
4175 : : !!
4176 : : !! SOURCE
4177 : :
4178 : 116 : subroutine dvdb_list_perts(db, ngqpt, npert_miss, unit)
4179 : :
4180 : : !Arguments ------------------------------------
4181 : : class(dvdb_t),target,intent(in) :: db
4182 : : integer,intent(out) :: npert_miss
4183 : : integer,optional,intent(in) :: unit
4184 : : !arrays
4185 : : integer,intent(in) :: ngqpt(3)
4186 : :
4187 : : !Local variables-------------------------------
4188 : : !scalars
4189 : : integer :: npert_redund,miss_q,idir,ipert,iv1,psy,weird_q,enough
4190 : : integer :: iq_ibz,nqibz,iq_file,qptopt,nshiftq,ii,timerev_q,unt,nqbz
4191 : : character(len=500) :: msg,ptype,found
4192 : : type(crystal_t),pointer :: cryst
4193 : : !arrays
4194 : : integer :: rfdir(3),qptrlatt(3,3)
4195 : 116 : integer,allocatable :: pertsy(:,:),symq(:,:,:),rfpert(:)
4196 : : real(dp) :: qq(3),shiftq(3,1)
4197 : 116 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:)
4198 : : ! *************************************************************************
4199 : :
4200 [ - + ]: 116 : unt = std_out; if (present(unit)) unt = unit
4201 : 116 : cryst => db%cryst
4202 : :
4203 [ + + + - : 464 : if (all(ngqpt == -1)) then
+ - ]
4204 : : ! Will test the q-points in db
4205 : 116 : call alloc_copy(db%qpts, qibz)
4206 : 116 : nqibz = db%nqpt
4207 : : else
4208 : : ! Will test the q-points in the IBZ associated to ngqpt hence build IBZ and BZ from ngqpt.
4209 : 0 : qptopt = 1; shiftq = zero; nshiftq = 1; qptrlatt = 0
4210 [ # # ]: 0 : do ii=1,3
4211 : 0 : qptrlatt(ii, ii) = ngqpt(ii)
4212 : : end do
4213 : :
4214 : 0 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, nshiftq, shiftq, nqibz, qibz, wtq, nqbz, qbz)
4215 : :
4216 [ # # ]: 0 : ABI_FREE(qbz)
4217 [ # # ]: 0 : ABI_FREE(wtq)
4218 : : end if
4219 : :
4220 : : ! Initialize the list of perturbations rfpert and rdfir
4221 : : ! WARNING: Only phonon perturbations are considered for the time being.
4222 [ - + + - : 348 : ABI_MALLOC(rfpert,(db%mpert))
+ - + - -
+ - + ]
4223 [ + + + + : 1602 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
4224 : :
4225 [ - + + - : 348 : ABI_MALLOC(symq, (4,2,cryst%nsym))
+ - + - -
+ - + ]
4226 [ - + + - : 348 : ABI_MALLOC(pertsy, (3,db%mpert))
+ - + - -
+ - + ]
4227 : :
4228 : : ! Loop over the q-points in the IBZ and test whether the q-point is present
4229 : : ! and if all the independent perturbations are available.
4230 : : ! `npert_miss` is the number of irreducible perturbations not found in the DVDB (critical)
4231 : : ! `npert_redund` is the number of redundant perturbations found in the DVDB (not critical)
4232 : : !
4233 [ + + ]: 116 : enough = 5; if (db%prtvol > 0) enough = nqibz + 1
4234 : 116 : npert_miss = 0; npert_redund = 0
4235 [ + + ]: 798 : do iq_ibz=1,nqibz
4236 [ + + ]: 682 : if (iq_ibz == enough) then
4237 : 45 : call wrtout(unt,' More than 20 q-points with prtvol == 0. Only important messages will be printed...')
4238 : : end if
4239 [ + + ]: 2728 : qq = qibz(:,iq_ibz)
4240 : 682 : iq_file = db%findq(qq)
4241 : :
4242 : : ! Examine the symmetries of the q wavevector
4243 : 682 : call littlegroup_q(cryst%nsym,qq,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=db%prtvol)
4244 : :
4245 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4246 : : ! 0 for non-target perturbations
4247 : : ! 1 for basis perturbations
4248 : : ! -1 for perturbations that can be found from basis perturbations
4249 : : call irreducible_set_pert(cryst%indsym,db%mpert,cryst%natom,cryst%nsym,&
4250 : 682 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4251 : :
4252 [ + - ]: 682 : if (iq_file /= -1) then
4253 : : ! This q-point is in the DVDB. Test if all the independent perturbations are available.
4254 [ + + ]: 682 : if (iq_ibz <= enough) then
4255 : 526 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is present in the DVDB file"))
4256 : 526 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4257 : : end if
4258 : 682 : ii = 0; weird_q = 0; miss_q = 0
4259 [ + + ]: 6039 : do ipert=1,db%mpert
4260 [ + + ]: 22110 : do idir=1,3
4261 : 16071 : psy = pertsy(idir,ipert)
4262 [ + + ]: 16071 : if (psy == 0) cycle
4263 : 3795 : iv1 = db%pos_dpq(idir,ipert,iq_file)
4264 [ + + ]: 3795 : ptype = "independent"; if (psy == -1) ptype = "symmetric"
4265 [ + + ]: 3795 : found = "Yes"; if (iv1 == 0) found = "No"
4266 : :
4267 [ - + ]: 3795 : if (psy == 1 .and. iv1 == 0) miss_q = miss_q + 1
4268 [ - + ]: 3795 : if (psy == -1 .and. iv1 /= 0) weird_q = weird_q + 1
4269 : :
4270 : 3795 : ii=ii+1
4271 [ + + ]: 9152 : if (iq_ibz <= enough) then
4272 : 2886 : write(msg,'(i5,a,i2,a,i4,4a)')ii,') idir=',idir,', ipert=',ipert,", type=",trim(ptype),", found=",trim(found)
4273 : 2886 : call wrtout(unt, msg)
4274 : : end if
4275 : : end do
4276 : : end do
4277 : :
4278 [ - + ]: 682 : if (weird_q /= 0) then
4279 : 0 : write(msg,"(a,i0,a)")" DVDB is overcomplete. ",weird_q, " perturbation(s) can be reconstructed by symmetry."
4280 : 0 : call wrtout(unt, msg)
4281 : : end if
4282 : :
4283 : 682 : npert_redund = npert_redund + weird_q
4284 : 682 : npert_miss = npert_miss + miss_q
4285 [ - + ]: 682 : if (miss_q /=0) then
4286 : 0 : call wrtout(unt, sjoin(" WARNING:", itoa(miss_q), "independent perturbation(s) are missing!."))
4287 : : end if
4288 : :
4289 : : else
4290 : : ! This q-point is not present in dvdb. Print the list of independent perturbations.
4291 : 0 : call wrtout(unt, sjoin(" qpoint:", ktoa(qq), "is NOT present in the DVDB file"))
4292 : 0 : call wrtout(unt,' The list of irreducible perturbations for this q vector is:')
4293 : 0 : ii = 0
4294 [ # # ]: 0 : do ipert=1,db%mpert
4295 [ # # ]: 0 : do idir=1,3
4296 [ # # ]: 0 : if (pertsy(idir,ipert) == 1) then
4297 : 0 : ii=ii+1
4298 : 0 : write(msg,'(i5,a,i2,a,i4,a)')ii,') idir=',idir,', ipert=',ipert,", type=independent, found=No"
4299 : 0 : call wrtout(unt, msg)
4300 : 0 : npert_miss = npert_miss + 1
4301 : : end if
4302 : : end do
4303 : : end do
4304 : : end if
4305 : :
4306 [ + + ]: 1480 : if (iq_ibz <= enough) call wrtout(unt," ")
4307 : : end do ! iq_ibz
4308 : :
4309 [ - + ]: 116 : if (npert_miss /= 0) then
4310 : 0 : call wrtout(unt, sjoin(ch10, " There are ",itoa(npert_miss), "independent perturbations missing!"))
4311 : : else
4312 : 116 : call wrtout(unt, " All the independent perturbations are available")
4313 [ - + ]: 116 : if (npert_redund /= 0) then
4314 : 0 : call wrtout(unt, " Note however that the DVDB is overcomplete as symmetric perturbations are present.")
4315 : : end if
4316 : : end if
4317 : :
4318 [ - + ]: 116 : ABI_FREE(qibz)
4319 [ - + ]: 116 : ABI_FREE(rfpert)
4320 [ - + ]: 116 : ABI_FREE(symq)
4321 [ - + ]: 116 : ABI_FREE(pertsy)
4322 : :
4323 [ - + - + ]: 116 : end subroutine dvdb_list_perts
4324 : : !!***
4325 : :
4326 : : !----------------------------------------------------------------------
4327 : :
4328 : : !!****f* m_dvdb/dvdb_merge_files
4329 : : !! NAME
4330 : : !! dvdb_merge_files
4331 : : !!
4332 : : !! FUNCTION
4333 : : !! Merge a list of POT1 or DEN1 files.
4334 : : !!
4335 : : !! INPUT
4336 : : !! nfiles=Number of files to be merged.
4337 : : !! dvdb_filepath=Name of output DVDB file.
4338 : : !! prtvol=Verbosity level.
4339 : : !!
4340 : : !! SIDE EFFECTS
4341 : : !! v1files=List of file names to merge. This list could be changed if POT1 files in netcdf format are found.
4342 : : !!
4343 : : !! SOURCE
4344 : :
4345 : 17 : subroutine dvdb_merge_files(nfiles, v1files, dvdb_filepath, prtvol)
4346 : :
4347 : : !Arguments ------------------------------------
4348 : : !scalars
4349 : : integer,intent(in) :: nfiles,prtvol
4350 : : character(len=*),intent(in) :: dvdb_filepath
4351 : : character(len=*),intent(inout) :: v1files(nfiles)
4352 : :
4353 : : !Local variables-------------------------------
4354 : : !scalars
4355 : : ! Here I made a mistake because 102 corresponds to GS potentials
4356 : : ! as a consequence DVDB files generated with version <= 8.1.6
4357 : : ! contain list of potentials with fform = 102.
4358 : : !integer :: fform_pot=102
4359 : : integer :: fform_pot = 111, gpu_option0 = 0
4360 : : integer :: ii,jj,fform,ount,cplex,nfft,ifft,ispden,nperts
4361 : : integer :: n1,n2,n3,v1_varid,ierr, npert_miss, first_fform
4362 : : logical :: qeq0
4363 : : character(len=500) :: msg
4364 : : type(hdr_type),pointer :: hdr1
4365 [ + + + + : 1581 : type(dvdb_t) :: dvdb
+ + + + +
+ + + + +
+ + + + +
+ + + + +
+ + ]
4366 : : !arrays
4367 : 34 : integer :: units(nfiles)
4368 : : real(dp) :: rhog1_g0(2)
4369 : 17 : real(dp),allocatable :: v1(:)
4370 : 34 : logical :: has_rhog1_g0(nfiles)
4371 : 17 : type(hdr_type),target,allocatable :: hdr1_list(:)
4372 : : !************************************************************************
4373 : :
4374 [ - + ]: 17 : if (file_exists(dvdb_filepath)) then
4375 : 0 : ABI_ERROR(sjoin("Cannot overwrite existing file:", dvdb_filepath))
4376 : : end if
4377 : :
4378 : : ! If a file is not found, try the netcdf version and change v1files accordingly.
4379 [ + + ]: 296 : do ii=1,nfiles
4380 [ - + ]: 296 : if (nctk_try_fort_or_ncfile(v1files(ii), msg) /= 0) then
4381 : 0 : ABI_ERROR(msg)
4382 : : end if
4383 : : end do
4384 : :
4385 : : ! Read the headers
4386 [ - + + - : 330 : ABI_MALLOC(hdr1_list, (nfiles))
+ - + - -
+ - + +
+ ]
4387 : 17 : nperts = size(hdr1_list)
4388 : :
4389 : : ! Write dvdb file (we only support fortran binary format)
4390 [ - + ]: 17 : if (open_file(dvdb_filepath, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
4391 : 0 : ABI_ERROR(msg)
4392 : : end if
4393 [ + - ]: 17 : write(ount, err=10, iomsg=msg) dvdb_last_version
4394 [ + - ]: 17 : write(ount, err=10, iomsg=msg) nperts
4395 : :
4396 : : ! Validate headers.
4397 : : ! TODO: Should perform consistency check on the headers
4398 : : ! rearrange them in blocks of q-points for efficiency reason.
4399 : : ! ignore POT1 files that do not correspond to atomic perturbations.
4400 : : ! Add POT file from GS run to support Sternheimer in eph_task = 4
4401 : :
4402 [ + + ]: 296 : do ii=1,nfiles
4403 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Reading header of file [",ii,"]: ",trim(v1files(ii))
4404 : :
4405 [ + - ]: 279 : if (endswith(v1files(ii), ".nc")) then
4406 [ - + ]: 279 : NCF_CHECK(nctk_open_read(units(ii), v1files(ii), xmpi_comm_self))
4407 : 279 : call hdr1_list(ii)%ncread(units(ii), fform)
4408 : : else
4409 [ # # ]: 0 : if (open_file(v1files(ii), msg, newunit=units(ii), form="unformatted", action="read", status="old") /= 0) then
4410 : 0 : ABI_ERROR(msg)
4411 : : end if
4412 : 0 : call hdr1_list(ii)%fort_read(units(ii), fform)
4413 : : end if
4414 : :
4415 [ - + ]: 279 : if (dvdb_check_fform(fform, "merge_dvdb", msg) /= 0) then
4416 : 0 : ABI_ERROR(sjoin("While reading:", v1files(ii), msg))
4417 : : end if
4418 [ - + ]: 279 : if (prtvol > 0) call hdr1_list(ii)%echo(fform, 3, unit=std_out)
4419 [ - + ]: 279 : if (hdr1_list(ii)%pertcase == 0) then
4420 : 0 : ABI_ERROR(sjoin("Found GS potential:", v1files(ii)))
4421 : : end if
4422 : : !write(std_out,*)"done", trim(v1files(ii))
4423 : :
4424 [ + + ]: 279 : if (ii == 1) then
4425 : 17 : first_fform = fform
4426 : : else
4427 [ - + ]: 262 : ABI_CHECK_IEQ(fform, first_fform, "Trying to merge files with different quantities")
4428 : : end if
4429 : :
4430 : : ! Supported fform:
4431 : : ! 109 POT1 files without vh1(G=0)
4432 : : ! 111 POT1 files with extra record with vh1(G=0) after FFT data.
4433 : : ! 54 RHO1 files (treating DRHODB as DVDB)
4434 : :
4435 : 279 : has_rhog1_g0(ii) = .True.
4436 [ + + ]: 279 : if (any(fform == [54, 109])) has_rhog1_g0(ii) = .False.
4437 : :
4438 [ + - ]: 279 : write(std_out,"(a,i0,2a)")"- Merging file [",ii,"]: ",trim(v1files(ii))
4439 : 279 : jj = ii
4440 : 279 : hdr1 => hdr1_list(jj)
4441 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4442 : 199 : call hdr1%fort_write(ount, fform_pot, ierr)
4443 : : else
4444 : 80 : call hdr1%fort_write(ount, den1_fforms(1), ierr)
4445 : : end if
4446 [ - + ]: 279 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
4447 : :
4448 : 279 : qeq0 = (hdr1%qptn(1)**2+hdr1%qptn(2)**2+hdr1%qptn(3)**2<1.d-14)
4449 [ + + ]: 279 : cplex = 2; if (qeq0) cplex = 1
4450 [ + + ]: 1116 : nfft = product(hdr1%ngfft(1:3))
4451 : 279 : n1 = hdr1%ngfft(1); n2 = hdr1%ngfft(2); n3 = hdr1%ngfft(3)
4452 : :
4453 [ - + + - : 837 : ABI_MALLOC(v1, (cplex*nfft))
+ - + - -
+ - + -
+ ]
4454 : :
4455 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4456 : : ! Fortran IO
4457 [ # # ]: 0 : do ispden=1,hdr1%nspden
4458 [ # # ]: 0 : read(units(jj), err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4459 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4460 : : end do
4461 : : ! Add rhog1(G=0)
4462 : 0 : rhog1_g0 = zero
4463 [ # # # # ]: 0 : if (has_rhog1_g0(jj)) read(units(jj), err=10, iomsg=msg) rhog1_g0
4464 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4465 : : else
4466 : : ! Netcdf IO
4467 : : ! netcdf array has shape [cplex, n1, n2, n3, nspden]
4468 [ + + ]: 279 : if (any(fform == pot1_fforms)) then
4469 [ - + ]: 199 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_potential", v1_varid))
4470 [ + + ]: 398 : do ispden=1,hdr1%nspden
4471 [ + + + + : 2189 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4472 [ + - ]: 398 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4473 : : end do
4474 : : ! Add rhog1(G=0)
4475 : 199 : rhog1_g0 = zero
4476 [ + - ]: 199 : if (has_rhog1_g0(jj)) then
4477 [ - + ]: 199 : NCF_CHECK(nf90_get_var(units(ii), nctk_idname(units(ii), "rhog1_g0"), rhog1_g0))
4478 : : end if
4479 [ + - ]: 80 : else if (any(fform == den1_fforms)) then
4480 : : ! v below should read as rho
4481 [ - + ]: 80 : NCF_CHECK(nf90_inq_varid(units(ii), "first_order_density", v1_varid))
4482 [ + + ]: 160 : do ispden=1,hdr1%nspden
4483 [ + + + + : 880 : NCF_CHECK(nf90_get_var(units(ii), v1_varid, v1, start=[1,1,1,1,ispden], count=[cplex, n1, n2, n3, 1]))
- + - - -
- ]
4484 [ + - ]: 160 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
4485 : : end do
4486 : : else
4487 : 0 : ABI_ERROR(sjoin("Don't know how to handle fform:", itoa(fform)))
4488 : : end if
4489 [ + - ]: 279 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
4490 : : end if
4491 : :
4492 [ - + ]: 279 : if (.not. endswith(v1files(ii), ".nc")) then
4493 : 0 : close(units(ii))
4494 : : else
4495 [ - + ]: 279 : NCF_CHECK(nf90_close(units(ii)))
4496 : : end if
4497 : :
4498 [ - + ]: 296 : ABI_FREE(v1)
4499 : : end do ! nperts
4500 : :
4501 : 17 : close(ount)
4502 : :
4503 [ + + ]: 296 : do ii=1,size(hdr1_list)
4504 : 296 : call hdr1_list(ii)%free()
4505 : : end do
4506 [ + - + + : 296 : ABI_FREE(hdr1_list)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + ]
4507 : :
4508 : 17 : write(std_out,"(a,i0,a)")" Merged successfully ", nfiles, " files"
4509 : :
4510 : : ! List available perturbations.
4511 : 17 : call dvdb%init(dvdb_filepath, gpu_option0, xmpi_comm_self)
4512 [ + + ]: 34 : call dvdb%print([std_out], "", 0)
4513 : 17 : call dvdb%list_perts([-1, -1, -1], npert_miss)
4514 : 17 : call dvdb%free()
4515 : :
4516 : 17 : return
4517 : :
4518 : : ! Handle Fortran IO error
4519 : : 10 continue
4520 : 0 : ABI_ERROR(sjoin("Error while merging files", ch10, msg))
4521 : :
4522 [ - + - + : 17 : end subroutine dvdb_merge_files
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
4523 : : !!***
4524 : :
4525 : : !!****f* m_dvdb/calc_eiqr
4526 : : !! NAME
4527 : : !! calc_eiqr
4528 : : !!
4529 : : !! FUNCTION
4530 : : !! Compute e^{iq.r} for nrpt R-points.
4531 : : !!
4532 : : !! INPUTS
4533 : : !!
4534 : : !! OUTPUT
4535 : : !!
4536 : : !! SOURCE
4537 : :
4538 : 5596 : subroutine calc_eiqr(qpt, nrpt, rpt, eiqr)
4539 : :
4540 : : !Arguments -------------------------------
4541 : : !scalars
4542 : : integer,intent(in) :: nrpt
4543 : : !arrays
4544 : : real(dp),intent(in) :: qpt(3), rpt(3, nrpt)
4545 : : real(dp),intent(out) :: eiqr(2, nrpt)
4546 : :
4547 : : !Local variables -------------------------
4548 : : !scalars
4549 : : integer :: ir
4550 : : real(dp) :: qr
4551 : : ! *********************************************************************
4552 : :
4553 : : !$OMP PARALLEL DO PRIVATE(qr)
4554 [ + + ]: 222124 : do ir=1,nrpt
4555 [ + + ]: 866112 : qr = two_pi * dot_product(qpt, rpt(:,ir))
4556 : 222124 : eiqr(1, ir) = cos(qr); eiqr(2, ir) = sin(qr)
4557 : : end do
4558 : :
4559 : 5596 : end subroutine calc_eiqr
4560 : : !!***
4561 : :
4562 : : !----------------------------------------------------------------------
4563 : :
4564 : : !!****f* m_dvdb/dvdb_check_fform
4565 : : !! NAME
4566 : : !! dvdb_check_fform
4567 : : !!
4568 : : !! FUNCTION
4569 : : !! Check the value of fform. Return exit status and error message.
4570 : : !!
4571 : : !! INPUTS
4572 : : !! fform=Value read from the header
4573 : : !! mode="merge_dvdb" to check the value of fform when we are merging POT1 files
4574 : : !! "read_dvdb" when we are reading POT1 files from a DVDB file.
4575 : : !!
4576 : : !! OUTPUT
4577 : : !! errmsg=String with error message if ierr /= 0
4578 : : !!
4579 : : !! SOURCE
4580 : :
4581 : 12349 : integer function dvdb_check_fform(fform, mode, errmsg) result(ierr)
4582 : :
4583 : : !Arguments ------------------------------------
4584 : : integer,intent(in) :: fform
4585 : : character(len=*),intent(in) :: mode
4586 : : character(len=*),intent(out) :: errmsg
4587 : : ! *************************************************************************
4588 : :
4589 : 12349 : ierr = 0
4590 : :
4591 : : ! Here I made a mistake because 102 corresponds to GS potentials
4592 : : ! as a consequence DVDB files generated with version <= 8.1.6
4593 : : ! contain list of potentials with fform = 102.
4594 : : !
4595 : : ! In GWPT, one may want to use DRHODB as DVDB. For this, here I
4596 : : ! also allow merging and reading first order density with fform = 54.
4597 : : !
4598 : : !integer :: fform_rho=54
4599 : : !integer :: fform_pot=102
4600 : : !integer :: fform_pot=109
4601 : : !integer :: fform_pot=111
4602 : :
4603 : 12349 : if (fform == 0) then
4604 [ # # # # ]: 0 : errmsg = "fform == 0! Either corrupted/nonexistent file or IO error"
4605 : 0 : ierr = 42; return
4606 : : end if
4607 : :
4608 : 279 : select case (mode)
4609 : : case ("merge_dvdb")
4610 [ + + - + ]: 279 : if (all(fform /= [54, 109, 111])) then
4611 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `merge_dvdb` mode")
4612 : 0 : ierr = 1; return
4613 : : end if
4614 : :
4615 : : case ("read_dvdb")
4616 [ + + - + ]: 12070 : if (all(fform /= [54, 102, 109, 111])) then
4617 [ # # # # ]: 0 : errmsg = sjoin("fform:", itoa(fform), "is not supported in `read_dvdb` mode")
4618 : 0 : ierr = 1; return
4619 : : end if
4620 : :
4621 : : case default
4622 [ # # # # ]: 0 : errmsg = sjoin("Invalid mode:", mode)
4623 [ + + - ]: 12349 : ierr = -1; return
4624 : : end select
4625 : :
4626 [ - + ]: 12349 : end function dvdb_check_fform
4627 : : !!***
4628 : :
4629 : : !!****f* m_dvdb/dvdb_test_v1rsym
4630 : : !! NAME
4631 : : !! dvdb_test_v1rsym
4632 : : !!
4633 : : !! FUNCTION
4634 : : !! Debugging tool used to check whether the DFPT potentials in real space fulfill
4635 : : !! the correct symmetries on the real space FFT mesh.
4636 : : !!
4637 : : !! INPUTS
4638 : : !! db_path=Filename
4639 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 to disable it.
4640 : : !! comm=MPI communicator.
4641 : : !!
4642 : : !! OUTPUT
4643 : : !! Only writing.
4644 : : !!
4645 : : !! SOURCE
4646 : :
4647 : 0 : subroutine dvdb_test_v1rsym(db_path, symv1scf, comm)
4648 : :
4649 : : !Arguments ------------------------------------
4650 : : character(len=*),intent(in) :: db_path
4651 : : integer,intent(in) :: symv1scf, comm
4652 : :
4653 : : !Local variables-------------------------------
4654 : : !scalars
4655 : : integer,parameter :: rfmeth2=2, syuse0=0, gpu_option0 = 0
4656 : : integer :: iqpt,idir,ipert,nsym1,cplex,v1pos, isym,nfft,ifft,ifft_rot,ispden
4657 : : real(dp) :: max_err,re,im,vre,vim !,pre,pim
4658 : : character(len=500) :: msg
4659 : : logical :: isok
4660 [ # # # # : 0 : type(dvdb_t),target :: db
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4661 : : type(crystal_t),pointer :: cryst
4662 : : !arrays
4663 : : integer :: ngfft(18)
4664 : 0 : integer,allocatable :: symafm1(:),symrel1(:,:,:),irottb(:,:)
4665 : : real(dp) :: qpt(3)
4666 : 0 : real(dp),allocatable :: tnons1(:,:),v1scf(:,:)
4667 : : ! *************************************************************************
4668 : :
4669 : 0 : call db%init(db_path, gpu_option0, comm)
4670 : 0 : db%debug = .True.
4671 : 0 : db%symv1 = symv1scf
4672 [ # # ]: 0 : call db%print([std_out], "", 0)
4673 : : !call db%list_perts([-1,-1,-1], npert_miss)
4674 : :
4675 : 0 : call ngfft_seq(ngfft, db%ngfft3_v1(:,1))
4676 [ # # ]: 0 : nfft = product(ngfft(1:3))
4677 : 0 : call db%open_read(ngfft, comm)
4678 : :
4679 : 0 : cryst => db%cryst
4680 [ # # # # : 0 : ABI_MALLOC(symafm1, (cryst%nsym))
# # # # #
# # # ]
4681 [ # # # # : 0 : ABI_MALLOC(symrel1, (3,3,cryst%nsym))
# # # # #
# # # ]
4682 [ # # # # : 0 : ABI_MALLOC(tnons1, (3,cryst%nsym))
# # # # #
# # # ]
4683 : :
4684 [ # # ]: 0 : do iqpt=1,db%nqpt
4685 : 0 : qpt = db%qpts(:, iqpt)
4686 [ # # ]: 0 : do ipert=1,db%natom
4687 [ # # ]: 0 : do idir=1,3
4688 [ # # ]: 0 : v1pos = db%pos_dpq(idir, ipert, iqpt); if (v1pos == 0) cycle
4689 : :
4690 : : ! Determines the set of symmetries that leaves the perturbation invariant.
4691 : : call littlegroup_pert(cryst%gprimd,idir,cryst%indsym,dev_null,ipert,cryst%natom,cryst%nsym,nsym1,rfmeth2,&
4692 : : cryst%symafm,symafm1,db%symq_table(:,:,:,iqpt),cryst%symrec,cryst%symrel,symrel1,syuse0,cryst%tnons,&
4693 : 0 : tnons1,unit=dev_null)
4694 : :
4695 : 0 : cplex = db%cplex_v1(v1pos)
4696 [ # # ]: 0 : ngfft(1:3) = db%ngfft3_v1(:, v1pos)
4697 [ # # ]: 0 : nfft = product(ngfft(:3))
4698 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex*nfft, db%nspden))
# # # # #
# # # # #
# # ]
4699 : :
4700 [ # # ]: 0 : if (db%read_onev1(idir, ipert, iqpt, cplex, nfft, ngfft, v1scf, msg) /= 0) then
4701 : 0 : ABI_ERROR(msg)
4702 : : end if
4703 : :
4704 [ # # # # : 0 : ABI_MALLOC(irottb, (nfft,nsym1))
# # # # #
# # # # #
# # ]
4705 : 0 : call rotate_fft_mesh(nsym1,symrel1,tnons1,ngfft,irottb,isok)
4706 [ # # ]: 0 : if (.not. isok) then
4707 : 0 : ABI_WARNING("Real space FFT mesh is not compatible with symmetries!")
4708 : : end if
4709 : :
4710 : 0 : max_err = zero
4711 [ # # ]: 0 : do isym=1,nsym1
4712 [ # # ]: 0 : do ispden=1,db%nspden
4713 [ # # ]: 0 : do ifft=1,nfft
4714 : 0 : ifft_rot = irottb(ifft, isym)
4715 : : !pre = cos(two_pi * dot_product(qpt, tnons1(:,isym)))
4716 : : !pim = -sin(two_pi * dot_product(qpt, tnons1(:,isym)))
4717 [ # # ]: 0 : if (cplex == 2) then
4718 : 0 : re = v1scf(2*ifft_rot-1, ispden)
4719 : 0 : im = v1scf(2*ifft_rot , ispden)
4720 : : !vre = re * pre - im * pim
4721 : : !vim = re * pim + im * pre
4722 : 0 : vre = re; vim = im
4723 : :
4724 : 0 : re = v1scf(2*ifft-1, ispden) - vre
4725 : 0 : im = v1scf(2*ifft , ispden) - vim
4726 : : else
4727 : 0 : re = v1scf(ifft, ispden) - v1scf(ifft_rot, ispden)
4728 : 0 : im = zero
4729 : : end if
4730 : : !if (sqrt(re**2 + im**2) > tol6) write(std_out,*)"ifft,isym,err: ",ifft,isym,sqrt(re**2 + im**2)
4731 : 0 : max_err = max(max_err, sqrt(re**2 + im**2))
4732 : : end do
4733 : : end do
4734 : : end do
4735 [ # # ]: 0 : if (nsym1>1) then
4736 : 0 : write(std_out,"(3(a,i2),a,i2,a,es16.8)")"For iqpt= ",iqpt,&
4737 : 0 : ", idir= ",idir,", ipert= ",ipert,", nsym= ",nsym1,", max_err= ",max_err
4738 : : end if
4739 : :
4740 [ # # ]: 0 : ABI_FREE(irottb)
4741 [ # # ]: 0 : ABI_FREE(v1scf)
4742 : : end do
4743 : : end do
4744 : :
4745 : : end do ! iqpt
4746 : :
4747 [ # # ]: 0 : ABI_FREE(symafm1)
4748 [ # # ]: 0 : ABI_FREE(symrel1)
4749 [ # # ]: 0 : ABI_FREE(tnons1)
4750 : :
4751 : 0 : call db%free()
4752 : :
4753 [ # # # # : 0 : end subroutine dvdb_test_v1rsym
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4754 : : !!***
4755 : :
4756 : : !----------------------------------------------------------------------
4757 : :
4758 : : !!****f* m_dvdb/dvdb_test_v1complete
4759 : : !! NAME
4760 : : !! dvdb_test_v1complete
4761 : : !!
4762 : : !! FUNCTION
4763 : : !! Debugging tool used to test the symmetrization of the DFPT potentials.
4764 : : !! Assumes DVDB file containing all 3*natom perturbations (either generated with nsym == 1 or
4765 : : !! via other specialized variables e.g. prepgkk)
4766 : : !!
4767 : : !! INPUTS
4768 : : !! db_path=Filename of the DVDB file.
4769 : : !! symv1scf=1 to activate symmetrization of DFPT potentials. 0 ti disable it.
4770 : : !! dump_path=File used to dump potentials (empty string to disable output)
4771 : : !! comm=MPI communicator.
4772 : : !!
4773 : : !! OUTPUT
4774 : : !! Only writing.
4775 : : !!
4776 : : !! SOURCE
4777 : :
4778 : 0 : subroutine dvdb_test_v1complete(dvdb_filepath, symv1scf, dump_path, comm)
4779 : :
4780 : : !Arguments ------------------------------------
4781 : : character(len=*),intent(in) :: dvdb_filepath,dump_path
4782 : : integer,intent(in) :: symv1scf, comm
4783 : :
4784 : : !Local variables-------------------------------
4785 : : !scalars
4786 : : integer,parameter :: master = 0, gpu_option0 = 0
4787 : : integer :: iqpt,pcase,idir,ipert,cplex,nfft,ispden,timerev_q,ifft,unt,my_rank, ncid
4788 : : integer :: i1,i2,i3,n1,n2,n3,id1,id2,id3,cnt, npert_miss
4789 : : integer :: ncerr
4790 : : character(len=500) :: msg
4791 : : type(crystal_t),pointer :: cryst
4792 [ # # # # : 0 : type(dvdb_t),target :: dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4793 : : type(vdiff_t) :: vd
4794 : : !arrays
4795 : : integer :: ngfft(18), rfdir(3)
4796 : 0 : integer,allocatable :: pflag(:,:), pertsy(:,:),rfpert(:),symq(:,:,:)
4797 : : real(dp) :: qpt(3)
4798 : 0 : real(dp),allocatable :: file_v1scf(:,:,:,:),symm_v1scf(:,:,:,:), work2(:,:,:,:)
4799 : : ! *************************************************************************
4800 : :
4801 : 0 : my_rank = xmpi_comm_rank(comm)
4802 : :
4803 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
4804 : 0 : dvdb%debug = .false.
4805 : 0 : dvdb%symv1 = symv1scf
4806 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
4807 : 0 : call dvdb%list_perts([-1,-1,-1], npert_miss)
4808 : :
4809 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
4810 [ # # ]: 0 : nfft = product(ngfft(1:3))
4811 : 0 : call dvdb%open_read(ngfft, comm)
4812 : :
4813 : 0 : cryst => dvdb%cryst
4814 : :
4815 : 0 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
4816 : 0 : id1 = n1/2+2; id2 = n2/2+2; id3 = n3/2+2
4817 : :
4818 [ # # # # : 0 : ABI_MALLOC(pflag, (3, dvdb%natom))
# # # # #
# # # ]
4819 : :
4820 : : ! Initialize the list of perturbations rfpert and rdfir
4821 : : ! WARNING: Only phonon perturbations are considered for the time being.
4822 [ # # # # : 0 : ABI_MALLOC(rfpert,(dvdb%mpert))
# # # # #
# # # ]
4823 [ # # # # : 0 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
# # ]
4824 [ # # # # : 0 : ABI_MALLOC(symq, (4,2,cryst%nsym))
# # # # #
# # # ]
4825 [ # # # # : 0 : ABI_MALLOC(pertsy, (3,dvdb%mpert))
# # # # #
# # # ]
4826 : :
4827 : 0 : unt = -1; ncid = nctk_noid
4828 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
4829 : 0 : write(std_out,"(a)")sjoin("Will write potentials to:", dump_path)
4830 [ # # ]: 0 : if (endswith(dump_path, ".nc")) then
4831 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
4832 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
4833 : : ncerr = nctk_def_dims(ncid, [&
4834 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
4835 : : nctkdim_t("natom3", cryst%natom * 3), nctkdim_t("mpert", dvdb%mpert), nctkdim_t("nqpt", dvdb%nqpt)], &
4836 [ # # ]: 0 : defmode=.True.)
4837 [ # # ]: 0 : NCF_CHECK(ncerr)
4838 [ # # # # : 0 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "symv1scf"]))
# # ]
4839 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
4840 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("origin_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4841 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("recons_v1scf", "dp", "two, nfft, nspden, natom3, nqpt")))
4842 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("pertsy_qpt", "int", "three, mpert, nqpt")))
4843 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
4844 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
4845 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
4846 [ # # # # ]: 0 : "symv1scf"], [symv1scf])
4847 [ # # ]: 0 : NCF_CHECK(ncerr)
4848 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
4849 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
4850 : : else
4851 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
4852 : 0 : ABI_ERROR(msg)
4853 : : end if
4854 : : end if
4855 : : end if
4856 : :
4857 [ # # # # : 0 : ABI_CALLOC(work2, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4858 : :
4859 : : ! loop over the q-points available in the dvdb (likely qpts in the IBZ)
4860 : : ! For each q-point, use symmetries to reconstruct all 3*natom perts for the independent ones
4861 : : ! and compare with the corresponding results available in the DVDB file
4862 : :
4863 [ # # ]: 0 : do iqpt=1,dvdb%nqpt
4864 [ # # ]: 0 : qpt = dvdb%qpts(:,iqpt)
4865 : :
4866 : : ! Examine the symmetries of the q wavevector
4867 : 0 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,timerev_q,prtvol=dvdb%prtvol)
4868 : :
4869 : : ! Determine the symmetrical perturbations. Meaning of pertsy:
4870 : : ! 0 for non-target perturbations
4871 : : ! 1 for basis perturbations
4872 : : ! -1 for perturbations that can be found from basis perturbations
4873 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
4874 : 0 : pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
4875 : :
4876 : : ! Read all potentials (here we assume that all perturbations are available in the DVDB)
4877 [ # # ]: 0 : call dvdb%readsym_allv1(iqpt, cplex, nfft, ngfft, file_v1scf, dvdb%comm)
4878 : :
4879 : : ! Copy basis perturbations in symm_v1scf and set pflag
4880 [ # # # # : 0 : ABI_MALLOC(symm_v1scf, (cplex, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4881 [ # # # # : 0 : symm_v1scf = huge(one); pflag = 0
# # # # #
# # # ]
4882 [ # # ]: 0 : do pcase=1,3*dvdb%cryst%natom
4883 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4884 [ # # ]: 0 : if (pertsy(idir, ipert) == 1) then
4885 [ # # # # : 0 : symm_v1scf(:,:,:,pcase) = file_v1scf(:,:,:,pcase)
# # ]
4886 : 0 : pflag(idir,ipert) = 1
4887 : : end if
4888 : : end do
4889 : :
4890 : : ! Complete potentials by symmetry.
4891 : 0 : call v1phq_complete(cryst,qpt,ngfft,cplex,nfft,dvdb%nspden,dvdb%nsppol,dvdb%mpi_enreg,dvdb%symv1,pflag,symm_v1scf)
4892 : :
4893 [ # # ]: 0 : if (ncid /= nctk_noid) then
4894 [ # # # # : 0 : work2 = zero
# # # # ]
4895 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = file_v1scf(1,:,:,:)
# # # # ]
4896 [ # # # # : 0 : if (cplex == 2) work2 = file_v1scf
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4897 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "origin_v1scf"), work2, start=[1,1,1,1,iqpt])
4898 [ # # ]: 0 : NCF_CHECK(ncerr)
4899 [ # # # # : 0 : if (cplex == 1) work2(1,:,:,:) = symm_v1scf(1,:,:,:)
# # # # ]
4900 [ # # # # : 0 : if (cplex == 2) work2 = symm_v1scf
# # # # #
# # # # #
# # # # #
# # # ]
4901 [ # # ]: 0 : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "recons_v1scf"), work2, start=[1,1,1,1,iqpt])
4902 [ # # ]: 0 : NCF_CHECK(ncerr)
4903 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "pertsy_qpt"), pertsy, start=[1,1,iqpt]))
# # ]
4904 : : end if
4905 : :
4906 : : ! Compare potentials.
4907 [ # # ]: 0 : do pcase=1,3*cryst%natom
4908 : 0 : idir = mod(pcase-1, 3) + 1; ipert = (pcase - idir) / 3 + 1
4909 [ # # ]: 0 : if (pflag(idir,ipert) /= 2) cycle
4910 : 0 : cnt = cnt+1
4911 : :
4912 [ # # ]: 0 : do ispden=1,dvdb%nspden
4913 : : !write(std_out,"(5(a,i0),3a,es12.4)")"For cnt: ",cnt ,", iqpt: ", iqpt, ", idir: ", idir, &
4914 : : ! ", ipert: ", ipert, ", ispden: ", ispden, ", qpt: ", trim(ktoa(qpt)) ,", max_err: ", &
4915 : : ! maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4916 : : !write(std_out,"(a,es10.3)")" max(abs(f1-f2))", maxval(abs(file_v1scf(:,:,ispden,pcase) - symm_v1scf(:,:,ispden,pcase)))
4917 : 0 : call vd%eval(cplex,nfft,file_v1scf(:,:,ispden,pcase),symm_v1scf(:,:,ispden,pcase),cryst%ucvol, unit=std_out)
4918 : :
4919 : : ! Debug: write potentials to file.
4920 [ # # ]: 0 : if (unt /= -1) then
4921 : 0 : write(unt,*)"# count:", cnt
4922 [ # # # # ]: 0 : write(unt,*)"# q-point:", trim(ktoa(qpt)), ", iqpt: ", trim(itoa(iqpt))
4923 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
4924 : 0 : write(unt,*)"# file_v1scf, symmetrized_v1scf, diff"
4925 [ # # ]: 0 : if (cplex == 1) then
4926 [ # # ]: 0 : do i3=1,n3
4927 [ # # ]: 0 : do i2=1,n2
4928 [ # # ]: 0 : do i1=1,n1
4929 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4930 : : write(unt,"(3i3,3(es12.4,2x))") &
4931 : 0 : i1,i2,i3, &
4932 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4933 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase)
4934 : : end do
4935 : : end do
4936 : : end do
4937 : : else
4938 [ # # ]: 0 : do i3=1,n3
4939 [ # # ]: 0 : do i2=1,n2
4940 [ # # ]: 0 : do i1=1,n1
4941 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
4942 : : write(unt, "(3i3,6(es12.4,2x))") &
4943 : 0 : i1,i2,i3, &
4944 : 0 : file_v1scf(1,ifft,ispden,pcase), symm_v1scf(1,ifft,ispden,pcase), &
4945 : 0 : file_v1scf(1,ifft,ispden,pcase) - symm_v1scf(1,ifft,ispden,pcase), &
4946 : 0 : file_v1scf(2,ifft,ispden,pcase), symm_v1scf(2,ifft,ispden,pcase), &
4947 : 0 : file_v1scf(2,ifft,ispden,pcase) - symm_v1scf(2,ifft,ispden,pcase)
4948 : : end do
4949 : : end do
4950 : : end do
4951 : : end if
4952 : 0 : write(unt,*)
4953 : 0 : write(unt,*)
4954 : : end if
4955 : :
4956 : : end do
4957 : : !write(std_out,*)""
4958 : : end do
4959 : :
4960 [ # # ]: 0 : ABI_FREE(symm_v1scf)
4961 [ # # ]: 0 : ABI_FREE(file_v1scf)
4962 : : end do
4963 : :
4964 [ # # ]: 0 : ABI_FREE(work2)
4965 [ # # ]: 0 : ABI_FREE(pflag)
4966 [ # # ]: 0 : ABI_FREE(rfpert)
4967 [ # # ]: 0 : ABI_FREE(symq)
4968 [ # # ]: 0 : ABI_FREE(pertsy)
4969 : :
4970 : 0 : call dvdb%free()
4971 : :
4972 [ # # ]: 0 : if (unt /= -1) close(unt)
4973 [ # # ]: 0 : if (ncid /= nctk_noid) then
4974 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
4975 : : end if
4976 : :
4977 [ # # # # : 0 : end subroutine dvdb_test_v1complete
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4978 : : !!***
4979 : :
4980 : : !----------------------------------------------------------------------
4981 : :
4982 : : !!****f* m_dvdb/dvdb_write_v1qavg
4983 : : !! NAME
4984 : : !! dvdb_write_v1qavg
4985 : : !!
4986 : : !! FUNCTION
4987 : : !! Computes the average over the unit cell of the periodic part of the DFPT potentials
4988 : : !! as a function of the q-point and the corresponding quantity obtained with the model for the LR part.
4989 : : !! Results are stored in the V1QAVG netcdf file. Two options are available:
4990 : : !!
4991 : : !! eph_task = -15 --> Use list of q-points found in the DVDB file. Mainly used to plot the average
4992 : : !! along a q-path. The procedure required to generate a DVDB with a q-path is rather lengthy
4993 : : !! as it requires several phonon calculations with WKQ followed by a merge of the POT files.
4994 : : !!
4995 : : !! eph_task = +15 --> Assume DVDB file with q-mesh (dvdb_ngqpt), use Fourier interpolation
4996 : : !! to interpolate potentials along the path specified by ph_qpath and ph_nqpath.
4997 : : !!
4998 : : !! INPUTS
4999 : : !! dtset<dataset_type>= Input variables.
5000 : : !! out_ncpath=Filename for output netcdf file.
5001 : : !!
5002 : : !! OUTPUT
5003 : : !! Only writing.
5004 : : !!
5005 : : !! SOURCE
5006 : :
5007 : 2 : subroutine dvdb_write_v1qavg(dvdb, dtset, out_ncpath)
5008 : :
5009 : : !Arguments ------------------------------------
5010 : : class(dvdb_t),target,intent(inout) :: dvdb
5011 : : type(dataset_type),target,intent(in) :: dtset
5012 : : character(len=*),intent(in) :: out_ncpath
5013 : :
5014 : : !Local variables-------------------------------
5015 : : !scalars
5016 : : integer,parameter :: master = 0
5017 : : integer :: nfft, iq, cplex, ispden, comm_rpt, my_rank, idir, ipert, ipc, imyp
5018 : : integer :: n1, n2, n3, unt, this_nqpt, interpolated
5019 : : integer :: i1, i2, i3, ifft, ig, ngsmall, ii, qptopt
5020 : : integer :: ncid, ncerr
5021 : : real(dp) :: gsq_max, g2
5022 : : !type(vdiff_t) :: vd_max
5023 : : logical :: write_v1r
5024 : : character(len=500) :: msg
5025 : : character(len=fnlen) :: dump_path
5026 : : !arrays
5027 : : integer :: ngfft(18), units(2)
5028 : 2 : integer, allocatable :: gfft(:,:),ig2ifft(:), gsmall(:,:)
5029 : : real(dp) :: dvdb_qdamp(1)
5030 : : real(dp) :: vals2(2)
5031 : 2 : real(dp),pointer :: this_qpts(:,:)
5032 : 2 : real(dp),allocatable :: file_v1r(:,:,:,:),long_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5033 : 2 : real(dp),allocatable :: maxw(:,:), all_rpt(:,:), all_rmod(:), workg(:,:), work_gsmall(:,:)
5034 : : ! *************************************************************************
5035 : :
5036 : 4 : my_rank = xmpi_comm_rank(dvdb%comm)
5037 [ + + ]: 6 : units = [std_out, ab_out]
5038 : :
5039 : 2 : call wrtout(units, " Computing average over the unit cell of the periodic part of the DFPT potentials", newlines=2)
5040 [ + + ]: 4 : call dvdb%print([std_out], "", 0)
5041 : :
5042 : : ! Define FFT mesh
5043 [ + + ]: 38 : ngfft = dvdb%ngfft
5044 [ + + ]: 8 : nfft = product(ngfft(1:3))
5045 : 2 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
5046 : :
5047 : : ! Get list of G-vectors in FFT mesh.
5048 [ - + + - : 6 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5049 : 2 : call get_gfft(ngfft, [zero, zero, zero], dvdb%cryst%gmet, gsq_max, gfft)
5050 [ - + + - : 6 : ABI_MALLOC(workg, (2, nfft))
+ - + - -
+ - + ]
5051 : :
5052 : : ! Select G-vectors in small sphere (ratio of gsq_max)
5053 [ + + ]: 6 : do ii=1,2
5054 [ + + ]: 4 : if (ii == 2) then
5055 [ - + + - : 6 : ABI_MALLOC(ig2ifft, (ngsmall))
+ - + - -
+ - + -
+ ]
5056 : : end if
5057 : 4 : ngsmall = 0
5058 [ + + ]: 16390 : do ig=1,nfft
5059 : : ! Don't include (2pi)**2 to be consistent with get_gfft
5060 [ + + + + : 327680 : g2 = dot_product(gfft(:,ig), matmul(dvdb%cryst%gmet, gfft(:, ig)))
+ + + - +
+ ]
5061 [ + + ]: 16384 : if (g2 <= gsq_max * 0.01_dp) ngsmall = ngsmall + 1
5062 [ + + ]: 16388 : if (ii == 2) ig2ifft(ngsmall) = ig
5063 : : end do
5064 : : end do
5065 : 2 : write(std_out, *)"Found ngsmall", ngsmall
5066 : :
5067 : : !call ig2fft_sphere(dvdb%cryst%gmet, gfft, ig2ifft)
5068 [ - + + - : 6 : ABI_MALLOC(gsmall, (3, ngsmall))
+ - + - -
+ - + -
+ ]
5069 [ + + ]: 56 : do ig=1,ngsmall
5070 [ + + ]: 218 : gsmall(:, ig) = gfft(:, ig2ifft(ig))
5071 : : end do
5072 [ - + + - : 6 : ABI_MALLOC(work_gsmall, (2, ngsmall))
+ - + - -
+ - + -
+ ]
5073 : :
5074 [ - + + - : 10 : ABI_MALLOC(long_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - + -
+ - - + -
+ - + ]
5075 [ - + + - : 8 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%my_npert))
- + + - -
+ + - - +
- + - + ]
5076 : :
5077 : 2 : unt = -1; dump_path = ""
5078 : : !dump_path = "V1QAVG.dat"
5079 [ - + - - ]: 2 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5080 [ # # ]: 0 : if (open_file(dump_path, msg, newunit=unt, action="write", status="unknown", form="formatted") /= 0) then
5081 : 0 : ABI_ERROR(msg)
5082 : : end if
5083 : 0 : write(std_out,"(a)")sjoin(" Will write potentials in text format to:", dump_path)
5084 : : end if
5085 : :
5086 : : ! Select list of q-points depending on eph_task (either from DVDB file or interpolated)
5087 : 2 : write_v1r = .False.
5088 [ + + ]: 2 : if (dtset%eph_task == -15) then
5089 : 1 : call wrtout(units, " Using list of q-points found in the DVDB file")
5090 : 1 : this_nqpt = dvdb%nqpt
5091 : 1 : this_qpts => dvdb%qpts
5092 : 1 : interpolated = 0
5093 : :
5094 [ + - ]: 1 : else if (dtset%eph_task == +15) then
5095 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
5096 : 1 : call wrtout(units, msg)
5097 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "When eph_task = +15, ph_qpath must be given in input.")
5098 : 1 : this_nqpt = dtset%ph_nqpath
5099 : 1 : this_qpts => dtset%ph_qpath(:, 1:this_nqpt)
5100 : 1 : comm_rpt = xmpi_comm_self
5101 [ - + ]: 1 : qptopt = dtset%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5102 : 1 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfft, ngfft, comm_rpt)
5103 : 1 : interpolated = 1
5104 : 1 : write_v1r = dtset%prtpot > 0
5105 : : else
5106 : 0 : ABI_ERROR(sjoin("Invalid value for eph_task:", itoa(dtset%eph_task)))
5107 : : end if
5108 : :
5109 : 2 : call wrtout(units, sjoin(ch10, "- Results stored in: ", out_ncpath))
5110 : 2 : call wrtout(units, " Use `abiopen.py out_V1QAVG.nc -e` to visualize results")
5111 : :
5112 [ + - ]: 2 : if (my_rank == master) then
5113 [ - + ]: 2 : NCF_CHECK(nctk_open_create(ncid, out_ncpath, xmpi_comm_self))
5114 [ - + ]: 2 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5115 : : ncerr = nctk_def_dims(ncid, [ &
5116 : : nctkdim_t("nspden", dvdb%nspden), nctkdim_t("natom", dvdb%natom3 / 3), nctkdim_t("nqpt", this_nqpt), &
5117 [ + + ]: 12 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("ngsmall", ngsmall)], defmode=.True.)
5118 [ - + ]: 2 : NCF_CHECK(ncerr)
5119 : :
5120 [ + + ]: 2 : if (interpolated == 1) then
5121 : : ! Define arrays for Max_r |W(R, r)|
5122 [ + + - + : 3 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nrpt", dvdb%nrtot), nctkdim_t("nfft", nfft)]))
- - ]
5123 : : ncerr = nctk_def_arrays(ncid, [ &
5124 : : nctkarr_t("ngqpt", "int", "three"), nctkarr_t("rpt", "dp", "three, nrpt"), nctkarr_t("rmod", "dp", "nrpt"), &
5125 : : nctkarr_t("ngfft", "int", "three"), &
5126 : : nctkarr_t("maxw", "dp", "nrpt, natom3") &
5127 [ + + ]: 6 : ])
5128 [ - + ]: 1 : NCF_CHECK(ncerr)
5129 : : end if
5130 : :
5131 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5132 [ + + ]: 10 : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"])
5133 [ - + ]: 2 : NCF_CHECK(ncerr)
5134 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
5135 [ + + ]: 12 : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield", "dvdb_add_lr"])
5136 [ - + ]: 2 : NCF_CHECK(ncerr)
5137 [ + + - + : 4 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"]))
- - ]
5138 : : ncerr = nctk_def_arrays(ncid, [ &
5139 : : nctkarr_t("v1scf_avg", "dp", "two, nspden, three, natom, nqpt"), &
5140 : : nctkarr_t("v1lr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5141 : : nctkarr_t("v1scfmlr_avg", "dp", "two, nspden, three, natom, nqpt"), &
5142 : : nctkarr_t("v1scfmlr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5143 : : nctkarr_t("v1scf_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5144 : : nctkarr_t("v1lr_abs_avg", "dp", "two, nspden, three, natom, nqpt"), &
5145 : : nctkarr_t("gsmall", "int", "three, ngsmall"), &
5146 : : nctkarr_t("v1scf_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5147 : : nctkarr_t("v1lr_gsmall", "dp", "two, ngsmall, nspden, three, natom, nqpt"), &
5148 : : nctkarr_t("qpoints", "dp", "three, nqpt") &
5149 [ + + ]: 22 : ])
5150 [ - + ]: 2 : NCF_CHECK(ncerr)
5151 : :
5152 [ - + ]: 2 : if (write_v1r) then
5153 : : ncerr = nctk_def_arrays(ncid, [ &
5154 : : nctkarr_t("v1r_interpolated", "dp", "two, nfft, nspden, natom3"), &
5155 : : nctkarr_t("v1r_lrmodel", "dp", "two, nfft, nspden, natom3") &
5156 [ # # ]: 0 : ])
5157 [ # # ]: 0 : NCF_CHECK(ncerr)
5158 : : end if
5159 : :
5160 [ - + ]: 2 : NCF_CHECK(nctk_set_datamode(ncid))
5161 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpoints"), this_qpts))
5162 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5163 : : "symdynmat", "symv1scf", "dvdb_add_lr", "interpolated"], &
5164 [ + + + + ]: 18 : [dtset%symdynmat, dvdb%symv1, dtset%dvdb_add_lr, interpolated])
5165 [ - + ]: 2 : NCF_CHECK(ncerr)
5166 : : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
5167 : : "has_dielt", "has_zeff", "has_quadrupoles", "has_efield"], &
5168 [ + + + + ]: 18 : l2int([dvdb%has_dielt, dvdb%has_zeff, dvdb%has_quadrupoles, dvdb%has_efield]))
5169 [ - + ]: 2 : NCF_CHECK(ncerr)
5170 [ + + ]: 4 : dvdb_qdamp = dvdb%qdamp
5171 [ + + - + : 4 : NCF_CHECK(nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: "qdamp"], dvdb_qdamp))
- - ]
5172 [ - + ]: 2 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "gsmall"), gsmall))
5173 : : end if
5174 : :
5175 [ + + ]: 10 : do iq=1,this_nqpt
5176 : :
5177 [ + + ]: 8 : if (interpolated == 0) then
5178 [ - + ]: 3 : call wrtout(std_out, sjoin(" Treating qpt:", ktoa(this_qpts(:,iq))))
5179 : :
5180 : : ! Read data from DVDB file, reconstruct all 3*natom perturbations in tmp_v1r.
5181 [ - + - + ]: 3 : call dvdb%readsym_allv1(dvdb%findq(this_qpts(:, iq)), cplex, nfft, ngfft, tmp_v1r, xmpi_comm_self)
5182 : :
5183 : : ! Transfer data to file_v1r taking into account my_npert
5184 [ + + ]: 21 : do imyp=1,dvdb%my_npert
5185 : 18 : ipc = dvdb%my_pinfo(3, imyp)
5186 [ + + ]: 21 : if (cplex == 1) then
5187 [ + + + + ]: 24588 : file_v1r(1,:,:,imyp) = tmp_v1r(1,:,:,ipc)
5188 [ + + + + ]: 24588 : file_v1r(2,:,:,imyp) = zero
5189 : : else
5190 [ + + + + : 147480 : file_v1r(:,:,:,imyp) = tmp_v1r(:,:,:,ipc)
+ + ]
5191 : : end if
5192 : : end do
5193 [ - + ]: 3 : ABI_FREE(tmp_v1r)
5194 : :
5195 : : else
5196 : : ! Interpolate my_npert potentials for this q-point.
5197 [ - + ]: 5 : call wrtout(std_out, sjoin(" Interpolating qpt:", ktoa(this_qpts(:,iq))))
5198 [ - + ]: 5 : call dvdb%ftinterp_qpt(this_qpts(:, iq), nfft, ngfft, file_v1r, comm_rpt) !, add_lr=?)
5199 : 5 : cplex = 2
5200 : : end if
5201 : :
5202 : : ! Compute the periodic part of the LR term (note add_qphase = 0 because we want the periodic part)
5203 [ + + ]: 56 : do imyp=1,dvdb%my_npert
5204 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5205 [ + + ]: 104 : do ispden=1,min(dvdb%nspden, 2)
5206 [ - + ]: 96 : call dvdb%get_v1r_long_range(this_qpts(:,iq), idir, ipert, nfft, ngfft, long_v1r(:,:,ispden,imyp), add_qphase=0)
5207 : : end do
5208 : : end do
5209 : :
5210 : : ! Compute average and write to file.
5211 [ + - ]: 8 : if (my_rank /= master) cycle
5212 : :
5213 [ - + ]: 8 : if (write_v1r .and. iq == 1) then
5214 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_interpolated"), file_v1r))
5215 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_lrmodel"), long_v1r))
5216 : : end if
5217 : :
5218 [ + + ]: 58 : do imyp=1,dvdb%my_npert
5219 : 48 : idir = dvdb%my_pinfo(1, imyp); ipert = dvdb%my_pinfo(2, imyp); ipc = dvdb%my_pinfo(3, imyp)
5220 [ + + ]: 104 : do ispden=1,dvdb%nspden
5221 : :
5222 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp), dim=2) / nfft
5223 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_avg"), vals2, &
5224 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5225 [ - + ]: 48 : NCF_CHECK(ncerr)
5226 : :
5227 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp)), dim=2) / nfft
5228 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_abs_avg"), vals2, &
5229 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5230 [ - + ]: 48 : NCF_CHECK(ncerr)
5231 : :
5232 [ + + + + ]: 393360 : vals2 = sum(long_v1r(:,:,ispden,imyp), dim=2) / nfft
5233 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_avg"), vals2, &
5234 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5235 [ - + ]: 48 : NCF_CHECK(ncerr)
5236 [ + + + + ]: 393360 : vals2 = sum(abs(long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5237 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_abs_avg"), vals2, &
5238 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5239 [ - + ]: 48 : NCF_CHECK(ncerr)
5240 [ + + + + ]: 393360 : vals2 = sum(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp), dim=2) / nfft
5241 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_avg"), vals2, &
5242 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5243 [ - + ]: 48 : NCF_CHECK(ncerr)
5244 [ + + + + ]: 393360 : vals2 = sum(abs(file_v1r(:,:,ispden,imyp) - long_v1r(:,:,ispden,imyp)), dim=2) / nfft
5245 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scfmlr_abs_avg"), vals2, &
5246 [ + + ]: 288 : start=[1,ispden,idir,ipert,iq], count=[2,1,1,1,1])
5247 [ - + ]: 48 : NCF_CHECK(ncerr)
5248 : :
5249 : : ! Compute G-components of DFPT potentials and LR model for G in small-sphere and save results to disk
5250 : 48 : call fourdp(2, workg, file_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5251 [ + + ]: 1344 : do ig=1,ngsmall
5252 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5253 : : end do
5254 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1scf_gsmall"), work_gsmall, &
5255 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5256 [ - + ]: 48 : NCF_CHECK(ncerr)
5257 : :
5258 : 48 : call fourdp(2, workg, long_v1r(:,:,ispden,imyp), -1, dvdb%mpi_enreg, nfft, 1, ngfft, 0)
5259 [ + + ]: 1344 : do ig=1,ngsmall
5260 [ + + ]: 3936 : work_gsmall(:, ig) = workg(:, ig2ifft(ig))
5261 : : end do
5262 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1lr_gsmall"), work_gsmall, &
5263 [ + + + + ]: 624 : start=[1,1,ispden,idir,ipert,iq], count=[2,ngsmall,1,1,1,1])
5264 [ - + ]: 48 : NCF_CHECK(ncerr)
5265 : :
5266 : : ! Debugging section.
5267 : : !write(std_out, "(a)")"--- !DVDB_LONGRANGE_DIFF"
5268 : : !write(std_out,"(3a)")" qpoint: ", trim(ktoa(this_qpts(:,iq))), ","
5269 : : !write(std_out,"(a,i0,a)")" iq: ", iq, ","
5270 : : !write(std_out,"(2(a,i0))")" idir: ", idir, ", ipert:", ipert
5271 : : !write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5272 : : !call call vd%eval(2, nfft, file_v1r(:,:,ispden,imyp), long_v1r(:,:,ispden,imyp), &
5273 : : ! dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out))
5274 : : !write(std_out,"(a)")"..."
5275 : :
5276 : : ! Debug: write potentials to file.
5277 [ - + ]: 96 : if (unt /= -1) then
5278 [ # # # # : 0 : write(unt,*)"# q-point:", trim(ktoa(this_qpts(:,iq))), ", iq: ", trim(itoa(iq))
# # ]
5279 : 0 : write(unt,*)"# idir: ",idir,", ipert: ",ipert,", ispden:", ispden
5280 : 0 : write(unt,*)"# file_v1r, long_v1r, diff"
5281 : :
5282 [ # # ]: 0 : if (cplex == 1) then
5283 [ # # ]: 0 : do i3=1,n3
5284 [ # # ]: 0 : do i2=1,n2
5285 [ # # ]: 0 : do i1=1,n1
5286 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5287 : : write(unt,"(3(i0,1x),3(es12.4,2x))") &
5288 : 0 : i1,i2,i3, &
5289 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5290 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp)
5291 : : end do
5292 : : end do
5293 : : end do
5294 : : else
5295 [ # # ]: 0 : do i3=1,n3
5296 [ # # ]: 0 : do i2=1,n2
5297 [ # # ]: 0 : do i1=1,n1
5298 : 0 : ifft = i1+n1*((i2-1)+n2*(i3-1))
5299 : : write(unt, "(3(i0,1x),6(es12.4,2x))") &
5300 : 0 : i1,i2,i3, &
5301 : 0 : file_v1r(1,ifft,ispden,imyp), long_v1r(1,ifft,ispden,imyp), &
5302 : 0 : file_v1r(1,ifft,ispden,imyp) - long_v1r(1,ifft,ispden,imyp), &
5303 : 0 : file_v1r(2,ifft,ispden,imyp), long_v1r(2,ifft,ispden,imyp), &
5304 : 0 : file_v1r(2,ifft,ispden,imyp) - long_v1r(2,ifft,ispden,imyp)
5305 : : end do
5306 : : end do
5307 : : end do
5308 : : end if
5309 : 0 : write(unt,*)
5310 : 0 : write(unt,*)
5311 : : end if
5312 : :
5313 : : end do
5314 : : end do
5315 : : !write(std_out,*)" "
5316 : : end do ! iq
5317 : :
5318 [ - + ]: 2 : ABI_FREE(long_v1r)
5319 [ - + ]: 2 : ABI_FREE(file_v1r)
5320 [ - + ]: 2 : ABI_FREE(workg)
5321 [ - + ]: 2 : ABI_FREE(gfft)
5322 [ - + ]: 2 : ABI_FREE(ig2ifft)
5323 [ - + ]: 2 : ABI_FREE(gsmall)
5324 [ - + ]: 2 : ABI_FREE(work_gsmall)
5325 : :
5326 [ + + ]: 2 : if (interpolated == 1) then
5327 : : ! Compute max_r |W(R,r)| and write data to file.
5328 [ - + - + : 1 : call dvdb%get_maxw(dtset%ddb_ngqpt, all_rpt, all_rmod, maxw)
- + ]
5329 [ + - ]: 1 : if (my_rank == master) then
5330 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), dtset%ddb_ngqpt))
5331 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rpt"), all_rpt))
5332 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "rmod"), all_rmod))
5333 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5334 [ - + ]: 1 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "maxw"), maxw))
5335 : : end if
5336 [ - + ]: 1 : ABI_FREE(all_rpt)
5337 [ - + ]: 1 : ABI_FREE(all_rmod)
5338 [ - + ]: 1 : ABI_FREE(maxw)
5339 : : end if
5340 : :
5341 [ + - ]: 2 : if (my_rank == master) then
5342 [ - + ]: 2 : NCF_CHECK(nf90_close(ncid))
5343 : : end if
5344 : :
5345 [ - + - + : 4 : end subroutine dvdb_write_v1qavg
- + - + -
+ - + - +
- + ]
5346 : : !!***
5347 : :
5348 : : !----------------------------------------------------------------------
5349 : :
5350 : : !!****f* m_dvdb/dvdb_test_ftinterp
5351 : : !! NAME
5352 : : !! dvdb_test_ftinterp
5353 : : !!
5354 : : !! FUNCTION
5355 : : !! Debugging tool used to test the Fourier interpolation of the DFPT potentials.
5356 : : !!
5357 : : !! INPUTS
5358 : : !! dvdb_filepath=Filename
5359 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equat to ddb_ngqpt)
5360 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5361 : : !! qdamp=Defines exponential damping in LR potential
5362 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5363 : : !! prtvol=Verbosity level.
5364 : : !! coarse_ngqpt(3)= Coarse q-mesh used to analyze the accuracy of the FT interpolation
5365 : : !! Must be divisor of dvdb_ngqpt. Use 0 to disable the test.
5366 : : !! comm=MPI communicator.
5367 : : !!
5368 : : !! OUTPUT
5369 : : !! Only writing.
5370 : : !!
5371 : : !! SOURCE
5372 : :
5373 : 0 : subroutine dvdb_test_ftinterp(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5374 : : ddb_filepath, prtvol, coarse_ngqpt, dump_path, comm)
5375 : :
5376 : : !Arguments ------------------------------------
5377 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5378 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5379 : : real(dp),intent(in) :: dvdb_qdamp
5380 : : integer,intent(in) :: dvdb_ngqpt(3), coarse_ngqpt(3)
5381 : :
5382 : : !Local variables-------------------------------
5383 : : !scalars
5384 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0
5385 : : integer :: nfft, iq, cplex, mu, ispden, comm_rpt, iblock_dielt, iblock_dielt_zeff, my_rank, ierr
5386 : : integer :: ncid, ncerr
5387 : : logical :: autotest
5388 [ # # # # : 0 : type(dvdb_t) :: dvdb, coarse_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
5389 : : type(vdiff_t) :: vd_max, vd
5390 : 0 : type(ddb_type) :: ddb
5391 : : character(len=fnlen) :: coarse_fname
5392 : : !arrays
5393 : : integer :: ngfft(18)
5394 : 0 : real(dp),allocatable :: file_v1r(:,:,:,:),intp_v1r(:,:,:,:),tmp_v1r(:,:,:,:)
5395 : : ! *************************************************************************
5396 : :
5397 : 0 : my_rank = xmpi_comm_rank(comm)
5398 : :
5399 : 0 : write(std_out,"(a)")sjoin(" Testing Fourier interpolation of V1(r) with ngqpt:", ltoa(dvdb_ngqpt))
5400 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5401 : 0 : write(std_out,"(a)")sjoin(" Reading Zeff and eps_inf from DDB file:", ddb_filepath)
5402 : 0 : write(std_out,"(a)")sjoin(" dvdb_add_lr set to:", itoa(dvdb_add_lr))
5403 : : end if
5404 : :
5405 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5406 : 0 : dvdb%debug = .False.
5407 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5408 : 0 : dvdb%symv1 = symv1
5409 : 0 : dvdb%add_lr = dvdb_add_lr
5410 : 0 : dvdb%qdamp = dvdb_qdamp
5411 : 0 : dvdb%rspace_cell = rspace_cell
5412 : :
5413 : : !call dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5414 : :
5415 : 0 : iblock_dielt = 0; iblock_dielt_zeff = 0
5416 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5417 : 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5418 : : else
5419 : 0 : dvdb%add_lr = 0
5420 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5421 : : end if
5422 : :
5423 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5424 : :
5425 : : ! Define FFT mesh for real space representation.
5426 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5427 [ # # ]: 0 : nfft = product(ngfft(1:3))
5428 : 0 : call dvdb%open_read(ngfft, comm)
5429 : :
5430 [ # # # # : 0 : ABI_MALLOC(intp_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5431 [ # # # # : 0 : ABI_MALLOC(file_v1r, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5432 : :
5433 : : ! Prepare FT interpolation.
5434 : 0 : comm_rpt = xmpi_comm_self
5435 : :
5436 : : ! Optionally dump ab-initio and interpolated V1(r) to a netcdf file for post-processing in python.
5437 : 0 : ncid = nctk_noid
5438 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5439 : 0 : write(std_out,"(a)")sjoin(" Will write ab-initio and interpolated potentials to:", dump_path)
5440 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5441 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5442 : : ncerr = nctk_def_dims(ncid, [ &
5443 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5444 [ # # ]: 0 : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nqpt", dvdb%nqpt)], defmode=.True.)
5445 [ # # ]: 0 : NCF_CHECK(ncerr)
5446 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpts", "dp", "three, nqpt")))
5447 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("ngfft", "int", "three")))
5448 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5449 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("self_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5450 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5451 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_ngqpt", "int", "three")))
5452 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_abinitio", "dp", "two, nfft, nspden, natom3, nqpt")))
5453 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("coarse_v1r_interp", "dp", "two, nfft, nspden, natom3, nqpt")))
5454 : : end if
5455 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5456 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpts"), dvdb%qpts))
5457 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngfft"), ngfft(1:3)))
5458 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5459 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_ngqpt"), coarse_ngqpt))
5460 : : end if
5461 : : end if
5462 : :
5463 : 0 : autotest = .True.
5464 : : if (autotest) then
5465 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5466 : :
5467 : : ! First step: Use FT interpolation to get q-points in the initial ab-initio mesh.
5468 : : ! We should get the same result...
5469 [ # # ]: 0 : do iq=1,dvdb%nqpt
5470 : : ! Read data from DVDB file and store it in file_v1r
5471 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5472 : :
5473 [ # # ]: 0 : if (cplex == 1) then
5474 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5475 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5476 : : else
5477 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5478 : : end if
5479 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5480 : :
5481 : : ! Interpolate data at the same q-point.
5482 : 0 : call dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5483 : :
5484 : 0 : write(std_out,"(a)")sjoin("=== For q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5485 [ # # ]: 0 : do mu=1,dvdb%natom3
5486 [ # # ]: 0 : do ispden=1,dvdb%nspden
5487 : 0 : write(std_out, "(a)")"--- !DVDB_SELF_DIFF"
5488 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5489 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5490 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5491 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5492 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5493 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5494 : 0 : write(std_out,"(a)")"..."
5495 : : !do ifft=1,nfft
5496 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5497 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5498 : : !end do
5499 : : end do
5500 : : end do
5501 : :
5502 [ # # ]: 0 : if (ncid /= nctk_noid) then
5503 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5504 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "self_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5505 : : end if
5506 : :
5507 : 0 : write(std_out,*)" "
5508 : : end do ! iq
5509 : :
5510 : 0 : write(std_out, "(/, a)")" Max values over q-points and perturbations"
5511 : 0 : call vd_max%print()
5512 [ # # ]: 0 : ABI_FREE(dvdb%wsr)
5513 : : end if
5514 : :
5515 : : ! Now downsample the q-mesh, build real-space representation with coarse q-mesh and
5516 : : ! compare with ab-intio values in the initial dvdb.
5517 [ # # # # : 0 : if (all(coarse_ngqpt /= 0)) then
# # ]
5518 [ # # ]: 0 : write(std_out, "(/, 2a)")" Downsampling Q-mesh using coarse_ngqpt:", trim(ltoa(coarse_ngqpt))
5519 : :
5520 [ # # ]: 0 : coarse_fname = strcat(dvdb_filepath, "_COARSE")
5521 : 0 : call dvdb%qdownsample(coarse_fname, qptopt1, coarse_ngqpt, comm)
5522 : :
5523 : 0 : call coarse_dvdb%init(coarse_fname, gpu_option0, comm)
5524 : 0 : call coarse_dvdb%open_read(ngfft, comm)
5525 : : !call coarse_dvdb%set_pert_distrib(sigma%comm_pert, sigma%my_pinfo, sigma%pert_table)
5526 : :
5527 : 0 : coarse_dvdb%debug = dvdb%debug
5528 : 0 : coarse_dvdb%symv1 = dvdb%symv1
5529 : 0 : coarse_dvdb%add_lr = dvdb%add_lr
5530 : 0 : coarse_dvdb%has_dielt = dvdb%has_dielt
5531 : 0 : coarse_dvdb%has_zeff = dvdb%has_zeff
5532 : 0 : coarse_dvdb%has_quadrupoles = dvdb%has_quadrupoles
5533 : 0 : coarse_dvdb%has_efield = dvdb%has_efield
5534 [ # # # # ]: 0 : coarse_dvdb%dielt = dvdb%dielt
5535 [ # # # # : 0 : coarse_dvdb%zeff = dvdb%zeff
# # # # #
# # # # #
# # # # #
# # # ]
5536 [ # # # # : 0 : coarse_dvdb%zeff_raw = dvdb%zeff_raw
# # # # #
# # # # #
# # # # #
# # # ]
5537 [ # # # # : 0 : coarse_dvdb%qstar = dvdb%qstar
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5538 : 0 : coarse_dvdb%qdamp = dvdb%qdamp
5539 : : !call coarse_dvdb%print()
5540 : :
5541 : : ! Prepare FT interpolation using coarse q-mesh.
5542 : 0 : call coarse_dvdb%ftinterp_setup(coarse_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5543 : :
5544 [ # # ]: 0 : do iq=1,dvdb%nqpt
5545 : : ! Read data from DVDB file and store it in file_v1r
5546 [ # # ]: 0 : call dvdb%readsym_allv1(dvdb%findq(dvdb%qpts(:,iq)), cplex, nfft, ngfft, tmp_v1r, comm)
5547 : :
5548 [ # # ]: 0 : if (cplex == 1) then
5549 [ # # # # : 0 : file_v1r(1,:,:,:) = tmp_v1r(1,:,:,:)
# # ]
5550 [ # # # # : 0 : file_v1r(2,:,:,:) = zero
# # ]
5551 : : else
5552 [ # # # # : 0 : file_v1r = tmp_v1r
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5553 : : end if
5554 [ # # ]: 0 : ABI_FREE(tmp_v1r)
5555 : :
5556 : : ! Interpolate data at the same q-point using the coarse Q-mesh
5557 : 0 : call coarse_dvdb%ftinterp_qpt(dvdb%qpts(:,iq), nfft, ngfft, intp_v1r, dvdb%comm_rpt)
5558 : :
5559 : 0 : write(std_out,"(a)")sjoin("=== For COARSE q-point:", ktoa(dvdb%qpts(:,iq)), "===")
5560 [ # # ]: 0 : do mu=1,dvdb%natom3
5561 [ # # ]: 0 : do ispden=1,dvdb%nspden
5562 : 0 : write(std_out, "(a)")"--- !DVDB_COARSE_DIFF"
5563 [ # # ]: 0 : write(std_out,"(3a)")" qpoint: ", trim(ktoa(dvdb%qpts(:,iq))), ","
5564 : 0 : write(std_out,"(a,i0,a)")" iqpt: ", iq, ","
5565 : 0 : write(std_out,"(a,i0,a)")" iatom3: ", mu, ","
5566 : 0 : write(std_out,"(a,i0,a)")" ispden: ", ispden, ","
5567 : : call vd%eval(2, nfft, file_v1r(:,:,ispden,mu), intp_v1r(:,:,ispden,mu), &
5568 : 0 : dvdb%cryst%ucvol, vd_max=vd_max, unit=std_out)
5569 : 0 : write(std_out,"(a)")"..."
5570 : : !do ifft=1,nfft
5571 : : ! write(std_out,*)file_v1r(1,ifft,ispden,mu),intp_v1r(1,ifft,ispden,mu),&
5572 : : ! file_v1r(2,ifft,ispden,mu),intp_v1r(2,ifft,ispden,mu)
5573 : : !end do
5574 : : end do
5575 : : end do
5576 : :
5577 [ # # ]: 0 : if (ncid /= nctk_noid) then
5578 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_abinitio"), file_v1r, start=[1,1,1,1,iq]))
# # ]
5579 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "coarse_v1r_interp"), intp_v1r, start=[1,1,1,1,iq]))
# # ]
5580 : : end if
5581 : :
5582 : 0 : write(std_out,*)" "
5583 : : end do ! iq
5584 : :
5585 : 0 : write(std_out, "(/, a)")" COARSE DVDB: Max values over q-points and perturbations"
5586 : 0 : call vd_max%print()
5587 : 0 : call coarse_dvdb%free()
5588 [ # # ]: 0 : if (my_rank == master) call delete_file(coarse_fname, ierr)
5589 : : end if
5590 : :
5591 [ # # ]: 0 : ABI_FREE(intp_v1r)
5592 [ # # ]: 0 : ABI_FREE(file_v1r)
5593 : :
5594 [ # # ]: 0 : if (ncid /= nctk_noid) then
5595 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5596 : : end if
5597 : :
5598 : 0 : call dvdb%free()
5599 : 0 : call ddb%free()
5600 : :
5601 [ # # # # : 0 : end subroutine dvdb_test_ftinterp
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5602 : : !!***
5603 : :
5604 : : !----------------------------------------------------------------------
5605 : :
5606 : : !!****f* m_dvdb/dvdb_test_symcheck
5607 : : !! NAME
5608 : : !! dvdb_test_symcheck
5609 : : !!
5610 : : !! FUNCTION
5611 : : !! Debugging tool: checks whether Fourier-interpolating the DFPT potential independently
5612 : : !! at q_source and at q_target = I(itimrev) S(isym) q_source (for every symmetry of the
5613 : : !! crystal) gives results consistent with each other via the exact rotation formula
5614 : : !! implemented in v1phq_rotate. This isolates the Fourier-interpolation machinery
5615 : : !! (dvdb_ftinterp_qpt) from gstore_symmetrize: no e-ph coupling / m_gstore.F90 code is
5616 : : !! involved at all. q_source need not be on the native ab-initio q-mesh.
5617 : : !!
5618 : : !! INPUTS
5619 : : !! dvdb_filepath=Filename
5620 : : !! dvdb_ngqpt(3)=Divisions of the Q-mesh reported in the DVDB file (usually equal to ddb_ngqpt)
5621 : : !! dvdb_add_lr=0 to disable treatment of long-range part in Fourier interpolation.
5622 : : !! qdamp=Defines exponential damping in LR potential
5623 : : !! ddb_filepath=Path to DDB file. Used to treat LR part.
5624 : : !! prtvol=Verbosity level.
5625 : : !! qpt_source(3)=Source q-point (reduced coordinates, arbitrary, need not be on the ab-initio mesh).
5626 : : !! comm=MPI communicator.
5627 : : !!
5628 : : !! OUTPUT
5629 : : !! Only writing.
5630 : : !!
5631 : : !! SOURCE
5632 : :
5633 : 0 : subroutine dvdb_test_symcheck(dvdb_filepath, rspace_cell, symv1, dvdb_ngqpt, dvdb_add_lr, dvdb_qdamp, &
5634 : : ddb_filepath, prtvol, qpt_source, dump_path, comm)
5635 : :
5636 : : !Arguments ------------------------------------
5637 : : character(len=*),intent(in) :: dvdb_filepath, ddb_filepath, dump_path
5638 : : integer,intent(in) :: comm, prtvol, dvdb_add_lr, rspace_cell, symv1
5639 : : real(dp),intent(in) :: dvdb_qdamp
5640 : : integer,intent(in) :: dvdb_ngqpt(3)
5641 : : real(dp),intent(in) :: qpt_source(3)
5642 : :
5643 : : !Local variables-------------------------------
5644 : : !scalars
5645 : : integer,parameter :: master = 0, chneut2 = 2, qptopt1 = 1, gpu_option0 = 0, cplex2 = 2
5646 : : integer :: nfft, isym, itimrev, tsign, mu, ispden, comm_rpt, iat, my_rank, ncid, ncerr
5647 [ # # # # : 0 : type(dvdb_t) :: dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5648 : : type(vdiff_t) :: vd_max, vd
5649 : : !arrays
5650 : : integer :: ngfft(18), g0q(3)
5651 : : real(dp) :: qpt_target(3)
5652 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5653 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5654 : : ! *************************************************************************
5655 : :
5656 : 0 : my_rank = xmpi_comm_rank(comm)
5657 : :
5658 : 0 : write(std_out,"(2a)")" Testing cross-q-point symmetry consistency of the FT interpolation of V1(r)", ch10
5659 : 0 : write(std_out,"(a)")sjoin(" q_source: ", ktoa(qpt_source))
5660 : :
5661 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5662 : 0 : dvdb%debug = .False.
5663 [ # # ]: 0 : ABI_CHECK(any(symv1 == [0, 1, 2]), sjoin("invalid value of symv1:", itoa(symv1)))
5664 : 0 : dvdb%symv1 = symv1
5665 : 0 : dvdb%add_lr = dvdb_add_lr
5666 : 0 : dvdb%qdamp = dvdb_qdamp
5667 : 0 : dvdb%rspace_cell = rspace_cell
5668 : :
5669 [ # # ]: 0 : if (len_trim(ddb_filepath) > 0) then
5670 : 0 : call dvdb%load_ddb(prtvol, chneut2, comm, ddb_filepath=ddb_filepath)
5671 : : else
5672 : 0 : dvdb%add_lr = 0
5673 : 0 : ABI_WARNING("ddb_filepath was not provided --> Setting dvdb_add_lr to zero")
5674 : : end if
5675 : :
5676 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5677 : :
5678 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5679 [ # # ]: 0 : nfft = product(ngfft(1:3))
5680 : 0 : call dvdb%open_read(ngfft, comm)
5681 : :
5682 : 0 : comm_rpt = xmpi_comm_self
5683 : 0 : call dvdb%ftinterp_setup(dvdb_ngqpt, qptopt1, 1, [zero, zero, zero], nfft, ngfft, comm_rpt)
5684 : :
5685 [ # # # # : 0 : ABI_MALLOC(v1r_source, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5686 [ # # # # : 0 : ABI_MALLOC(v1r_target, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5687 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # ]
5688 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5689 : :
5690 : : ! Interpolate once at q_source (this itself is a genuine off-grid interpolation if q_source
5691 : : ! is not on the coarse ab-initio mesh).
5692 : 0 : call dvdb%ftinterp_qpt(qpt_source, nfft, ngfft, v1r_source, dvdb%comm_rpt)
5693 : :
5694 : : ! Optionally dump v1r_target (independent re-interpolation at q_target) and v1r_predicted
5695 : : ! (rotated prediction from q_source) to a netcdf file for post-processing in python.
5696 : 0 : ncid = nctk_noid
5697 [ # # # # ]: 0 : if (len_trim(dump_path) /= 0 .and. my_rank == master) then
5698 : 0 : write(std_out,"(a)")sjoin(" Will write target and predicted potentials to:", dump_path)
5699 [ # # ]: 0 : NCF_CHECK(nctk_open_create(ncid, dump_path, xmpi_comm_self))
5700 [ # # ]: 0 : NCF_CHECK(dvdb%cryst%ncwrite(ncid))
5701 : : ncerr = nctk_def_dims(ncid, [ &
5702 : : nctkdim_t("two", 2), nctkdim_t("three", 3), nctkdim_t("nfft", nfft), nctkdim_t("nspden", dvdb%nspden), &
5703 : : nctkdim_t("natom3", dvdb%natom3), nctkdim_t("nsym", dvdb%cryst%nsym), nctkdim_t("ntimrev", 2)], &
5704 [ # # ]: 0 : defmode=.True.)
5705 [ # # ]: 0 : NCF_CHECK(ncerr)
5706 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_source", "dp", "three")))
5707 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("qpt_target", "dp", "three, ntimrev, nsym")))
5708 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_target", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5709 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1r_predicted", "dp", "two, nfft, nspden, natom3, ntimrev, nsym")))
5710 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(ncid))
5711 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_source"), qpt_source))
5712 : : end if
5713 : :
5714 : 0 : g0q = 0
5715 [ # # ]: 0 : do isym=1,dvdb%cryst%nsym
5716 [ # # ]: 0 : do itimrev=1,2
5717 : 0 : tsign = 3 - 2*itimrev
5718 [ # # # # : 0 : qpt_target = tsign * matmul(dvdb%cryst%symrec(:,:,isym), qpt_source)
# # # # #
# # # ]
5719 : :
5720 : : ! Independent, direct interpolation at the target q (no symmetry involved at all).
5721 : 0 : call dvdb%ftinterp_qpt(qpt_target, nfft, ngfft, v1r_target, dvdb%comm_rpt)
5722 : :
5723 : : ! Predicted potential at q_target obtained by ROTATING the q_source interpolation
5724 : : ! with the exact same formula gstore_symmetrize/v1phq_rotate uses to expand IBZ->BZ.
5725 : : call v1phq_rotate(dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5726 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5727 : :
5728 [ # # ]: 0 : if (ncid /= nctk_noid) then
5729 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpt_target"), qpt_target, start=[1,itimrev,isym]))
# # ]
5730 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_target"), v1r_target, start=[1,1,1,1,itimrev,isym]))
# # ]
5731 [ # # # # : 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1r_predicted"), v1r_predicted, start=[1,1,1,1,itimrev,isym]))
# # ]
5732 : : end if
5733 : :
5734 [ # # ]: 0 : do mu=1,dvdb%natom3
5735 : 0 : iat = (mu - 1) / 3 + 1
5736 [ # # ]: 0 : do ispden=1,dvdb%nspden
5737 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5738 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5739 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5740 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5741 : : end do
5742 : : end do
5743 : :
5744 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK"
5745 : 0 : write(std_out,"(a,i0,a)")" isym: ", isym, ","
5746 : 0 : write(std_out,"(a,i0,a)")" itimrev: ", itimrev, ","
5747 [ # # ]: 0 : write(std_out,"(3a)")" qpt_target: ", trim(ktoa(qpt_target)), ","
5748 : 0 : call vd_max%print()
5749 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5750 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5751 : : end do
5752 : 0 : write(std_out,"(a)")"..."
5753 : : end do ! itimrev
5754 : : end do ! isym
5755 : :
5756 [ # # ]: 0 : ABI_FREE(v1r_source)
5757 [ # # ]: 0 : ABI_FREE(v1r_target)
5758 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5759 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5760 : :
5761 [ # # ]: 0 : if (ncid /= nctk_noid) then
5762 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
5763 : : end if
5764 : :
5765 : 0 : call dvdb%free()
5766 : :
5767 [ # # # # : 0 : end subroutine dvdb_test_symcheck
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5768 : : !!***
5769 : :
5770 : : !----------------------------------------------------------------------
5771 : :
5772 : : !!****f* m_dvdb/dvdb_test_symcheck_native
5773 : : !! NAME
5774 : : !! dvdb_test_symcheck_native
5775 : : !!
5776 : : !! FUNCTION
5777 : : !! Debugging tool: like dvdb_test_symcheck but operates on TWO LITERAL, independently
5778 : : !! DFPT-computed q-points already present in the DVDB (no Fourier interpolation involved
5779 : : !! at all -- no ftinterp_setup/ftinterp_qpt call anywhere). Reads q_source and q_target
5780 : : !! directly via readsym_allv1, predicts q_target from q_source via v1phq_rotate, and
5781 : : !! compares against q_target's own literal data. Isolates v1phq_rotate/rotate_fqg
5782 : : !! completely from the W(R,r) real-space Fourier-interpolation machinery.
5783 : : !!
5784 : : !! INPUTS
5785 : : !! dvdb_filepath=Filename (must contain BOTH q_source and q_target as literal,
5786 : : !! fully-available (3*natom perturbations) q-points, e.g. produced with nsym 1).
5787 : : !! sym_dvdb_filepath=Filename of a DIFFERENT DVDB (or any file crystal_from_file can read) that
5788 : : !! carries the crystal's TRUE, full symmetry table (dvdb_filepath's own nsym is typically 1,
5789 : : !! since that's what forces every requested perturbation/q to be explicitly, independently
5790 : : !! computed in the first place -- so its own %cryst cannot be used to look up isym > 1).
5791 : : !! qpt_source(3), qpt_target(3)=The two q-points (reduced coordinates), assumed related by
5792 : : !! the given isym/itimrev/g0q.
5793 : : !! isym, itimrev, g0q(3)=Symmetry indices such that qpt_target = I(itimrev) S(isym) qpt_source + g0q.
5794 : : !! comm=MPI communicator.
5795 : : !!
5796 : : !! OUTPUT
5797 : : !! Only writing.
5798 : : !!
5799 : : !! SOURCE
5800 : :
5801 : 0 : subroutine dvdb_test_symcheck_native(dvdb_filepath, sym_dvdb_filepath, qpt_source, qpt_target, &
5802 : : isym, itimrev, g0q, comm)
5803 : :
5804 : : !Arguments ------------------------------------
5805 : : character(len=*),intent(in) :: dvdb_filepath, sym_dvdb_filepath
5806 : : integer,intent(in) :: comm, isym, itimrev
5807 : : integer,intent(in) :: g0q(3)
5808 : : real(dp),intent(in) :: qpt_source(3), qpt_target(3)
5809 : :
5810 : : !Local variables-------------------------------
5811 : : !scalars
5812 : : integer,parameter :: gpu_option0 = 0, cplex2 = 2
5813 : : integer :: nfft, mu, ispden, iq_source, iq_target, iat
5814 [ # # # # : 0 : type(dvdb_t) :: dvdb, sym_dvdb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
5815 : : type(vdiff_t) :: vd_max, vd
5816 : : !arrays
5817 : : integer :: ngfft(18)
5818 : 0 : real(dp),allocatable :: v1r_source(:,:,:,:), v1r_target(:,:,:,:), v1r_predicted(:,:,:,:)
5819 : 0 : type(vdiff_t),allocatable :: vd_max_atom(:)
5820 : : ! *************************************************************************
5821 : :
5822 : 0 : write(std_out,"(2a)")" Testing v1phq_rotate against TWO LITERAL, non-interpolated q-points", ch10
5823 [ # # ]: 0 : write(std_out,"(2a)")" q_source: ", trim(ktoa(qpt_source))
5824 [ # # ]: 0 : write(std_out,"(2a)")" q_target: ", trim(ktoa(qpt_target))
5825 : :
5826 : 0 : call dvdb%init(dvdb_filepath, gpu_option0, comm)
5827 : 0 : dvdb%debug = .False.
5828 [ # # ]: 0 : call dvdb%print([std_out], "", 0)
5829 : :
5830 : 0 : call ngfft_seq(ngfft, dvdb%ngfft3_v1(:,1))
5831 [ # # ]: 0 : nfft = product(ngfft(1:3))
5832 : 0 : call dvdb%open_read(ngfft, comm)
5833 : :
5834 : : ! Load a SEPARATE dvdb just to get the crystal's true, full symmetry table (dvdb_filepath's
5835 : : ! own %cryst normally has nsym=1, see docstring above).
5836 : 0 : call sym_dvdb%init(sym_dvdb_filepath, gpu_option0, comm)
5837 : 0 : write(std_out,"(a,i0,a,i0)")" sym_dvdb nsym: ", sym_dvdb%cryst%nsym, " dvdb (literal) nsym: ", dvdb%cryst%nsym
5838 : :
5839 : 0 : iq_source = dvdb%findq(qpt_source)
5840 : 0 : iq_target = dvdb%findq(qpt_target)
5841 [ # # ]: 0 : ABI_CHECK(iq_source /= -1, "qpt_source not found in DVDB!")
5842 [ # # ]: 0 : ABI_CHECK(iq_target /= -1, "qpt_target not found in DVDB!")
5843 : :
5844 : 0 : call dvdb%readsym_allv1(iq_source, mu, nfft, ngfft, v1r_source, comm) ! mu reused as cplex out-arg
5845 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_source")
5846 : 0 : call dvdb%readsym_allv1(iq_target, mu, nfft, ngfft, v1r_target, comm)
5847 [ # # ]: 0 : ABI_CHECK_IEQ(mu, cplex2, "cplex != 2 for qpt_target")
5848 : :
5849 [ # # # # : 0 : ABI_MALLOC(v1r_predicted, (2, nfft, dvdb%nspden, dvdb%natom3))
# # # # #
# # # # #
# # # # #
# ]
5850 [ # # # # : 0 : ABI_MALLOC(vd_max_atom, (dvdb%cryst%natom))
# # # # #
# # # #
# ]
5851 : :
5852 : : call v1phq_rotate(sym_dvdb%cryst, qpt_source, isym, itimrev, g0q, ngfft, cplex2, nfft, dvdb%nspden, &
5853 : 0 : dvdb%mpi_enreg, v1r_source, v1r_predicted, xmpi_comm_self)
5854 : :
5855 : 0 : call sym_dvdb%free()
5856 : :
5857 [ # # ]: 0 : do mu=1,dvdb%natom3
5858 : 0 : iat = (mu - 1) / 3 + 1
5859 [ # # ]: 0 : do ispden=1,dvdb%nspden
5860 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5861 : 0 : dvdb%cryst%ucvol, vd_max=vd_max)
5862 : : call vd%eval(cplex2, nfft, v1r_predicted(:,:,ispden,mu), v1r_target(:,:,ispden,mu), &
5863 : 0 : dvdb%cryst%ucvol, vd_max=vd_max_atom(iat))
5864 : : end do
5865 : : end do
5866 : :
5867 : 0 : write(std_out,"(a)")"--- !DVDB_SYMCHECK_NATIVE"
5868 : 0 : call vd_max%print()
5869 [ # # ]: 0 : do iat=1,dvdb%cryst%natom
5870 : 0 : write(std_out,"(a,i0,a,es12.4)")" atom_max_adiff[", iat, "]: ", vd_max_atom(iat)%max_adiff
5871 : : end do
5872 : 0 : write(std_out,"(a)")"..."
5873 : :
5874 [ # # ]: 0 : ABI_FREE(v1r_source)
5875 [ # # ]: 0 : ABI_FREE(v1r_target)
5876 [ # # ]: 0 : ABI_FREE(v1r_predicted)
5877 [ # # ]: 0 : ABI_FREE(vd_max_atom)
5878 : :
5879 : 0 : call dvdb%free()
5880 : :
5881 [ # # # # : 0 : end subroutine dvdb_test_symcheck_native
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
5882 : : !!***
5883 : :
5884 : : !----------------------------------------------------------------------
5885 : :
5886 : : !!****f* m_dvdb/dvdb_get_v1r_long_range
5887 : : !! NAME
5888 : : !! dvdb_get_v1r_long_range
5889 : : !!
5890 : : !! FUNCTION
5891 : : !! Compute the long-range part of the phonon potential
5892 : : !! due to the Born effective charges, PRL 115, 176401 (2015) [[cite:Verdi2015]].
5893 : : !!
5894 : : !! V^L_{iatom,idir}(r) = i (4pi/vol) sum_G (q+G) . Zeff_{iatom,idir}
5895 : : !! e^{i (q+G).(r - tau_{iatom})} / ((q+G) . dielt . (q+G))
5896 : : !!
5897 : : !! where Zeff and dielt are the Born effective charge tensor and the dielectric tensor in cart coords,
5898 : : !! tau is the atom position, and vol is the volume of the unit cell.
5899 : : !! Note that internally the tensors are stored in Cartesian coordinates while in output we need
5900 : : !! the contribution due to the displacement of the iatom-sublattice along the reduced direction idir
5901 : : !! hence we need to perform some tensor gymnastics to go from Cart to reduced.
5902 : : !!
5903 : : !! INPUTS
5904 : : !! db = the DVDB object.
5905 : : !! qpt = the q-point in reduced coordinates.
5906 : : !! idir = direction index.
5907 : : !! iatom = atom index.
5908 : : !! nfft = number of fft points.
5909 : : !! ngfft(18) = FFT mesh.
5910 : : !! [add_qphase]=By default, the routine returns the LR potential with the e^{iqr} phase.
5911 : : !! Use add_qphase = 0 to get the lattice-periodic part.
5912 : : !!
5913 : : !! OUTPUT
5914 : : !! v1r_lr = dipole potential
5915 : : !!
5916 : : !! SOURCE
5917 : :
5918 : 22234 : subroutine dvdb_get_v1r_long_range(db, qpt, idir, iatom, nfft, ngfft, v1r_lr, add_qphase)
5919 : :
5920 : : !Arguments ------------------------------------
5921 : : !scalars
5922 : : class(dvdb_t),intent(in) :: db
5923 : : integer,intent(in) :: idir, iatom, nfft
5924 : : integer,optional,intent(in) :: add_qphase
5925 : : !arrays
5926 : : integer,intent(in) :: ngfft(18)
5927 : : real(dp),intent(in) :: qpt(3)
5928 : : real(dp),intent(out) :: v1r_lr(2,nfft)
5929 : :
5930 : : !Local variables-------------------------------
5931 : : !scalars
5932 : : integer :: n1, n2, n3, nfftot, ig, iphase, ii, jj, kk, ll, mm, ifft, ispden
5933 : : real(dp) :: fac, qGZ, qGS, denom, denom_inv, qtau, re, im, phre, phim, qg_mod, gsq_max
5934 : : real(dp),parameter :: tol_denom = tol8
5935 : : !arrays
5936 : 22234 : integer, allocatable :: gfft(:,:)
5937 : : real(dp) :: gprimd(3,3), rprimd(3,3), dielt_red(3,3)
5938 : : real(dp) :: qG_red(3), qG_cart(3), Zstar(3), Sstar(3,3), tau_red(3)
5939 : 22234 : real(dp), allocatable :: v1G_lr(:,:), v1G_lr33(:,:,:,:), workr(:,:)
5940 : : ! *************************************************************************
5941 : :
5942 : : ! Return immediately if metals by
5943 : : !if (db%has_zeff .or. db%has_quadrupoles) then
5944 : :
5945 [ + + ]: 22234 : iphase = 1; if (present(add_qphase)) iphase = add_qphase
5946 : :
5947 : : ! Make sure FFT parallelism is not used
5948 [ + + ]: 88936 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); nfftot = product(ngfft(1:3))
5949 [ - + ]: 22234 : ABI_CHECK(nfftot == nfft, "FFT parallelism not supported")
5950 : :
5951 : : ! Allocate memory
5952 [ - + + - : 66702 : ABI_MALLOC(gfft, (3, nfft))
+ - + - -
+ - + ]
5953 [ - + + - : 66702 : ABI_MALLOC(v1G_lr, (2, nfft))
+ - + - -
+ - + ]
5954 : :
5955 : : ! Reciprocal and real space primitive vectors
5956 [ + + + + : 555850 : gprimd = db%cryst%gprimd; rprimd = db%cryst%rprimd
+ + + + ]
5957 : :
5958 : : ! Prefactor
5959 : 22234 : fac = four_pi / db%cryst%ucvol
5960 : :
5961 : : ! Transform the Born effective charge tensor from Cartesian to reduced coordinates
5962 : : ! and select the relevant direction.
5963 [ + - + - : 689254 : Zstar = matmul(transpose(gprimd), matmul(db%zeff(:,:,iatom), rprimd(:,idir))) * two_pi
+ - - + -
+ + + + +
+ + + - +
- + - +
+ ]
5964 : :
5965 [ - + ]: 22234 : if (db%has_quadrupoles) then
5966 : : ! Transform Qstar from Cartesian to reduced coordinates and select the relevant direction.
5967 : 0 : Sstar = zero
5968 [ # # ]: 0 : do ii=1,3
5969 [ # # ]: 0 : do jj=1,3
5970 [ # # ]: 0 : do kk=1,3
5971 [ # # ]: 0 : do ll=1,3
5972 [ # # ]: 0 : do mm=1,3
5973 : : Sstar(ii,jj) = Sstar(ii,jj) + &
5974 : 0 : gprimd(mm,jj) * gprimd(ll,ii) * db%qstar(mm,ll,kk,iatom) * rprimd(kk,idir) * two_pi ** 2
5975 : : end do
5976 : : end do
5977 : : end do
5978 : : end do
5979 : : end do
5980 : : end if
5981 : :
5982 : : ! Transform the dielectric tensor from Cartesian to reduced coordinates.
5983 : : ! q_cart e_cart q_cart = q_red (G^t e_cart G) q_red
5984 [ + + + + : 2023294 : dielt_red = matmul(transpose(gprimd), matmul(db%dielt, gprimd)) * two_pi ** 2
+ + + + +
+ + + + +
+ + ]
5985 : :
5986 : : ! Atom position
5987 [ + + ]: 88936 : tau_red = db%cryst%xred(:,iatom)
5988 : :
5989 : : ! Get the set of G vectors
5990 : : ! TODO: May use zero-padded FFT with small G-sphere
5991 : 22234 : call get_gfft(ngfft, qpt, db%cryst%gmet, gsq_max, gfft)
5992 : :
5993 : : ! Compute the long-range potential in G-space due to Z* and Q* (if present)
5994 [ + + + + ]: 336598582 : v1G_lr = zero
5995 [ - + - - ]: 22234 : if (db%has_zeff .or. db%has_quadrupoles) then
5996 : :
5997 [ + + ]: 112214350 : do ig=1,nfft
5998 : : ! (q + G)
5999 [ + + ]: 448768464 : qG_red = qpt + gfft(:,ig)
6000 [ + + + + : 1795073856 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
+ + ]
6001 [ + + ]: 448768464 : qG_mod = sqrt(sum(qG_cart ** 2))
6002 : : ! (q + G) . Zeff(:,idir,iatom)
6003 [ + + ]: 448768464 : qGZ = dot_product(qG_red, Zstar)
6004 : : ! (q + G) . dielt . (q + G)
6005 [ + + + + : 1795073856 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
+ + ]
6006 : : ! Avoid (q + G) = 0
6007 [ + + ]: 112192116 : if (denom < tol_denom) cycle
6008 : 112191608 : denom_inv = one / denom
6009 : : ! HM hard cutoff, in this case qdamp takes the meaning of an energy cutoff in Hartree (hardcoded to 1 for the moment)
6010 : : !if (half*qG_mod**2 > 1) cycle
6011 [ + - ]: 112191608 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6012 : 112191608 : qGS = zero
6013 [ - + ]: 112191608 : if (db%has_quadrupoles) then
6014 [ # # ]: 0 : do ii=1,3
6015 [ # # ]: 0 : do jj=1,3
6016 : 0 : qGS = qGS + qG_red(ii) * qG_red(jj) * Sstar(ii,jj) / two
6017 : : end do
6018 : : end do
6019 : : end if
6020 : :
6021 : : ! Phase factor exp(-i (q+G) . tau)
6022 [ + + ]: 448766432 : qtau = - two_pi * dot_product(qG_red, tau_red)
6023 : 112191608 : phre = cos(qtau); phim = sin(qtau)
6024 : : !phre = one; phim = zero
6025 : :
6026 : 112191608 : re = +fac * qGS * denom_inv !re = zero
6027 : 112191608 : im = fac * qGZ * denom_inv
6028 : 112191608 : v1G_lr(1,ig) = phre * re - phim * im
6029 : 112213842 : v1G_lr(2,ig) = phim * re + phre * im
6030 : : end do
6031 : : end if
6032 : :
6033 : : ! FFT to get the long-range potential in r-space
6034 : 22234 : call fourdp(2, v1G_lr, v1r_lr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6035 : :
6036 [ - + ]: 22234 : if (db%has_efield) then
6037 : : ! Add term due to Electric field.
6038 : : ! TODO: Change API to account for ispden/isppol. return nspden LR part
6039 : : ! although only the electric field part depends on nsppden.
6040 : : !v1r_lr = zero ! Comment this line to have only efield contribution
6041 [ # # ]: 0 : ABI_CHECK(db%nspden == 1, "nspden != 1 not coded")
6042 : 0 : ispden = 1
6043 [ # # # # : 0 : ABI_CALLOC(v1G_lr33, (3, 3, 2, nfft))
# # # # #
# # # # #
# # # # #
# ]
6044 [ # # ]: 0 : do ig=1,nfft
6045 : : !if (ig > 1) cycle
6046 : : ! (q + G)
6047 [ # # ]: 0 : qG_red = qpt + gfft(:,ig)
6048 [ # # # # : 0 : qG_cart = two_pi * matmul(db%cryst%gprimd, qG_red)
# # ]
6049 [ # # ]: 0 : qG_mod = sqrt(sum(qG_cart ** 2))
6050 : : ! (q + G) . Zeff(:,idir,iatom)
6051 : : !qGZ = dot_product(qG_red, Zstar)
6052 : : ! (q + G) . dielt . (q + G)
6053 [ # # # # : 0 : denom = dot_product(qG_red, matmul(dielt_red, qG_red))
# # ]
6054 : : ! Avoid (q + G) = 0
6055 [ # # ]: 0 : if (denom < tol_denom) cycle
6056 : 0 : denom_inv = one / denom
6057 [ # # ]: 0 : if (db%qdamp > zero) denom_inv = denom_inv * exp(-qG_mod ** 2 / (four * db%qdamp))
6058 : 0 : fac = (four_pi / db%cryst%ucvol) * denom_inv !* qGZ
6059 : : ! Phase factor exp(-i (q+G) . tau)
6060 [ # # ]: 0 : qtau = - two_pi * dot_product(qG_red, tau_red)
6061 : 0 : phre = cos(qtau); phim = sin(qtau)
6062 : : !phre = one; phim = zero
6063 : :
6064 [ # # ]: 0 : do ii=1,3
6065 [ # # ]: 0 : do jj=1,3
6066 : 0 : v1G_lr33(ii, jj, 1, ig) = fac * phre * qG_red(ii) * qG_red(jj)
6067 : 0 : v1G_lr33(ii, jj, 2, ig) = fac * phim * qG_red(ii) * qG_red(jj)
6068 : : end do
6069 : : end do
6070 : : end do ! ig
6071 : :
6072 [ # # # # : 0 : ABI_MALLOC(workr, (2, nfft))
# # # # ]
6073 [ # # ]: 0 : do ii=1,3
6074 [ # # ]: 0 : do jj=1,3
6075 [ # # # # : 0 : v1G_lr = v1G_lr33(ii, jj, :, :)
# # ]
6076 : 0 : call fourdp(2, v1G_lr, workr, 1, db%mpi_enreg, nfft, 1, ngfft, 0)
6077 : : ! Two pi comes for qpt but we should check whether the gradient wrt E-field is in gprimd or 2pi gprimd coordinates.
6078 : : ! MG: Remove two_pi factor because jump discontinuity in the real part for G != 0 are overestimated.
6079 [ # # ]: 0 : do ifft=1,nfft
6080 : : !v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) * two_pi
6081 [ # # ]: 0 : v1r_lr(:, ifft) = v1r_lr(:, ifft) - Zstar(ii) * db%v1r_efield(ifft, jj, ispden) * workr(:, ifft) ! * two_pi
6082 : : end do
6083 : : end do
6084 : : end do
6085 : :
6086 [ # # ]: 0 : ABI_FREE(workr)
6087 [ # # ]: 0 : ABI_FREE(v1G_lr33)
6088 : : end if
6089 : :
6090 : : ! Multiply by exp(i q.r)
6091 [ + + ]: 22234 : if (iphase == 1) call times_eikr(qpt, ngfft, nfft, 1, v1r_lr)
6092 : :
6093 [ - + ]: 22234 : ABI_FREE(gfft)
6094 [ - + ]: 22234 : ABI_FREE(v1G_lr)
6095 : :
6096 : 22234 : end subroutine dvdb_get_v1r_long_range
6097 : : !!***
6098 : :
6099 : : !----------------------------------------------------------------------
6100 : :
6101 : : !!****f* m_dvdb/dvdb_load_ddb
6102 : : !! NAME
6103 : : !! dvdb_load_ddb
6104 : : !!
6105 : : !! FUNCTION
6106 : : !! Load information about the Born effective charges and dielectric tensor from a DDB file
6107 : : !!
6108 : : !! TODO
6109 : : !! Use this function in eph driver
6110 : :
6111 : 0 : subroutine dvdb_load_ddb(dvdb, chneut, prtvol, comm, ddb_filepath, ddb)
6112 : :
6113 : : !Arguments ------------------------------------
6114 : : !scalars
6115 : : class(dvdb_t),intent(inout) :: dvdb
6116 : : integer,intent(in) :: chneut, prtvol, comm
6117 : : character(len=*),optional,intent(in) :: ddb_filepath
6118 : : type(ddb_type),optional,target,intent(in) :: ddb
6119 : :
6120 : : !Local variables ------------------------------
6121 : : integer,parameter :: master = 0, rfmeth1 = 1, selectz0 = 0
6122 : : integer :: my_rank, iblock_dielt, iblock_dielt_zeff, iblock_quadrupoles
6123 : : logical :: free_ddb
6124 [ # # # # : 0 : type(crystal_t) :: cryst_ddb
# # # # #
# # # # #
# # # # #
# ]
6125 : : type(ddb_type),pointer :: ddb_ptr
6126 : 0 : type(ddb_type),target :: this_ddb
6127 [ # # # # : 0 : type(ddb_hdr_type) :: ddb_hdr
# # # # #
# # # # #
# # # # #
# ]
6128 : : !arrays
6129 : : real(dp) :: dielt(3,3)
6130 : 0 : real(dp),allocatable :: zeff(:,:,:), zeff_raw(:,:,:)
6131 : : ! *************************************************************************
6132 : :
6133 : 0 : my_rank = xmpi_comm_rank(comm)
6134 : :
6135 [ # # ]: 0 : if (present(ddb_filepath)) then
6136 : : ! Build ddb object from file. Will release memory before returning.
6137 [ # # ]: 0 : ABI_CHECK(.not. present(ddb), "ddb argument cannot be present when ddb_filepath is used")
6138 : 0 : call this_ddb%from_file(ddb_filepath, ddb_hdr, cryst_ddb, comm, prtvol=prtvol)
6139 : 0 : call this_ddb%set_brav(dvdb%brav)
6140 : 0 : call cryst_ddb%free()
6141 : 0 : ddb_ptr => this_ddb
6142 : 0 : free_ddb = .True.
6143 : : else
6144 : : ! Point input ddb, won't release memory.
6145 : : free_ddb = .False.
6146 : : ddb_ptr => ddb
6147 : : end if
6148 : :
6149 : : ! Get dielectric Tensor
6150 : 0 : iblock_dielt = ddb_ptr%get_dielt(rfmeth1, dielt)
6151 [ # # # # ]: 0 : dvdb%dielt = dielt
6152 : :
6153 : : ! Get Dielectric Tensor and Effective Charges
6154 : : ! (initialized to one_3D and zero if the derivatives are not available in the DDB file)
6155 [ # # # # : 0 : ABI_MALLOC(zeff, (3, 3, dvdb%natom))
# # # # #
# # # ]
6156 [ # # # # : 0 : ABI_MALLOC(zeff_raw, (3, 3, dvdb%natom))
# # # # ]
6157 : 0 : iblock_dielt_zeff = ddb_ptr%get_dielt_zeff(dvdb%cryst, rfmeth1, chneut, selectz0, dielt, zeff, zeff_raw=zeff_raw)
6158 : :
6159 [ # # ]: 0 : if (my_rank == master) then
6160 [ # # ]: 0 : if (iblock_dielt_zeff == 0) then
6161 : 0 : call wrtout(ab_out, sjoin("- Cannot find dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6162 : 0 : call wrtout(ab_out, "Values initialized with zeros")
6163 : : else
6164 : 0 : call wrtout(ab_out, sjoin("- Found dielectric tensor and Born effective charges in DDB file:", ddb_filepath))
6165 : : end if
6166 : : end if
6167 : :
6168 [ # # ]: 0 : if (iblock_dielt /= 0) then
6169 : 0 : dvdb%has_dielt = .True.
6170 [ # # # # ]: 0 : dvdb%dielt = dielt
6171 : : end if
6172 [ # # ]: 0 : if (iblock_dielt_zeff /= 0) then
6173 [ # # # # : 0 : dvdb%has_zeff = .True.; dvdb%zeff = zeff; dvdb%zeff_raw = zeff_raw
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6174 : : end if
6175 [ # # # # : 0 : if (dvdb%has_dielt .and. (dvdb%has_zeff .or. dvdb%has_quadrupoles)) then
# # ]
6176 [ # # ]: 0 : if (dvdb%add_lr == 0) then
6177 : : call wrtout([std_out, ab_out], &
6178 [ # # ]: 0 : " WARNING: dvdb_add_lr set to 0. Long-range term won't be subtracted in Fourier interpolation.")
6179 : : end if
6180 : : end if
6181 : :
6182 : : ! Read the quadrupoles
6183 : 0 : iblock_quadrupoles = ddb_ptr%get_quadrupoles(ddb_hdr%ddb_version,1,BLKTYP_d3E_xx,dvdb%qstar)
6184 [ # # ]: 0 : if (iblock_quadrupoles /=0) dvdb%has_quadrupoles = .True.
6185 : :
6186 [ # # ]: 0 : if (present(ddb_filepath)) call ddb_hdr%free()
6187 : :
6188 [ # # ]: 0 : ABI_FREE(zeff)
6189 [ # # ]: 0 : ABI_FREE(zeff_raw)
6190 [ # # ]: 0 : if (free_ddb) call ddb_ptr%free()
6191 : :
6192 [ # # # # : 0 : end subroutine dvdb_load_ddb
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6193 : : !!***
6194 : :
6195 : : !!****f* m_dvdb/dvdb_load_efield
6196 : : !! NAME
6197 : : !! dvdb_load_efield
6198 : : !!
6199 : : !! FUNCTION
6200 : : !! Load first order derivatives wrt the electric file from files
6201 : : !!
6202 : : !! INPUTS
6203 : : !! pot_paths=List of strings with paths to POT1 files.
6204 : : !! comm=MPI communicator.
6205 : :
6206 : 0 : subroutine dvdb_load_efield(dvdb, pot_paths, comm)
6207 : :
6208 : : !Arguments ------------------------------------
6209 : : !scalars
6210 : : class(dvdb_t),intent(inout) :: dvdb
6211 : : integer,intent(in) :: comm
6212 : : character(len=*),intent(in) :: pot_paths(3)
6213 : :
6214 : : !Local variables-------------------------------
6215 : : !scalars
6216 : : integer,parameter :: pawread0 = 0, cplex1 = 1
6217 : : integer :: ii, idir, ipert, nfft
6218 : 0 : type(hdr_type) :: hdr
6219 : : !arrays
6220 : 0 : real(dp),allocatable :: v1e_red(:,:,:)
6221 : 0 : type(pawrhoij_type),allocatable :: pawrhoij(:)
6222 : : ! *************************************************************************
6223 : :
6224 [ # # # # : 0 : ABI_CHECK(all(dvdb%ngfft /= -1), "dbvd%ngfft must be defined!")
# # ]
6225 : :
6226 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6227 [ # # # # : 0 : ABI_CALLOC(v1e_red, (nfft, dvdb%nspden, 3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
6228 : :
6229 [ # # ]: 0 : do ii=1,3
6230 : : ! Read DFPT potentials due to E-field.
6231 : : ! TODO: Should implement symmetries so that only the irred pots are needed.
6232 : 0 : call wrtout(std_out, sjoin("Loading Efield DFPT potential from:", pot_paths(ii)))
6233 : : call read_rhor(pot_paths(ii), cplex1, dvdb%nspden, nfft, dvdb%ngfft, pawread0, &
6234 : 0 : dvdb%mpi_enreg, v1e_red(:,:,ii), hdr, pawrhoij, comm, allow_interp=.True., want_varname="first_order_potential")
6235 : :
6236 : : ! Consistency check: expecting E-field perturbation.
6237 : 0 : idir = mod(hdr%pertcase - 1, 3) + 1; ipert = (hdr%pertcase - idir) / 3 + 1
6238 [ # # # # : 0 : ABI_CHECK(all(abs(hdr%qptn) < tol12), sjoin("Expecting Gamma point in E-field pert, got qpt:", ktoa(hdr%qptn)))
# # ]
6239 [ # # ]: 0 : ABI_CHECK(ipert == hdr%natom + 2, sjoin("Expecting E-field perturbation, got ipert:", itoa(ipert)))
6240 [ # # ]: 0 : ABI_CHECK(idir == ii, sjoin("Expecting E-field perturbation along idir:", itoa(ii), " got idir:", itoa(idir)))
6241 : 0 : call hdr%free()
6242 : : end do
6243 : :
6244 : : ! Transfer data.
6245 [ # # # # : 0 : ABI_MALLOC(dvdb%v1r_efield, (nfft, 3, dvdb%nspden))
# # # # #
# # # # #
# # # # ]
6246 [ # # ]: 0 : do ii=1,3
6247 [ # # # # ]: 0 : dvdb%v1r_efield(:,ii,:) = v1e_red(:,:,ii)
6248 : : end do
6249 [ # # ]: 0 : ABI_FREE(v1e_red)
6250 : :
6251 : 0 : dvdb%has_efield = .True.
6252 : :
6253 [ # # # # : 0 : end subroutine dvdb_load_efield
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
6254 : : !!***
6255 : :
6256 : : !----------------------------------------------------------------------
6257 : :
6258 : : !!****f* m_dvdb/dvdb_interpolate_and_write
6259 : : !! NAME
6260 : : !! dvdb_interpolate_and_write
6261 : : !!
6262 : : !! FUNCTION
6263 : : !! Interpolate the phonon potential onto a fine q-point grid
6264 : : !! and write the data in a new DVDB file.
6265 : : !!
6266 : : !! INPUTS
6267 : : !!
6268 : : !! OUTPUT
6269 : : !!
6270 : : !! SOURCE
6271 : :
6272 : 8 : subroutine dvdb_interpolate_and_write(dvdb, dtset, new_dvdb_fname, ngfft, ngfftf, cryst, &
6273 [ - + - - : 8 : ngqpt_coarse, nqshift_coarse, qshift_coarse, comm, custom_qpt)
- - ]
6274 : :
6275 : : !Arguments ------------------------------------
6276 : : !scalars
6277 : : integer,intent(in) :: nqshift_coarse, comm
6278 : : character(len=*),intent(in) :: new_dvdb_fname
6279 : : type(crystal_t),intent(in) :: cryst
6280 : : class(dvdb_t),intent(inout) :: dvdb
6281 : : type(dataset_type),intent(in) :: dtset
6282 : : !arrays
6283 : : integer,intent(in) :: ngfft(18), ngfftf(18)
6284 : : integer,intent(in) :: ngqpt_coarse(3)
6285 : : real(dp),intent(in) :: qshift_coarse(3,nqshift_coarse)
6286 : : real(dp),optional,intent(in) :: custom_qpt(:,:)
6287 : :
6288 : : !Local variables ------------------------------
6289 : : !scalars
6290 : : integer,parameter :: master=0, fform_pot=111
6291 : : integer :: my_rank,nproc,idir,ipert,iat,ipc,ispden, ierr
6292 : : integer :: cplex,db_iqpt,natom,natom3,npc,trev_q,nspden
6293 : : integer :: nqbz, nqibz, iq, ifft, nqbz_coarse
6294 : : integer :: nperts_read, nperts_interpolate, nperts
6295 : : integer :: nqpt_read, nqpt_interpolate, qptopt
6296 : : integer :: nfft,nfftf, dimv1, ount, unt, fform, ncid, ncerr
6297 : : logical :: use_netcdf
6298 : : real(dp) :: cpu, wall, gflops, cpu_all, wall_all, gflops_all
6299 : : character(len=500) :: msg
6300 : : character(len=fnlen) :: tmp_fname
6301 : 8 : type(hdr_type) :: hdr_ref
6302 : : !arrays
6303 : 16 : integer :: qptrlatt(3,3), rfdir(3), symq(4,2,cryst%nsym)
6304 : 8 : integer,allocatable :: pinfo(:,:),rfpert(:),pertsy(:,:,:),iq_read(:),this_pertsy(:,:)
6305 : : real(dp) :: qpt(3), rhog1_g0(2)
6306 : 8 : real(dp),allocatable :: v1scf(:,:,:), v1scf_rpt(:,:,:,:),v1(:)
6307 : 8 : real(dp),allocatable :: wtq(:),qibz(:,:),qbz(:,:),q_interp(:,:),q_read(:,:)
6308 : : !************************************************************************
6309 : :
6310 : 8 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6311 : :
6312 : 8 : write(msg, '(2a)') " Interpolation of the electron-phonon coupling potential", ch10
6313 : 8 : call wrtout(ab_out, msg, do_flush=.True.); call wrtout(std_out, msg, do_flush=.True.)
6314 : :
6315 : 8 : call cwtime(cpu_all, wall_all, gflops_all, "start")
6316 : :
6317 [ + + - + ]: 8 : if (dtset%eph_task == 5 .or. present(custom_qpt)) then
6318 [ + - ]: 7 : msg = sjoin(" From coarse q-mesh:", ltoa(ngqpt_coarse), "to:", ltoa(dtset%eph_ngqpt_fine))
6319 [ + + ]: 21 : call wrtout([std_out, ab_out], msg)
6320 : : ! Setup fine q-point grid in the IBZ
6321 : : ! Generate the list of irreducible q-points in the grid
6322 : 7 : qptrlatt = 0
6323 : 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)
6324 [ + + ]: 7 : qptopt = 1; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
6325 : 7 : call wrtout(std_out, sjoin(" Generating q-IBZ for DVDB with qptopt:", itoa(qptopt)))
6326 [ - + - + : 7 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
- + ]
6327 : :
6328 [ + - ]: 1 : else if (dtset%eph_task == -5) then
6329 [ + - ]: 1 : msg = sjoin(" Using list of q-points specified by ph_qpath with ", itoa(dtset%ph_nqpath), "qpoints")
6330 [ + + ]: 3 : call wrtout([std_out, ab_out], msg)
6331 [ - + ]: 1 : ABI_CHECK(dtset%ph_nqpath > 0, "ph_nqpath must be specified when eph_task == -5")
6332 : 1 : nqibz = dtset%ph_nqpath
6333 [ - + + - : 3 : ABI_MALLOC(qibz, (3, nqibz))
+ - + - -
+ - + -
+ ]
6334 [ + - - + : 22 : qibz = dtset%ph_qpath(:, 1:nqibz)
- - + + +
+ ]
6335 [ - + + - : 8 : ABI_CALLOC(wtq, (nqibz))
+ - + - -
+ - + - +
+ + ]
6336 : 1 : nqbz = nqibz
6337 [ - + + - : 2 : ABI_MALLOC(qbz, (3, nqbz))
- + - + -
+ ]
6338 [ + - + - : 22 : qbz = qibz
- + - - +
+ + + ]
6339 : :
6340 : : else
6341 : 0 : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
6342 : : end if
6343 : :
6344 [ - + ]: 8 : if (present(custom_qpt)) then
6345 [ # # ]: 0 : ABI_SFREE(qibz)
6346 [ # # ]: 0 : ABI_SFREE(wtq)
6347 [ # # ]: 0 : ABI_SFREE(qbz)
6348 : 0 : nqibz = size(custom_qpt,dim=2)
6349 [ # # # # : 0 : ABI_MALLOC(qibz, (3, nqibz))
# # # # #
# # # #
# ]
6350 [ # # # # : 0 : qibz = custom_qpt
# # # # #
# # # ]
6351 [ # # # # : 0 : ABI_CALLOC(wtq, (nqibz))
# # # # #
# # # # #
# # ]
6352 : 0 : nqbz = nqibz
6353 [ # # # # : 0 : ABI_MALLOC(qbz, (3, nqbz))
# # # # #
# ]
6354 [ # # # # : 0 : qbz = qibz
# # # # #
# # # ]
6355 : : end if
6356 : :
6357 [ + + ]: 32 : nfft = product(ngfft(1:3)); nfftf = product(ngfftf(1:3))
6358 : :
6359 : : ! check that ngqpt_coarse is in DVDB.
6360 [ + + ]: 32 : nqbz_coarse = product(ngqpt_coarse) * nqshift_coarse
6361 : :
6362 : : ! ==========================================
6363 : : ! Prepare the header to write the potentials
6364 : : ! ==========================================
6365 : :
6366 : : ! Read the first header
6367 [ + - ]: 8 : if (my_rank == master) then
6368 [ - + ]: 8 : if (open_file(dvdb%path, msg, newunit=unt, form="unformatted", status="old", action="read") /= 0) then
6369 : 0 : ABI_ERROR(msg)
6370 : : end if
6371 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%version
6372 [ + - ]: 8 : read(unt, err=10, iomsg=msg) dvdb%numv1
6373 : :
6374 : 8 : call hdr_ref%fort_read(unt, fform)
6375 [ - + ]: 8 : if (dvdb_check_fform(fform, "read_dvdb", msg) /= 0) then
6376 : 0 : ABI_ERROR(sjoin("While reading:", dvdb%path, ch10, msg))
6377 : : end if
6378 : 8 : close(unt)
6379 : : end if
6380 : :
6381 : : ! Reset the symmetries of the header
6382 : : ! One might have disable the symmetries in the response function calculation
6383 : : ! that produced the initial set of potentials present in the DVDB.
6384 : : ! This is because the symmetry features are not used in all parts
6385 : : ! of the response function driver.
6386 : : !write(std_out,*)hdr_ref%nsym, cryst%nsym
6387 : : !ABI_CHECK(hdr_ref%nsym == cryst%nsym, "Diff nsym")
6388 [ + - ]: 8 : ABI_SFREE(hdr_ref%symrel)
6389 [ + - ]: 8 : ABI_SFREE(hdr_ref%tnons)
6390 [ + - ]: 8 : ABI_SFREE(hdr_ref%symafm)
6391 : 8 : hdr_ref%nsym = cryst%nsym
6392 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symrel, (3,3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6393 [ - + + - : 24 : ABI_MALLOC(hdr_ref%tnons, (3,hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6394 [ - + + - : 24 : ABI_MALLOC(hdr_ref%symafm, (hdr_ref%nsym))
+ - + - -
+ - + -
+ ]
6395 : :
6396 [ + + + + : 5000 : hdr_ref%symrel(:,:,:) = cryst%symrel(:,:,:)
+ + ]
6397 [ + + + + ]: 1544 : hdr_ref%tnons(:,:) = cryst%tnons(:,:)
6398 [ + + ]: 392 : hdr_ref%symafm(:) = cryst%symafm(:)
6399 [ + + ]: 32 : hdr_ref%ngfft = ngfftf(1:3)
6400 : :
6401 : : ! =======================================
6402 : : ! Open DVDB and copy important dimensions
6403 : : ! =======================================
6404 : :
6405 : 8 : call dvdb%open_read(ngfftf, xmpi_comm_self)
6406 : :
6407 : : ! Besides perturbations with same q-points won't be contiguous on file --> IO is gonna be inefficient.
6408 [ + + ]: 16 : call dvdb%print([std_out], "", dtset%prtvol)
6409 : :
6410 : 8 : natom = cryst%natom
6411 : 8 : natom3 = 3 * natom
6412 : 8 : nspden = dvdb%nspden
6413 : :
6414 : : ! ==================================================
6415 : : ! Sort the q-points to read and those to interpolate
6416 : : ! and find the irreducible perturbations
6417 : : ! ==================================================
6418 [ - + + - : 24 : ABI_MALLOC(iq_read, (nqibz))
+ - + - -
+ - + ]
6419 [ - + + - : 24 : ABI_MALLOC(q_read, (3,nqibz))
+ - + - -
+ - + ]
6420 [ - + + - : 16 : ABI_MALLOC(q_interp, (3,nqibz))
- + - + ]
6421 [ - + + - : 32 : ABI_MALLOC(pertsy, (nqibz,3,dvdb%mpert))
- + + - +
- + - - +
- + ]
6422 [ - + + - : 24 : ABI_MALLOC(this_pertsy, (3,dvdb%mpert))
+ - + - -
+ - + ]
6423 [ - + + - : 24 : ABI_MALLOC(rfpert, (dvdb%mpert))
+ - + - -
+ - + ]
6424 [ + - - + : 24 : ABI_MALLOC(pinfo, (3,3*dvdb%mpert))
+ - + - +
- - + -
+ ]
6425 [ + + + + : 110 : rfpert = 0; rfpert(1:cryst%natom) = 1; rfdir = 1
+ + ]
6426 : :
6427 [ + + + + : 2645 : pertsy = 0
+ + ]
6428 : 8 : nqpt_read = 0
6429 : 8 : nperts_read = 0
6430 : 8 : nqpt_interpolate = 0
6431 : 8 : nperts_interpolate = 0
6432 : :
6433 [ + + ]: 111 : do iq=1,nqibz
6434 [ + + ]: 412 : qpt = qibz(:,iq)
6435 : :
6436 : : ! Find the index of the q-point in the DVDB.
6437 : 103 : db_iqpt = dvdb%findq(qpt)
6438 : : !if (db_iqpt /= 1) db_iqpt = -1
6439 : :
6440 [ + + ]: 111 : if (db_iqpt /= -1) then
6441 [ + + ]: 29 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt)," found in DVDB with index ",itoa(db_iqpt)))
6442 : 29 : nqpt_read = nqpt_read + 1
6443 [ + + ]: 116 : q_read(:,nqpt_read) = qpt(:)
6444 : 29 : iq_read(nqpt_read) = db_iqpt
6445 : :
6446 : : ! Count the perturbations
6447 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6448 [ + + ]: 85 : do ipc=1,npc
6449 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6450 [ + - ]: 85 : if (iat .le. natom) nperts_read = nperts_read + 1
6451 : : end do
6452 : :
6453 : : else
6454 [ + + ]: 74 : if (dvdb%prtvol > 0) call wrtout(std_out, sjoin("Q-point: ",ktoa(qpt), "not found in DVDB. Will interpolate."))
6455 : 74 : nqpt_interpolate = nqpt_interpolate + 1
6456 [ + + ]: 296 : q_interp(:,nqpt_interpolate) = qpt(:)
6457 : :
6458 : : ! Examine the symmetries of the q wavevector
6459 : 74 : call littlegroup_q(cryst%nsym,qpt,symq,cryst%symrec,cryst%symafm,trev_q,prtvol=0)
6460 : :
6461 : : ! Find the list of irreducible perturbations for this q-point.
6462 : : call irreducible_set_pert(cryst%indsym,dvdb%mpert,cryst%natom,cryst%nsym,&
6463 : 74 : this_pertsy,rfdir,rfpert,symq,cryst%symrec,cryst%symrel)
6464 [ + + + + ]: 2358 : pertsy(nqpt_interpolate,:,:) = this_pertsy
6465 : : !pertsy = 1
6466 : :
6467 [ + + ]: 201 : do iat=1,natom
6468 [ + + ]: 582 : do idir=1,3
6469 : 381 : ipert = (iat-1) * 3 + idir
6470 [ + + ]: 508 : if (pertsy(nqpt_interpolate,idir,iat) == 1) nperts_interpolate = nperts_interpolate + 1
6471 : : end do
6472 : : end do
6473 : :
6474 : : end if
6475 : : end do
6476 : :
6477 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points found in input DVDB:", itoa(nqpt_read)))
6478 [ + + ]: 24 : call wrtout([std_out, ab_out], sjoin(" Number of q-points requiring Fourier interpolation", itoa(nqpt_interpolate)))
6479 : :
6480 : : ! =================================================
6481 : : ! Open the new DVDB file and write preliminary info
6482 : : ! =================================================
6483 : 8 : nperts = nperts_read + nperts_interpolate
6484 : :
6485 [ + - ]: 8 : if (my_rank == master) then
6486 [ - + ]: 8 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6487 : 0 : ABI_ERROR(msg)
6488 : : end if
6489 [ + - ]: 8 : write(ount, err=10, iomsg=msg) dvdb_last_version
6490 [ + - ]: 8 : write(ount, err=10, iomsg=msg) nperts
6491 : : end if
6492 : :
6493 : : ! =================================================================
6494 : : ! Master reads all available perturbations and copy in the new DVDB
6495 : : ! =================================================================
6496 : :
6497 : 0 : rhog1_g0 = zero
6498 : :
6499 : : if (my_rank == master) then
6500 [ + + ]: 37 : do iq=1,nqpt_read
6501 [ + + ]: 116 : qpt = q_read(:,iq)
6502 : 29 : db_iqpt = iq_read(iq)
6503 : :
6504 : : ! Read each irreducible perturbation potentials
6505 : 29 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6506 [ - + ]: 29 : ABI_CHECK(npc /= 0, "npc == 0!")
6507 : :
6508 : : ! These arrays depend on cplex.
6509 [ - + + - : 145 : ABI_MALLOC(v1scf, (cplex, nfftf, nspden))
- + + - -
+ + - + -
+ - - + -
+ - + ]
6510 [ - + + - : 87 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6511 : :
6512 [ + + ]: 85 : do ipc=1,npc
6513 : 56 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6514 [ - + ]: 56 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfftf, ngfftf, v1scf, msg) /= 0) then
6515 : 0 : ABI_ERROR(msg)
6516 : : end if
6517 : :
6518 : : ! Write header
6519 [ + + ]: 224 : hdr_ref%qptn = qpt
6520 : 56 : hdr_ref%pertcase = ipert
6521 : 56 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6522 [ - + ]: 56 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6523 : :
6524 [ + + ]: 112 : do ispden=1,nspden
6525 [ + + ]: 112 : v1 = reshape(v1scf(:,:,ispden), (/cplex*nfftf/))
6526 [ + - ]: 112 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6527 : : end do
6528 [ + - ]: 85 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6529 : : end do
6530 : :
6531 [ - + ]: 29 : ABI_FREE(v1scf)
6532 [ - + ]: 37 : ABI_FREE(v1)
6533 : : end do
6534 : : end if ! master
6535 : :
6536 : 8 : call xmpi_barrier(comm)
6537 : :
6538 : : ! ================================================================
6539 : : ! Interpolate the potential for q-points not in the original DVDB
6540 : : ! ================================================================
6541 : :
6542 : 8 : dvdb%my_nrpt = nqbz_coarse
6543 [ - + + - : 40 : ABI_MALLOC_OR_DIE(v1scf_rpt, (2, dvdb%my_nrpt, nfftf, dvdb%nspden), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
6544 : :
6545 : 8 : cplex = 2
6546 [ - + + - : 32 : ABI_MALLOC(v1scf, (cplex,nfftf,nspden))
- + + - +
- + - - +
- + - + ]
6547 [ - + + - : 24 : ABI_MALLOC(v1, (cplex*nfftf))
+ - + - -
+ - + ]
6548 : :
6549 : : use_netcdf = .False.
6550 : : ! Create temporary netcdf file used to write Fortran file with contiguous perturbations.
6551 : 8 : use_netcdf = .True.
6552 [ + - ]: 8 : if (my_rank == master) then
6553 [ + - ]: 8 : tmp_fname = strcat(new_dvdb_fname, "_TEMPORARY_TRANSFER_FILE.nc")
6554 : 8 : dimv1 = cplex * nfftf
6555 [ - + ]: 8 : NCF_CHECK(nctk_open_create(ncid, tmp_fname, xmpi_comm_self))
6556 : : ncerr = nctk_def_dims(ncid, [&
6557 : : nctkdim_t("dimv1", dimv1), nctkdim_t("nspden", nspden), &
6558 : : nctkdim_t("natom", natom), nctkdim_t("nqpt_intp", nqpt_interpolate), &
6559 : : nctkdim_t("nrpt", dvdb%my_nrpt), nctkdim_t("nfft", nfftf), nctkdim_t("natom3", natom * 3) &
6560 [ + + ]: 64 : ])
6561 [ - + ]: 8 : NCF_CHECK(ncerr)
6562 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1", "dp", "dimv1, nspden, three, natom, nqpt_intp")))
6563 : : !NCF_CHECK(nctk_def_arrays(ncid, nctkarr_t("v1scf_rpt", "dp", "two, nrpt, nfft, nspden, natom3")))
6564 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(ncid))
6565 : : end if
6566 : :
6567 [ + + ]: 23 : do iat=1,natom
6568 [ + + ]: 68 : do idir=1,3
6569 : 45 : ipert = (iat-1) * 3 + idir
6570 : :
6571 : : ! Entry set to -1 for perturbations that can be found from basis perturbations.
6572 [ + + + + ]: 576 : if (sum(pertsy(:,idir,iat)) == -nqpt_interpolate) cycle
6573 : :
6574 : 31 : call wrtout(std_out, sjoin(" Interpolating perturbation iat, idir = ",itoa(iat), itoa(idir)), do_flush=.True.)
6575 : 31 : call cwtime(cpu, wall, gflops, "start")
6576 : :
6577 : : ! TODO: This part is slow.
6578 : : ! Compute phonon potential in real space lattice representation.
6579 : : call dvdb_get_v1scf_rpt(dvdb, cryst, ngqpt_coarse, nqshift_coarse, &
6580 : : qshift_coarse, nfftf, ngfftf, &
6581 : 31 : dvdb%my_nrpt, dvdb%nspden, ipert, v1scf_rpt, comm)
6582 : :
6583 : : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "v1scf_rpt"), v1scf_rpt, start=[1,1,1,1,ipert]))
6584 : 31 : call cwtime_report(" v1scf_rpt built", cpu, wall, gflops)
6585 : :
6586 [ + + ]: 348 : do iq=1,nqpt_interpolate
6587 [ + + ]: 317 : if (pertsy(iq,idir,iat) == -1) cycle
6588 [ + + ]: 976 : qpt = q_interp(:,iq)
6589 : :
6590 : : ! Interpolate the phonon potential
6591 : : call dvdb_get_v1scf_qpt(dvdb, cryst, qpt, nfftf, ngfftf, dvdb%my_nrpt, &
6592 : 244 : dvdb%nspden, ipert, v1scf_rpt, v1scf, comm)
6593 : :
6594 : : !call wrtout(std_out, sjoin("Writing q-point", itoa(iq)))
6595 [ + - ]: 275 : if (my_rank == master) then
6596 : : if (use_netcdf) then
6597 : : ncerr = nf90_put_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6598 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6599 [ - + ]: 244 : NCF_CHECK(ncerr)
6600 : : else
6601 : : ! Master writes the file (change also qpt and ipert in hdr%)
6602 : : hdr_ref%qptn = qpt
6603 : : hdr_ref%pertcase = ipert
6604 : : call hdr_ref%fort_write(ount, fform_pot, ierr)
6605 : : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6606 : :
6607 : : do ispden=1,nspden
6608 : : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6609 : : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6610 : : end do
6611 : : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6612 : : end if
6613 : : end if
6614 : : end do
6615 : :
6616 : 31 : call cwtime_report(" q-points interpolated and written to new DVDB file.", cpu, wall, gflops)
6617 [ - + ]: 122 : ABI_FREE(dvdb%my_rpt)
6618 : : end do
6619 : : end do
6620 : :
6621 [ + - ]: 8 : if (use_netcdf .and. my_rank == master) then
6622 [ + + ]: 82 : do iq=1,nqpt_interpolate
6623 [ + + ]: 296 : qpt = q_interp(:,iq)
6624 [ + + ]: 209 : do iat=1,natom
6625 [ + + ]: 582 : do idir=1,3
6626 [ + + ]: 381 : if (pertsy(iq,idir,iat) == -1) cycle
6627 : 244 : ipert = (iat-1) * 3 + idir
6628 [ + + ]: 976 : hdr_ref%qptn = qpt
6629 : 244 : hdr_ref%pertcase = ipert
6630 : 244 : call hdr_ref%fort_write(ount, fform_pot, ierr)
6631 : : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "v1"), v1scf, &
6632 [ + + + + ]: 2684 : start=[1,1,idir,iat,iq], count=[dimv1,nspden,1,1,1])
6633 [ - + ]: 244 : NCF_CHECK(ncerr)
6634 [ + + ]: 488 : do ispden=1,nspden
6635 [ + + ]: 488 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfftf])
6636 [ + - ]: 488 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfftf)
6637 : : end do
6638 [ + - ]: 371 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6639 : : end do
6640 : : end do
6641 : : end do
6642 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
6643 : 8 : call delete_file(tmp_fname, ierr)
6644 : : end if
6645 : :
6646 : 8 : if (my_rank == master) close(ount)
6647 : :
6648 : : ! Free memory
6649 [ - + ]: 8 : ABI_FREE(v1scf)
6650 [ - + ]: 8 : ABI_FREE(v1)
6651 [ - + ]: 8 : ABI_FREE(v1scf_rpt)
6652 [ - + ]: 8 : ABI_FREE(qbz)
6653 [ - + ]: 8 : ABI_FREE(qibz)
6654 [ - + ]: 8 : ABI_FREE(q_interp)
6655 [ - + ]: 8 : ABI_FREE(q_read)
6656 [ - + ]: 8 : ABI_FREE(wtq)
6657 [ - + ]: 8 : ABI_FREE(iq_read)
6658 [ - + ]: 8 : ABI_FREE(pertsy)
6659 [ - + ]: 8 : ABI_FREE(this_pertsy)
6660 [ - + ]: 8 : ABI_FREE(rfpert)
6661 [ - + ]: 8 : ABI_FREE(pinfo)
6662 : :
6663 : 8 : call hdr_ref%free()
6664 : :
6665 : 8 : write(msg, '(2a)') "Interpolation of the electron-phonon coupling potential completed", ch10
6666 [ + + ]: 24 : call wrtout([std_out, ab_out], msg, do_flush=.True.)
6667 : :
6668 : 8 : call cwtime_report(" Overall time:", cpu_all, wall_all, gflops_all)
6669 : :
6670 : 8 : return
6671 : :
6672 : : ! Handle Fortran IO error
6673 : : 10 continue
6674 : 0 : ABI_ERROR(msg)
6675 : :
6676 [ - + - + : 24 : end subroutine dvdb_interpolate_and_write
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - ]
6677 : : !!***
6678 : :
6679 : : !----------------------------------------------------------------------
6680 : :
6681 : : !!****f* m_dvdb/dvdb_qdownsample
6682 : : !! NAME
6683 : : !! dvdb_qdownsample
6684 : : !!
6685 : : !! FUNCTION
6686 : : !! Downsample the q-mesh. Produce new DVDB file
6687 : : !!
6688 : : !! INPUTS
6689 : : !! new_dvdb_fname=Path of output DVDB
6690 : : !! qptopt=option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
6691 : : !! ngqpt(3)=Division of coarse Q-mesh
6692 : : !! comm=MPI communicator.
6693 : : !!
6694 : : !! OUTPUT
6695 : : !! Only writing
6696 : : !!
6697 : : !! SOURCE
6698 : :
6699 : 0 : subroutine dvdb_qdownsample(dvdb, new_dvdb_fname, qptopt, ngqpt, comm)
6700 : :
6701 : : !Arguments ------------------------------------
6702 : : !scalars
6703 : : integer,intent(in) :: comm
6704 : : class(dvdb_t),intent(inout) :: dvdb
6705 : : character(len=*),intent(in) :: new_dvdb_fname
6706 : : !arrays
6707 : : integer,intent(in) :: qptopt, ngqpt(3)
6708 : :
6709 : : !Local variables ------------------------------
6710 : : !scalars
6711 : : integer,parameter :: master=0, fform_pot=111
6712 : : integer :: ierr,my_rank,nproc,idir,ipert,iat,ipc,ispden
6713 : : integer :: cplex, db_iqpt, npc, nqbz, nqibz, iq, ifft, nperts_read, nfft, ount
6714 : : character(len=500) :: msg
6715 : : !arrays
6716 : : integer :: qptrlatt(3,3)
6717 : 0 : integer,allocatable :: iq_read(:), pinfo(:,:)
6718 : : real(dp) :: rhog1_g0(2)
6719 : 0 : real(dp),allocatable :: v1scf(:,:,:), v1(:), wtq(:), qibz(:,:), qbz(:,:)
6720 : : !************************************************************************
6721 : :
6722 : 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6723 [ # # ]: 0 : if (my_rank /= master) goto 20
6724 : :
6725 [ # # ]: 0 : nfft = product(dvdb%ngfft(1:3))
6726 : :
6727 : : ! =======================
6728 : : ! Setup fine q-point grid
6729 : : ! =======================
6730 : : ! Generate the list of irreducible q-points in the coarse grid
6731 : 0 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
6732 : 0 : call kpts_ibz_from_kptrlatt(dvdb%cryst, qptrlatt, qptopt, 1, [zero, zero, zero], nqibz, qibz, wtq, nqbz, qbz)
6733 : :
6734 : : ! =======================================
6735 : : ! Open DVDB and copy important dimensions
6736 : : ! =======================================
6737 : :
6738 [ # # # # : 0 : ABI_MALLOC(iq_read, (nqibz))
# # # # #
# # # ]
6739 [ # # # # : 0 : ABI_MALLOC(pinfo, (3, 3*dvdb%mpert))
# # # # #
# # # #
# ]
6740 : 0 : nperts_read = 0
6741 : :
6742 [ # # ]: 0 : do iq=1,nqibz
6743 : : ! Find the index of the q-point in the DVDB.
6744 : 0 : db_iqpt = dvdb%findq(qibz(:, iq))
6745 [ # # ]: 0 : ABI_CHECK(db_iqpt /= -1, sjoin("Q-point:", ktoa(qibz(:, iq)), "not found in DVDB!"))
6746 : 0 : iq_read(iq) = db_iqpt
6747 : :
6748 : : ! Count the number of perturbations.
6749 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6750 [ # # ]: 0 : do ipc=1,npc
6751 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6752 [ # # ]: 0 : if (iat <= dvdb%cryst%natom) nperts_read = nperts_read + 1
6753 : : end do
6754 : : end do
6755 : :
6756 : : ! =================================================
6757 : : ! Open the new DVDB file and write preliminary info
6758 : : ! =================================================
6759 : : !nperts = nperts_read + nperts_interpolate
6760 [ # # ]: 0 : if (open_file(new_dvdb_fname, msg, newunit=ount, form="unformatted", action="write", status="unknown") /= 0) then
6761 : 0 : ABI_ERROR(msg)
6762 : : end if
6763 [ # # ]: 0 : write(ount, err=10, iomsg=msg) dvdb_last_version
6764 [ # # ]: 0 : write(ount, err=10, iomsg=msg) nperts_read
6765 : :
6766 : : ! Read all perturbations on the coarse Q-mesh and write them to the new DVDB
6767 : 0 : rhog1_g0 = zero
6768 : :
6769 [ # # ]: 0 : do iq=1,nqibz
6770 : 0 : db_iqpt = iq_read(iq)
6771 : :
6772 : : ! Read each irreducible perturbation potentials
6773 : 0 : npc = dvdb_get_pinfo(dvdb, db_iqpt, cplex, pinfo)
6774 [ # # ]: 0 : ABI_CHECK(npc /= 0, "npc == 0!")
6775 : :
6776 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex, nfft, dvdb%nspden))
# # # # #
# # # # #
# # # # #
# ]
6777 [ # # # # : 0 : ABI_MALLOC(v1, (cplex*nfft))
# # # # #
# # # ]
6778 : :
6779 [ # # ]: 0 : do ipc=1,npc
6780 : 0 : idir = pinfo(1,ipc); iat = pinfo(2,ipc); ipert = pinfo(3, ipc)
6781 [ # # ]: 0 : if (dvdb%read_onev1(idir, iat, db_iqpt, cplex, nfft, dvdb%ngfft, v1scf, msg) /= 0) then
6782 : 0 : ABI_ERROR(msg)
6783 : : end if
6784 : :
6785 : : ! Change the header.
6786 [ # # ]: 0 : dvdb%hdr_ref%qptn = qibz(:, iq)
6787 : 0 : dvdb%hdr_ref%pertcase = ipert
6788 : :
6789 : : ! Write header
6790 : 0 : call dvdb%hdr_ref%fort_write(ount, fform_pot, ierr)
6791 [ # # ]: 0 : ABI_CHECK(ierr == 0, "hdr_fort_write returned ierr = 0")
6792 : :
6793 [ # # ]: 0 : do ispden=1,dvdb%nspden
6794 [ # # ]: 0 : v1 = reshape(v1scf(:,:,ispden), [cplex*nfft])
6795 [ # # ]: 0 : write(ount, err=10, iomsg=msg) (v1(ifft), ifft=1,cplex*nfft)
6796 : : end do
6797 [ # # ]: 0 : if (dvdb_last_version > 1) write(ount, err=10, iomsg=msg) rhog1_g0
6798 : : end do
6799 : :
6800 [ # # ]: 0 : ABI_FREE(v1scf)
6801 [ # # ]: 0 : ABI_FREE(v1)
6802 : : end do
6803 : :
6804 : 0 : close(ount)
6805 : :
6806 : : ! Free memory
6807 [ # # ]: 0 : ABI_FREE(qbz)
6808 [ # # ]: 0 : ABI_FREE(qibz)
6809 [ # # ]: 0 : ABI_FREE(wtq)
6810 [ # # ]: 0 : ABI_FREE(iq_read)
6811 [ # # ]: 0 : ABI_FREE(pinfo)
6812 : :
6813 : 0 : write(msg, '(2a)') " Downsampling of the e-ph coupling potential completed", ch10
6814 : 0 : call wrtout(std_out, msg, do_flush=.True.)
6815 : :
6816 : : 20 continue
6817 : 0 : call xmpi_barrier(comm)
6818 : :
6819 : 0 : return
6820 : :
6821 : : ! Handle Fortran IO error
6822 : : 10 continue
6823 : 0 : ABI_ERROR(msg)
6824 : :
6825 [ # # # # : 0 : end subroutine dvdb_qdownsample
# # # # #
# # # #
# ]
6826 : : !!***
6827 : :
6828 [ - + - - : 38966 : end module m_dvdb
+ + - + +
- - + - +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6829 : : !!***
|
