Branch data Line data Source code
1 : : !!****m*ABINIT/m_lwf
2 : : !! NAME
3 : : !! m_lwf
4 : : !!
5 : : !! FUNCTION
6 : : !! Module for the lattice Wannier function
7 : : !! Container type is defined, and destruction, print subroutines
8 : : !! as well as the central mkphdos
9 : : !!
10 : : !! COPYRIGHT
11 : : !! Copyright (C) 1999-2026 ABINIT group (HeXu)
12 : : !! This file is distributed under the terms of the
13 : : !! GNU General Public Licence, see ~abinit/COPYING
14 : : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
16 : : !!
17 : : !! SOURCE
18 : :
19 : :
20 : : !! Todolist:
21 : : !! - LWF output filename change
22 : : !! - LWF specific outputs: lwf_masses, original crystal structure
23 : : !! - Units of Hamiltonian need to be changed to eV-Angstrom units
24 : : !! - dipole-dipole
25 : : !! - MPI
26 : : !! - exclude_bands
27 : :
28 : : #if defined HAVE_CONFIG_H
29 : : #include "config.h"
30 : : #endif
31 : :
32 : : #include "abi_common.h"
33 : :
34 : : module m_lwf
35 : :
36 : : use, intrinsic :: iso_c_binding
37 : : use defs_basis
38 : : use m_errors
39 : : use m_xmpi
40 : : use m_abicore
41 : : use m_htetra
42 : : use m_numeric_tools
43 : : use m_cgtools
44 : : use m_crystal
45 : : use m_nctk
46 : : use m_atprj
47 : : use m_sortph
48 : : use m_ddb
49 : : use netcdf
50 : : use m_supercell
51 : : use m_dtset
52 : : use m_krank
53 : :
54 : : use m_fstrings, only : ltoa
55 : : use m_io_tools, only : open_file
56 : : use m_geometry, only : mkrdim, symredcart, phdispl_cart2red
57 : : use m_dynmat, only : gtdyn9, dfpt_phfrq, dfpt_prtph, pheigvec_normalize, massmult_and_breaksym, phdispl_from_eigvec, &
58 : : ifc_atom_phase
59 : : use m_bz_mesh, only : make_path
60 : : use m_ifc, only : ifc_type
61 : : use m_anaddb_dataset, only : anaddb_dataset_type
62 : : use m_kpts, only : kpts_ibz_from_kptrlatt
63 : : use m_scdm_math, only : build_Rgrid
64 : : use m_wannier_builder, only : WannierBuilder_witheigen_t
65 : : use m_wann_netcdf, only : IOWannNC
66 : :
67 : :
68 : : implicit none
69 : :
70 : : type LatticeWannier
71 : : type(WannierBuilder_witheigen_t):: scdm
72 : : type(ifc_type), pointer:: ifc
73 : : type(crystal_t), pointer:: crystal
74 : : integer:: qptrlatt(3, 3)
75 : : real(dp):: shiftq(3)
76 : : integer:: nqibz
77 : : real(dp), allocatable:: qibz(:, :), qweights(:)
78 : : integer:: nR, natom
79 : : integer, allocatable:: Rlist(:, :)
80 : : real(dp), allocatable:: eigenvalues(:, :) ! iband, iqpt
81 : : complex(dp), allocatable:: eigenvectors(:,:, :) ! ibasis, iband, iqpt
82 : : integer:: comm, nprocs, my_rank
83 : : contains
84 : : procedure:: initialize
85 : : procedure:: finalize
86 : : procedure:: init_mpi
87 : : procedure:: sanity_check
88 : : procedure:: prepare_qpoints
89 : : procedure:: prepare_Rlist
90 : : procedure:: get_ifc_eigens
91 : : procedure:: run_all
92 : : procedure:: write_lwf_nc
93 : : procedure:: print_Rlist
94 : : procedure :: write_bands
95 : : end type LatticeWannier
96 : :
97 : : private
98 : :
99 : : public:: run_lattice_wannier
100 : :
101 : : contains
102 : 3 : subroutine initialize(self, ifc, crystal, dtset, comm)
103 : : class(LatticeWannier), intent(inout):: self
104 : : integer, intent(in):: comm
105 : : type(ifc_type), target, intent(in):: ifc
106 : : type(crystal_t), target, intent(in):: crystal
107 : : type(anaddb_dataset_type), intent(in):: dtset
108 : 6 : real(dp):: symcart(3, 3, crystal%nsym)
109 : : integer:: isym
110 : : ! TODO: add exclude_bands
111 : : integer:: exclude_bands(0)
112 : :
113 : 3 : character(len = 500+dtset%lwf_nwann*10):: msg
114 : : real(dp):: mu, sigma
115 : :
116 : 3 : self%ifc => ifc
117 : 3 : self%crystal => crystal
118 : :
119 : : ! mpi vars
120 : 3 : call self%init_mpi(comm)
121 : :
122 : : ! sanity check
123 : 3 : call self%sanity_check(dtset)
124 : :
125 [ + + ]: 147 : do isym = 1, crystal%nsym
126 : 147 : call symredcart(crystal%rprimd, crystal%gprimd, symcart(:,:,isym), crystal%symrel(:,:,isym))
127 : : end do
128 : :
129 : : ! prepare qpoints
130 : 3 : call self%prepare_qpoints(crystal, dtset)
131 : 3 : call self%prepare_Rlist()
132 : : ! prepare eigen values and eigen vectors
133 : :
134 : 3 : call self%get_ifc_eigens(ifc, crystal)
135 : :
136 : : ! set mu and sigma from cm^-1 to eigenvalue
137 [ + - ]: 3 : if(dtset%lwfflag == 1 .or. dtset%lwfflag == 2) then
138 : 6 : mu = freq_to_eigenval(dtset%lwf_mu/Ha_cmm1)
139 : 3 : sigma = freq_to_eigenval(dtset%lwf_sigma/Ha_cmm1)
140 : : end if
141 : :
142 : : ! set up scdm
143 : :
144 : : call self%scdm%initialize( &
145 : : & kpts = self%qibz, kweights = self%qweights, Rlist = self%Rlist, &
146 : : & nwann = dtset%lwf_nwann, nbasis=self%natom*3, nband=self%natom*3, disentangle_func_type = dtset%lwf_disentangle, &
147 : : & mu = mu, sigma = sigma, exclude_bands = exclude_bands, &
148 : 3 : & project_to_anchor = (dtset%lwf_anchor_proj > 0 ), method = dtset%lwfflag)
149 : 3 : call self%scdm%set_eigen(evals = self%eigenvalues, psi = self%eigenvectors)
150 : :
151 [ + + ]: 3 : if(dtset%lwfflag == 1) then
152 : 2 : write(msg, '(a)') ' Constructing LWF with SCDM-k method.'
153 [ + + ]: 6 : call wrtout([ab_out, std_out], msg )
154 : 2 : write(msg, '(a, i0)') ' Number of LWF: ', dtset%lwf_nwann
155 [ + + ]: 6 : call wrtout([ab_out, std_out], msg )
156 : 2 : write(msg, '(a, 3f8.5)') ' Anchor Points q-point: ', &
157 : 4 : & dtset%lwf_anchor_qpt(1), dtset%lwf_anchor_qpt(2), dtset%lwf_anchor_qpt(3)
158 : : !write(msg, '(2a) ') 'Anchor points band indices: ', trim(ltoa(self%scdm%anchor_ibands))
159 [ + + ]: 6 : call wrtout([ab_out, std_out], msg )
160 : :
161 [ + - ]: 2 : if(dtset%lwf_anchor_iband(1) > 0) then
162 : 2 : call self%scdm%set_anchor( dtset%lwf_anchor_qpt, dtset%lwf_anchor_iband)
163 : : else
164 : 0 : call self%scdm%set_anchor(anchor_kpt = dtset%lwf_anchor_qpt)
165 : : end if
166 : : ! output information
167 [ + - ]: 1 : else if(dtset%lwfflag == 2) then
168 : : ! TODO: projected lattice wannier function
169 : 1 : write(msg, '(a)') ' Constructing LWF with projected wannier function method.'
170 [ + + ]: 3 : call wrtout([ab_out, std_out], msg )
171 : 1 : call self%scdm%set_disp_projector(dtset%lwf_projector)
172 [ + - ]: 1 : write(msg, '(2a)') ' The projectors: ', trim(ltoa(dtset%lwf_projector))
173 [ + + ]: 3 : call wrtout([ab_out, std_out], msg )
174 : : end if
175 : :
176 : 3 : end subroutine initialize
177 : :
178 : 3 : subroutine finalize(self)
179 : : class(LatticeWannier), intent(inout):: self
180 : 3 : call self%scdm%finalize()
181 [ + - ]: 3 : ABI_SFREE(self%qibz)
182 [ + - ]: 3 : ABI_SFREE(self%qweights)
183 [ + - ]: 3 : ABI_SFREE(self%eigenvalues)
184 [ + - ]: 3 : ABI_SFREE(self%eigenvectors)
185 [ + - ]: 3 : ABI_SFREE(self%Rlist)
186 : 3 : end subroutine finalize
187 : :
188 : 3 : subroutine init_mpi(self, comm)
189 : : class(LatticeWannier), intent(inout):: self
190 : : integer, intent(in):: comm
191 : 3 : self%comm = comm
192 : 3 : self%nprocs = xmpi_comm_size(comm)
193 : 3 : self%my_rank = xmpi_comm_rank(comm)
194 : 3 : end subroutine init_mpi
195 : :
196 : 3 : subroutine sanity_check(self, dtset)
197 : : class(LatticeWannier), intent(inout):: self
198 : : type(anaddb_dataset_type), intent(in):: dtset
199 [ - + ]: 3 : if(self%nprocs /= 1) then
200 : 0 : ABI_ERROR(" MPI is not yet implemented for Lattice Wannier function.")
201 : : end if
202 : :
203 [ - + ]: 3 : if(dtset%dipdip > 0) then
204 : 0 : ABI_ERROR(" dipdip is not yet implemented for Lattice Wannier function.")
205 : : end if
206 : 3 : end subroutine sanity_check
207 : :
208 : :
209 : 3 : subroutine prepare_qpoints(self, crystal, dtset)
210 : : class(LatticeWannier), intent(inout):: self
211 : : type(crystal_t), intent(in):: crystal
212 : : type(anaddb_dataset_type), intent(in):: dtset
213 : : integer:: nqshft = 1
214 : : real(dp):: lwf_qshift(3, 1)
215 : : integer:: nqbz
216 : 3 : real(dp), allocatable:: qbz(:, :)
217 : : integer:: in_qptrlatt(3, 3), new_qptrlatt(3, 3)
218 : 3 : integer, allocatable:: bz2ibz_smap(:,:)!, bz2ibz(:)
219 : 3 : real(dp), allocatable:: new_shiftq(:,:)
220 : : integer, parameter:: bcorr0 = 0, master = 0
221 : : integer:: my_qptopt
222 : : character(len = 500):: msg
223 : : integer:: iqpt, nkpout
224 : : ! Copied from m_phonons/mkphdos
225 : 3 : in_qptrlatt = 0
226 : 3 : in_qptrlatt(1, 1) = dtset%lwf_ngqpt(1)
227 : 3 : in_qptrlatt(2, 2) = dtset%lwf_ngqpt(2)
228 : 3 : in_qptrlatt(3, 3) = dtset%lwf_ngqpt(3)
229 : :
230 : : ! TODO: shift is now not supported.
231 : 3 : nqshft = 1
232 : 3 : lwf_qshift(:, :) = 0.0_dp
233 : :
234 : : ! TODO: HeXu: symmetry is not used. Check if it is available.
235 : : ! In m_phonons, mkphdos, there is the comment:
236 : : ! Rotate e(q) to get e(Sq) to account for symmetrical q-points in BZ.
237 : : ! eigenvectors indeed are not invariant under rotation. See e.g. Eq 39-40 of PhysRevB.76.165108 [[cite:Giustino2007]].
238 : : ! In principle there's a phase due to nonsymmorphic translations but we here need |e(Sq)_iatom|**2
239 : 3 : my_qptopt = 3
240 : :
241 : : call kpts_ibz_from_kptrlatt(crystal, in_qptrlatt, my_qptopt, nqshft, lwf_qshift, &
242 : : & self%nqibz, self%qibz, self%qweights, nqbz, qbz, new_kptrlatt = new_qptrlatt, &
243 [ - + - + ]: 3 : & new_shiftk = new_shiftq, bz2ibz = bz2ibz_smap)
244 : :
245 [ - + ]: 3 : ABI_FREE(bz2ibz_smap)
246 : : !ABI_FREE(bz2ibz)
247 : :
248 [ + + + + ]: 39 : self%qptrlatt = new_qptrlatt
249 [ + + ]: 12 : self%shiftq(:) = new_shiftq(:, 1) ! only one shift in output
250 [ + - ]: 3 : if (self%my_rank == master) then
251 [ + - ]: 3 : write(msg, "(3a, i0)")" LWF ngqpt: ", trim(ltoa(dtset%lwf_ngqpt)), ", qptopt: ", my_qptopt
252 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
253 : 3 : write(msg, "(2(a, i0))")" Number of q-points in the IBZ: ", self%nqibz, ", number of MPI processes: ", self%nprocs
254 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
255 : :
256 : 3 : write(msg, "(a)") " List of q-points: "
257 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
258 : :
259 : 3 : write(msg,'(a,i8)')' Grid q points for sampling in the reciprocal space : ',self%nqibz
260 [ + + ]: 9 : call wrtout([ab_out, std_out],msg,'COLL')
261 : 3 : nkpout=self%nqibz
262 [ - + ]: 3 : if(self%nqibz>80)then
263 [ # # ]: 0 : call wrtout([ab_out, std_out],' greater than 80, so only write 20 of them ','COLL')
264 : 0 : nkpout=20
265 : : end if
266 [ + + ]: 195 : do iqpt=1,nkpout
267 : 192 : write(msg, '(1x,i2,a2,3es16.8)' )iqpt,') ',self%qibz(1,iqpt),self%qibz(2,iqpt),self%qibz(3,iqpt)
268 [ + + ]: 579 : call wrtout([ab_out, std_out], msg, 'COLL')
269 : : end do
270 : : end if
271 [ + - ]: 3 : ABI_SFREE(new_shiftq)
272 [ + - ]: 3 : ABI_SFREE(qbz)
273 [ - + - + ]: 3 : end subroutine prepare_qpoints
274 : :
275 : 3 : subroutine print_Rlist(self, dtset)
276 : : class(LatticeWannier), intent(inout):: self
277 : : type(anaddb_dataset_type) :: dtset
278 : : integer :: master=0
279 : : integer :: nRout, ii
280 : : character(len = 500):: msg
281 : :
282 [ + - ]: 3 : if (self%my_rank == master) then
283 [ + - ]: 3 : write(msg, "(2a)")" LWF is transformed to the real space cells: ", trim(ltoa(dtset%lwf_ngqpt))
284 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
285 : 3 : write(msg, "((a, i0))")" Number of cells: ", self%nR
286 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
287 : :
288 : 3 : write(msg,'(a,i8)')' R-vectors for cells in the real space : ',self%nR
289 [ + + ]: 9 : call wrtout([ab_out, std_out],msg,'COLL')
290 : 3 : nRout=self%nR
291 [ - + ]: 3 : if(self%nR>80)then
292 [ # # ]: 0 : call wrtout([ab_out, std_out],' greater than 80, so only write 20 of them ','COLL')
293 : 0 : nRout=20
294 : : end if
295 [ + + ]: 195 : do ii=1,nRout
296 : 192 : write(msg, '(1x,i2,a2,3i8)' )ii,') ',self%Rlist(1,ii),self%Rlist(2,ii),self%Rlist(3,ii)
297 [ + + ]: 579 : call wrtout([ab_out, std_out], msg, 'COLL')
298 : : end do
299 : : end if
300 : 3 : end subroutine print_Rlist
301 : :
302 : :
303 : :
304 : :
305 : 3 : subroutine prepare_Rlist(self)
306 : : class(LatticeWannier), intent(inout):: self
307 : : integer:: qptrlatt(3), i
308 : 3 : self%nR=1
309 [ + + ]: 12 : do i = 1, 3
310 : 9 : qptrlatt(i) = self%qptrlatt(i, i)
311 : 12 : self%nR=self%nR*qptrlatt(i)
312 : : end do
313 : 3 : call build_Rgrid(qptrlatt, self%Rlist)
314 : 3 : end subroutine prepare_Rlist
315 : :
316 : 2886 : elemental function freq_to_eigenval(f) result (evalue)
317 : : real(dp), intent(in):: f
318 : : real(dp):: evalue
319 [ - + - + ]: 6 : if(f < -1d-16) then
320 : 144 : evalue = - f*f
321 [ + + + - : 2742 : else if (f > 1d-16) then
+ + ]
322 : 2731 : evalue = f*f
323 : : else
324 : : evalue = 0.0_dp
325 : : end if
326 : : end function freq_to_eigenval
327 : :
328 : 3 : subroutine get_ifc_eigens(self, ifc, crystal)
329 : : class(LatticeWannier), intent(inout):: self
330 : : type(ifc_type), intent(in):: ifc
331 : : type(crystal_t), intent(in):: crystal
332 : 6 : real(dp):: eigvec(2, 3, Crystal%natom, 3*Crystal%natom), phfrq(3*Crystal%natom)
333 : 6 : real(dp):: displ(2*3*Crystal%natom*3*Crystal%natom)
334 : : integer:: iq_ibz
335 : : integer:: natom, natom3
336 : : integer:: iatom, iband, i3
337 : : complex(dp):: phase
338 : : real(dp):: phase_re, phase_im
339 : 3 : natom = crystal%natom
340 : 3 : self%natom = natom
341 : 3 : natom3 = natom*3
342 [ - + + - : 12 : ABI_MALLOC(self%eigenvalues, (natom3, self%nqibz))
- + + - +
- + - - +
- + - + ]
343 [ - + + - : 15 : ABI_MALLOC(self%eigenvectors, (natom3, natom3, self%nqibz))
- + + - -
+ + - + -
+ - - + -
+ - + ]
344 : : !print *, "trans:", ifc%trans
345 : : !print *, "xred:", crystal%xred
346 [ + + ]: 195 : do iq_ibz = 1, self%nqibz
347 : 192 : call ifc%fourq(crystal, self%qibz(:,iq_ibz), phfrq, displ, out_eigvec = eigvec)
348 : : ! frequency to eigenvalues
349 [ + + + + ]: 3072 : self%eigenvalues(:, iq_ibz) = freq_to_eigenval(phfrq)
350 : : ! remove phases from eigenvector
351 [ + + ]: 1155 : do iatom = 1, natom
352 : : ! to remove the phase factor exp(iqr), i.e. exp(-i.2pi.q.trans_iatom)
353 : 960 : call ifc_atom_phase(self%qibz(:,iq_ibz), ifc%trans(:,iatom), phase_re, phase_im)
354 : 960 : phase = cmplx(phase_re, -phase_im, kind=dp)
355 [ + + ]: 15552 : do iband=1, natom3
356 [ + + ]: 58560 : do i3 = 1, 3
357 : : self%eigenvectors((iatom-1)*3+i3, iband, iq_ibz ) = &
358 : 57600 : & CMPLX(eigvec(1, i3, iatom, iband), eigvec(2, i3, iatom, iband)) * phase
359 : : end do
360 : : end do
361 : : end do
362 : : end do
363 : 3 : end subroutine get_ifc_eigens
364 : :
365 : 3 : subroutine write_lwf_nc(self, prefix)
366 : : class(LatticeWannier), intent(inout):: self
367 : : character(len=*), intent(in) :: prefix
368 : : character(len=500) :: msg
369 : : type(IOWannNC):: ncfile
370 [ + - ]: 3 : call self%scdm%create_ncfile(trim(prefix)//"_lwf.nc", ncfile)
371 : 3 : call self%scdm%write_wann_netcdf(ncfile, wannR_unit='dimensionless', HwannR_unit='Ha')
372 : : !NCF_CHECK(self%crystal%ncwrite(ncfile%ncid))
373 : 3 : call self%scdm%close_ncfile(ncfile)
374 : 3 : write(msg, '(a)') ' LWF construction finished.'
375 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
376 : 3 : write(msg, '(a)') ' LWF coefficients and Hamiltonian writen to file: '//trim(prefix)//"_lwf.nc ."
377 [ + + ]: 9 : call wrtout([ab_out, std_out], msg)
378 : 3 : end subroutine write_lwf_nc
379 : :
380 : :
381 : 3 : subroutine run_all(self, prefix, dtset)
382 : : class(LatticeWannier), intent(inout):: self
383 : : character(len=*), intent(in) :: prefix
384 : : type(anaddb_dataset_type), intent(in):: dtset
385 : 3 : call self%scdm%construct_wannier()
386 : 3 : call self%print_Rlist(dtset)
387 : 3 : call self%write_lwf_nc(prefix = prefix)
388 [ + + ]: 3 : if(dtset%nqpath>0) then
389 : 2 : call self%write_bands(prefix, dtset)
390 : : end if
391 : 3 : end subroutine run_all
392 : :
393 : 3 : subroutine run_lattice_wannier(ifc, crystal, dtset, prefix, comm)
394 : : integer, intent(in):: comm
395 : : character(len=*), intent(in):: prefix
396 : : type(ifc_type), intent(in):: ifc
397 : : type(crystal_t), intent(in):: crystal
398 : : type(anaddb_dataset_type), intent(in):: dtset
399 : 3 : type(LatticeWannier):: lwf
400 : 3 : call lwf%initialize(ifc, crystal, dtset, comm)
401 : 3 : call lwf%run_all(prefix, dtset)
402 : 3 : call lwf%finalize()
403 [ - + - + : 3 : end subroutine run_lattice_wannier
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
404 : :
405 : :
406 : 2 : subroutine write_bands(self, prefix, inp)
407 : : class(LatticeWannier), intent(inout):: self
408 : : character(len=*), intent(in):: prefix
409 : : type(anaddb_dataset_type), intent(in):: inp
410 : 2 : integer,allocatable :: ndiv(:)
411 : : integer :: nfineqpath
412 : 2 : real(dp),allocatable :: fineqpath(:,:)
413 : 2 : real(dp),allocatable :: phfrq(:, :)
414 : 2 : complex(dp), allocatable :: eigvec(:,:, :)
415 : : !real(dp),allocatable :: weights(:)
416 : : integer :: iq, iband
417 : : real(dp) :: f
418 [ + - - + : 6 : ABI_MALLOC(ndiv,(inp%nqpath-1))
+ - + - +
- - + -
+ ]
419 : 2 : call make_path(inp%nqpath,inp%qpath,self%Crystal%gmet,'G',inp%ndivsm,ndiv,nfineqpath,fineqpath,std_out)
420 [ - + ]: 2 : ABI_FREE(ndiv)
421 : :
422 [ - + + - : 8 : ABI_MALLOC(phfrq, (inp%lwf_nwann, nfineqpath))
- + + - +
- + - - +
- + ]
423 [ - + + - : 10 : ABI_MALLOC(eigvec, (inp%lwf_nwann, inp%lwf_nwann, nfineqpath))
- + + - -
+ + - + -
+ - - + -
+ ]
424 : :
425 : 2 : call self%scdm%get_wannier_eigen_klist(fineqpath, nfineqpath, phfrq, eigvec)
426 [ + + ]: 346 : do iq=1, nfineqpath
427 [ + + ]: 1378 : do iband =1, inp%lwf_nwann
428 : 1032 : f=phfrq(iband, iq)
429 [ + + ]: 1376 : if (f>1.0d-9) then
430 : 648 : phfrq(iband, iq)= sqrt(f)
431 [ + + ]: 384 : else if (f<-1.0d-9) then
432 : 383 : phfrq(iband, iq)= -sqrt(-f)
433 : : else
434 : 1 : phfrq(iband, iq)= 0.0_dp
435 : : end if
436 : :
437 : : end do
438 : : end do
439 : :
440 [ + - ]: 2 : call write_phfrq(trim(prefix)//"_lwf_PHFRQ", inp%lwf_nwann, nfineqpath, phfrq)
441 : :
442 [ - + ]: 2 : ABI_FREE(phfrq)
443 [ - + ]: 2 : ABI_FREE(eigvec)
444 [ - + ]: 2 : ABI_FREE(fineqpath)
445 : 2 : end subroutine write_bands
446 : :
447 : 2 : subroutine write_phfrq(path,nlwf,nqpts,phfreq)
448 : :
449 : : !Arguments ------------------------------------
450 : : !scalars
451 : : integer,intent(in) :: nqpts, nlwf
452 : : character(len=*),intent(in) :: path
453 : : !arrays
454 : : !real(dp),intent(in) :: qpoints(3,nqpts)
455 : : real(dp),intent(in) :: phfreq(nlwf,nqpts)
456 : :
457 : : !Local variables-------------------------------
458 : : !scalars
459 : : integer :: nphmodes, iq, iunit
460 : : !real(dp) :: dummy
461 : : character(len=300) :: fmt
462 : : character(len=500) :: msg
463 : :
464 : : ! *************************************************************************
465 : :
466 : 2 : nphmodes = nlwf
467 : : !dummy = qpoints(1,1); dummy = weights(1)
468 [ - + ]: 2 : if (open_file(path, msg, newunit=iunit, form="formatted", status="unknown", action="write") /= 0) then
469 : 0 : ABI_ERROR(msg)
470 : : end if
471 : :
472 : 2 : write (iunit, '(a)') '# ABINIT generated LWF phonon band structure file. All in Ha atomic units'
473 : 2 : write (iunit, '(a)') '# '
474 : 2 : write (iunit, '(a,i0)') '# number_of_qpoints ', nqpts
475 : 2 : write (iunit, '(a,i0)') '# number_of_phonon_modes ', nphmodes
476 : 2 : write (iunit, '(a)') '# '
477 : 2 : write (fmt,'(a,i0,a)') "(I5, ", nphmodes, "E20.10)"
478 [ + + ]: 346 : do iq= 1, nqpts
479 : 346 : write (iunit, fmt) iq, phfreq(:,iq)
480 : : end do
481 : 2 : close(iunit)
482 : :
483 : 2 : end subroutine write_phfrq
484 : :
485 : :
486 : :
487 [ # # # # : 0 : end module m_lwf
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
488 : : !!***
|
