Line data Source code
1 : !!****m* ABINIT/m_ebands
2 : !! NAME
3 : !! m_ebands
4 : !!
5 : !! FUNCTION
6 : !! This module contains utilities to analyze and retrieve information from the ebands_t.
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2008-2026 ABINIT group (MG, MJV, BXu)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! TODO
15 : !! 1) Remove npwarr, istwfk.
16 : !! 2) Use 3d arrays for ebands%nband
17 : !! 3) Solve issue with Hdr dependency
18 : !!
19 : !! SOURCE
20 :
21 : #if defined HAVE_CONFIG_H
22 : #include "config.h"
23 : #endif
24 :
25 : #include "abi_common.h"
26 :
27 : module m_ebands
28 :
29 : use defs_basis
30 : use m_errors
31 : use m_abicore
32 : use m_xmpi
33 : use m_htetra
34 : use m_nctk
35 : use netcdf
36 : use m_hdr
37 : use m_krank
38 : use m_skw
39 : use m_kpts
40 : use m_sort
41 : use m_dtset
42 : use m_yaml
43 :
44 : use defs_datatypes, only : ebands_base_t
45 : use m_copy, only : alloc_copy
46 : use m_io_tools, only : file_exists, open_file
47 : use m_time, only : cwtime, cwtime_report
48 : use m_fstrings, only : tolower, itoa, sjoin, ftoa, ltoa, ktoa, strcat, basename, replace
49 : use m_numeric_tools, only : arth, imin_loc, imax_loc, bisect, stats_t, stats_eval, simpson, simpson_int, wrap2_zero_one, &
50 : isdiagmat, get_diag, interpol3d_0d, interpol3d_indices, linspace
51 : use m_special_funcs, only : gaussian
52 : use m_geometry, only : normv
53 : use m_cgtools, only : set_istwfk
54 : use m_pptools, only : printbxsf
55 : use m_occ, only : getnel, newocc, occ_fd
56 : use m_nesting, only : mknesting
57 : use m_crystal, only : crystal_t
58 : use m_bz_mesh, only : isamek, kpath_t, littlegroup_t, kmesh_t
59 : use m_fftcore, only : get_kg
60 :
61 : implicit none
62 :
63 : private
64 : !!***
65 :
66 : ! Helper functions
67 : public :: pack_eneocc ! Helper function for reshaping (energies|occupancies|derivate of occupancies).
68 : public :: get_eneocc_vect ! Reshape (ene|occ|docdde) returning a matrix instead of a vector.
69 : public :: put_eneocc_vect ! Put (ene|occ|doccde) in vectorial form into the data type doing a reshape.
70 : public :: unpack_eneocc ! Helper function for reshaping (energies|occupancies|derivate of occupancies).
71 :
72 : !----------------------------------------------------------------------
73 :
74 : !!****t* m_ebands/ebands_t
75 : !! NAME
76 : !! ebands_t
77 : !!
78 : !! FUNCTION
79 : !! Electron energies and occupations
80 : !!
81 : !! SOURCE
82 :
83 : type, extends(ebands_base_t), public :: ebands_t
84 :
85 : contains
86 :
87 : procedure :: init => ebands_init
88 : ! Main creation method.
89 :
90 : procedure :: free => ebands_free
91 : ! Destruction method.
92 :
93 : procedure :: from_hdr => ebands_from_hdr
94 : ! Init object from the abinit header.
95 :
96 : procedure :: from_dtset => ebands_from_dtset
97 : ! Init object from the abinit dataset.
98 :
99 : procedure :: copy => ebands_copy ! Copy of the ebands_t.
100 : procedure :: move_alloc => ebands_move_alloc ! Transfer allocation.
101 : procedure :: print => ebands_print ! Printout basic info on the data type.
102 : procedure :: get_bandenergy => ebands_get_bandenergy ! Returns the band energy of the system.
103 : procedure :: get_valence_idx => ebands_get_valence_idx ! Gives the index of the (valence|bands at E_f).
104 : procedure :: get_bands_from_erange => ebands_get_bands_from_erange ! Return the indices of the mix and max band within an energy window.
105 : procedure :: vcbm_range_from_gaps => ebands_vcbm_range_from_gaps ! Find band and energy range for states close to the CBM/VBM given input energies.
106 : procedure :: apply_scissors => ebands_apply_scissors ! Apply scissors operator (no k-dependency).
107 : procedure :: read_qpdata => ebands_read_qpdata ! Read quasi-particle energies from file, update %eig and %fermi_energy
108 : procedure :: get_occupied => ebands_get_occupied ! Returns band indices after which occupations are less than an input value.
109 : procedure :: enclose_degbands => ebands_enclose_degbands ! Adjust band indices such that all degenerate states are treated.
110 : procedure :: get_bands_e0 => ebands_get_bands_e0 ! Find min/max band indices crossing energy e0
111 : procedure :: get_erange => ebands_get_erange ! Compute the minimum and maximum energy enclosing a list of states.
112 : procedure :: nelect_per_spin => ebands_nelect_per_spin ! Returns number of electrons per spin channel
113 : procedure :: get_minmax => ebands_get_minmax ! Returns min and Max value of (eig|occ|doccde).
114 : procedure :: has_metal_scheme => ebands_has_metal_scheme ! .True. if metallic occupation scheme is used.
115 : procedure :: write_bxsf => ebands_write_bxsf ! Write 3D energies for Fermi surface visualization (XSF format)
116 : procedure :: update_occ => ebands_update_occ ! Update the occupation numbers.
117 : procedure :: set_scheme => ebands_set_scheme ! Set the occupation scheme.
118 : procedure :: set_fermie => ebands_set_fermie ! Change the fermi level (assume metallic scheme).
119 : procedure :: set_extrael => ebands_set_extrael ! Add extrael to initial number of electrons to simulate e/h doping. (assume metallic scheme).
120 : procedure :: get_muT_with_fd => ebands_get_muT_with_fd ! Change the number of electrons (assume metallic scheme).
121 : procedure :: calc_nelect => ebands_calc_nelect ! Compute nelect from Fermi level and Temperature.
122 : procedure :: report_gap => ebands_report_gap ! Print info on the fundamental and direct gap.
123 : procedure :: ncwrite => ebands_ncwrite ! Write object to NETCDF file (use ncid)
124 : procedure :: ncwrite_path => ebands_ncwrite_path ! Dump the object into NETCDF file (use filepath)
125 : procedure :: write_nesting => ebands_write_nesting ! Calculate the nesting function and output data to file.
126 : procedure :: expandk => ebands_expandk ! Build a new ebands_t in the full BZ.
127 : procedure :: downsample => ebands_downsample ! Build a new ebands_t with a downsampled IBZ.
128 : procedure :: chop => ebands_chop ! Build a new ebands_t with selected nbands.
129 : procedure :: get_edos => ebands_get_edos ! Compute e-DOS from band structure.
130 : procedure :: get_jdos => ebands_get_jdos ! Compute electron joint-DOS from band structure.
131 : procedure :: get_edos_matrix_elements => ebands_get_edos_matrix_elements ! Compute e-DOS and other DOS-like quantities involving ! vectorial or tensorial matrix elements.
132 : procedure :: interp_kmesh => ebands_interp_kmesh ! Use SWK to interpolate energies on a k-mesh.
133 : procedure :: interp_kpath => ebands_interp_kpath ! Interpolate energies on a k-path.
134 : procedure :: interpolate_kpath => ebands_interpolate_kpath
135 : procedure :: prtbltztrp => ebands_prtbltztrp ! Output files for BoltzTraP code.
136 : procedure :: write => ebands_write ! Driver routine to write bands in different txt formats.
137 : procedure :: get_carriers => ebands_get_carriers ! Compute carrier concentration from input Fermi level and list of Temperatures.
138 : procedure :: get_gaps => ebands_get_gaps ! Build the gaps object from a bandstructure.
139 : procedure :: print_gaps => ebands_print_gaps ! Helper function to print gaps directly from ebands.
140 : procedure :: write_xmgrace => ebands_write_xmgrace
141 : procedure :: write_gnuplot => ebands_write_gnuplot
142 : procedure :: sort => ebands_sort
143 : procedure :: has_enough_bands_for_ef => ebands_has_enough_bands_for_ef ! Check if nband is "large enough" to compute the Fermi level Ef(T).
144 :
145 : end type ebands_t
146 : !!***
147 :
148 : public :: ebands_prtbltztrp_tau_out ! Output files for BoltzTraP code,
149 :
150 : !----------------------------------------------------------------------
151 :
152 : !!****t* m_ebands/edos_t
153 : !! NAME
154 : !! edos_t
155 : !!
156 : !! FUNCTION
157 : !! Store the electronic DOS
158 : !!
159 : !! SOURCE
160 :
161 : type,public :: edos_t
162 :
163 : integer :: nsppol = -1
164 : ! Number of spins.
165 :
166 : integer :: nspinor = -1
167 : ! Number of spinors
168 :
169 : integer :: nkibz = -1
170 : ! Number of k-points in the IBZ.
171 :
172 : integer :: nw = -1
173 : ! Number of points in the frequency mesh.
174 :
175 : integer :: ief = 0
176 : ! Rightmost Index of the energy mesh such as IDOS[mesh[ief]] < nelect.
177 : ! 0 if Fermi level could not be computed
178 : ! Note the value of gef stored in edos_t is computed by performing
179 : ! a linear interpolation between ief and ief + 1
180 :
181 : integer :: ihf = 0
182 : ! Like ief (see above)
183 : ! But for fermi level of thermalized holes in valence bands
184 : ! For occopt 9 purposes
185 :
186 : integer :: intmeth = 0
187 : ! 1 for gaussian, 2 tetra
188 :
189 : real(dp) :: broad = zero
190 : ! Gaussian broadening
191 :
192 : real(dp) :: step = -one
193 : ! Step of the mesh
194 :
195 : real(dp) :: nelect = zero
196 : ! Number of electrons taken from ebands.
197 :
198 : real(dp),allocatable :: mesh(:)
199 : ! mesh(nw)
200 :
201 : real(dp),allocatable :: dos(:,:)
202 : ! dos(nw, 0:nsppol)
203 : ! Total DOS, spin up and spin down component.
204 :
205 : real(dp),allocatable :: idos(:,:)
206 : ! idos(nw, 0:nsppol)
207 : ! Integrated DOS: (total, spin up, spin down) component.
208 :
209 : real(dp),allocatable :: gef(:)
210 : ! gef(0:nsppol)
211 : ! DOS at the Fermi level. Total, spin up, spin down
212 :
213 : real(dp),allocatable :: ghf(:)
214 : ! ghf(0:nsppol)
215 : ! DOS at the Fermi level of thermalized holes. Total, spin up, spin down
216 :
217 : contains
218 :
219 : procedure :: free => edos_free
220 : ! Free memory
221 :
222 : procedure :: write => edos_write
223 : ! Write results to file (formatted mode)
224 :
225 : procedure :: print => edos_print
226 : ! Print eDOS info to Fortran unit.
227 :
228 : procedure :: ncwrite => edos_ncwrite
229 : ! Write eDOS to netcdf file.
230 :
231 : procedure :: get_carriers => edos_get_carriers
232 : ! Compute number of holes (nh) and electrons (ne) per unit cell from a given
233 : ! list of `ntemp` temperatures `kTmesh` and chemical potentials `mu_e`.
234 :
235 : end type edos_t
236 : !!***
237 :
238 : !!****t* m_ebands/jdos_t
239 : !! NAME
240 : !! jdos_t
241 : !!
242 : !! FUNCTION
243 : !! Store the electron joint DOS
244 : !!
245 : !! SOURCE
246 :
247 : type,public :: jdos_t
248 :
249 : integer :: nsppol
250 : ! Number of spins.
251 :
252 : integer :: nkibz
253 : ! Number of k-points in the IBZ.
254 :
255 : integer :: nw
256 : ! Number of points in the frequency mesh.
257 :
258 : integer :: intmeth
259 : ! 1 for gaussian, 2 tetra
260 :
261 : real(dp) :: broad = zero
262 : ! Gaussian broadening
263 :
264 : real(dp) :: step
265 : ! Step of the mesh
266 :
267 : real(dp),allocatable :: mesh(:)
268 : ! mesh(nw)
269 :
270 : real(dp),allocatable :: values(:,:)
271 : ! dos(nw,0:nsppol)
272 : ! Total jDOS, spin up and spin down component.
273 :
274 : contains
275 :
276 : procedure :: free => jdos_free
277 : ! Free memory
278 :
279 : !procedure :: write => jdos_write
280 : ! Write results to file (formatted mode)
281 :
282 : !procedure :: print => jdos_print
283 : ! Print jDOS info to Fortran unit.
284 :
285 : procedure :: ncwrite => jdos_ncwrite
286 : ! Write jDOS to netcdf file.
287 :
288 : end type jdos_t
289 : !!***
290 :
291 : !----------------------------------------------------------------------
292 :
293 : !!****t* m_ebands/gaps_t
294 : !! NAME
295 : !! gaps_t
296 : !!
297 : !! FUNCTION
298 : !! Structure with information on the fundamental and direct gaps returned by ebands_report_gap.
299 : !!
300 : !! SOURCE
301 :
302 : type,public :: gaps_t
303 :
304 : integer :: nsppol
305 : ! Number of spins.
306 :
307 : integer,allocatable :: fo_kpos(:,:)
308 : ! fo_kpos(3,nsppol)
309 : ! fo_kpos(1:2,spin) ==> Indices of the k-points where the homo, lumo states are located (for each spin).
310 : ! fo_kpos(3,spin) ==> the index of k-point where the direct gap is located (for each spin).
311 : ! NB: f stands for fundamental, o for "optical" gap.
312 :
313 : real(dp) :: fermie
314 : ! Fermi energy taken from ebands.
315 :
316 : real(dp) :: nelect
317 : ! Number of electrons taken from ebands.
318 :
319 : integer,allocatable :: ierr(:)
320 : ! ierr(nsppol)
321 : ! 0 if the gap has been computed.
322 : ! 1 if the system (or spin-channel) is metallic.
323 : ! 2 if gaps were not computed (because there are only valence bands).
324 :
325 : real(dp),allocatable :: fo_values(:,:)
326 : ! fo_values(2,nsppol)
327 : ! Fundamental and direct gaps (in Hartree) for each spin.
328 :
329 : real(dp),allocatable :: vb_max(:), cb_min(:)
330 : ! vb_max(nsppol)
331 : ! valence band max and conduction band min for each spin in Ha.
332 : ! Only for Semiconductors, set to (+, -) huge(one) for metals.
333 :
334 : real(dp),allocatable :: optical_kpoints(:,:)
335 : ! (3, nsppol)
336 : ! kpoint of optical gap for each spin
337 :
338 : real(dp),allocatable :: fund_kpoints(:,:, :)
339 : ! (3, 2, nsppol)
340 : ! kpoint of the fundamental gap for (val, cond) and each spin
341 :
342 : character(len=500),allocatable :: errmsg_spin(:)
343 : ! errmsg_spin(nsppol)
344 : ! String with human-readable error message if ierr(spin) != 0.
345 :
346 : contains
347 :
348 : procedure :: free => gaps_free
349 : ! Free memory
350 :
351 : procedure :: print => gaps_print
352 : ! Print info on the gaps
353 :
354 : end type gaps_t
355 : !!***
356 :
357 : !!****t* m_ebands/klinterp_t
358 : !! NAME
359 : !! klinterp_t
360 : !!
361 : !! FUNCTION
362 : !! Linear interpolation of eigenvalue-like quantities (scalars with the same symmetry as the KS eigenvalues)
363 : !! Used, for instance, to interpolate electron or phonon lifetimes.
364 : !!
365 : !! SOURCE
366 :
367 : type,public :: klinterp_t
368 :
369 : integer :: bsize, nsppol, ndat
370 : ! Max number of bands, number of independent spin polarization, size of "extra" dimension.
371 :
372 : integer :: nkx, nky, nkz
373 : ! Number of divisions of the grid enclosing the first unit cell
374 :
375 : real(dp),allocatable :: data_uk_bsd(:,:,:,:,:,:)
376 : ! (nkx*nky*nkz, mband, nsppol, ndat)
377 :
378 : contains
379 :
380 : procedure :: free => klinterp_free
381 : ! Free dynamic memory
382 :
383 : procedure :: eval_bsd => klinterp_eval_bsd
384 : ! Interpolate values at an arbitrary k-point.
385 :
386 : end type klinterp_t
387 : !!***
388 :
389 : public :: klinterp_new ! Build interpolator.
390 :
391 : !----------------------------------------------------------------------
392 :
393 : CONTAINS !=====================================================================================
394 :
395 : !----------------------------------------------------------------------
396 :
397 : !!****f* m_ebands/ebands_print_gaps
398 : !! NAME
399 : !! ebands_print_gaps
400 : !!
401 : !! FUNCTION
402 : !! Helper function to print gaps directly from ebands.
403 : !!
404 : !! INPUTS
405 : !! ebands<ebands_t>=Info on the band structure, the smearing technique and the physical temperature used.
406 : !! units=Unit numbers
407 : !!
408 : !! OUTPUT
409 : !!
410 : !! SOURCE
411 :
412 0 : subroutine ebands_print_gaps(ebands, units, header)
413 :
414 : !Arguments ------------------------------------
415 : class(ebands_t),intent(in) :: ebands
416 : integer,intent(in) :: units(:)
417 : character(len=*),optional,intent(in) :: header
418 :
419 : !Local variables-------------------------------
420 : integer :: ierr, spin
421 : type(gaps_t) :: gaps
422 : !character(len=500) :: msg
423 : ! *********************************************************************
424 :
425 : !if (unit == dev_null) return
426 0 : gaps = ebands_get_gaps(ebands, ierr)
427 0 : if (ierr /= 0) then
428 0 : do spin=1, ebands%nsppol
429 0 : call wrtout(units, trim(gaps%errmsg_spin(spin)))
430 : end do
431 : end if
432 :
433 0 : if (present(header)) then
434 0 : call gaps%print(units, header=header)
435 : else
436 0 : call gaps%print(units)
437 : end if
438 0 : call gaps%free()
439 :
440 0 : end subroutine ebands_print_gaps
441 : !!***
442 :
443 : !----------------------------------------------------------------------
444 :
445 : !!****f* m_ebands/ebands_get_gaps
446 : !! NAME
447 : !! ebands_get_gaps
448 : !!
449 : !! FUNCTION
450 : !! Returns a gaps_t object with info on the fundamental and direct gap.
451 : !!
452 : !! INPUTS
453 : !! ebands<ebands_t>=Info on the band structure, the smearing technique and the physical temperature used.
454 : !!
455 : !! OUTPUT
456 : !! ierr=Return code (!=0 signals failure)
457 : !! gaps<gaps_t>=object with info on the gaps (caller is responsible for freeing the object).
458 : !!
459 : !! SOURCE
460 :
461 298 : type(gaps_t) function ebands_get_gaps(ebands, ierr) result(gaps)
462 :
463 : !Arguments ------------------------------------
464 : !scalars
465 : class(ebands_t),target,intent(in) :: ebands
466 : integer,intent(out) :: ierr
467 :
468 : !Local variables-------------------------------
469 : !scalars
470 : integer,parameter :: occopt3 = 3, prtvol0 = 0
471 : real(dp),parameter :: spinmagntarget_ = -99.99_dp
472 : real(dp) :: tsmear
473 298 : type(ebands_t) :: tmp_ebands
474 : !character(len=500) :: msg
475 : ! *********************************************************************
476 :
477 298 : call get_gaps_(ebands, gaps, ierr)
478 :
479 298 : if (ierr /= 0) then
480 : ! get_gaps_ will fail if we have a real metal/semimetal
481 : ! but it's also possible to have a false negative if the input ebands represents a:
482 : !
483 : ! 1) highly degenerate doped semiconductor with the Fermi level in the bands.
484 : ! 2) Small gap semiconductor at relatively high T.
485 : !
486 : ! Here I try to compute the gaps of an intrinsic semiconductor at low T with Fermi-Dirac.
487 : ! This might still fail though and the caller should handle that.
488 16 : call gaps%free()
489 16 : call ebands%copy(tmp_ebands)
490 16 : tsmear = 0.01_dp * eV_Ha
491 16 : call tmp_ebands%set_scheme(occopt3, tsmear, spinmagntarget_, prtvol0, update_occ=.False.)
492 : ! Remove extrael to go back to intrinsic system
493 16 : if (ebands%extrael /= zero) tmp_ebands%nelect = ebands%nelect - ebands%extrael
494 : !if (ebands%cellcharge /= zero) tmp_ebands%nelect = ebands%nelect + ebands%cellcharge
495 16 : call tmp_ebands%update_occ(spinmagntarget_)
496 :
497 : ! Try to compute gaps the again with new Fermi level at FD T = tsmear computed from update_occ.
498 : ! Return ierr
499 16 : call get_gaps_(tmp_ebands, gaps, ierr)
500 16 : call tmp_ebands%free()
501 : end if
502 :
503 596 : end function ebands_get_gaps
504 : !!***
505 :
506 : !----------------------------------------------------------------------
507 :
508 : !!****f* m_ebands/get_gaps_
509 : !! NAME
510 : !! get_gaps_
511 : !!
512 : !! FUNCTION
513 : !! Private function that returns a gaps_t object with info on the fundamental and direct gap.
514 : !!
515 : !! INPUTS
516 : !! ebands<ebands_t>=Info on the band structure, the smearing technique and the physical temperature used.
517 : !!
518 : !! OUTPUT
519 : !! ierr=Return code (!=0 signals failure)
520 : !! gaps<gaps_t>=object with info on the gaps (caller is responsible for freeing the object).
521 : !!
522 : !! SOURCE
523 :
524 314 : subroutine get_gaps_(ebands, gaps, ierr)
525 :
526 : !Arguments ------------------------------------
527 : !scalars
528 : class(ebands_t),target,intent(in) :: ebands
529 : type(gaps_t),intent(out) :: gaps
530 : integer,intent(out) :: ierr
531 :
532 : !Local variables-------------------------------
533 : !scalars
534 : integer :: ikibz,nband_k,spin,nsppol,ikopt,ivk,ick,ivb,icb
535 : real(dp),parameter :: tol_fermi = tol6
536 : real(dp) :: fun_gap, opt_gap
537 : logical :: ismetal
538 : !arrays
539 628 : integer :: val_idx(ebands%nkpt, ebands%nsppol)
540 314 : real(dp) :: top_valence(ebands%nkpt), bot_conduct(ebands%nkpt)
541 : ! *********************************************************************
542 :
543 314 : call gaps%free()
544 314 : nsppol = ebands%nsppol
545 :
546 : ! Initialize gaps_t
547 314 : gaps%nsppol = nsppol
548 314 : gaps%nelect = ebands%nelect
549 942 : ABI_MALLOC(gaps%fo_kpos, (3, nsppol))
550 942 : ABI_MALLOC(gaps%ierr, (nsppol))
551 942 : ABI_MALLOC(gaps%fo_values, (2, nsppol))
552 942 : ABI_MALLOC(gaps%vb_max, (nsppol))
553 628 : ABI_MALLOC(gaps%cb_min, (nsppol))
554 942 : ABI_MALLOC(gaps%errmsg_spin, (nsppol))
555 :
556 942 : ABI_MALLOC(gaps%fund_kpoints, (3, 2, nsppol))
557 942 : ABI_MALLOC(gaps%optical_kpoints, (3, nsppol))
558 3176 : gaps%fund_kpoints = huge(one)
559 1586 : gaps%optical_kpoints = huge(one)
560 :
561 1586 : gaps%fo_kpos = 0
562 632 : gaps%ierr = 0
563 1268 : gaps%fo_values = zero
564 950 : gaps%vb_max = huge(one); gaps%cb_min = -huge(one)
565 632 : gaps%errmsg_spin(:) = ""
566 314 : gaps%fermie = ebands%fermie
567 :
568 : ! Compute "valence index" using efermi
569 314 : val_idx(:,:) = ebands_get_valence_idx(ebands, tol_fermi=tol_fermi)
570 :
571 : spin_loop: &
572 632 : do spin=1,nsppol
573 :
574 : ! No output if system is metallic
575 9723 : ismetal = ANY(val_idx(:,spin) /= val_idx(1,spin))
576 318 : if (ismetal) then
577 28 : gaps%ierr(spin) = 1
578 28 : write(gaps%errmsg_spin(spin), "(a,i0)")" Detected metallic system for spin channel: ", spin
579 28 : cycle
580 : endif
581 :
582 290 : ivb = val_idx(1, spin)
583 290 : icb = ivb + 1
584 :
585 9619 : do ikibz=1,ebands%nkpt
586 9331 : nband_k = ebands%nband(ikibz + (spin-1)*ebands%nkpt)
587 9331 : top_valence(ikibz) = ebands%eig(ivb, ikibz, spin)
588 9331 : if (icb > nband_k) then
589 2 : gaps%ierr(spin) = 2
590 2 : gaps%errmsg_spin(spin) = "Not enough states to calculate the band gap."
591 2 : cycle spin_loop
592 : end if
593 9617 : bot_conduct(ikibz) = ebands%eig(icb, ikibz, spin)
594 : end do
595 :
596 : ! Minimum of the direct Gaps
597 9617 : ikopt = imin_loc(bot_conduct - top_valence)
598 288 : opt_gap = bot_conduct(ikopt) - top_valence(ikopt)
599 :
600 : ! Fundamental Gap
601 288 : ick = imin_loc(bot_conduct)
602 288 : ivk = imax_loc(top_valence)
603 :
604 288 : gaps%vb_max(spin) = ebands%eig(ivb, ivk, spin)
605 288 : gaps%cb_min(spin) = ebands%eig(icb, ick, spin)
606 288 : fun_gap = ebands%eig(icb, ick, spin) - ebands%eig(ivb, ivk, spin)
607 864 : gaps%fo_values(:, spin) = [fun_gap, opt_gap]
608 1152 : gaps%fo_kpos(:, spin) = [ivk, ick, ikopt]
609 :
610 1152 : gaps%optical_kpoints(:, spin) = ebands%kptns(:, ikopt)
611 1152 : gaps%fund_kpoints(:, 1, spin) = ebands%kptns(:, ivk)
612 1466 : gaps%fund_kpoints(:, 2, spin) = ebands%kptns(:, ick)
613 : end do spin_loop
614 :
615 632 : ierr = maxval(gaps%ierr)
616 :
617 314 : if (ierr /= 0) then
618 : ! Set VBM and CBM to fermie if metal.
619 60 : do spin=1,nsppol
620 60 : if (gaps%ierr(spin) /= 0) then
621 30 : gaps%vb_max(spin) = ebands%fermie
622 30 : gaps%cb_min(spin) = ebands%fermie
623 : end if
624 : end do
625 : end if
626 :
627 314 : end subroutine get_gaps_
628 : !!***
629 :
630 : !----------------------------------------------------------------------
631 :
632 : !!****f* m_ebands/gaps_free
633 : !! NAME
634 : !! gaps_free
635 : !!
636 : !! FUNCTION
637 : !! Free the memory allocated in gaps_t
638 : !!
639 : !! SOURCE
640 :
641 630 : subroutine gaps_free(gaps)
642 :
643 : !Arguments ------------------------------------
644 : class(gaps_t),intent(inout) :: gaps
645 : ! *********************************************************************
646 :
647 : !integer
648 630 : ABI_SFREE(gaps%fo_kpos)
649 630 : ABI_SFREE(gaps%ierr)
650 :
651 : !real
652 630 : ABI_SFREE(gaps%fo_values)
653 630 : ABI_SFREE(gaps%vb_max)
654 630 : ABI_SFREE(gaps%cb_min)
655 630 : ABI_SFREE(gaps%optical_kpoints)
656 630 : ABI_SFREE(gaps%fund_kpoints)
657 :
658 : !chars
659 630 : ABI_SFREE(gaps%errmsg_spin)
660 :
661 630 : end subroutine gaps_free
662 : !!***
663 :
664 : !----------------------------------------------------------------------
665 :
666 : !!****f* m_ebands/gaps_print
667 : !! NAME
668 : !! gaps_print
669 : !!
670 : !! FUNCTION
671 : !! Print info on the fundamental and direct gap.
672 : !!
673 : !! INPUTS
674 : !! units=Unit numbers
675 : !! [header]=Optional title.
676 : !! [kTmesh]=List of temperatures. If present activates output of (T, mu_e, band_edges)
677 : !! [mu_e]=List of Fermi levels for each T.
678 : !!
679 : !! OUTPUT
680 : !! Only writing.
681 : !!
682 : !! SOURCE
683 :
684 298 : subroutine gaps_print(gaps, units, header, kTmesh, mu_e)
685 :
686 : !Arguments ------------------------------------
687 : !scalars
688 : class(gaps_t),intent(in) :: gaps
689 : integer,intent(in) :: units(:)
690 : character(len=*),intent(in),optional :: header
691 : real(dp),optional,intent(in) :: kTmesh(:), mu_e(:)
692 :
693 : !Local variables-------------------------------
694 : !scalars
695 : integer :: spin, ikopt, ivk, ick, itemp, ntemp
696 : real(dp) :: fun_gap, opt_gap, csi_c, csi_v
697 : character(len=500) :: msg
698 : ! *********************************************************************
699 :
700 600 : do spin=1,gaps%nsppol
701 302 : if (spin == 1) then
702 298 : msg = ch10
703 298 : if (present(header)) msg = ch10//' === '//trim(adjustl(header))//' === '
704 298 : call wrtout(units, msg)
705 : end if
706 :
707 302 : if (gaps%ierr(spin) /= 0) then
708 14 : call wrtout(units, gaps%errmsg_spin(spin))
709 : continue
710 : end if
711 :
712 : ! Get minimum of the direct Gap.
713 302 : fun_gap = gaps%fo_values(1, spin)
714 302 : opt_gap = gaps%fo_values(2, spin)
715 :
716 1166 : if (any(gaps%fo_kpos(:,spin) == 0)) then
717 14 : call wrtout(units, sjoin(" Cannot detect gap for spin: ", itoa(spin)))
718 14 : cycle
719 : end if
720 :
721 288 : ivk = gaps%fo_kpos(1, spin)
722 288 : ick = gaps%fo_kpos(2, spin)
723 288 : ikopt = gaps%fo_kpos(3, spin)
724 :
725 : ! >>>> For spin 2
726 : !Direct band gap semiconductor.
727 : !Fundamental gap: 4.48 (eV)
728 : ! VBM: 4.47 (eV) at k: [ 0.0000E+00, 0.0000E+00, 0.0000E+00]
729 : ! CBM: 8.96 (eV) at k: [ 0.0000E+00, 0.0000E+00, 0.0000E+00]
730 : !Optical gap: 4.48 (eV) at k:[ 0.0000E+00, 0.0000E+00, 0.0000E+00]
731 :
732 288 : if (gaps%nsppol == 2) call wrtout(units, sjoin(' >>>> For spin ', itoa(spin)))
733 288 : if (ivk == ick) call wrtout(units, " Direct band gap semiconductor")
734 288 : if (ivk /= ick) call wrtout(units, " Indirect band gap semiconductor")
735 288 : write(msg, "(a,f9.3,a )")" Fundamental gap: ", fun_gap * Ha_eV, " (eV)"
736 288 : call wrtout(units, msg)
737 288 : write(msg, "(a,f9.3,2a)")" VBM: ", gaps%vb_max(spin) * Ha_eV, " (eV) at k: ", trim(ktoa(gaps%fund_kpoints(:,1,spin)))
738 288 : call wrtout(units, msg)
739 288 : write(msg, "(a,f9.3,2a)")" CBM: ", gaps%cb_min(spin) * Ha_eV, " (eV) at k: ", trim(ktoa(gaps%fund_kpoints(:,2,spin)))
740 288 : call wrtout(units, msg)
741 288 : write(msg, "(a,f9.3,2a)")" Direct gap: ", opt_gap * Ha_eV," (eV) at k: ", trim(ktoa(gaps%optical_kpoints(:,spin)))
742 288 : call wrtout(units, msg)
743 : !write(msg, "((2(a, f9.3)))")" Fermi level:", gaps%fermie * Ha_eV, " (eV) with nelect:", gaps%nelect
744 : !call wrtout(units, msg)
745 :
746 882 : if (present(mu_e) .and. present(kTmesh) .and. all(gaps%ierr == 0)) then
747 63 : ntemp = size(mu_e)
748 63 : call wrtout(units, " Position of CBM/VBM with respect to the Fermi level:", pre_newlines=1)
749 63 : call wrtout(units, " Notations: mu_e = Fermi level, D_v = (mu_e - VBM), D_c = (CBM - mu_e)")
750 63 : call wrtout(units, " T(K) kT (eV) mu_e (eV) D_v (eV) D_c (eV)", pre_newlines=1)
751 306 : do itemp=1,ntemp
752 243 : csi_c = gaps%cb_min(spin) - mu_e(itemp)
753 243 : csi_v = -gaps%vb_max(spin) + mu_e(itemp)
754 : write(msg, "(f6.1, 1x, 4(f9.3, 1x))") &
755 243 : kTmesh(itemp) / kb_HaK, kTmesh(itemp) * Ha_eV, mu_e(itemp) * Ha_eV, csi_v * Ha_eV, csi_c * Ha_eV
756 306 : call wrtout(units, msg)
757 : end do
758 63 : call wrtout(units, "")
759 : end if
760 :
761 : end do ! spin
762 :
763 1450 : if (any(gaps%fo_kpos == 0)) then
764 14 : write(msg, "((2(a, f9.3)))") " Fermi level:", gaps%fermie * Ha_eV, " (eV) with nelect:", gaps%nelect
765 14 : call wrtout(units, msg)
766 : end if
767 :
768 298 : call wrtout(units, "")
769 :
770 298 : end subroutine gaps_print
771 : !!***
772 :
773 : !----------------------------------------------------------------------
774 :
775 : !!****f* m_ebands/ebands_init
776 : !! NAME
777 : !! ebands_init
778 : !!
779 : !! FUNCTION
780 : !! This subroutine initializes the ebands_t structured datatype
781 : !!
782 : !! INPUTS
783 : !! bantot=total number of bands (=sum(nband(:))
784 : !! doccde(bantot)=derivative of the occupation numbers with respect to the energy (Ha)
785 : !! eig(bantot)=eigenvalues (hartree)
786 : !! istwfk(nkpt)=parameter that describes the storage of wfs.
787 : !! ivalence = index of the valence band separating thermalized excited holes
788 : !! from excited thermalized excited electrons
789 : !! kptns(3,nkpt)=k points in terms of recip primitive translations
790 : !! nband(nkpt*nsppol)=number of bands
791 : !! nelect=Number of electrons.
792 : !! ne_qFD, nh_qFD= number of electrons (holes resp.) excited in the bands above band
793 : !! index ivalence + 1 (below ivalence resp.)
794 : !! nkpt=number of k points
795 : !! npwarr(nkpt)=number of planewaves at each k point
796 : !! nsppol=1 for unpolarized, 2 for spin-polarized
797 : !! nspinor=Number of spinor components
798 : !! occopt=Occupation options (see input variable)
799 : !! occ(bantot)=occupation numbers
800 : !! tphysel=Physical temperature (input variable)
801 : !! tsmear=Temperature of smearing.
802 : !! wtk(nkpt)=weight assigned to each k point
803 : !! cellcharge=Additional charge added to the unit cell (input variable).
804 : !! kptopt=Option for k-point generation (see input variable)
805 : !! kptrlatt_orig=Original value of kptrlatt given in input
806 : !! nshiftk_orig=Original number of shifts given in input
807 : !! shiftk_orig(3,nshiftk_orig)=Original set of shifts given in input
808 : !! kptrlatt=Value of kptrlatt after inkpts
809 : !! nshiftk=Number of shifts after inkpts
810 : !! shiftk(3,nshiftk)=Set of shifts after inkpts.
811 : !!
812 : !! OUTPUT
813 : !! ebands<ebands_t>=the ebands_t datatype
814 : !!
815 : !! SOURCE
816 :
817 35719 : subroutine ebands_init(ebands, bantot, nelect, ne_qFD, nh_qFD, ivalence, doccde, eig, istwfk, kptns, &
818 35719 : nband, nkpt, npwarr, nsppol, nspinor, tphysel, tsmear, occopt, occ, wtk, &
819 35719 : cellcharge, kptopt, kptrlatt_orig, nshiftk_orig, shiftk_orig, kptrlatt, nshiftk, shiftk)
820 :
821 : !Arguments ------------------------------------
822 : !scalars
823 : class(ebands_t),intent(out) :: ebands
824 : integer,intent(in) :: bantot,nkpt,nsppol,nspinor,occopt,ivalence
825 : real(dp),intent(in) :: nelect,ne_qFD,nh_qFD,tphysel,tsmear
826 : !arrays
827 : integer,intent(in) :: istwfk(nkpt),nband(nkpt*nsppol),npwarr(nkpt)
828 : real(dp),intent(in) :: doccde(bantot),eig(bantot),kptns(3,nkpt),occ(bantot)
829 : real(dp),intent(in) :: wtk(nkpt)
830 : integer,intent(in) :: kptopt, nshiftk_orig, nshiftk
831 : real(dp),intent(in) :: cellcharge
832 : integer,intent(in) :: kptrlatt_orig(3,3),kptrlatt(3,3)
833 : real(dp),intent(in) :: shiftk_orig(3,nshiftk_orig),shiftk(3,nshiftk)
834 : ! *************************************************************************
835 :
836 : ! Copy the scalars
837 : ! MG TODO here there is a inconsistency in the way occ are treated in the header
838 : ! (only the states used, bantot. are saved, and the way occ. and energies
839 : ! are passed to routines (mband,nkpt,nsppol). It might happen that bantot<mband*nktp*nsppol
840 : ! this should not lead to problems since arrays are passed by reference
841 : ! anyway the treatment of these arrays have to be rationalized
842 35719 : ebands%bantot = bantot
843 796265 : ebands%mband = MAXVAL(nband(1:nkpt*nsppol))
844 35719 : ebands%nkpt = nkpt
845 35719 : ebands%nspinor= nspinor
846 35719 : ebands%nsppol = nsppol
847 35719 : ebands%occopt = occopt
848 :
849 35719 : ebands%entropy= zero
850 35719 : ebands%fermie = zero
851 35719 : ebands%fermih = zero
852 35719 : ebands%ivalence =ivalence
853 35719 : ebands%nelect = nelect
854 35719 : ebands%ne_qFD =ne_qFD
855 35719 : ebands%nh_qFD =nh_qFD
856 35719 : ebands%tphysel= tphysel
857 35719 : ebands%tsmear = tsmear
858 :
859 : ! Allocate the components
860 107157 : ABI_MALLOC(ebands%nband, (nkpt*nsppol))
861 107157 : ABI_MALLOC(ebands%istwfk, (nkpt))
862 71438 : ABI_MALLOC(ebands%npwarr, (nkpt))
863 107157 : ABI_MALLOC(ebands%kptns, (3, nkpt))
864 :
865 : ! Copy the arrays
866 796265 : ebands%nband(1:nkpt*nsppol) = nband(1:nkpt*nsppol)
867 781274 : ebands%istwfk(1:nkpt) = istwfk(1:nkpt)
868 781274 : ebands%npwarr(1:nkpt) = npwarr(1:nkpt)
869 3017939 : ebands%kptns(1:3,1:nkpt) = kptns(1:3,1:nkpt)
870 :
871 : ! In ebands, energies and occupations are stored in a matrix (mband,nkpt,nsppol).
872 : ! put_eneocc_vect is used to reshape the values stored in vectorial form.
873 178595 : ABI_MALLOC(ebands%eig , (ebands%mband, nkpt, nsppol))
874 142876 : ABI_MALLOC(ebands%occ , (ebands%mband, nkpt, nsppol))
875 142876 : ABI_MALLOC(ebands%doccde, (ebands%mband, nkpt, nsppol))
876 :
877 35719 : call put_eneocc_vect(ebands,'eig', eig )
878 35719 : call put_eneocc_vect(ebands,'occ', occ )
879 35719 : call put_eneocc_vect(ebands,'doccde',doccde)
880 :
881 107157 : ABI_MALLOC(ebands%wtk, (nkpt))
882 781274 : ebands%wtk(1:nkpt) = wtk(1:nkpt)
883 :
884 35719 : ebands%kptopt = kptopt
885 35719 : ebands%nshiftk_orig = nshiftk_orig
886 35719 : ebands%nshiftk = nshiftk
887 35719 : ebands%cellcharge = cellcharge
888 464347 : ebands%kptrlatt_orig = kptrlatt_orig
889 464347 : ebands%kptrlatt = kptrlatt
890 :
891 35719 : call alloc_copy(shiftk_orig, ebands%shiftk_orig)
892 35719 : call alloc_copy(shiftk, ebands%shiftk)
893 :
894 35719 : end subroutine ebands_init
895 : !!***
896 :
897 : !----------------------------------------------------------------------
898 :
899 : !!****f* m_ebands/ebands_from_hdr
900 : !! NAME
901 : !! ebands_from_hdr
902 : !!
903 : !! FUNCTION
904 : !! This subroutine initializes the ebands_t datatype from the abinit header by
905 : !! calling the main creation method.
906 : !!
907 : !! INPUTS
908 : !! Hdr<hdr_type>=Abinit header.
909 : !! mband=Maximum number of bands.
910 : !! ene3d(mband,Hdr%nkpt,Hdr%nsppol)=Energies.
911 : !! [nelect]=Number of electrons per unit cell.
912 : !! Optional argument that can be used for performing a ridid shift of the fermi level.
913 : !! in the case of metallic occupancies.
914 : !! If not specified, nelect will be initialized from Hdr.
915 : !!
916 : !! SOURCE
917 :
918 3220 : subroutine ebands_from_hdr(ebands, hdr, mband, ene3d, nelect)
919 :
920 : !Arguments ------------------------------------
921 : !scalars
922 : class(ebands_t),intent(out) :: ebands
923 : integer,intent(in) :: mband
924 : type(hdr_type),intent(in) :: hdr
925 : real(dp),optional,intent(in) :: nelect
926 : !arrays
927 : real(dp),intent(in) :: ene3d(mband,hdr%nkpt,hdr%nsppol)
928 :
929 : !Local variables-------------------------------
930 : !scalars
931 : real(dp) :: my_nelect
932 : !arrays
933 3220 : real(dp),allocatable :: ugly_doccde(:),ugly_ene(:)
934 : ! *************************************************************************
935 :
936 3220 : my_nelect = hdr%nelect; if (present(nelect)) my_nelect = nelect
937 :
938 : ! Have to use ugly 1d vectors to call ebands_init
939 483318 : ABI_CALLOC(ugly_doccde, (hdr%bantot))
940 6440 : ABI_MALLOC(ugly_ene, (hdr%bantot))
941 :
942 3220 : call pack_eneocc(hdr%nkpt, hdr%nsppol, mband, hdr%nband, hdr%bantot, ene3d, ugly_ene)
943 :
944 : call ebands%init(hdr%bantot, my_nelect, hdr%ne_qFD, hdr%nh_qFD, hdr%ivalence, &
945 : ugly_doccde, ugly_ene, hdr%istwfk, hdr%kptns, hdr%nband, hdr%nkpt, &
946 : hdr%npwarr, hdr%nsppol, hdr%nspinor, hdr%tphysel, hdr%tsmear, hdr%occopt, hdr%occ, hdr%wtk, &
947 3220 : hdr%cellcharge, hdr%kptopt, hdr%kptrlatt_orig, hdr%nshiftk_orig, hdr%shiftk_orig, hdr%kptrlatt, hdr%nshiftk, hdr%shiftk)
948 :
949 : ! Copy the fermi level reported in the header
950 3220 : ebands%fermie = hdr%fermie
951 3220 : ebands%fermih = hdr%fermih
952 :
953 3220 : ABI_FREE(ugly_doccde)
954 3220 : ABI_FREE(ugly_ene)
955 :
956 3220 : end subroutine ebands_from_hdr
957 : !!***
958 :
959 : !----------------------------------------------------------------------
960 :
961 : !!****f* m_ebands/ebands_from_dtset
962 : !! NAME
963 : !! ebands_from_dtset
964 : !!
965 : !! FUNCTION
966 : !! Build and return a new ebands_t datatype. Dimensions are taken from the abinit dataset.
967 : !!
968 : !! INPUTS
969 : !! dtset<dataset_type>=Abinit dataset
970 : !! npwarr(dtset%nkpt)=Number of G-vectors for each k-point.
971 : !! [nband]= If present, use these values instead of dtset%nband
972 : !!
973 : !! OUTPUT
974 : !! ebands<ebands_t>=The ebands_t datatype completely initialized.
975 : !! The Fermi level and the entropy are set to zero.
976 : !!
977 : !! SOURCE
978 :
979 6436 : subroutine ebands_from_dtset(new, dtset, npwarr, nband)
980 :
981 : !Arguments ------------------------------------
982 : !scalars
983 : class(ebands_t),intent(out) :: new
984 : type(dataset_type),target,intent(in) :: dtset
985 : integer,target,optional,intent(in) :: nband(dtset%nkpt * dtset%nsppol)
986 : !arrays
987 : integer,intent(in) :: npwarr(dtset%nkpt)
988 :
989 : !Local variables-------------------------------
990 : !scalars
991 : integer :: bantot
992 : !arrays
993 6436 : real(dp),allocatable :: ugly_doccde(:), ugly_ene(:), ugly_occ(:)
994 6436 : integer,pointer :: nband__(:)
995 : ! *************************************************************************
996 :
997 6436 : nband__ => dtset%nband; if (present(nband)) nband__ => nband
998 :
999 : ! Have to use ugly 1d vectors to call ebands_init
1000 189904 : bantot = sum(nband__)
1001 822848 : ABI_CALLOC(ugly_doccde, (bantot))
1002 822848 : ABI_CALLOC(ugly_ene, (bantot))
1003 822848 : ABI_CALLOC(ugly_occ, (bantot))
1004 :
1005 : call new%init(bantot, dtset%nelect, dtset%ne_qFD, dtset%nh_qFD, dtset%ivalence, ugly_doccde, ugly_ene, &
1006 : dtset%istwfk, dtset%kptns, nband__, dtset%nkpt, &
1007 : npwarr, dtset%nsppol, dtset%nspinor, dtset%tphysel, dtset%tsmear, dtset%occopt, ugly_occ, dtset%wtk,&
1008 : dtset%cellcharge(1), dtset%kptopt, dtset%kptrlatt_orig, dtset%nshiftk_orig, dtset%shiftk_orig, &
1009 6436 : dtset%kptrlatt, dtset%nshiftk, dtset%shiftk)
1010 :
1011 : !new%extrael = dtset%eph_extrael
1012 :
1013 6436 : ABI_FREE(ugly_doccde)
1014 6436 : ABI_FREE(ugly_ene)
1015 6436 : ABI_FREE(ugly_occ)
1016 :
1017 6436 : end subroutine ebands_from_dtset
1018 : !!***
1019 :
1020 : !----------------------------------------------------------------------
1021 :
1022 : !!****f* m_ebands/ebands_free
1023 : !! NAME
1024 : !! ebands_free
1025 : !!
1026 : !! FUNCTION
1027 : !! Deallocates the components of the ebands_t structured datatype
1028 : !!
1029 : !! SOURCE
1030 :
1031 37442 : subroutine ebands_free(ebands)
1032 :
1033 : !Arguments ------------------------------------
1034 : class(ebands_t),intent(inout) :: ebands
1035 : ! *************************************************************************
1036 :
1037 37442 : ABI_SFREE(ebands%istwfk)
1038 37442 : ABI_SFREE(ebands%nband)
1039 37442 : ABI_SFREE(ebands%npwarr)
1040 37442 : ABI_SFREE(ebands%kptns)
1041 37442 : ABI_SFREE(ebands%eig)
1042 37442 : ABI_SFREE(ebands%linewidth)
1043 37442 : ABI_SFREE(ebands%occ)
1044 37442 : ABI_SFREE(ebands%doccde)
1045 37442 : ABI_SFREE(ebands%wtk)
1046 37442 : ABI_SFREE(ebands%shiftk_orig)
1047 37442 : ABI_SFREE(ebands%shiftk)
1048 :
1049 37442 : end subroutine ebands_free
1050 : !!***
1051 :
1052 : !----------------------------------------------------------------------
1053 :
1054 : !!****f* m_ebands/ebands_copy
1055 : !! NAME
1056 : !! ebands_copy
1057 : !!
1058 : !! FUNCTION
1059 : !! This subroutine performs a deep copy of an ebands_t datatype.
1060 : !!
1061 : !! INPUTS
1062 : !! ibands<ebands_t>=The data type to be copied.
1063 : !!
1064 : !! OUTPUT
1065 : !! obands<ebands_t>=The copy.
1066 : !!
1067 : !! SOURCE
1068 :
1069 701 : subroutine ebands_copy(ibands, obands)
1070 :
1071 : !Arguments ------------------------------------
1072 : !scalars
1073 : class(ebands_t),intent(in) :: ibands
1074 : class(ebands_t),intent(out) :: obands
1075 : ! *********************************************************************
1076 :
1077 701 : call obands%free()
1078 :
1079 : ! Copy scalars
1080 701 : obands%bantot = ibands%bantot
1081 701 : obands%ivalence = ibands%ivalence
1082 701 : obands%mband = ibands%mband
1083 701 : obands%nkpt = ibands%nkpt
1084 701 : obands%nspinor = ibands%nspinor
1085 701 : obands%nsppol = ibands%nsppol
1086 701 : obands%occopt = ibands%occopt
1087 701 : obands%kptopt = ibands%kptopt
1088 701 : obands%nshiftk_orig = ibands%nshiftk_orig
1089 701 : obands%nshiftk = ibands%nshiftk
1090 :
1091 701 : obands%cellcharge = ibands%cellcharge
1092 701 : obands%extrael = ibands%extrael
1093 701 : obands%entropy = ibands%entropy
1094 701 : obands%fermie = ibands%fermie
1095 701 : obands%fermih = ibands%fermih
1096 701 : obands%nelect = ibands%nelect
1097 701 : obands%ne_qFD = ibands%ne_qFD
1098 701 : obands%nh_qFD = ibands%nh_qFD
1099 701 : obands%tphysel = ibands%tphysel
1100 701 : obands%tsmear = ibands%tsmear
1101 :
1102 9113 : obands%kptrlatt_orig = ibands%kptrlatt_orig
1103 9113 : obands%kptrlatt = ibands%kptrlatt
1104 :
1105 : ! Copy allocatable arrays
1106 : ! integer
1107 701 : call alloc_copy(ibands%istwfk, obands%istwfk)
1108 701 : call alloc_copy(ibands%nband , obands%nband )
1109 701 : call alloc_copy(ibands%npwarr, obands%npwarr)
1110 :
1111 : ! real
1112 701 : call alloc_copy(ibands%kptns , obands%kptns )
1113 701 : call alloc_copy(ibands%eig , obands%eig )
1114 701 : call alloc_copy(ibands%occ , obands%occ )
1115 701 : call alloc_copy(ibands%doccde, obands%doccde)
1116 701 : call alloc_copy(ibands%wtk , obands%wtk )
1117 701 : call alloc_copy(ibands%shiftk_orig, obands%shiftk_orig)
1118 701 : call alloc_copy(ibands%shiftk, obands%shiftk)
1119 :
1120 701 : if (allocated(ibands%linewidth)) call alloc_copy(ibands%linewidth, obands%linewidth)
1121 :
1122 701 : end subroutine ebands_copy
1123 : !!***
1124 :
1125 : !----------------------------------------------------------------------
1126 :
1127 : !!****f* m_ebands/ebands_move_alloc
1128 : !! NAME
1129 : !! ebands_move_alloc
1130 : !!
1131 : !! FUNCTION
1132 : !! Transfer allocate from `from_ebands` to `to_ebands`.
1133 : !! `from_ebands` is destroyed when the routine returns.
1134 : !!
1135 : !! SOURCE
1136 :
1137 1 : subroutine ebands_move_alloc(from_ebands, to_ebands)
1138 :
1139 : !Arguments ------------------------------------
1140 : class(ebands_t),intent(inout) :: from_ebands
1141 : class(ebands_t),intent(inout) :: to_ebands
1142 : ! *********************************************************************
1143 :
1144 1 : call to_ebands%free()
1145 1 : call from_ebands%copy(to_ebands)
1146 1 : call from_ebands%free()
1147 :
1148 1 : end subroutine ebands_move_alloc
1149 : !!***
1150 :
1151 : !----------------------------------------------------------------------
1152 :
1153 : !!****f* m_ebands/ebands_print
1154 : !! NAME
1155 : !! ebands_print
1156 : !!
1157 : !! FUNCTION
1158 : !! Print the content of the object.
1159 : !!
1160 : !! INPUTS
1161 : !! units=Unit numbers
1162 : !! [header]=title for info
1163 : !! [prtvol]=Verbosity level (default: 0)
1164 : !!
1165 : !! OUTPUT
1166 : !! Only writing
1167 : !!
1168 : !! SOURCE
1169 :
1170 294 : subroutine ebands_print(ebands, units, header, prtvol)
1171 :
1172 : !Arguments ------------------------------------
1173 : class(ebands_t),intent(in) :: ebands
1174 : integer,intent(in) :: units(:)
1175 : integer,optional,intent(in) :: prtvol
1176 : character(len=*),optional,intent(in) :: header
1177 :
1178 : !Local variables-------------------------------
1179 : integer :: spin, ikpt, my_prtvol, ii
1180 : character(len=500) :: msg
1181 : ! *************************************************************************
1182 :
1183 147 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
1184 :
1185 147 : msg = ' ==== Info on the ebands_t ==== '
1186 147 : if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
1187 147 : call wrtout(units, msg)
1188 :
1189 : write(msg,'(6(a,i0,a))')&
1190 147 : ' Number of spinorial components ...... ',ebands%nspinor,ch10,&
1191 147 : ' Number of spin polarizations ........ ',ebands%nsppol,ch10,&
1192 147 : ' Number of k-points in the IBZ ....... ',ebands%nkpt,ch10,&
1193 147 : ' kptopt .............................. ',ebands%kptopt,ch10,&
1194 147 : ' Maximum number of bands ............. ',ebands%mband,ch10,&
1195 294 : ' Occupation option ................... ',ebands%occopt,ch10
1196 147 : call wrtout(units, msg)
1197 :
1198 147 : write(msg,"(2a)")" kptrlatt .............. ",trim(ltoa(reshape(ebands%kptrlatt, [9])))
1199 147 : call wrtout(units, msg)
1200 294 : write(msg,"(2a)")" shiftk ................ ",trim(ltoa(reshape(ebands%shiftk, [3 * ebands%nshiftk])))
1201 147 : call wrtout(units, msg)
1202 :
1203 : write(msg,'(3(a,f14.2,a),4(a,f14.6,a))')&
1204 147 : ' Number of valence electrons ......... ',ebands%nelect,ch10,&
1205 147 : ' Extra cell charge (from GS run)...... ',ebands%cellcharge,ch10,&
1206 147 : ' Extra electrons (after GS run)....... ',ebands%extrael,ch10,&
1207 147 : ' Fermi level ........................ ',ebands%fermie,ch10,&
1208 147 : ' Entropy ............................. ',ebands%entropy,ch10,&
1209 147 : ' Tsmear value ........................ ',ebands%tsmear,ch10,&
1210 294 : ' Tphysel value ....................... ',ebands%tphysel,ch10
1211 147 : call wrtout(units, msg)
1212 :
1213 147 : if (my_prtvol > 10) then
1214 0 : if (ebands%nsppol == 1)then
1215 0 : call wrtout(units, sjoin(' New occ. numbers for occopt= ', itoa(ebands%occopt),' , spin-unpolarized case.'))
1216 : end if
1217 :
1218 0 : do spin=1,ebands%nsppol
1219 0 : if (ebands%nsppol == 2) then
1220 0 : write(msg,'(a,i9,a,i0)')' New occ. numbers for occopt= ',ebands%occopt,', spin ',spin
1221 0 : call wrtout(units, msg)
1222 : end if
1223 :
1224 0 : do ikpt=1,ebands%nkpt
1225 0 : write(msg,'(2a,i4,3a,f6.3,2a)')ch10,&
1226 0 : ' k-point number ',ikpt,') ',trim(ktoa(ebands%kptns(:,ikpt))),'; weight: ',ebands%wtk(ikpt), ch10, &
1227 0 : " eig (Ha), eig (eV), occ, doccde"
1228 0 : call wrtout(units, msg)
1229 0 : do ii=1,ebands%nband(ikpt+(spin-1)*ebands%nkpt)
1230 0 : write(msg,'(4(f7.3,1x))')ebands%eig(ii,ikpt,spin), ebands%eig(ii,ikpt,spin) * Ha_eV, &
1231 0 : ebands%occ(ii,ikpt,spin), ebands%doccde(ii,ikpt,spin)
1232 0 : call wrtout(units, msg)
1233 : end do
1234 : end do !ikpt
1235 :
1236 : end do !spin
1237 :
1238 : end if !my_prtvol
1239 :
1240 147 : end subroutine ebands_print
1241 : !!***
1242 :
1243 : !----------------------------------------------------------------------
1244 :
1245 : !!****f* m_ebands/unpack_eneocc
1246 : !! NAME
1247 : !! unpack_eneocc
1248 : !!
1249 : !! FUNCTION
1250 : !! Helper function to do a reshape of (energies|occupancies|derivate of occupancies)
1251 : !! initially stored in a vector. Return a 3D array index by (band,ikpt,spin)
1252 : !!
1253 : !! INPUTS
1254 : !! nkpt=number of k-points
1255 : !! nsppol=number of spin polarizations
1256 : !! mband=Max number of bands over k-points (just to dimension the output)
1257 : !! nbands(nkpt*nsppol)=Number of bands at eack k and spin
1258 : !! vect(:)=The input values to reshape
1259 : !! [val]=Optional value used to initialize the array.
1260 : !!
1261 : !! OUTPUT
1262 : !! array3d(mband,nkpt,nsppol)=Arrays containing the values of vect.
1263 : !! Note that the first dimension is usually larger than the
1264 : !! number of bands really used for a particular k-point and spin.
1265 : !!
1266 : !! SOURCE
1267 :
1268 118727 : subroutine unpack_eneocc(nkpt,nsppol,mband,nband,vect,array3d,val)
1269 :
1270 : !Arguments ------------------------------------
1271 : !scalars
1272 : integer,intent(in) :: nkpt,nsppol,mband
1273 : real(dp),optional,intent(in) :: val
1274 : !arrays
1275 : integer,intent(in) :: nband(nkpt*nsppol)
1276 : real(dp),intent(in) :: vect(:)
1277 : real(dp),intent(out) :: array3d(mband,nkpt,nsppol)
1278 :
1279 : !Local variables-------------------------------
1280 : integer :: spin,ikpt,band,idx
1281 : ! *************************************************************************
1282 :
1283 118727 : if (present(val)) then
1284 20160264 : array3d = val
1285 : else
1286 808420 : array3d = huge(one)
1287 : end if
1288 :
1289 : idx=0
1290 : ! elements in vect are packed in the first positions.
1291 247660 : do spin=1,nsppol
1292 3011422 : do ikpt=1,nkpt
1293 20846751 : do band=1,nband(ikpt + (spin-1)*nkpt)
1294 17954056 : idx = idx + 1
1295 20717818 : array3d(band, ikpt, spin) = vect(idx)
1296 : end do
1297 : end do
1298 : end do
1299 :
1300 118727 : end subroutine unpack_eneocc
1301 : !!***
1302 :
1303 : !----------------------------------------------------------------------
1304 :
1305 : !!****f* m_ebands/pack_eneocc
1306 : !! NAME
1307 : !! pack_eneocc
1308 : !!
1309 : !! FUNCTION
1310 : !! Helper function to do a reshape of (energies|occupancies|derivate of occupancies)
1311 : !! initially stored in a 3D arrays returning a vector.
1312 : !!
1313 : !! INPUTS
1314 : !! nkpt=number of k-points
1315 : !! nsppol=number of spin polarizations
1316 : !! mband=Max number of bands over k-points (just to dimension the output)
1317 : !! nbands(nkpt*nsppol)=Number of bands at eack k and spin
1318 : !! bantot=Total number of bands
1319 : !! array3d(mband,nkpt,nsppol)=Arrays containing the values to reshape.
1320 : !!
1321 : !! OUTPUT
1322 : !! vect(bantot)=The input values stored in vector mode. Only the values really
1323 : !! considered at each k-point and spin are copied.
1324 : !!
1325 : !! SOURCE
1326 :
1327 3698 : subroutine pack_eneocc(nkpt, nsppol, mband, nband, bantot, array3d, vect)
1328 :
1329 : !Arguments ------------------------------------
1330 : !scalars
1331 : integer,intent(in) :: nkpt,nsppol,mband,bantot
1332 : !arrays
1333 : integer,intent(in) :: nband(nkpt*nsppol)
1334 : real(dp),intent(in) :: array3d(mband,nkpt,nsppol)
1335 : real(dp),intent(out) :: vect(bantot)
1336 :
1337 : !Local variables-------------------------------
1338 : integer :: spin,ikpt,band,idx
1339 : ! *************************************************************************
1340 :
1341 1054801 : vect(:)=zero
1342 : idx=0
1343 7716 : do spin=1,nsppol
1344 116075 : do ikpt=1,nkpt
1345 1163480 : do band=1,nband(ikpt+(spin-1)*nkpt)
1346 1051103 : idx=idx+1
1347 1159462 : vect(idx)=array3d(band,ikpt,spin)
1348 : end do
1349 : end do
1350 : end do
1351 :
1352 3698 : end subroutine pack_eneocc
1353 : !!***
1354 :
1355 : !----------------------------------------------------------------------
1356 :
1357 : !!****f* m_ebands/get_eneocc_vect
1358 : !! NAME
1359 : !! get_eneocc_vect
1360 : !!
1361 : !! FUNCTION
1362 : !! Retrieve energies or occupations from a ebands_t structure accessing by name.
1363 : !! Results are reported in a vector to facilitate the interface with other abinit routines.
1364 : !!
1365 : !! INPUTS
1366 : !! ebands<ebands_t>The type containing the data.
1367 : !! arr_name=The name of the quantity to retrieve. Allowed values are
1368 : !! == "eig" == For the eigenvalues.
1369 : !! == "occ" == For the occupation numbers.
1370 : !! == "doccde" == For the derivative of the occupancies wrt the energy.
1371 : !!
1372 : !! OUTPUT
1373 : !! vect(ebands%bantot)=The values required.
1374 : !!
1375 : !! SOURCE
1376 :
1377 445 : subroutine get_eneocc_vect(ebands, arr_name, vect)
1378 :
1379 : !Arguments ------------------------------------
1380 : !scalars
1381 : class(ebands_t),intent(in) :: ebands
1382 : character(len=*),intent(in) :: arr_name
1383 : real(dp),intent(out) :: vect(ebands%bantot)
1384 :
1385 : !Local variables-------------------------------
1386 : integer :: nkpt,nsppol,mband,bantot
1387 : ! *************************************************************************
1388 :
1389 445 : mband = ebands%mband; bantot = ebands%bantot; nkpt = ebands%nkpt; nsppol = ebands%nsppol
1390 :
1391 97 : select case (arr_name)
1392 : case ('occ')
1393 97 : call pack_eneocc(nkpt, nsppol, mband, ebands%nband, bantot, ebands%occ, vect)
1394 : case ('eig')
1395 348 : call pack_eneocc(nkpt,nsppol,mband,ebands%nband,bantot,ebands%eig, vect)
1396 : case ('doccde')
1397 0 : call pack_eneocc(nkpt,nsppol,mband,ebands%nband,bantot,ebands%doccde,vect)
1398 : case default
1399 445 : ABI_BUG(sjoin('Wrong arr_name:', arr_name))
1400 : end select
1401 :
1402 445 : end subroutine get_eneocc_vect
1403 : !!***
1404 :
1405 : !----------------------------------------------------------------------
1406 :
1407 : !!****f* m_ebands/put_eneocc_vect
1408 : !! NAME
1409 : !! put_eneocc_vect
1410 : !!
1411 : !! FUNCTION
1412 : !! Update the energies or the occupations stored in a ebands_t structure.
1413 : !! The input values are stored in a vector according to the abinit convention
1414 : !! In the data type, on the contrary, we use 3D arrays (mband,nkpt,nsspol)
1415 : !! which are much easier to use inside loops.
1416 : !!
1417 : !! INPUTS
1418 : !! vect(ebands%bantot)=The new values to be stored in the structure.
1419 : !! arr_name=The name of the quantity to be saved (CASE insensitive).
1420 : !! Allowed values are
1421 : !! == "eig" == For the eigenvalues.
1422 : !! == "occ" == For the occupation numbers.
1423 : !! == "doccde" == For the derivative of the occupancies wrt the energy.
1424 : !!
1425 : !! OUTPUT
1426 : !! See SIDE EFFECTS
1427 : !!
1428 : !! SIDE EFFECTS
1429 : !! ebands<ebands_t>=The object with updated values depending on the value of arr_name
1430 : !!
1431 : !! SOURCE
1432 :
1433 112548 : subroutine put_eneocc_vect(ebands, arr_name, vect)
1434 :
1435 : !Arguments ------------------------------------
1436 : !scalars
1437 : class(ebands_t),intent(inout) :: ebands
1438 : character(len=*),intent(in) :: arr_name
1439 : real(dp),intent(in) :: vect(:)
1440 :
1441 : !Local variables-------------------------------
1442 : integer :: nkpt,nsppol,mband,bantot
1443 : real(dp) :: val
1444 : ! *************************************************************************
1445 :
1446 112548 : mband = ebands%mband; bantot = ebands%bantot; nkpt= ebands%nkpt; nsppol = ebands%nsppol
1447 :
1448 261163 : select case (tolower(arr_name))
1449 : case ('occ')
1450 36067 : call unpack_eneocc(nkpt,nsppol,mband,ebands%nband,vect,ebands%occ, val=zero)
1451 : case ('eig')
1452 : ! DFPT routines call ebands_init with the wrong bantot. Using maxval(vect) causes SEGFAULT
1453 : ! so I have to recompute the correct bantot here
1454 : !ABI_CHECK(sum(ebands%nband) == ebands%bantot, "bantot and nband are inconsistent")
1455 7684384 : val = maxval(vect(1:sum(ebands%nband)))
1456 40414 : call unpack_eneocc(nkpt,nsppol,mband,ebands%nband,vect,ebands%eig, val=val)
1457 : case ('doccde')
1458 36067 : call unpack_eneocc(nkpt,nsppol,mband,ebands%nband,vect,ebands%doccde, val=zero)
1459 : case default
1460 112548 : ABI_BUG(sjoin('Wrong arr_name= ', arr_name))
1461 : end select
1462 :
1463 112548 : end subroutine put_eneocc_vect
1464 : !!***
1465 :
1466 : !----------------------------------------------------------------------
1467 :
1468 : !!****f* m_ebands/ebands_get_bandenergy
1469 : !! NAME
1470 : !! ebands_get_bandenergy
1471 : !!
1472 : !! FUNCTION
1473 : !! Return the band energy (weighted sum of occupied eigenvalues)
1474 : !!
1475 : !! INPUTS
1476 : !!
1477 : !! OUTPUT
1478 : !!
1479 : !! NOTES
1480 : !! TODO Likely this expression is not accurate since it is not variatonal
1481 : !! One should use
1482 : !! band_energy = \int e N(e) de for e<Ef , where N(e) is the e-DOS
1483 : !!
1484 : !! SOURCE
1485 :
1486 76 : pure real(dp) function ebands_get_bandenergy(ebands) result(band_energy)
1487 :
1488 : !Arguments ------------------------------------
1489 : !scalars
1490 : class(ebands_t),intent(in) :: ebands
1491 :
1492 : !Local variables-------------------------------
1493 : integer :: spin,ikibz,nband_k
1494 : real(dp) :: wtk
1495 : ! *********************************************************************
1496 :
1497 76 : band_energy=zero
1498 154 : do spin=1,ebands%nsppol
1499 607 : do ikibz=1,ebands%nkpt
1500 453 : wtk=ebands%wtk(ikibz)
1501 453 : nband_k=ebands%nband(ikibz+(spin-1)*ebands%nkpt)
1502 5787 : band_energy = band_energy + wtk*SUM( ebands%eig(1:nband_k,ikibz,spin)*ebands%occ(1:nband_k,ikibz,spin) )
1503 : end do
1504 : end do
1505 :
1506 76 : end function ebands_get_bandenergy
1507 : !!***
1508 :
1509 : !!****f* m_ebands/ebands_get_valence_idx
1510 : !! NAME
1511 : !! ebands_get_valence_idx
1512 : !!
1513 : !! FUNCTION
1514 : !! For each k-point and spin polarisation, report:
1515 : !!
1516 : !! 1) the index of the valence in case of semiconductors at T = 0
1517 : !! 2) (band_k - 1) where band_k is the first band whose energy is > Fermi energy + told_fermi
1518 : !!
1519 : !! using the value of the Fermi level.
1520 : !!
1521 : !! INPUTS
1522 : !! ebands<ebands_t>=The object describing the band structure.
1523 : !! tol_fermi[optional]
1524 : !!
1525 : !! OUTPUT
1526 : !!
1527 : !! SOURCE
1528 :
1529 7324 : pure function ebands_get_valence_idx(ebands, tol_fermi) result(val_idx)
1530 :
1531 : !Arguments ------------------------------------
1532 : !scalars
1533 : class(ebands_t),intent(in) :: ebands
1534 : real(dp),optional,intent(in) :: tol_fermi
1535 : !arrays
1536 : integer :: val_idx(ebands%nkpt,ebands%nsppol)
1537 :
1538 : !Local variables-------------------------------
1539 : integer :: band,ikpt,spin,idx,nband_k
1540 : real(dp) :: tol_
1541 : ! *************************************************************************
1542 :
1543 7324 : tol_ = tol6; if (present(tol_fermi)) tol_ = tol_fermi
1544 :
1545 15222 : do spin=1,ebands%nsppol
1546 108316 : do ikpt=1,ebands%nkpt
1547 100992 : if (ebands%occopt == 9) then
1548 10 : val_idx(ikpt,spin) = ebands%ivalence
1549 : else
1550 93084 : nband_k = ebands%nband(ikpt+(spin-1)*ebands%nkpt)
1551 93084 : idx = 0
1552 426755 : do band=1,nband_k
1553 426755 : if (ebands%eig(band,ikpt,spin) > ebands%fermie + abs(tol_)) then
1554 : idx = band; exit
1555 : end if
1556 : end do
1557 93084 : val_idx(ikpt,spin) = idx - 1
1558 93084 : if (idx == 1) val_idx(ikpt, spin) = idx
1559 93084 : if (idx == 0) val_idx(ikpt, spin) = nband_k
1560 : end if
1561 : end do
1562 : end do
1563 :
1564 7324 : end function ebands_get_valence_idx
1565 : !!***
1566 :
1567 : !!****f* m_ebands/ebands_get_bands_from_erange
1568 : !! NAME
1569 : !! ebands_get_bands_from_erange
1570 : !!
1571 : !! FUNCTION
1572 : !! Return the indices of the min and max band index within an energy window.
1573 : !!
1574 : !! INPUTS
1575 : !! elow, ehigh: Min and max energy
1576 : !!
1577 : !! OUTPUT
1578 : !! bstart, bstop: Min and max band index. Initialized to bstart = huge(1); bstop = -huge(1)
1579 : !!
1580 : !! SOURCE
1581 :
1582 25 : pure subroutine ebands_get_bands_from_erange(ebands, elow, ehigh, bstart, bstop)
1583 :
1584 : !Arguments ------------------------------------
1585 : !scalars
1586 : class(ebands_t),intent(in) :: ebands
1587 : real(dp),intent(in) :: elow, ehigh
1588 : integer,intent(out) :: bstart, bstop
1589 :
1590 : !Local variables-------------------------------
1591 : integer :: band, ik, spin
1592 : ! *************************************************************************
1593 :
1594 25 : bstart = huge(1); bstop = -huge(1)
1595 50 : do spin=1,ebands%nsppol
1596 3648 : do ik=1,ebands%nkpt
1597 35069 : do band=1,ebands%nband(ik + (spin - 1) * ebands%nkpt)
1598 35044 : if (ebands%eig(band, ik , spin) >= elow .and. ebands%eig(band, ik , spin) <= ehigh) then
1599 767 : bstart = min(bstart, band)
1600 767 : bstop = max(bstop, band)
1601 : end if
1602 : end do
1603 : end do
1604 : end do
1605 :
1606 25 : end subroutine ebands_get_bands_from_erange
1607 : !!***
1608 :
1609 : !!****f* m_ebands/ebands_vcbm_range_from_gaps
1610 : !! NAME
1611 : !! ebands_vcbm_range_from_gaps
1612 : !!
1613 : !! FUNCTION
1614 : !! Find band and energy range for states close to the CBM/VBM given input energies in ebands and gaps.
1615 : !! Return exit status and error message in msg.
1616 : !!
1617 : !! INPUTS
1618 : !! gaps<gaps_t>=Object with info on the gaps.
1619 : !! erange(2)=Energy range for holes and electrons. Only those states whose relative position
1620 : !! wrt to the VBM/CBM is <= than erange are included. Note that relative positions are always
1621 : !! positive (even for holes). Use a negative value to exclude either holes or electrons.
1622 : !!
1623 : !! OUTPUT
1624 : !! e_lowhigh(2)=min and Max energy.
1625 : !! band_lowhigh=min and Max band index.
1626 : !! [ks_range]: For each spin and k-point, the min and max band index included in the output set.
1627 : !! if (ik, spin) is not included then ib_work(1, ik, spin) > ib_work(2, ik, spin) = -huge(1)
1628 : !!
1629 : !! SOURCE
1630 :
1631 0 : integer function ebands_vcbm_range_from_gaps(ebands, gaps, erange, e_lowhigh, band_lowhigh, ks_range, msg) result(ierr)
1632 :
1633 : !Arguments ------------------------------------
1634 : !scalars
1635 : class(ebands_t),intent(in) :: ebands
1636 : class(gaps_t),intent(in) :: gaps
1637 : real(dp),intent(in) :: erange(2)
1638 : real(dp),intent(out) :: e_lowhigh(2)
1639 : integer,intent(out) :: band_lowhigh(2)
1640 : integer,optional,intent(out) :: ks_range(2, ebands%nkpt, ebands%nsppol)
1641 : character(len=*),intent(out) :: msg
1642 :
1643 : !Local variables-------------------------------
1644 : integer :: band, ik, spin, band_low, band_high
1645 : real(dp) :: cmin, vmax, ee, elow, ehigh
1646 0 : integer,allocatable :: ib_work(:,:,:)
1647 : ! *************************************************************************
1648 :
1649 0 : ABI_MALLOC(ib_work, (2, ebands%nkpt, ebands%nsppol))
1650 0 : elow = huge(one); ehigh = -huge(one)
1651 0 : band_low = huge(1); band_high = -huge(1)
1652 :
1653 0 : ierr = 1
1654 0 : do spin=1,ebands%nsppol
1655 : ! Get cmb and vbm with some tolerance
1656 0 : vmax = gaps%vb_max(spin) + tol2 * eV_Ha
1657 0 : cmin = gaps%cb_min(spin) - tol2 * eV_Ha
1658 0 : do ik=1,ebands%nkpt
1659 0 : ib_work(1, ik, spin) = huge(1)
1660 0 : ib_work(2, ik, spin) = -huge(1)
1661 0 : do band=1,ebands%nband(ik+(spin-1)*ebands%nkpt)
1662 0 : ee = ebands%eig(band, ik, spin)
1663 0 : if (erange(1) > zero) then
1664 0 : if (ee <= vmax .and. vmax - ee <= erange(1)) then
1665 0 : ib_work(1, ik, spin) = min(ib_work(1, ik, spin), band)
1666 0 : ib_work(2, ik, spin) = max(ib_work(2, ik, spin), band)
1667 0 : elow = min(elow, ee); ehigh = max(ehigh, ee)
1668 0 : band_low = min(band_low, band); band_high = max(band_high, band)
1669 : !write(std_out, *), "Adding valence", band
1670 : end if
1671 : end if
1672 0 : if (erange(2) > zero) then
1673 0 : if (ee >= cmin .and. ee - cmin <= erange(2)) then
1674 0 : ib_work(1, ik, spin) = min(ib_work(1, ik, spin), band)
1675 0 : ib_work(2, ik, spin) = max(ib_work(2, ik, spin), band)
1676 0 : elow = min(elow, ee); ehigh = max(ehigh, ee)
1677 0 : band_low = min(band_low, band); band_high = max(band_high, band)
1678 : !write(std_out, *)"Adding conduction", band
1679 : end if
1680 : end if
1681 : end do
1682 : end do
1683 : end do
1684 :
1685 0 : e_lowhigh = [elow, ehigh]
1686 0 : band_lowhigh = [band_low, band_high]
1687 :
1688 0 : if (present(ks_range)) ks_range = ib_work
1689 0 : ABI_FREE(ib_work)
1690 :
1691 : ! Set exit status and msg. Caller will handle it.
1692 0 : ierr = 0; msg = ""
1693 0 : if (elow > ehigh) then
1694 0 : ierr = 1
1695 0 : write(msg, *)"Cannot find states close to the band edges with erange: ", erange
1696 : end if
1697 :
1698 0 : end function ebands_vcbm_range_from_gaps
1699 : !!***
1700 :
1701 : !----------------------------------------------------------------------
1702 :
1703 : !!****f* m_ebands/ebands_apply_scissors
1704 : !! NAME
1705 : !! ebands_apply_scissors
1706 : !!
1707 : !! FUNCTION
1708 : !! Apply a scissor operator of amplitude scissor_energy.
1709 : !!
1710 : !! INPUTS
1711 : !! scissor_energy=The energy shift in Hartree.
1712 : !!
1713 : !! OUTPUT
1714 : !!
1715 : !! SIDE EFFECT
1716 : !! ebands<ebands_t>=The following quantities are modified:
1717 : !! %eig(mband,nkpt,nsppol)=The band structure after the application of the scissor operator
1718 : !! %fermi_energy
1719 : !!
1720 : !! SOURCE
1721 :
1722 34 : subroutine ebands_apply_scissors(ebands, scissor_energy)
1723 :
1724 : !Arguments ------------------------------------
1725 : !scalars
1726 : real(dp),intent(in) :: scissor_energy
1727 : class(ebands_t),intent(inout) :: ebands
1728 :
1729 : !Local variables-------------------------------
1730 : integer :: ikpt,spin,ival,nband_k
1731 : real(dp) :: spinmagntarget_
1732 : character(len=500) :: msg
1733 : !arrays
1734 68 : integer :: val_idx(ebands%nkpt,ebands%nsppol)
1735 : ! *************************************************************************
1736 :
1737 : ! Get the valence band index for each k and spin
1738 34 : val_idx(:,:) = ebands_get_valence_idx(ebands)
1739 :
1740 69 : do spin=1,ebands%nsppol
1741 1226 : if (any(val_idx(:, spin) /= val_idx(1, spin))) then
1742 : write(msg,'(a,i0,a)')&
1743 0 : 'Trying to apply a scissor operator on a metallic band structure for spin: ',spin,&
1744 0 : 'Assuming you know what you are doing, continuing anyway!'
1745 0 : ABI_COMMENT(msg)
1746 : !Likely newocc will stop, unless the system is semimetallic ?
1747 : end if
1748 : end do
1749 :
1750 : ! Apply the scissor
1751 69 : do spin=1,ebands%nsppol
1752 1226 : do ikpt=1,ebands%nkpt
1753 1157 : nband_k = ebands%nband(ikpt+(spin-1)*ebands%nkpt)
1754 1157 : ival = val_idx(ikpt,spin)
1755 :
1756 1192 : if (nband_k >= ival+1) then
1757 4567 : ebands%eig(ival+1:,ikpt,spin) = ebands%eig(ival+1:,ikpt,spin) + scissor_energy
1758 : else
1759 : write(msg,'(2a,4(a,i0))')&
1760 0 : 'Not enough bands to apply the scissor operator. ',ch10,&
1761 0 : 'spin: ',spin,' ikpt: ',ikpt,' nband_k: ',nband_k,' but valence index: ',ival
1762 0 : ABI_ERROR(msg)
1763 : end if
1764 :
1765 : end do
1766 : end do
1767 :
1768 : ! Recalculate the Fermi level and occupation factors.
1769 : ! For Semiconductors only the Fermi level is changed (in the middle of the new gap)
1770 34 : spinmagntarget_ = -99.99_dp !?; if (PRESENT(spinmagntarget)) spinmagntarget_=spinmagntarget
1771 34 : call ebands%update_occ(spinmagntarget_)
1772 :
1773 34 : end subroutine ebands_apply_scissors
1774 : !!***
1775 :
1776 : !----------------------------------------------------------------------
1777 :
1778 : !!****f* m_ebands/ebands_read_qpdata
1779 : !! NAME
1780 : !! ebands_read_qpdata
1781 : !!
1782 : !! FUNCTION
1783 : !! Read quasi-particle energies from QPDATA file, update %eig and %fermi_energy
1784 : !! The QPDATA is a text file usually produced by a python post-processing script
1785 : !!
1786 : !! INPUTS
1787 : !!
1788 : !! SIDE EFFECT
1789 : !! ebands<ebands_t>=The following quantities are modified:
1790 : !! %eig(mband,nkpt,nsppol)=The band structure after the application of the scissor operator
1791 : !! %fermi_energy
1792 : !!
1793 : !! SOURCE
1794 :
1795 0 : subroutine ebands_read_qpdata(qp_ebands, ks_ebands, filepath, comm)
1796 :
1797 : !Arguments ------------------------------------
1798 : class(ebands_t),intent(out) :: qp_ebands
1799 : class(ebands_t),intent(in) :: ks_ebands
1800 : character(len=*),intent(in) :: filepath
1801 : integer,intent(in) :: comm
1802 :
1803 : !Local variables-------------------------------
1804 : integer,parameter :: master = 0
1805 : integer :: units(2), irec, unt, nkibz_file, nsppol_file, nspinor_file !, ii
1806 : integer :: spin, b_start, b_stop, b_stop__, ikpt, nband_k, version, ierr
1807 : real(dp),parameter :: ktol = tol6
1808 : real(dp) :: kpt(3), spinmagntarget_, delta
1809 : character(len=500) :: msg, err_msg
1810 : !arrays
1811 0 : integer :: ifound(ks_ebands%nkpt, ks_ebands%nsppol)
1812 : !integer, allocatable :: iperm(:)
1813 0 : real(dp),allocatable :: re_enes(:), im_enes(:)
1814 : ! *************************************************************************
1815 :
1816 0 : units = [std_out, ab_out]
1817 :
1818 : ! Start by copying the input bands.
1819 0 : call ks_ebands%copy(qp_ebands)
1820 :
1821 : ! Only master read data and broadcast results.
1822 : ! File format of QPDATA file with energies in eV units.
1823 : !
1824 : ! # Comment
1825 : ! version
1826 : ! nkibz, nsppol
1827 : ! for spin in range(nsppol):
1828 : ! for kpoint in kpoints:
1829 : ! kpoint spin b_start, b_stop
1830 : ! real_energies_ev
1831 : ! imag_energies_ev
1832 :
1833 0 : if (xmpi_comm_rank(comm) == master) then
1834 0 : call wrtout(units, sjoin("- Reading QP energies from:", filepath, ch10))
1835 0 : if (open_file(filepath, msg, newunit=unt, form="formatted", action="read") /= 0) then
1836 0 : ABI_ERROR(msg)
1837 : end if
1838 :
1839 : ! Read dimensions + consistency check.
1840 0 : read(unt, *, err=10, iomsg=err_msg) msg
1841 0 : read(unt, *, err=10, iomsg=err_msg) version
1842 0 : read(unt, *, err=10, iomsg=err_msg) nkibz_file, nsppol_file, nspinor_file
1843 0 : call wrtout(units, msg)
1844 0 : call wrtout(units, sjoin("nkibz_file:", itoa(nkibz_file), ", nsppol_file:", itoa(nsppol_file)))
1845 :
1846 0 : ABI_CHECK_IEQ(ks_ebands%nkpt, nkibz_file, "Different number of k-points.")
1847 0 : ABI_CHECK_IEQ(ks_ebands%nsppol, nsppol_file, "Different number of spins.")
1848 0 : ABI_CHECK_IEQ(ks_ebands%nspinor, nspinor_file, "Different values of nspinor.")
1849 :
1850 : ! Read records.
1851 0 : ifound = 0
1852 0 : do irec=1, nkibz_file * nsppol_file
1853 : !write(std_out, *) "Reading record", irec
1854 0 : read(unt, *, err=10, iomsg=err_msg) kpt, spin, b_start, b_stop
1855 : ! Find k-point in ks_ebands%kptns.
1856 0 : do ikpt=1,ks_ebands%nkpt
1857 0 : if (all(abs(ks_ebands%kptns(:, ikpt) - kpt) < ktol)) exit
1858 : end do
1859 0 : ABI_CHECK_ILEQ(ikpt, ks_ebands%nkpt, sjoin("Cannot find k-point:", ktoa(kpt)))
1860 :
1861 0 : nband_k = ks_ebands%nband(ikpt+(spin-1)*ks_ebands%nkpt)
1862 0 : ifound(ikpt, spin) = ifound(ikpt, spin) + 1
1863 :
1864 0 : ABI_CHECK_ILEQ(b_start, b_stop, "b_start cannot be greater than b_stop")
1865 : !write(std_out, *) "About to read energies"
1866 :
1867 : ! Read new energies (first real, then imaginary part)
1868 0 : ABI_MALLOC(re_enes, (b_start:b_stop))
1869 0 : ABI_MALLOC(im_enes, (b_start:b_stop))
1870 0 : read(unt, *, err=10, iomsg=err_msg) re_enes
1871 0 : read(unt, *, err=10, iomsg=err_msg) im_enes
1872 0 : re_enes = re_enes * eV_Ha
1873 0 : im_enes = im_enes * eV_Ha
1874 :
1875 0 : if (b_start /= 1) then
1876 0 : call wrtout(units, " Extrapolating QP energies for low-energy states with band-independent shift.")
1877 0 : delta = re_enes(b_start) - ks_ebands%eig(b_start, ikpt, spin)
1878 0 : qp_ebands%eig(1:b_start-1, ikpt, spin) = qp_ebands%eig(1:b_start-1, ikpt, spin) + delta
1879 : end if
1880 :
1881 0 : b_stop__ = min(b_stop, nband_k)
1882 0 : if (b_stop__ /= nband_k) then
1883 0 : call wrtout(units, " Extrapolating QP energies for high-energy states with band-independent shift.")
1884 0 : delta = re_enes(b_stop__) - ks_ebands%eig(b_stop__, ikpt, spin)
1885 0 : qp_ebands%eig(b_stop__:nband_k, ikpt, spin) = qp_ebands%eig(b_stop__:nband_k, ikpt, spin) + delta
1886 : end if
1887 :
1888 : ! Update energies with results from QPDATA file.
1889 0 : qp_ebands%eig(b_start:b_stop__, ikpt, spin) = re_enes(b_start:b_stop__)
1890 :
1891 : ! Make sure energies are sorted.
1892 : ! FIXME: The sorting section should be removed as we loose the correspondence
1893 : ! between the band indices for energies and the ones in the e-ph matrix elements.
1894 : !ABI_MALLOC(iperm, (nband_k))
1895 : !iperm = [(ii, ii=1, nband_k)]
1896 : !call sort_dp(nband_k, qp_ebands%eig(:, ikpt, spin), iperm, tol6)
1897 : !ABI_FREE(iperm)
1898 :
1899 0 : ABI_FREE(re_enes)
1900 0 : ABI_FREE(im_enes)
1901 : end do ! irec
1902 :
1903 0 : close(unt)
1904 :
1905 : ! Final consistency check
1906 0 : if (any(ifound /= 1)) then
1907 0 : write(std_out)" ifound:", ifound
1908 0 : ABI_ERROR("Not all k-points and spins have been found!")
1909 : end if
1910 :
1911 : end if ! master
1912 :
1913 : ! Master broadcasts final results.
1914 0 : call xmpi_bcast(qp_ebands%eig, master, comm, ierr)
1915 :
1916 : ! Recalculate the Fermi level and occupation factors.
1917 : ! For Semiconductors only the Fermi level is changed (in the middle of the new gap)
1918 0 : spinmagntarget_ = -99.99_dp !?; if (PRESENT(spinmagntarget)) spinmagntarget_=spinmagntarget
1919 0 : call qp_ebands%update_occ(spinmagntarget_)
1920 :
1921 0 : return
1922 :
1923 : 10 continue
1924 0 : ABI_ERROR(err_msg)
1925 :
1926 0 : end subroutine ebands_read_qpdata
1927 : !!***
1928 :
1929 : !----------------------------------------------------------------------
1930 :
1931 : !!****f* m_ebands/ebands_get_occupied
1932 : !! NAME
1933 : !! ebands_get_occupied
1934 : !!
1935 : !! FUNCTION
1936 : !! For each k-point and spin polarisation, report the band index
1937 : !! after which the occupation numbers are less than tol_occ.
1938 : !!
1939 : !! INPUTS
1940 : !! ebands<ebands_t>=The object describing the band structure.
1941 : !! tol_occ[Optional]=Tolerance on the occupation factors.
1942 : !!
1943 : !! OUTPUT
1944 : !!
1945 : !! NOTES
1946 : !! We assume that the occupation factors monotonically decrease as a function of energy.
1947 : !! This is not always true for every smearing technique implemented in Abinit.
1948 : !! CP: this also not true for occopt 9
1949 : !!
1950 : !! SOURCE
1951 :
1952 148 : pure function ebands_get_occupied(ebands, tol_occ) result(occ_idx)
1953 :
1954 : !Arguments ------------------------------------
1955 : !scalars
1956 : class(ebands_t),intent(in) :: ebands
1957 : real(dp),optional,intent(in) :: tol_occ
1958 : !arrays
1959 : integer :: occ_idx(ebands%nkpt,ebands%nsppol)
1960 :
1961 : !Local variables-------------------------------
1962 : integer :: band,ikpt,spin,idx,nband_k
1963 : real(dp) :: tol_
1964 : ! *************************************************************************
1965 :
1966 148 : tol_=tol8; if (PRESENT(tol_occ)) tol_=tol_occ
1967 :
1968 298 : do spin=1,ebands%nsppol
1969 1159 : do ikpt=1,ebands%nkpt
1970 861 : nband_k = ebands%nband(ikpt+(spin-1)*ebands%nkpt)
1971 :
1972 861 : idx=0
1973 4948 : do band=1,nband_k
1974 4948 : if (ebands%occ(band,ikpt,spin) < ABS(tol_)) then
1975 : idx=band; EXIT
1976 : end if
1977 : end do
1978 861 : occ_idx(ikpt,spin)=idx-1
1979 861 : if (idx==1) occ_idx(ikpt,spin)=idx
1980 1011 : if (idx==0) occ_idx(ikpt,spin)=nband_k
1981 :
1982 : end do
1983 : end do
1984 :
1985 148 : end function ebands_get_occupied
1986 : !!***
1987 :
1988 : !----------------------------------------------------------------------
1989 :
1990 : !!****f* m_ebands/ebands_enclose_degbands
1991 : !! NAME
1992 : !! ebands_enclose_degbands
1993 : !!
1994 : !! FUNCTION
1995 : !! Adjust ibmin and ibmax such that all the degenerate states are enclosed
1996 : !! between ibmin and ibmax. The routine works for a given k-point a spin.
1997 : !!
1998 : !! INPUTS
1999 : !! ebands<ebands_t>=The object describing the band structure.
2000 : !! ikibz=Index of the k-point.
2001 : !! spin=Spin index.
2002 : !! tol_enedif=Tolerance on the energy difference.
2003 : !!
2004 : !! OUTPUT
2005 : !! changed=.TRUE. if ibmin or ibmax has been changed.
2006 : !! [degblock(2,ndeg)]=Table allocated by the routine containing the index
2007 : !! of the bands in the `ndeg` degenerate sub-sets
2008 : !! degblock(1, ii) = first band index in the ii-th degenerate subset.
2009 : !! degblock(2, ii) = last band index in the ii-th degenerate subset.
2010 : !!
2011 : !! SIDE EFFECTS
2012 : !! ibmin,ibmax=
2013 : !! Input: initial guess for the indices
2014 : !! Output: All the denerate states are between ibmin and ibmax
2015 : !!
2016 : !! SOURCE
2017 :
2018 767 : subroutine ebands_enclose_degbands(ebands, ikibz, spin, ibmin, ibmax, changed, tol_enedif, &
2019 : degblock) ! Optional
2020 :
2021 : !Arguments ------------------------------------
2022 : !scalars
2023 : class(ebands_t),intent(in) :: ebands
2024 : integer,intent(in) :: ikibz,spin
2025 : integer,intent(inout) :: ibmin,ibmax
2026 : real(dp),intent(in) :: tol_enedif
2027 : logical,intent(out) :: changed
2028 : !arrays
2029 : integer,allocatable,optional,intent(out) :: degblock(:,:)
2030 :
2031 : !Local variables-------------------------------
2032 : !scalars
2033 : integer :: ib,ibmin_bkp,ibmax_bkp,ndeg
2034 : real(dp) :: emin,emax
2035 : ! *************************************************************************
2036 :
2037 767 : ibmin_bkp = ibmin; ibmax_bkp = ibmax
2038 :
2039 767 : emin = ebands%eig(ibmin,ikibz,spin)
2040 916 : do ib=ibmin-1,1,-1
2041 916 : if (ABS(ebands%eig(ib,ikibz,spin) - emin) > tol_enedif) then
2042 233 : ibmin = ib +1
2043 233 : EXIT
2044 : else
2045 149 : ibmin = ib
2046 : end if
2047 : end do
2048 :
2049 767 : emax = ebands%eig(ibmax,ikibz,spin)
2050 901 : do ib=ibmax+1,ebands%nband(ikibz+(spin-1)*ebands%nkpt)
2051 901 : if (abs(ebands%eig(ib,ikibz,spin) - emax) > tol_enedif) then
2052 552 : ibmax = ib - 1
2053 552 : EXIT
2054 : else
2055 134 : ibmax = ib
2056 : end if
2057 : end do
2058 :
2059 767 : changed = (ibmin /= ibmin_bkp) .or. (ibmax /= ibmax_bkp)
2060 :
2061 : ! Compute degeneracy table.
2062 767 : if (present(degblock)) then
2063 : ! Count number of degeneracies.
2064 226 : ndeg = 1
2065 1065 : do ib=ibmin+1,ibmax
2066 1065 : if ( abs(ebands%eig(ib,ikibz,spin) - ebands%eig(ib-1,ikibz,spin) ) > tol_enedif) ndeg = ndeg + 1
2067 : end do
2068 : ! Build degblock table.
2069 678 : ABI_REMALLOC(degblock, (2, ndeg))
2070 226 : ndeg = 1; degblock(1, 1) = ibmin
2071 1065 : do ib=ibmin+1,ibmax
2072 1065 : if ( abs(ebands%eig(ib,ikibz,spin) - ebands%eig(ib-1,ikibz,spin) ) > tol_enedif) then
2073 416 : degblock(2, ndeg) = ib - 1
2074 416 : ndeg = ndeg + 1
2075 416 : degblock(1, ndeg) = ib
2076 : end if
2077 : end do
2078 226 : degblock(2, ndeg) = ibmax
2079 : end if
2080 :
2081 767 : end subroutine ebands_enclose_degbands
2082 : !!***
2083 :
2084 : !----------------------------------------------------------------------
2085 :
2086 : !!****f* m_ebands/ebands_get_bands_e0
2087 : !! NAME
2088 : !! ebands_get_bands_e0
2089 : !!
2090 : !! FUNCTION
2091 : !! Find min/max band indices crossing energy e0
2092 : !! min/max are returned in brange_spin(1:2, spin) for each spin.
2093 : !! If no band crosses e0, bmin is set to +huge(1) and bmax to -huge(1) and ierr != 0
2094 : !!
2095 : !! INPUTS
2096 : !!
2097 : !! OUTPUT
2098 : !!
2099 : !! SOURCE
2100 :
2101 0 : subroutine ebands_get_bands_e0(ebands, e0, brange_spin, ierr)
2102 :
2103 : !Arguments ------------------------------------
2104 : !scalars
2105 : class(ebands_t),intent(in) :: ebands
2106 : real(dp),intent(in) :: e0
2107 : integer,intent(out) :: brange_spin(2, ebands%nsppol)
2108 : integer,intent(out) :: ierr
2109 : !Local variables-------------------------------
2110 : integer :: band, spin, bmin, bmax
2111 : real(dp) :: emin, emax
2112 : ! *************************************************************************
2113 :
2114 0 : ierr = 0
2115 0 : do spin=1,ebands%nsppol
2116 0 : bmin = +huge(1); bmax = -huge(1)
2117 :
2118 0 : do band=1,minval(ebands%nband)
2119 0 : emin = minval(ebands%eig(band, :, spin))
2120 0 : emax = maxval(ebands%eig(band, :, spin))
2121 0 : if (emin <= e0 .and. emax >= e0) then
2122 0 : bmin = min(bmin, band)
2123 0 : bmax = max(bmax, band)
2124 : end if
2125 : end do
2126 :
2127 0 : brange_spin(:, spin) = [bmin, bmax]
2128 0 : if (bmin == +huge(1)) ierr = ierr + 1
2129 : end do
2130 :
2131 0 : end subroutine ebands_get_bands_e0
2132 : !!***
2133 :
2134 : !----------------------------------------------------------------------
2135 :
2136 : !!****f* m_ebands/ebands_get_erange
2137 : !! NAME
2138 : !! ebands_get_erange
2139 : !!
2140 : !! FUNCTION
2141 : !! Compute the minimum and maximum energy enclosing a list of states
2142 : !! specified by k-points and band indices.
2143 : !!
2144 : !! INPUTS
2145 : !! ebands<ebands_t>=The object describing the band structure.
2146 : !! nkpts=Number of k-points
2147 : !! kpoints(3,nkpts)=K-points
2148 : !! band_range(2,nkpts)=Gives for each k-points, the initial and the final band index to include.
2149 : !!
2150 : !! OUTPUT
2151 : !! emin,emax=min and max energy
2152 : !!
2153 : !! SOURCE
2154 :
2155 0 : subroutine ebands_get_erange(ebands, nkpts, kpoints, band_range, emin, emax)
2156 :
2157 : !Arguments ------------------------------------
2158 : !scalars
2159 : class(ebands_t),intent(in) :: ebands
2160 : integer,intent(in) :: nkpts
2161 : real(dp),intent(out) :: emin,emax
2162 : !arrays
2163 : integer,intent(in) :: band_range(2,nkpts)
2164 : real(dp),intent(in) :: kpoints(3,nkpts)
2165 :
2166 : !Local variables-------------------------------
2167 : !scalars
2168 : integer :: spin,ik,ikpt,cnt
2169 0 : type(krank_t) :: krank
2170 : ! *************************************************************************
2171 :
2172 0 : call krank%init(ebands%nkpt, ebands%kptns)
2173 0 : emin = huge(one); emax = -huge(one); cnt = 0
2174 :
2175 0 : do spin=1,ebands%nsppol
2176 0 : do ik=1,nkpts
2177 0 : ikpt = krank%get_index(kpoints(:,ik))
2178 0 : if (ikpt == -1) then
2179 0 : ABI_WARNING(sjoin("Cannot find k-point:", ktoa(kpoints(:,ik))))
2180 0 : cycle
2181 : end if
2182 0 : if (.not. (band_range(1,ik) >= 1 .and. band_range(2,ik) <= ebands%mband)) cycle
2183 0 : cnt = cnt + 1
2184 0 : emin = min(emin, minval(ebands%eig(band_range(1,ik):band_range(2,ik), ikpt, spin)))
2185 0 : emax = max(emax, maxval(ebands%eig(band_range(1,ik):band_range(2,ik), ikpt, spin)))
2186 : end do
2187 : end do
2188 :
2189 0 : call krank%free()
2190 :
2191 : ! This can happen if wrong input.
2192 0 : if (cnt == 0) then
2193 0 : ABI_WARNING("None of the k-points/bands provided was found in ebands%")
2194 0 : emin = minval(ebands%eig); emax = maxval(ebands%eig)
2195 : end if
2196 :
2197 0 : end subroutine ebands_get_erange
2198 : !!***
2199 :
2200 : !----------------------------------------------------------------------
2201 :
2202 : !!****f* m_ebands/ebands_nelect_per_spin
2203 : !! NAME
2204 : !! ebands_nelect_per_spin
2205 : !!
2206 : !! FUNCTION
2207 : !! Return number of electrons in each spin channel (computed from occoputation factors if nsppol=2)
2208 : !!
2209 : !! INPUTS
2210 : !! ebands<ebands_t>=The object describing the band structure.
2211 : !!
2212 : !! OUTPUT
2213 : !! nelect_per_spin(ebands%nsppol)=For each spin the number of electrons (eventually fractional)
2214 : !!
2215 : !! SOURCE
2216 :
2217 2 : pure function ebands_nelect_per_spin(ebands) result(nelect_per_spin)
2218 :
2219 : !Arguments ------------------------------------
2220 : !scalars
2221 : class(ebands_t),intent(in) :: ebands
2222 : !arrays
2223 : real(dp) :: nelect_per_spin(ebands%nsppol)
2224 :
2225 : !Local variables-------------------------------
2226 : integer :: iband,ikpt,spin
2227 : ! *************************************************************************
2228 :
2229 4 : nelect_per_spin = ebands%nelect
2230 2 : if (ebands%nsppol > 1) then
2231 0 : nelect_per_spin = zero
2232 0 : do spin=1,ebands%nsppol
2233 0 : do ikpt=1,ebands%nkpt
2234 0 : do iband=1,ebands%nband(ikpt+ebands%nkpt*(spin-1))
2235 0 : nelect_per_spin(spin) = nelect_per_spin(spin) + ebands%wtk(ikpt) * ebands%occ(iband, ikpt, spin)
2236 : end do
2237 : end do
2238 : end do
2239 : end if
2240 :
2241 2 : end function ebands_nelect_per_spin
2242 : !!***
2243 :
2244 : !----------------------------------------------------------------------
2245 :
2246 : !!****f* m_ebands/ebands_get_minmax
2247 : !! NAME
2248 : !! ebands_get_minmax
2249 : !!
2250 : !! FUNCTION
2251 : !! Report the min and max value over k-points and bands of (eig|occ|doccde) for each
2252 : !! spin. Cannot use F90 array syntax due to the internal storage used in abinit.
2253 : !!
2254 : !! INPUTS
2255 : !! arr_name=The name of the array whose min and Max value has to be calculated.
2256 : !! Possible values: 'occ', 'eig' 'doccde'
2257 : !!
2258 : !! OUTPUT
2259 : !! minmax(2,ebands%nsppol)=For each spin the min and max value of the quantity specified by "arr_name"
2260 : !!
2261 : !! SOURCE
2262 :
2263 18 : function ebands_get_minmax(ebands, arr_name) result(minmax)
2264 :
2265 : !Arguments ------------------------------------
2266 : !scalars
2267 : class(ebands_t),target,intent(in) :: ebands
2268 : character(len=*),intent(in) :: arr_name
2269 : !arrays
2270 : real(dp) :: minmax(2,ebands%nsppol)
2271 :
2272 : !Local variables-------------------------------
2273 : !scalars
2274 : integer :: band,ikpt,spin,nband_k
2275 : real(dp) :: datum
2276 : !arrays
2277 18 : real(dp), contiguous, pointer :: rdata(:,:,:)
2278 : ! *************************************************************************
2279 :
2280 36 : select case (tolower(arr_name))
2281 : case ('occ')
2282 0 : rdata => ebands%occ
2283 : case ('eig')
2284 18 : rdata => ebands%eig
2285 : case ('doccde')
2286 0 : rdata => ebands%doccde
2287 : case default
2288 18 : ABI_BUG(sjoin('Wrong arr_name:', arr_name))
2289 : end select
2290 :
2291 36 : minmax(1,:)=greatest_real
2292 36 : minmax(2,:)=smallest_real
2293 :
2294 36 : do spin=1,ebands%nsppol
2295 4088 : do ikpt=1,ebands%nkpt
2296 4052 : nband_k=ebands%nband(ikpt+(spin-1)*ebands%nkpt)
2297 38169 : do band=1,nband_k
2298 34099 : datum=rdata(band,ikpt,spin)
2299 34099 : minmax(1,spin)=MIN(minmax(1,spin),datum)
2300 38151 : minmax(2,spin)=MAX(minmax(2,spin),datum)
2301 : end do
2302 : end do
2303 : end do
2304 :
2305 18 : end function ebands_get_minmax
2306 : !!***
2307 :
2308 : !----------------------------------------------------------------------
2309 :
2310 : !!****f* m_ebands/ebands_has_metal_scheme
2311 : !! NAME
2312 : !! ebands_metallic_scheme
2313 : !!
2314 : !! FUNCTION
2315 : !! Returns .TRUE. if metallic occupation scheme is used.
2316 : !! Note that this does not imply that the system is metallic.
2317 : !!
2318 : !! SOURCE
2319 :
2320 1988 : pure logical function ebands_has_metal_scheme(ebands) result(ans)
2321 :
2322 : !Arguments ------------------------------------
2323 : class(ebands_t),intent(in) :: ebands
2324 : ! *************************************************************************
2325 :
2326 13259 : ans = (any(ebands%occopt == [3, 4, 5, 6, 7, 8, 9]))
2327 :
2328 922 : end function ebands_has_metal_scheme
2329 : !!***
2330 :
2331 : !----------------------------------------------------------------------
2332 :
2333 : !!****f* m_ebands/ebands_write_bxsf
2334 : !! NAME
2335 : !! ebands_write_bxsf
2336 : !!
2337 : !! FUNCTION
2338 : !! Write 3D energies for Fermi surface visualization (XSF format)
2339 : !!
2340 : !! INPUTS
2341 : !! crystal<crystal_t>=Info on unit cell and symmetries.
2342 : !! fname=File name for output.
2343 : !!
2344 : !! OUTPUT
2345 : !! ierr=Status error.
2346 : !!
2347 : !! SIDE EFFECTS
2348 : !! Produce BXSF file.
2349 : !!
2350 : !! SOURCE
2351 :
2352 2 : integer function ebands_write_bxsf(ebands, crystal, fname) result(ierr)
2353 :
2354 : !Arguments ------------------------------------
2355 : !scalars
2356 : class(ebands_t),intent(in) :: ebands
2357 : character(len=*),intent(in) :: fname
2358 : class(crystal_t),intent(in) :: crystal
2359 :
2360 : !Local variables-------------------------------
2361 : logical :: use_timrev
2362 : ! *************************************************************************
2363 :
2364 2 : use_timrev = (crystal%timrev==2)
2365 :
2366 2 : if (ebands%occopt /= 9) then
2367 : call printbxsf(ebands%eig,zero,ebands%fermie,crystal%gprimd,ebands%kptrlatt,ebands%mband,&
2368 : ebands%nkpt,ebands%kptns,crystal%nsym,crystal%use_antiferro,crystal%symrec,crystal%symafm,&
2369 2 : use_timrev,ebands%nsppol,ebands%shiftk,ebands%nshiftk,fname,ierr)
2370 : else
2371 : call printbxsf(ebands%eig,zero,ebands%fermie,crystal%gprimd,ebands%kptrlatt,ebands%mband,&
2372 : ebands%nkpt,ebands%kptns,crystal%nsym,crystal%use_antiferro,crystal%symrec,crystal%symafm,&
2373 0 : use_timrev,ebands%nsppol,ebands%shiftk,ebands%nshiftk,trim(fname)//"-e",ierr)
2374 :
2375 : call printbxsf(ebands%eig,zero,ebands%fermih,crystal%gprimd,ebands%kptrlatt,ebands%mband,&
2376 : ebands%nkpt,ebands%kptns,crystal%nsym,crystal%use_antiferro,crystal%symrec,crystal%symafm,&
2377 0 : use_timrev,ebands%nsppol,ebands%shiftk,ebands%nshiftk,trim(fname)//"-h",ierr)
2378 : end if
2379 :
2380 2 : end function ebands_write_bxsf
2381 : !!***
2382 :
2383 : !----------------------------------------------------------------------
2384 :
2385 : !!****f* m_ebands/ebands_update_occ
2386 : !! NAME
2387 : !! ebands_update_occ
2388 : !!
2389 : !! FUNCTION
2390 : !! Calculate new occupation numbers, the Fermi level and the Max occupied band index
2391 : !! for each spin channel starting from the the knowledge of eigenvalues.
2392 : !!
2393 : !! INPUTS
2394 : !! ebands<ebands_t>=Info on the band structure, the smearing technique and the physical temperature used.
2395 : !! spinmagntarget=if differ from -99.99d0, fix the spin polarization (in Bohr magneton)
2396 : !! [stmbias]=
2397 : !! [prtvol]=Verbosity level (0 for lowest level)
2398 : !! [fermie_to_zero]=If True, fermie is set to zero and energies are shifted accordingly. Default: False
2399 : !!
2400 : !! OUTPUT
2401 : !! see also SIDE EFFECTS.
2402 : !!
2403 : !! SIDE EFFECTS
2404 : !! === For metallic occupation the following quantities are recalculated ===
2405 : !! %fermie=the new Fermi energy
2406 : !! %entropy=the new entropy associated with the smearing.
2407 : !! %occ(mband,nkpt,nsppol)=occupation numbers
2408 : !! %doccde(mband,nkpt,nsppol)=derivative of occupancies wrt the energy for each band and k point
2409 : !!
2410 : !! === In case of semiconductors ===
2411 : !! All the quantitities in ebands are left unchanged with the exception of:
2412 : !! %fermie=Redefined so that it is in the middle of the gap
2413 : !! %entropy=Set to zero
2414 : !!
2415 : !! SOURCE
2416 :
2417 1045 : subroutine ebands_update_occ(ebands, spinmagntarget, stmbias, prtvol, fermie_to_zero)
2418 :
2419 : !Arguments ------------------------------------
2420 : !scalars
2421 : class(ebands_t),intent(inout) :: ebands
2422 : integer,optional,intent(in) :: prtvol
2423 : real(dp),intent(in) :: spinmagntarget
2424 : real(dp),optional,intent(in) :: stmbias
2425 : logical,optional,intent(in) :: fermie_to_zero
2426 :
2427 : !Local variables-------------------------------
2428 : !scalars
2429 : integer :: band,mband,ikibz,nkpt,spin,nsppol,my_prtvol,nband_k
2430 : real(dp) :: entropy,fermie,fermih,stmbias_local,ndiff,cbot,vtop,maxocc
2431 : character(len=500) :: msg
2432 : !arrays
2433 4180 : real(dp) :: nelect_spin(ebands%nsppol),condbottom(ebands%nsppol),valencetop(ebands%nsppol)
2434 1045 : real(dp),allocatable :: doccde(:),occ(:),eigen(:)
2435 : ! *************************************************************************
2436 :
2437 1045 : my_prtvol = 0; if (PRESENT(prtvol )) my_prtvol = prtvol
2438 1045 : stmbias_local = zero; if (PRESENT(stmbias)) stmbias_local = stmbias
2439 :
2440 1045 : if (ebands_has_metal_scheme(ebands)) then
2441 : ! Compute new occupation numbers if metallic occupation.
2442 347 : if (my_prtvol > 10) then
2443 0 : call wrtout(std_out, sjoin(' metallic scheme: calling newocc with spinmagntarget:', ftoa(spinmagntarget, fmt="f9.5")))
2444 : end if
2445 :
2446 : ! newocc assumes eigenvalues and occupations packed in 1d-vector!!
2447 347 : mband = ebands%mband; nkpt = ebands%nkpt; nsppol = ebands%nsppol
2448 :
2449 1041 : ABI_MALLOC(eigen, (mband*nkpt*nsppol))
2450 347 : call get_eneocc_vect(ebands, 'eig', eigen)
2451 :
2452 694 : ABI_MALLOC(occ, (mband*nkpt*nsppol))
2453 694 : ABI_MALLOC(doccde, (mband*nkpt*nsppol))
2454 :
2455 : call newocc(doccde,eigen,entropy,fermie,fermih,ebands%ivalence,spinmagntarget,mband,ebands%nband,&
2456 : ebands%nelect,ebands%ne_qFD,ebands%nh_qFD,ebands%nkpt,ebands%nspinor,ebands%nsppol,occ,ebands%occopt,&
2457 347 : my_prtvol,ebands%tphysel,ebands%tsmear,ebands%wtk,stmbias=stmbias_local)
2458 :
2459 : ! Save output in ebands%.
2460 347 : ebands%entropy = entropy
2461 347 : ebands%fermie = fermie
2462 347 : ebands%fermih = fermih
2463 347 : call put_eneocc_vect(ebands, 'occ', occ)
2464 347 : call put_eneocc_vect(ebands, 'doccde', doccde)
2465 347 : ABI_FREE(eigen)
2466 347 : ABI_FREE(occ)
2467 694 : ABI_FREE(doccde)
2468 :
2469 : else
2470 : ! Semiconductor (non magnetic case)
2471 698 : maxocc = two / (ebands%nsppol*ebands%nspinor)
2472 : !
2473 : ! FIXME here there is an inconsistency btw the GW code and Abinit
2474 : ! In ABINIT, Fermi is set to the HOMO level while in GW fermi is at midgap
2475 : ! In case of crystal systems, the later convention should be preferable.
2476 : ! Anyway we have to decide and follow a unique convention to avoid problems.
2477 : !
2478 : ! Occupation factors MUST be initialized
2479 : !if (ALL(ABS(ebands%occ) < tol6)) then
2480 698 : if (ebands%occopt /= 2) then
2481 692 : ABI_CHECK(ebands%nelect == nint(ebands%nelect), "nelect should be integer")
2482 692 : mband = nint((ebands%nelect * ebands%nspinor) / 2)
2483 131513 : ebands%occ = zero
2484 42511 : ebands%occ(1:mband,:,:) = maxocc
2485 : !ABI_ERROR("Occupation factors are not initialized, likely due to scf = -2")
2486 : end if
2487 :
2488 : ! Calculate the valence index for each spin channel.
2489 1410 : do spin=1,ebands%nsppol
2490 712 : valencetop(spin) = smallest_real
2491 712 : condbottom(spin) = greatest_real / 1000000_dp ! to avoid overflow when multiply by Ha2meV.
2492 8882 : do ikibz=1,ebands%nkpt
2493 7472 : nband_k = ebands%nband(ikibz + (spin-1)*ebands%nkpt)
2494 130905 : do band=1,nband_k
2495 122721 : if (ebands%occ(band,ikibz,spin) / maxocc > one-tol6 .and. valencetop(spin) < ebands%eig(band,ikibz,spin)) then
2496 4307 : valencetop(spin) = ebands%eig(band,ikibz,spin)
2497 : end if
2498 130193 : if (ebands%occ(band,ikibz,spin) / maxocc < tol6 .and. condbottom(spin) > ebands%eig(band,ikibz,spin)) then
2499 2029 : condbottom(spin) = ebands%eig(band,ikibz,spin)
2500 : end if
2501 : end do
2502 : end do
2503 : end do
2504 :
2505 2108 : vtop = MAXVAL(valencetop)
2506 2108 : cbot = MINVAL(condbottom)
2507 :
2508 : write(msg,'(3(a,f8.4,2a))') &
2509 698 : " Top of valence: ", vtop * Ha_eV," (eV)", ch10, &
2510 698 : " Bottom of conduction: ", cbot * Ha_eV, " (eV)", ch10, &
2511 1396 : " Fundamental gap:", (cbot - vtop) * Ha_eV, " (eV)", ch10
2512 698 : call wrtout(std_out, msg)
2513 :
2514 698 : if (ebands%nsppol == 2) then
2515 56 : if (ABS(vtop - MINVAL(valencetop)) > tol6) then
2516 10 : call wrtout(std_out, sjoin(' Top of valence is spin: ', itoa(imax_loc(valencetop))))
2517 : end if
2518 56 : if (ABS(cbot - MAXVAL(condbottom)) > tol6) then
2519 6 : call wrtout(std_out, ' Bottom of conduction is spin: ', itoa(imin_loc(condbottom)))
2520 : end if
2521 : end if
2522 :
2523 : ! Save results. Here I dont know if it is better to be consistent with the abinit convention i.e fermi = vtop
2524 698 : ebands%entropy = zero
2525 698 : ebands%fermie = (vtop + cbot) / 2
2526 698 : if (ABS(cbot - vtop) < tol4) ebands%fermie = vtop ! To avoid error on the last digit
2527 : end if
2528 :
2529 1045 : call wrtout(std_out, sjoin(' Fermi level: ', ftoa(ebands%fermie * Ha_eV, fmt="f8.4"), " (eV)", ch10))
2530 :
2531 : ! Compute number of electrons for each spin channel.
2532 2106 : nelect_spin(:)=zero
2533 2106 : do spin=1,ebands%nsppol
2534 59298 : do ikibz=1,ebands%nkpt
2535 57192 : nband_k = ebands%nband(ikibz+(spin-1)*ebands%nkpt)
2536 661165 : nelect_spin(spin)= nelect_spin(spin) + ebands%wtk(ikibz) * sum(ebands%occ(1:nband_k,ikibz,spin))
2537 : end do
2538 : end do
2539 :
2540 2106 : ndiff = ebands%nelect - SUM(nelect_spin)
2541 1045 : if (my_prtvol > 0) then
2542 109 : write(msg,'(2a,f6.2,2a,f7.4)')ch10,&
2543 218 : ' Total number of electrons: ', sum(nelect_spin),ch10,&
2544 218 : ' Input and calculated no. of electrons differ by ',ndiff
2545 109 : call wrtout(std_out, msg)
2546 : end if
2547 :
2548 1045 : if (ABS(ndiff) > 5.d-2*ebands%nelect) then
2549 : write(msg,'(2a,2(a,es12.4))') &
2550 0 : 'Too large difference in number of electrons:,',ch10,&
2551 0 : 'Expected = ',ebands%nelect,' Calculated = ',sum(nelect_spin)
2552 0 : ABI_ERROR(msg)
2553 : end if
2554 :
2555 1045 : if (present(fermie_to_zero)) then
2556 0 : if (fermie_to_zero) then
2557 0 : ebands%eig = ebands%eig - ebands%fermie
2558 0 : ebands%fermih = ebands%fermih - ebands%fermie
2559 0 : ebands%fermie = zero
2560 : end if
2561 : end if
2562 :
2563 1045 : end subroutine ebands_update_occ
2564 : !!***
2565 :
2566 : !----------------------------------------------------------------------
2567 :
2568 : !!****f* m_ebands/ebands_set_scheme
2569 : !! NAME
2570 : !! ebands_set_scheme
2571 : !!
2572 : !! FUNCTION
2573 : !! Set the occupation scheme and re-calculate new occupation numbers,
2574 : !! the Fermi level and the Max occupied band index for each spin channel starting
2575 : !! from the the knowledge of eigenvalues. See ebands_update_occ for more info.
2576 : !!
2577 : !! INPUTS
2578 : !! occopt=Occupation options (see input variable)
2579 : !! tsmear=Temperature of smearing.
2580 : !! spinmagntarget=if differ from -99.99d0, fix the spin polarization (in Bohr magneton)
2581 : !! prtvol=Verbosity level (0 for lowest level)
2582 : !! [update_occ]=False to avoid recomputing occupation factors (mainly used when a call to set_scheme is followed
2583 : !! by another call to set_extrael (update_occ is expensive for large k-meshes). Default: True.
2584 : !!
2585 : !! SOURCE
2586 :
2587 301 : subroutine ebands_set_scheme(ebands, occopt, tsmear, spinmagntarget, prtvol, update_occ)
2588 :
2589 : !Arguments ------------------------------------
2590 : !scalars
2591 : class(ebands_t),intent(inout) :: ebands
2592 : integer,intent(in) :: occopt
2593 : integer,intent(in) :: prtvol
2594 : real(dp),intent(in) :: tsmear, spinmagntarget
2595 : logical,optional,intent(in) :: update_occ
2596 :
2597 : !Local variables-------------------------------
2598 : logical :: my_update_occ
2599 : ! *************************************************************************
2600 :
2601 301 : my_update_occ = .True.; if (present(update_occ)) my_update_occ = update_occ
2602 :
2603 301 : if (prtvol > 10) then
2604 0 : call wrtout(std_out, " Changing occupation scheme in electron bands")
2605 0 : call wrtout(std_out, sjoin(" occopt:", itoa(ebands%occopt), " ==> ", itoa(occopt)))
2606 0 : call wrtout(std_out, sjoin(" tsmear:", ftoa(ebands%tsmear), " ==> ", ftoa(tsmear)))
2607 : end if
2608 :
2609 301 : ebands%occopt = occopt; ebands%tsmear = tsmear
2610 :
2611 301 : if (my_update_occ) then
2612 265 : call ebands%update_occ(spinmagntarget, prtvol=prtvol)
2613 265 : if (prtvol > 10) call wrtout(std_out, sjoin(' Fermi level is now:', ftoa(ebands%fermie)))
2614 : end if
2615 :
2616 301 : end subroutine ebands_set_scheme
2617 : !!***
2618 :
2619 : !----------------------------------------------------------------------
2620 :
2621 : !!****f* m_ebands/ebands_set_fermie
2622 : !! NAME
2623 : !! ebands_set_fermie
2624 : !!
2625 : !! FUNCTION
2626 : !! Set the new Fermi level from eigenenergies eigen and change the number of electrons
2627 : !! Compute also new occupation numbers at each k point, from eigenenergies eigen, according to the
2628 : !! smearing scheme defined by occopt (and smearing width tsmear or tphysel) as well as
2629 : !! entropy and derivative of occupancies wrt the energy for each band and k point.
2630 : !!
2631 : !! INPUTS
2632 : !! fermie=New fermi level
2633 : !!
2634 : !! OUTPUT
2635 : !! msg=String describing the changes in fermie and nelect.
2636 : !!
2637 : !! NOTES
2638 : !! The routine assumes metallic occupation scheme and will abort it this condition is not satisfied.
2639 : !! Use ebands_set_scheme before calling this routine, if you have a semiconductor.
2640 : !!
2641 : !! SOURCE
2642 :
2643 1 : subroutine ebands_set_fermie(ebands, fermie, msg)
2644 :
2645 : !Arguments ------------------------------------
2646 : !scalars
2647 : class(ebands_t),intent(inout) :: ebands
2648 : real(dp),intent(in) :: fermie
2649 : character(len=*),intent(out) :: msg
2650 :
2651 : !Local variables-------------------------------
2652 : !scalars
2653 : integer,parameter :: option1=1, unitdos0 = 0
2654 : integer :: mband, nkpt, nsppol
2655 : real(dp),parameter :: dosdeltae0 = zero
2656 : real(dp) :: prev_fermie, prev_nelect, maxocc
2657 : !arrays
2658 1 : real(dp),allocatable :: doccde(:),occ(:),eigen(:)
2659 : ! *************************************************************************
2660 :
2661 1 : if (ebands%occopt == 9) then
2662 0 : ABI_ERROR("set_fermie unavailable when occopt 9")
2663 : end if
2664 1 : if (.not. ebands_has_metal_scheme(ebands)) then
2665 0 : ABI_ERROR("set_fermie assumes a metallic occupation scheme. Use ebands_set_scheme before calling ebands_set_fermie!")
2666 : end if
2667 :
2668 1 : prev_fermie = ebands%fermie; prev_nelect = ebands%nelect
2669 :
2670 : ! newocc assumes eigenvalues and occupations packed in 1d-vector!!
2671 1 : mband = ebands%mband
2672 1 : nkpt = ebands%nkpt
2673 1 : nsppol = ebands%nsppol
2674 1 : maxocc = two / (nsppol*ebands%nspinor)
2675 :
2676 3 : ABI_MALLOC(eigen, (mband*nkpt*nsppol))
2677 1 : call get_eneocc_vect(ebands, 'eig', eigen)
2678 2 : ABI_MALLOC(occ, (mband*nkpt*nsppol))
2679 2 : ABI_MALLOC(doccde, (mband*nkpt*nsppol))
2680 :
2681 : ! Get the total number of electrons nelect, given the new fermi energy.
2682 : call getnel(doccde,dosdeltae0,eigen,ebands%entropy,fermie,fermie,maxocc,mband,ebands%nband,&
2683 : ebands%nelect,nkpt,nsppol,occ,ebands%occopt,option1,ebands%tphysel,ebands%tsmear,unitdos0,&
2684 1 : ebands%wtk,1,ebands%nband(1))
2685 :
2686 : ! Save changes in ebands%.
2687 1 : ebands%fermie = fermie
2688 1 : call put_eneocc_vect(ebands,'occ' ,occ)
2689 1 : call put_eneocc_vect(ebands,'doccde',doccde)
2690 :
2691 1 : ABI_FREE(eigen)
2692 1 : ABI_FREE(occ)
2693 1 : ABI_FREE(doccde)
2694 :
2695 : write(msg,"(2(a,es16.6),a,2(a,es16.6))") &
2696 1 : " Old fermi level: ",prev_fermie,", with nelect: ",prev_nelect,ch10, &
2697 2 : " New fermi level: ",ebands%fermie,", with nelect: ",ebands%nelect
2698 :
2699 1 : end subroutine ebands_set_fermie
2700 : !!***
2701 :
2702 : !----------------------------------------------------------------------
2703 :
2704 : !!****f* m_ebands/ebands_set_extrael
2705 : !! NAME
2706 : !! ebands_set_extrael
2707 : !!
2708 : !! FUNCTION
2709 : !! Add extrael to ebands%nelect. Set value of ebands%extrael
2710 : !! Recompute Fermi level from eigenenergies
2711 : !! and new occupation numbers according to the smearing scheme defined by occopt
2712 : !! (and smearing width tsmear or tphysel) as well as
2713 : !! entropy and derivative of occupancies wrt the energy for each band and k point.
2714 : !!
2715 : !! INPUTS
2716 : !! nelect=New number of electrons
2717 : !! nholes=New number of excited holes
2718 : !! extrael=Number of electrons be added in units. Negative to add holes
2719 : !! spinmagntarget=if differ from -99.99d0, fix the spin polarization (in Bohr magneton)
2720 : !! [prtvol]=Verbosity level
2721 : !!
2722 : !! OUTPUT
2723 : !! msg=String describing the changes in fermie and nelect.
2724 : !!
2725 : !! NOTES
2726 : !! The routine assumes metallic occupation scheme and will abort it this condition is not satisfied.
2727 : !! Use ebands_set_scheme before calling this routine, if you have a semiconductor.
2728 : !!
2729 : !! SOURCE
2730 20 : subroutine ebands_set_extrael(ebands, nelect, nholes, spinmagntarget, msg, prtvol)
2731 :
2732 : !Arguments ------------------------------------
2733 : !scalars
2734 : class(ebands_t),intent(inout) :: ebands
2735 : integer,optional,intent(in) :: prtvol
2736 : real(dp),intent(in) :: nelect,nholes,spinmagntarget
2737 : character(len=*),intent(out) :: msg
2738 :
2739 : !Local variables-------------------------------
2740 : !scalars
2741 : integer :: my_prtvol
2742 : real(dp) :: prev_fermie,prev_fermih,prev_nelect,prev_nholes
2743 : ! *************************************************************************
2744 :
2745 20 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
2746 :
2747 20 : if (.not. ebands_has_metal_scheme(ebands)) then
2748 0 : ABI_ERROR("set_extrael assumes a metallic occupation scheme. Use ebands_set_scheme!")
2749 : end if
2750 :
2751 20 : prev_fermie = ebands%fermie; prev_nelect = ebands%nelect
2752 20 : prev_fermih = ebands%fermie; prev_nholes = zero
2753 : ! Here we set the value of extrael
2754 20 : ebands%extrael = nelect-nholes
2755 20 : ebands%nelect = ebands%nelect + ebands%extrael
2756 20 : if (ebands%occopt /= 9) then
2757 20 : ebands%ne_qFD = zero
2758 20 : ebands%nh_qFD = zero
2759 : else
2760 0 : prev_fermie = ebands%fermie; prev_nelect = ebands%ne_qFD
2761 0 : prev_fermih = ebands%fermih; prev_nholes = ebands%nh_qFD
2762 0 : ebands%ne_qFD = nelect
2763 0 : ebands%nh_qFD = nholes
2764 : end if
2765 :
2766 20 : call ebands%update_occ(spinmagntarget, prtvol=my_prtvol)
2767 :
2768 20 : if (ebands%occopt/=9) then
2769 : write(msg,"(2(a,es16.6),a,2(a,es16.6))")&
2770 20 : " Old fermi level: ",prev_fermie,", with nelect: ",prev_nelect,ch10,&
2771 40 : " New fermi level: ",ebands%fermie,", with nelect: ",ebands%nelect
2772 20 : call wrtout(std_out, msg)
2773 : else
2774 : write(msg,"(2(a,es16.6),a,2(a,es16.6))")&
2775 0 : " Old electron fermi level: ",prev_fermie,", with nelect: ",prev_nelect,ch10,&
2776 0 : " New electron fermi level: ",ebands%fermie,", with nelect: ",ebands%ne_qFD
2777 0 : call wrtout(std_out, msg)
2778 : write(msg,"(2(a,es16.6),a,2(a,es16.6))")&
2779 0 : " Old holes fermi level: ",prev_fermih,", with nelect: ",prev_nelect-prev_nholes,ch10,&
2780 0 : " New holes fermi level: ",ebands%fermih,", with nholes: ",ebands%nelect-ebands%nh_qFD
2781 0 : call wrtout(std_out, msg)
2782 : end if
2783 :
2784 20 : end subroutine ebands_set_extrael
2785 : !!***
2786 :
2787 : !----------------------------------------------------------------------
2788 :
2789 : !!****f* m_ebands/ebands_get_muT_with_fd
2790 : !! NAME
2791 : !! ebands_get_muT_with_fd
2792 : !!
2793 : !! FUNCTION
2794 : !! Compute the Fermi level for different temperatures using Fermi-Dirac occupation function (physical T)
2795 : !! Use ebands%nelect provided in input. Does not change input ebands.
2796 : !!
2797 : !! INPUTS
2798 : !!
2799 : !! OUTPUT
2800 : !!
2801 : !! SOURCE
2802 :
2803 64 : subroutine ebands_get_muT_with_fd(self, ntemp, kTmesh, spinmagntarget, prtvol, mu_e, comm)
2804 :
2805 : !Arguments ------------------------------------
2806 : !scalars
2807 : class(ebands_t),intent(in) :: self
2808 : integer,intent(in) :: ntemp, prtvol, comm
2809 : real(dp),intent(in) :: spinmagntarget
2810 : real(dp),intent(in) :: kTmesh(ntemp)
2811 : real(dp),intent(out) :: mu_e(ntemp)
2812 :
2813 : !Local variables-------------------------------
2814 : !scalars
2815 : integer,parameter :: occopt3 = 3
2816 : integer :: ierr, it, nprocs, my_rank
2817 : real(dp) :: nelect, cpu, wall, gflops
2818 64 : type(ebands_t) :: tmp_ebands
2819 : character(len=500) :: msg
2820 : ! *************************************************************************
2821 :
2822 64 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
2823 64 : call cwtime(cpu, wall, gflops, "start")
2824 :
2825 64 : call self%copy(tmp_ebands)
2826 :
2827 : ! Check if nband is "large enough" to compute the Fermi level.
2828 64 : ierr = self%has_enough_bands_for_ef(msg)
2829 64 : if (ierr /= 0) then
2830 1 : ABI_WARNING(msg)
2831 : end if
2832 : !if (ierr > 0) then
2833 : ! ABI_ERROR(msg)
2834 : !end if
2835 : !if (ierr < 0) then
2836 : ! ABI_WARNING(msg)
2837 : !end if
2838 :
2839 308 : mu_e = zero
2840 308 : do it=1,ntemp
2841 244 : if (mod(it, nprocs) /= my_rank) cycle ! MPI parallelism inside comm.
2842 :
2843 : ! Use Fermi-Dirac occopt
2844 244 : call tmp_ebands%set_scheme(occopt3, kTmesh(it), spinmagntarget, prtvol)
2845 244 : mu_e(it) = tmp_ebands%fermie
2846 : !
2847 : ! Check that the total number of electrons is correct
2848 : ! This is to trigger problems as the routines that calculate the occupations in ebands_set_extrael
2849 : ! are different from the occ_fd that will be used in the rest of the code.
2850 244 : nelect = ebands_calc_nelect(tmp_ebands, kTmesh(it), mu_e(it))
2851 :
2852 308 : if (abs(nelect - self%nelect) > tol6) then
2853 : ! For T = 0 the number of occupied states goes in discrete steps (according to the k-point sampling)
2854 : ! for finite doping its hard to find nelect that exactly matches self%nelect.
2855 : ! in this case we print a warning
2856 : write(msg,'(2(a,f10.6,a), f10.6)') &
2857 4 : 'Calculated number of electrons nelect : ',nelect, ch10, &
2858 8 : ' does not correspond with ebands%nelect: ',tmp_ebands%nelect,' for kT: ', kTmesh(it)
2859 :
2860 4 : if (kTmesh(it) == zero) then
2861 4 : ABI_WARNING(msg)
2862 : else
2863 0 : ABI_ERROR(msg)
2864 : end if
2865 : end if
2866 : end do ! it
2867 :
2868 64 : call tmp_ebands%free()
2869 64 : call xmpi_sum(mu_e, comm, ierr)
2870 :
2871 64 : call cwtime_report(" ebands_get_muT_with_fd", cpu, wall, gflops, end_str=ch10)
2872 :
2873 64 : end subroutine ebands_get_muT_with_fd
2874 : !!***
2875 :
2876 : !----------------------------------------------------------------------
2877 :
2878 : !!****f* m_ebands/ebands_calc_nelect
2879 : !! NAME
2880 : !! ebands_calc_nelect
2881 : !!
2882 : !! FUNCTION
2883 : !! Compute nelect from Fermi level and Temperature.
2884 : !!
2885 : !! INPUTS
2886 : !!
2887 : !! OUTPUT
2888 : !!
2889 : !! SOURCE
2890 :
2891 244 : real(dp) pure function ebands_calc_nelect(self, kt, fermie) result(nelect)
2892 :
2893 : !Arguments ------------------------------------
2894 : !scalars
2895 : class(ebands_t),intent(in) :: self
2896 : real(dp),intent(in) :: kt, fermie
2897 :
2898 : !Local variables-------------------------------
2899 : !scalars
2900 : integer :: spin, ik, ib
2901 : real(dp) :: ofact
2902 : ! *************************************************************************
2903 :
2904 244 : ofact = two / (self%nsppol * self%nspinor)
2905 244 : nelect = zero
2906 488 : do spin=1,self%nsppol
2907 37794 : do ik=1,self%nkpt
2908 406158 : do ib=1,self%nband(ik + (spin-1)*self%nkpt)
2909 405914 : nelect = nelect + self%wtk(ik) * occ_fd(self%eig(ib,ik,spin), kt, fermie)
2910 : end do
2911 : end do
2912 : end do
2913 :
2914 244 : nelect = ofact * nelect
2915 :
2916 244 : end function ebands_calc_nelect
2917 : !!***
2918 :
2919 : !----------------------------------------------------------------------
2920 :
2921 : !!****f* m_ebands/ebands_report_gap
2922 : !! NAME
2923 : !! ebands_report_gap
2924 : !!
2925 : !! FUNCTION
2926 : !! Print info on the fundamental and direct gap.
2927 : !!
2928 : !! INPUTS
2929 : !! ebands<ebands_t>=Info on the band structure, the smearing technique and the physical temperature used.
2930 : !! [header]=Optional title.
2931 : !! [unit]=Optional unit for output (std_out if not specified)
2932 : !! [mode_paral]=Either "COLL" or "PERS", former is default.
2933 : !!
2934 : !! OUTPUT
2935 : !! writing.
2936 : !! [gaps(3,nsppol)]=Fundamental and direct gaps. The third index corresponds to a "status":
2937 : !! 0.0dp if gaps were not computed (because there are only valence bands);
2938 : !! -1.0dp if the system (or spin-channel) is metallic;
2939 : !! 1.0dp if the gap has been computed.
2940 : !!
2941 : !! SOURCE
2942 :
2943 5635 : subroutine ebands_report_gap(ebands, header, unit, mode_paral, gaps)
2944 :
2945 : !Arguments ------------------------------------
2946 : !scalars
2947 : integer,intent(in),optional :: unit
2948 : character(len=4),intent(in),optional :: mode_paral
2949 : character(len=*),intent(in),optional :: header
2950 : class(ebands_t),intent(in) :: ebands
2951 : !arrays
2952 : real(dp),optional,intent(out) :: gaps(3,ebands%nsppol)
2953 :
2954 : !Local variables-------------------------------
2955 : !scalars
2956 : integer :: ikibz,nband_k,spin,nsppol,ikopt,ivk,ick,ivb,icb,unt,first
2957 : real(dp),parameter :: tol_fermi = tol6
2958 : real(dp) :: fun_gap,opt_gap
2959 : logical :: ismetal
2960 : character(len=4) :: my_mode
2961 : character(len=500) :: msg
2962 : !arrays
2963 12322 : integer :: val_idx(ebands%nkpt,ebands%nsppol)
2964 6161 : real(dp) :: top_valence(ebands%nkpt),bot_conduct(ebands%nkpt)
2965 : ! *********************************************************************
2966 :
2967 6161 : nsppol = ebands%nsppol
2968 :
2969 6161 : unt =std_out; if (PRESENT(unit )) unt =unit
2970 6161 : my_mode='COLL' ; if (PRESENT(mode_paral)) my_mode=mode_paral
2971 :
2972 30869 : if (PRESENT(gaps)) gaps=zero
2973 :
2974 6161 : val_idx(:,:) = ebands_get_valence_idx(ebands, tol_fermi)
2975 6161 : first = 0
2976 :
2977 : ! Initialize the return status for the gaps
2978 30869 : if (PRESENT(gaps)) gaps(1:3,1:nsppol)=zero
2979 :
2980 9989 : do spin=1,nsppol
2981 :
2982 : ! No output if system i metallic
2983 67290 : ismetal=ANY(val_idx(:,spin)/=val_idx(1,spin))
2984 6490 : if (ismetal .or. (ebands%occopt==9)) then
2985 946 : if (PRESENT(gaps)) gaps(3,nsppol)=-one
2986 : cycle
2987 : endif
2988 :
2989 5544 : first=first+1
2990 5544 : if (first==1) then
2991 5340 : msg=ch10
2992 5340 : if (PRESENT(header)) msg=ch10//' === '//TRIM(ADJUSTL(header))//' === '
2993 5340 : call wrtout(unt,msg,my_mode)
2994 : end if
2995 :
2996 5544 : ivb=val_idx(1,spin)
2997 5544 : icb=ivb+1
2998 :
2999 26751 : do ikibz=1,ebands%nkpt
3000 23869 : nband_k = ebands%nband(ikibz+(spin-1)*ebands%nkpt)
3001 23869 : top_valence(ikibz) = ebands%eig(ivb,ikibz,spin)
3002 23869 : if (icb>nband_k) then
3003 : GOTO 10 ! Only occupied states are present, no output!
3004 : end if
3005 24089 : bot_conduct(ikibz) = ebands%eig(icb,ikibz,spin)
3006 : end do
3007 :
3008 : ! Get minimum of the direct Gap
3009 24089 : ikopt= imin_loc(bot_conduct-top_valence)
3010 2882 : opt_gap=bot_conduct(ikopt)-top_valence(ikopt)
3011 :
3012 : ! Get fundamental Gap
3013 2882 : ick = imin_loc(bot_conduct)
3014 2882 : ivk = imax_loc(top_valence)
3015 2882 : fun_gap = ebands%eig(icb,ick,spin)-ebands%eig(ivb,ivk,spin)
3016 :
3017 : write(msg,'(a,i2,a,2(a,f8.4,a,3f8.4,a),33x,a,3f8.4)')&
3018 2882 : ' >>>> For spin ',spin,ch10,&
3019 2882 : ' Minimum direct gap = ',opt_gap*Ha_eV,' [eV], located at k-point : ',ebands%kptns(:,ikopt),ch10,&
3020 2882 : ' Fundamental gap = ',fun_gap*Ha_eV,' [eV], Top of valence bands at : ',ebands%kptns(:,ivk),ch10, &
3021 5764 : ' Bottom of conduction at : ',ebands%kptns(:,ick)
3022 2882 : call wrtout(unt,msg, my_mode)
3023 :
3024 13494 : if (present(gaps)) gaps(:,spin) = [fun_gap, opt_gap, one]
3025 : end do !spin
3026 :
3027 2662 : return
3028 :
3029 : 10 continue
3030 2662 : call wrtout(std_out, "Not enough states to calculate the band gap.", "COLL")
3031 :
3032 6161 : end subroutine ebands_report_gap
3033 : !!***
3034 :
3035 : !----------------------------------------------------------------------
3036 :
3037 : !!****f* m_ebands/ebands_ncwrite
3038 : !! NAME
3039 : !! ebands_ncwrite
3040 : !!
3041 : !! FUNCTION
3042 : !! Writes the content of an ebands_t object to a NETCDF file
3043 : !! according to the ETSF-IO specifications. Return nf90_noerr if success.
3044 : !!
3045 : !! INPUTS
3046 : !! ncid =NC file handle
3047 : !!
3048 : !! SOURCE
3049 :
3050 11164 : integer function ebands_ncwrite(ebands, ncid) result(ncerr)
3051 :
3052 : !Arguments ------------------------------------
3053 : !scalars
3054 : class(ebands_t),intent(in) :: ebands
3055 : integer,intent(in) :: ncid
3056 :
3057 : !Local variables-------------------------------
3058 : !scalars
3059 : integer :: ii,nelect_int
3060 : logical :: write_ngkpt
3061 : character(len=etsfio_charlen) :: smearing,k_dependent
3062 : !arrays
3063 : integer :: ngkpt(3)
3064 : ! *************************************************************************
3065 :
3066 11164 : smearing = nctk_string_from_occopt(ebands%occopt)
3067 :
3068 : ! ==============================================
3069 : ! === Write the dimensions specified by ETSF ===
3070 : ! ==============================================
3071 : ncerr = nctk_def_dims(ncid, [ &
3072 : nctkdim_t("max_number_of_states", ebands%mband), &
3073 : nctkdim_t("number_of_spinor_components", ebands%nspinor), &
3074 : nctkdim_t("number_of_spins", ebands%nsppol), &
3075 : nctkdim_t("number_of_kpoints", ebands%nkpt), &
3076 : nctkdim_t("nshiftk_orig", ebands%nshiftk_orig), &
3077 : nctkdim_t("nshiftk", ebands%nshiftk)], &
3078 78148 : defmode=.True.)
3079 11164 : NCF_CHECK(ncerr)
3080 :
3081 : ! FIXME
3082 : ! Unofficial variables. Notes:
3083 : ! 1) ETSF-IO does not support nshifts > 1
3084 : ! 2) shiftk_orig, nshiftk_orig refers to the values specified in the input (most useful ones).
3085 : ! 3) shiftk, kptrlatt refers to the values computed in inkpts.
3086 : ! 4) Should define a protocol so that abipy understands if we have a path or a mesh.
3087 : !write_kptrlatt = (SUM(ABS(ebands%kptrlatt))/=0)
3088 : !write_kptrlatt = (ebands%kptopt /= 0)
3089 :
3090 11164 : ngkpt = 0; write_ngkpt = .False.
3091 11164 : if (isdiagmat(ebands%kptrlatt) .and. ebands%nshiftk == 1) then
3092 34072 : write_ngkpt = .True.
3093 34072 : do ii=1,3
3094 34072 : ngkpt(ii) = ebands%kptrlatt(ii, ii)
3095 : end do
3096 8518 : ncerr = nctk_def_dims(ncid, nctkdim_t('ngkpt_nshiftk', ebands%nshiftk_orig))
3097 8518 : NCF_CHECK(ncerr)
3098 : end if
3099 :
3100 : ! Define k-points
3101 : ncerr = nctk_def_arrays(ncid, [&
3102 : nctkarr_t("reduced_coordinates_of_kpoints", "dp", "number_of_reduced_dimensions, number_of_kpoints"), &
3103 : nctkarr_t("kpoint_weights", "dp", "number_of_kpoints"), &
3104 : nctkarr_t("monkhorst_pack_folding", "int", "number_of_vectors") &
3105 44656 : ])
3106 11164 : NCF_CHECK(ncerr)
3107 :
3108 : ! Define states section.
3109 : ncerr = nctk_def_arrays(ncid, [&
3110 : nctkarr_t("number_of_states", "int", "number_of_kpoints, number_of_spins"), &
3111 : nctkarr_t("eigenvalues", "dp", "max_number_of_states, number_of_kpoints, number_of_spins"), &
3112 : nctkarr_t("occupations", "dp", "max_number_of_states, number_of_kpoints, number_of_spins"), &
3113 : nctkarr_t("smearing_scheme", "char", "character_string_length") &
3114 55820 : ])
3115 11164 : NCF_CHECK(ncerr)
3116 :
3117 22328 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "number_of_electrons"])
3118 11164 : NCF_CHECK(ncerr)
3119 33492 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "fermi_energy", "smearing_width"])
3120 11164 : NCF_CHECK(ncerr)
3121 :
3122 : ! Some variables require the specifications of units.
3123 11164 : NCF_CHECK(nctk_set_atomic_units(ncid, "eigenvalues"))
3124 11164 : NCF_CHECK(nctk_set_atomic_units(ncid, "fermi_energy"))
3125 :
3126 138096 : k_dependent = "no"; if (any(ebands%nband(1) /= ebands%nband)) k_dependent = "yes"
3127 11164 : NCF_CHECK(nf90_put_att(ncid, vid("number_of_states"), "k_dependent", k_dependent))
3128 :
3129 : ! Write data.
3130 : ! 1) Electrons.
3131 : ! NB: In etsf_io the number of electrons is declared as integer.
3132 : ! We use abinit nelect to store the value as real(dp).
3133 11164 : nelect_int = nint(ebands%nelect)
3134 :
3135 11164 : NCF_CHECK(nctk_set_datamode(ncid))
3136 11164 : NCF_CHECK(nf90_put_var(ncid, vid("fermi_energy"), ebands%fermie))
3137 11164 : NCF_CHECK(nf90_put_var(ncid, vid("number_of_electrons"), nelect_int))
3138 11164 : NCF_CHECK(nf90_put_var(ncid, vid("smearing_width"), ebands%tsmear))
3139 33492 : NCF_CHECK(nf90_put_var(ncid, vid("number_of_states"), ebands%nband, count=[ebands%nkpt, ebands%nsppol]))
3140 11164 : NCF_CHECK(nf90_put_var(ncid, vid("eigenvalues"), ebands%eig))
3141 11164 : NCF_CHECK(nf90_put_var(ncid, vid("occupations"), ebands%occ))
3142 11164 : NCF_CHECK(nf90_put_var(ncid, vid("smearing_scheme"), smearing))
3143 :
3144 : ! K-points
3145 11164 : NCF_CHECK(nf90_put_var(ncid, vid("reduced_coordinates_of_kpoints"), ebands%kptns))
3146 11164 : NCF_CHECK(nf90_put_var(ncid, vid("kpoint_weights"), ebands%wtk))
3147 :
3148 11164 : if (write_ngkpt) then
3149 8518 : NCF_CHECK(nf90_put_var(ncid, vid("monkhorst_pack_folding"), ngkpt))
3150 : end if
3151 :
3152 : ! ===========================================================
3153 : ! === Write abinit-related stuff (not covered by ETSF-IO) ===
3154 : ! ===========================================================
3155 : ! Define variables.
3156 33492 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "occopt", "kptopt"], defmode=.True.))
3157 55820 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "tphysel", "charge", "nelect", "extrael"]))
3158 :
3159 11164 : ncerr = nctk_def_arrays(ncid, nctkarr_t('istwfk', "i", 'number_of_kpoints'))
3160 11164 : NCF_CHECK(ncerr)
3161 :
3162 : ! Abinit variables defining the K-point sampling.
3163 : ncerr = nctk_def_arrays(ncid, [ &
3164 : nctkarr_t('kptrlatt_orig', "i", 'number_of_reduced_dimensions, number_of_reduced_dimensions'), &
3165 : nctkarr_t('shiftk_orig', "dp", 'number_of_reduced_dimensions, nshiftk_orig'), &
3166 : nctkarr_t('kptrlatt', "i", 'number_of_reduced_dimensions, number_of_reduced_dimensions'), &
3167 : nctkarr_t('shiftk', "dp", 'number_of_reduced_dimensions, nshiftk') &
3168 55820 : ])
3169 11164 : NCF_CHECK(ncerr)
3170 :
3171 11164 : if (write_ngkpt) then
3172 8518 : ncerr = nctk_def_arrays(ncid, nctkarr_t('ngkpt_shiftk', "dp", "number_of_reduced_dimensions, ngkpt_nshiftk"))
3173 8518 : NCF_CHECK(ncerr)
3174 : end if
3175 :
3176 : ! Write Abinit variables
3177 11164 : NCF_CHECK(nctk_set_datamode(ncid))
3178 11164 : NCF_CHECK(nf90_put_var(ncid, vid("tphysel"), ebands%tphysel))
3179 11164 : NCF_CHECK(nf90_put_var(ncid, vid("occopt"), ebands%occopt))
3180 11164 : NCF_CHECK(nf90_put_var(ncid, vid("istwfk"), ebands%istwfk))
3181 11164 : NCF_CHECK(nf90_put_var(ncid, vid("kptopt"), ebands%kptopt))
3182 11164 : NCF_CHECK(nf90_put_var(ncid, vid("charge"), ebands%cellcharge))
3183 11164 : NCF_CHECK(nf90_put_var(ncid, vid("extrael"), ebands%extrael))
3184 11164 : NCF_CHECK(nf90_put_var(ncid, vid("nelect"), ebands%nelect))
3185 11164 : NCF_CHECK(nf90_put_var(ncid, vid('kptrlatt_orig'), ebands%kptrlatt_orig))
3186 11164 : NCF_CHECK(nf90_put_var(ncid, vid('shiftk_orig'), ebands%shiftk_orig))
3187 11164 : NCF_CHECK(nf90_put_var(ncid, vid('kptrlatt'),ebands%kptrlatt))
3188 11164 : NCF_CHECK(nf90_put_var(ncid, vid('shiftk'), ebands%shiftk))
3189 :
3190 11164 : if (write_ngkpt) then
3191 8518 : NCF_CHECK(nf90_put_var(ncid, vid('ngkpt_shiftk'), ebands%shiftk_orig))
3192 : end if
3193 :
3194 : !In the case occopt 9
3195 11164 : if (ebands%occopt == 9) then
3196 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
3197 3 : "number_of_conduction_electrons", "number_of_valence_holes"])
3198 1 : NCF_CHECK(ncerr)
3199 2 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "holes_fermi_energy"])
3200 1 : NCF_CHECK(ncerr)
3201 1 : NCF_CHECK(nctk_set_atomic_units(ncid,"holes_fermi_energy"))
3202 1 : NCF_CHECK(nf90_put_var(ncid, vid("holes_fermi_energy"), ebands%fermih))
3203 1 : NCF_CHECK(nf90_put_var(ncid, vid("number_of_conduction_electrons"), ebands%ne_qFD))
3204 1 : NCF_CHECK(nf90_put_var(ncid, vid("number_of_valence_holes"), ebands%nh_qFD))
3205 : endif
3206 :
3207 : contains
3208 251483 : integer function vid(vname)
3209 : character(len=*),intent(in) :: vname
3210 251483 : vid = nctk_idname(ncid, vname)
3211 : end function vid
3212 :
3213 : end function ebands_ncwrite
3214 : !!***
3215 :
3216 : !----------------------------------------------------------------------
3217 :
3218 : !!****f* m_ebands/ebands_ncwrite_path
3219 : !! NAME
3220 : !! ebands_ncwrite_path
3221 : !!
3222 : !! FUNCTION
3223 : !! Writes the content of an ebands_t object to a NETCDF file
3224 : !!
3225 : !! INPUTS
3226 : !! cryst=Crystal structure
3227 : !! path=File name
3228 : !!
3229 : !! OUTPUT
3230 : !!
3231 : !! SOURCE
3232 :
3233 0 : integer function ebands_ncwrite_path(ebands, cryst, path) result(ncerr)
3234 :
3235 : !Arguments ------------------------------------
3236 : !scalars
3237 : class(ebands_t),intent(in) :: ebands
3238 : type(crystal_t),intent(in) :: cryst
3239 : character(len=*),intent(in) :: path
3240 :
3241 : !Local variables-------------------------------
3242 : !scalars
3243 : integer :: ncid
3244 : ! *************************************************************************
3245 :
3246 0 : ncerr = nf90_noerr
3247 0 : if (file_exists(path)) then
3248 0 : NCF_CHECK(nctk_open_modify(ncid, path, xmpi_comm_self))
3249 : else
3250 0 : ncerr = nctk_open_create(ncid, path, xmpi_comm_self)
3251 0 : NCF_CHECK_MSG(ncerr, sjoin("Creating", path))
3252 : end if
3253 :
3254 0 : NCF_CHECK(cryst%ncwrite(ncid))
3255 0 : NCF_CHECK(ebands_ncwrite(ebands, ncid))
3256 0 : NCF_CHECK(nf90_close(ncid))
3257 :
3258 0 : end function ebands_ncwrite_path
3259 : !!***
3260 :
3261 : !----------------------------------------------------------------------
3262 :
3263 : !!****f* m_ebands/ebands_get_edos
3264 : !! NAME
3265 : !! ebands_get_edos
3266 : !!
3267 : !! FUNCTION
3268 : !! Calculate the electronic density of states from ebands_t
3269 : !!
3270 : !! INPUTS
3271 : !! ebands<ebands_t>=Band structure object.
3272 : !! cryst<cryst_t>=Info on the crystalline structure.
3273 : !! intmeth= 1 for Gaussian, 2 or -2 for tetrahedra (-2 if Blochl corrections must be included).
3274 : !! If nkpt == 1 (Gamma only), the routine fallbacks to gaussian method.
3275 : !! step=Step on the linear mesh in Ha. If <0, the routine will use the mean of the energy level spacing
3276 : !! broad=Gaussian broadening, If <0, the routine will use a default
3277 : !! value for the broadening computed from the mean of the energy level spacing.
3278 : !! No meaning for tetrahedra
3279 : !! comm=MPI communicator
3280 : !!
3281 : !! OUTPUT
3282 : !! edos<edos_t>=Electronic DOS and IDOS.
3283 : !!
3284 : !! SOURCE
3285 :
3286 5 : type(edos_t) function ebands_get_edos(ebands, cryst, intmeth, step, broad, comm) result(edos)
3287 :
3288 : !Arguments ------------------------------------
3289 : !scalars
3290 : class(ebands_t),target,intent(in) :: ebands
3291 : type(crystal_t),intent(in) :: cryst
3292 : integer,intent(in) :: intmeth,comm
3293 : real(dp),intent(in) :: step,broad
3294 :
3295 : !Local variables-------------------------------
3296 : !scalars
3297 : integer :: nw,spin,band,ikpt,ief,ihf,nproc,my_rank,ierr,cnt,bcorr
3298 : real(dp) :: max_ene,min_ene,wtk,max_occ
3299 : character(len=500) :: msg
3300 5 : type(htetra_t) :: tetra
3301 : !arrays
3302 10 : real(dp) :: eminmax_spin(2,ebands%nsppol)
3303 5 : real(dp),allocatable :: wme0(:),wdt(:,:),tmp_eigen(:)
3304 : ! *********************************************************************
3305 :
3306 5 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3307 5 : ierr = 0
3308 :
3309 5 : edos%nkibz = ebands%nkpt; edos%nsppol = ebands%nsppol; edos%nspinor = ebands%nspinor
3310 5 : edos%intmeth = intmeth
3311 5 : edos%nelect = ebands%nelect
3312 :
3313 5 : if (ebands%nkpt == 1) then
3314 0 : ABI_COMMENT("Cannot use tetrahedra for e-DOS when nkpt == 1. Switching to gaussian method")
3315 0 : edos%intmeth = 1
3316 : end if
3317 :
3318 5 : edos%broad = broad; edos%step = step
3319 :
3320 : ! Compute the linear mesh so that it encloses all bands.
3321 5 : eminmax_spin = ebands_get_minmax(ebands, "eig")
3322 15 : min_ene = minval(eminmax_spin(1, :)); min_ene = min_ene - 0.1_dp * abs(min_ene)
3323 15 : max_ene = maxval(eminmax_spin(2, :)); max_ene = max_ene + 0.1_dp * abs(max_ene)
3324 :
3325 5 : nw = nint((max_ene - min_ene) / edos%step) + 1; edos%nw = nw
3326 :
3327 15 : ABI_MALLOC(edos%mesh, (nw))
3328 15510 : edos%mesh = arth(min_ene, edos%step, nw)
3329 :
3330 25 : ABI_CALLOC(edos%gef, (0:edos%nsppol))
3331 20 : ABI_CALLOC(edos%ghf, (0:edos%nsppol))
3332 31030 : ABI_CALLOC(edos%dos, (nw, 0:edos%nsppol))
3333 31025 : ABI_CALLOC(edos%idos, (nw, 0:edos%nsppol))
3334 :
3335 5 : select case (edos%intmeth)
3336 : case (1)
3337 : !call wrtout(std_out, " Computing electron-DOS with Gaussian method")
3338 : !call wrtout(std_out, sjoin(" broadening: ", ftoa(edos%broad * Ha_eV), " (eV), step: ", ftoa(edos%step * Ha_eV), "(eV), npts: ",
3339 : !itoa(nw)))
3340 : ! Gaussian
3341 0 : ABI_MALLOC(wme0, (nw))
3342 0 : cnt = 0
3343 0 : do spin=1,edos%nsppol
3344 0 : do ikpt=1,ebands%nkpt
3345 0 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism
3346 0 : wtk = ebands%wtk(ikpt)
3347 0 : do band=1,ebands%nband(ikpt+(spin-1)*ebands%nkpt)
3348 0 : wme0 = edos%mesh - ebands%eig(band, ikpt, spin)
3349 0 : edos%dos(:, spin) = edos%dos(:, spin) + wtk * gaussian(wme0, edos%broad)
3350 : end do
3351 : end do
3352 : end do
3353 0 : ABI_FREE(wme0)
3354 0 : call xmpi_sum(edos%dos, comm, ierr)
3355 :
3356 : case (2, -2)
3357 : !call wrtout(std_out, " Computing electron-DOS with tetrahedron method")
3358 : ! Consistency test
3359 150 : if (any(ebands%nband /= ebands%nband(1)) ) ABI_ERROR('for tetrahedra, nband(:) must be constant')
3360 :
3361 : ! Build tetra object.
3362 : tetra = tetra_from_kptrlatt(cryst, ebands%kptopt, ebands%kptrlatt, &
3363 5 : ebands%nshiftk, ebands%shiftk, ebands%nkpt, ebands%kptns, comm, msg, ierr)
3364 5 : ABI_CHECK(ierr == 0, msg)
3365 :
3366 : ! For each spin and band, interpolate over kpoints, calculate integration weights and DOS contribution.
3367 15 : ABI_MALLOC(tmp_eigen, (ebands%nkpt))
3368 15 : ABI_MALLOC(wdt, (nw, 2))
3369 :
3370 5 : bcorr = 0; if (intmeth == -2) bcorr = 1
3371 5 : cnt = 0
3372 10 : do spin=1,ebands%nsppol
3373 35 : do band=1,ebands%nband(1)
3374 : ! For each band get its contribution
3375 775 : tmp_eigen = ebands%eig(band,:,spin)
3376 755 : do ikpt=1,ebands%nkpt
3377 725 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
3378 :
3379 : ! Calculate integration weights at each irred k-point (Blochl et al PRB 49 16223 [[cite:Bloechl1994a]])
3380 725 : call tetra%get_onewk(ikpt, bcorr, nw, ebands%nkpt, tmp_eigen, min_ene, max_ene, one, wdt)
3381 :
3382 2248225 : edos%dos(:,spin) = edos%dos(:,spin) + wdt(:, 1) * ebands%wtk(ikpt)
3383 2248250 : edos%idos(:,spin) = edos%idos(:,spin) + wdt(:, 2) * ebands%wtk(ikpt)
3384 : end do ! ikpt
3385 : end do ! band
3386 : end do ! spin
3387 :
3388 5 : call xmpi_sum(edos%dos, comm, ierr)
3389 5 : call xmpi_sum(edos%idos, comm, ierr)
3390 :
3391 : ! Free memory
3392 5 : ABI_FREE(tmp_eigen)
3393 5 : ABI_FREE(wdt)
3394 5 : call tetra%free()
3395 :
3396 : ! Filter so that dos[i] is always >= 0 and idos is monotonic
3397 : ! IDOS is computed afterwards with simpson
3398 15515 : where (edos%dos(:,1:) <= zero)
3399 : edos%dos(:,1:) = zero
3400 : end where
3401 :
3402 : case default
3403 5 : ABI_ERROR(sjoin("Wrong integration method:", itoa(intmeth)))
3404 : end select
3405 :
3406 : ! Compute total DOS and IDOS by summing the two spin channels.
3407 5 : max_occ = two / (ebands%nspinor * ebands%nsppol)
3408 31005 : edos%dos(:, 0) = max_occ * sum(edos%dos(:,1:), dim=2)
3409 :
3410 5 : if (edos%intmeth == 1) then
3411 0 : do spin=1,edos%nsppol
3412 0 : call simpson_int(nw, edos%step, edos%dos(:,spin), edos%idos(:,spin))
3413 : end do
3414 : end if
3415 31005 : edos%idos(:, 0) = max_occ * sum(edos%idos(:,1:), dim=2)
3416 :
3417 : ! Use bisection to find the Fermi level at T = 0
3418 : ! Warning: this code assumes idos[i+1] >= idos[i]. This condition may not be
3419 : ! fulfilled if we use tetra and this is the reason why we have filtered the DOS.
3420 5 : if (ebands%occopt == 9) then
3421 0 : ihf = bisect(edos%idos(:,0), ebands%nelect-ebands%nh_qFD)
3422 0 : ief = bisect(edos%idos(:,0), ebands%nelect+ebands%ne_qFD)
3423 : else
3424 5 : ief = bisect(edos%idos(:,0), ebands%nelect)
3425 5 : ihf = ief
3426 : end if
3427 :
3428 : ! Handle out of range condition.
3429 5 : if (ief == 0 .or. ief == nw) then
3430 : write(msg,"(3a)")&
3431 0 : "Bisection could not find an initial guess for the Fermi level!",ch10,&
3432 0 : "Possible reasons: not enough bands or wrong number of electrons"
3433 0 : ABI_WARNING(msg)
3434 0 : return
3435 5 : else if (ihf == 0 .or. ihf == nw) then
3436 : write(msg,"(3a)")&
3437 0 : "Bisection could not find an initial guess for the holes Fermi level!",ch10,&
3438 0 : "Possible reasons: not enough bands or wrong number of holes"
3439 0 : ABI_WARNING(msg)
3440 0 : return
3441 : end if
3442 :
3443 : ! TODO: Use linear interpolation to find an improved estimate of the Fermi level?
3444 5 : edos%ief = ief
3445 5 : edos%ihf = ihf
3446 15 : do spin=0,edos%nsppol
3447 10 : edos%gef(spin) = edos%dos(ief,spin)
3448 15 : edos%ghf(spin) = edos%dos(ihf,spin)
3449 : end do
3450 :
3451 : !write(std_out,*)"fermie from ebands: ",ebands%fermie
3452 : !write(std_out,*)"fermie from IDOS: ",edos%mesh(ief)
3453 : !write(std_out,*)"gef:from ebands%fermie: " ,edos%dos(bisect(edos%mesh, ebands%fermie), 0)
3454 : !write(std_out,*)"gef:from edos: " ,edos%gef(0)
3455 :
3456 10 : end function ebands_get_edos
3457 : !!***
3458 :
3459 : !----------------------------------------------------------------------
3460 :
3461 : !!****f* m_ebands/edos_free
3462 : !! NAME
3463 : !! edos_free
3464 : !!
3465 : !! FUNCTION
3466 : !! Free the memory allocated in edos_t
3467 : !!
3468 : !! SOURCE
3469 :
3470 76 : subroutine edos_free(edos)
3471 :
3472 : !Arguments ------------------------------------
3473 : class(edos_t),intent(inout) :: edos
3474 : ! *********************************************************************
3475 :
3476 : !real
3477 76 : ABI_SFREE(edos%mesh)
3478 76 : ABI_SFREE(edos%dos)
3479 76 : ABI_SFREE(edos%idos)
3480 76 : ABI_SFREE(edos%gef)
3481 76 : ABI_SFREE(edos%ghf)
3482 :
3483 76 : end subroutine edos_free
3484 : !!***
3485 :
3486 : !----------------------------------------------------------------------
3487 :
3488 : !!****f* m_ebands/edos_write
3489 : !! NAME
3490 : !! edos_write
3491 : !!
3492 : !! FUNCTION
3493 : !! Write results to file.
3494 : !!
3495 : !! INPUTS
3496 : !! path=File name.
3497 : !!
3498 : !! SOURCE
3499 :
3500 5 : subroutine edos_write(edos, path)
3501 :
3502 : !Arguments ------------------------------------
3503 : class(edos_t),intent(in) :: edos
3504 : character(len=*),intent(in) :: path
3505 :
3506 : !Local variables-------------------------------
3507 : integer :: iw,spin,unt
3508 : real(dp) :: efermi, gef_tot, gef_up, gef_down
3509 : character(len=500) :: msg
3510 : type(yamldoc_t) :: ydoc
3511 : ! *************************************************************************
3512 :
3513 15 : call wrtout([std_out, ab_out], sjoin("- Writing electron DOS to file:", path, ch10))
3514 :
3515 5 : if (open_file(path, msg, newunit=unt, form="formatted", action="write") /= 0) then
3516 0 : ABI_ERROR(msg)
3517 : end if
3518 :
3519 : ! Write header (human-readable format)
3520 5 : write(unt,'(a)')'# Electron density of states: Energy in eV, DOS in states/eV per unit cell.'
3521 5 : write(unt,"(a)")"# The zero of energies corresponds to the Fermi level."
3522 :
3523 : ! Add Yaml section with parameters.
3524 5 : ydoc = yamldoc_open("EDOS_PARAMS")
3525 : call ydoc%add_ints("nkibz, nsppol, nspinor, intmeth, edos_npts", &
3526 30 : [edos%nkibz, edos%nsppol, edos%nspinor, edos%intmeth, edos%nw])
3527 : call ydoc%add_reals("nelect, edos_mesh_step_eV", &
3528 15 : [edos%nelect, edos%step * Ha_eV])
3529 :
3530 5 : select case (edos%intmeth)
3531 : case (1)
3532 0 : call ydoc%add_string("method", "Gaussian")
3533 0 : call ydoc%add_real("gaussian_broadening_eV", edos%broad * Ha_eV)
3534 : case (2)
3535 5 : call ydoc%add_string("method", "Linear tetrahedron")
3536 : case (-2)
3537 0 : call ydoc%add_string("method", "Linear tetrahedron method with Blochl corrections")
3538 : case default
3539 5 : ABI_ERROR(sjoin("Wrong method:", itoa(edos%intmeth)))
3540 : end select
3541 :
3542 5 : if (edos%ief == 0) then
3543 0 : call ydoc%set_keys_to_string("Fermi_level_eV, gef, gef_up, gef_down", "null")
3544 0 : efermi = zero
3545 : else
3546 5 : efermi = edos%mesh(edos%ief)
3547 5 : call ydoc%add_real("Fermi_level_eV", efermi * Ha_eV)
3548 5 : gef_tot = edos%gef(0) / Ha_eV
3549 5 : gef_up = gef_tot / two; gef_down = gef_tot / two
3550 5 : if (edos%nsppol == 2) then
3551 0 : gef_up = edos%gef(1) / Ha_eV; gef_down = edos%gef(2) / Ha_eV
3552 : end if
3553 5 : if (edos%nspinor == 1) then
3554 20 : call ydoc%add_reals("gef, gef_up, gef_down", [gef_tot, gef_up, gef_down])
3555 : else
3556 0 : call ydoc%add_reals("gef", [gef_tot])
3557 : end if
3558 : end if
3559 :
3560 : ! Write header in Yaml format but prepend # so that one can still use tools such as gnuplot or xmgrace.
3561 5 : call ydoc%write_and_free(unt, firstchar="#")
3562 :
3563 : ! Write data.
3564 5 : write(unt,"(a)")"# Energy DOS_TOT IDOS_TOT DOS[spin=UP] IDOS[spin=UP] ..."
3565 15505 : do iw=1,edos%nw
3566 15500 : write(unt,'(es17.8)',advance='no')(edos%mesh(iw) - efermi) * Ha_eV
3567 46500 : do spin=0,edos%nsppol
3568 46500 : write(unt,'(2es17.8)',advance='no')max(edos%dos(iw,spin) / Ha_eV, tol30), max(edos%idos(iw,spin), tol30)
3569 : end do
3570 15505 : write(unt,*)
3571 : end do
3572 :
3573 5 : close(unt)
3574 :
3575 5 : end subroutine edos_write
3576 : !!***
3577 :
3578 : !----------------------------------------------------------------------
3579 :
3580 : !!****f* m_ebands/edos_ncwrite
3581 : !! NAME
3582 : !! edos_ncwrite
3583 : !!
3584 : !! FUNCTION
3585 : !! Write results to netcdf file.
3586 : !!
3587 : !! INPUTS
3588 : !! ncid=NC file handle.
3589 : !! [prefix]=String prepended to netcdf dimensions/variables (HDF5 poor-man groups)
3590 : !! Empty string if not specified.
3591 : !!
3592 : !! OUTPUT
3593 : !! ncerr= netcdf exit status.
3594 : !!
3595 : !! SOURCE
3596 :
3597 18 : integer function edos_ncwrite(edos, ncid, prefix) result(ncerr)
3598 :
3599 : !Arguments ------------------------------------
3600 : class(edos_t),intent(in) :: edos
3601 : integer,intent(in) :: ncid
3602 : character(len=*),optional,intent(in) :: prefix
3603 :
3604 : !Local variables-------------------------------
3605 : character(len=500) :: prefix_
3606 : ! *************************************************************************
3607 :
3608 0 : prefix_ = ""; if (present(prefix)) prefix_ = trim(prefix)
3609 :
3610 : ! Define dimensions.
3611 : ncerr = nctk_def_dims(ncid, [ &
3612 54 : nctkdim_t("nsppol_plus1", edos%nsppol + 1), nctkdim_t("edos_nw", edos%nw)], defmode=.True., prefix=prefix_)
3613 18 : NCF_CHECK(ncerr)
3614 :
3615 : ! Define variables
3616 54 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "edos_intmeth", "edos_nkibz"], prefix=prefix_))
3617 54 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "edos_ief", "edos_ihf"], prefix=prefix_))
3618 36 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "edos_broad"], prefix=prefix_))
3619 :
3620 : ncerr = nctk_def_arrays(ncid, [ &
3621 : nctkarr_t("edos_mesh", "dp", "edos_nw"), &
3622 : nctkarr_t("edos_dos", "dp", "edos_nw, nsppol_plus1"), &
3623 : nctkarr_t("edos_idos", "dp", "edos_nw, nsppol_plus1"), &
3624 : nctkarr_t("edos_gef", "dp", "nsppol_plus1"), &
3625 : nctkarr_t("edos_ghf", "dp", "nsppol_plus1") &
3626 108 : ], prefix=prefix_)
3627 18 : NCF_CHECK(ncerr)
3628 :
3629 : ! Write data.
3630 18 : NCF_CHECK(nctk_set_datamode(ncid))
3631 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_intmeth")), edos%intmeth))
3632 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_nkibz")), edos%nkibz))
3633 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_ief")), edos%ief))
3634 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_ihf")), edos%ihf))
3635 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_broad")), edos%broad))
3636 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_mesh")), edos%mesh))
3637 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_dos")), edos%dos))
3638 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_idos")), edos%idos))
3639 18 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_gef")), edos%gef))
3640 36 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_ghf")), edos%ghf))
3641 :
3642 : contains
3643 180 : pure function pre(istr) result(ostr)
3644 : character(len=*),intent(in) :: istr
3645 : character(len=len_trim(prefix_) + len_trim(istr)+1) :: ostr
3646 180 : ostr = trim(prefix_) // trim(istr)
3647 180 : end function pre
3648 :
3649 : end function edos_ncwrite
3650 : !!***
3651 :
3652 : !!****f* m_ebands/edos_print
3653 : !! NAME
3654 : !! edos_print
3655 : !!
3656 : !! FUNCTION
3657 : !! Print DOS info.
3658 : !!
3659 : !! INPUTS
3660 : !! units=Unit numbers for output
3661 : !! [header]=Header string.
3662 : !!
3663 : !! SOURCE
3664 :
3665 36 : subroutine edos_print(edos, units, header)
3666 :
3667 : !Arguments ------------------------------------
3668 : class(edos_t),intent(in) :: edos
3669 : integer,intent(in) :: units(:)
3670 : character(len=*),optional,intent(in) :: header
3671 :
3672 : !Local variables-------------------------------
3673 : character(len=500) :: msg
3674 : ! *************************************************************************
3675 :
3676 18 : if (present(header)) then
3677 13 : write(msg, "(a)") ch10//' === '//trim(adjustl(header))//' === '
3678 : else
3679 5 : write(msg, "(a)") ch10
3680 : end if
3681 18 : call wrtout(units, msg)
3682 :
3683 18 : select case (edos%intmeth)
3684 : case (1)
3685 0 : write(msg, "(a,f5.1,a)") " Gaussian method with broadening: ", edos%broad * Ha_meV, " (meV)"
3686 : case (2)
3687 18 : write(msg, "(a)")" Linear tetrahedron method."
3688 : case (-2)
3689 0 : write(msg, "(a)")" Linear tetrahedron method with Blochl corrections."
3690 : case default
3691 18 : ABI_ERROR(sjoin("Wrong intmeth:", itoa(edos%intmeth)))
3692 : end select
3693 18 : call wrtout(units, msg)
3694 :
3695 18 : write(msg, "(a,f5.1,a, i0)")" Mesh step: ", edos%step * Ha_meV, " (meV) with npts: ", edos%nw
3696 18 : call wrtout(units, msg)
3697 18 : write(msg, "(2(a,f5.1),a)")" From emin: ", edos%mesh(1) * Ha_eV, " to emax: ", edos%mesh(edos%nw) * Ha_eV, " (eV)"
3698 18 : call wrtout(units, msg)
3699 18 : write(msg, "(a, i0)")" Number of k-points in the IBZ: ", edos%nkibz
3700 18 : call wrtout(units, msg)
3701 :
3702 18 : if (edos%ief == 0) then
3703 12 : call wrtout(units, " edos%ief == 0 --> Cannot print quantities at the Fermi level.", newlines=1)
3704 12 : return
3705 : end if
3706 :
3707 6 : write(msg,'(a,es16.8,a)')' Fermi level: ',edos%mesh(edos%ief) * Ha_eV, " (eV)"
3708 6 : call wrtout(units, msg)
3709 6 : write(msg,"(a,es16.8)")" Total electron DOS at Fermi level in states/eV: ", edos%gef(0) / Ha_eV
3710 6 : call wrtout(units, msg)
3711 :
3712 6 : if (edos%nsppol == 2) then
3713 0 : write(msg,"(a,es16.8)")" g(eF) for spin up: ", edos%gef(1) / Ha_eV
3714 0 : call wrtout(units, msg)
3715 0 : write(msg,"(a,es16.8)")" g(eF) for spin down:", edos%gef(2) / Ha_eV
3716 0 : call wrtout(units, msg)
3717 : end if
3718 6 : write(msg,"(a,f6.1)")" Total number of electrons at eF: ", edos%idos(edos%ief, 0)
3719 6 : call wrtout(units, msg)
3720 :
3721 6 : if (edos%nsppol == 2) then
3722 0 : write(msg,"(a,es16.8)")" IDOS(eF) for spin up: ", edos%idos(edos%ief, 1)
3723 0 : call wrtout(units, msg)
3724 0 : write(msg,"(a,es16.8)")" IDOS(eF) for spin down:", edos%idos(edos%ief, 2)
3725 0 : call wrtout(units, msg)
3726 : end if
3727 :
3728 6 : if (edos%ihf /= edos%ief) then
3729 0 : write(msg,'(a,es16.8,a)')' Fermi level for excited holes: ',edos%mesh(edos%ihf) * Ha_eV, " (eV)"
3730 0 : call wrtout(units, msg)
3731 0 : write(msg,"(a,es16.8)")" Total hole DOS at Fermi level in states/eV: ", edos%ghf(0) / Ha_eV
3732 0 : call wrtout(units, msg)
3733 0 : if (edos%nsppol == 2) then
3734 0 : write(msg,"(a,es16.8)")" g(hF) for spin up: ", edos%ghf(1) / Ha_eV
3735 0 : call wrtout(units, msg)
3736 0 : write(msg,"(a,es16.8)")" g(hF) for spin down:", edos%ghf(2) / Ha_eV
3737 0 : call wrtout(units, msg)
3738 : end if
3739 0 : write(msg,"(a,f6.1)")" Total number of electrons at hF: ", edos%idos(edos%ihf, 0)
3740 0 : call wrtout(units, msg)
3741 :
3742 0 : if (edos%nsppol == 2) then
3743 0 : write(msg,"(a,es16.8)")" N(hF) for spin up: ", edos%idos(edos%ihf, 1)
3744 0 : call wrtout(units, msg)
3745 0 : write(msg,"(a,es16.8)")" N(hF) for spin down:", edos%idos(edos%ihf, 2)
3746 0 : call wrtout(units, msg)
3747 : end if
3748 : end if
3749 :
3750 6 : call wrtout(units, " ")
3751 :
3752 18 : end subroutine edos_print
3753 : !!***
3754 :
3755 : !!****f* m_ebands/edos_get_carriers
3756 : !! NAME
3757 : !! edos_get_carriers
3758 : !!
3759 : !! FUNCTION
3760 : !! Compute number of holes (nh) and electrons (ne) per unit cell from a given
3761 : !! list of `ntemp` temperatures `kTmesh` and chemical potentials `mu_e`.
3762 : !! Return n_ehst(2, nsppol, ntemp) where the first dimension if for electrons/holes.
3763 : !! If nsppol == 2, the second dimension is the number of e/h for spin else the total number of e/h summed over spins.!!
3764 : !! To discern between electrons and holes in semiconductors we assume that ef is inside the gap.
3765 : !!
3766 : !! INPUTS
3767 : !!
3768 : !! OUTPUT
3769 : !!
3770 : !! SOURCE
3771 :
3772 0 : subroutine edos_get_carriers(edos, ntemp, kTmesh, mu_e, n_ehst)
3773 :
3774 : !Arguments ------------------------------------
3775 : class(edos_t),intent(in) :: edos
3776 : integer,intent(in) :: ntemp
3777 : !arrays
3778 : real(dp),intent(in) :: kTmesh(ntemp), mu_e(ntemp)
3779 : real(dp),intent(out) :: n_ehst(2, edos%nsppol, ntemp)
3780 :
3781 : !Local variables-------------------------------
3782 : integer :: itemp, iw, spin
3783 0 : real(dp),allocatable :: values(:)
3784 : ! *************************************************************************
3785 :
3786 : ! Copy important dimensions
3787 0 : n_ehst = zero
3788 0 : ABI_MALLOC(values, (edos%nw))
3789 :
3790 0 : do itemp=1,ntemp
3791 :
3792 : ! For electrons (assuming ef inside the gap if semiconductor)
3793 0 : do spin=1,edos%nsppol
3794 0 : do iw=1,edos%nw
3795 0 : if (edos%mesh(iw) >= mu_e(itemp)) then
3796 0 : values(iw) = edos%dos(iw, spin) * occ_fd(edos%mesh(iw), kTmesh(itemp), mu_e(itemp))
3797 : else
3798 0 : values(iw) = zero
3799 : end if
3800 : end do
3801 0 : n_ehst(1, spin, itemp) = simpson(edos%step, values)
3802 : end do ! spin
3803 :
3804 : ! For holes
3805 0 : do spin=1,edos%nsppol
3806 0 : do iw=1,edos%nw
3807 0 : if (edos%mesh(iw) < mu_e(itemp)) then
3808 0 : values(iw) = edos%dos(iw, spin) * (one - occ_fd(edos%mesh(iw), kTmesh(itemp), mu_e(itemp)))
3809 : else
3810 0 : values(iw) = zero
3811 : end if
3812 : end do
3813 0 : n_ehst(2, spin, itemp) = simpson(edos%step, values)
3814 : end do ! spin
3815 :
3816 : end do ! itemp
3817 :
3818 0 : if (edos%nsppol == 1 .and. edos%nspinor == 1) n_ehst = two * n_ehst
3819 0 : ABI_FREE(values)
3820 :
3821 0 : end subroutine edos_get_carriers
3822 : !!***
3823 :
3824 : !----------------------------------------------------------------------
3825 :
3826 : !!****f* m_ebands/ebands_write_nesting
3827 : !! NAME
3828 : !! ebands_write_nesting
3829 : !!
3830 : !! FUNCTION
3831 : !! Calculate the nesting function and output data to file.
3832 : !!
3833 : !! INPUTS
3834 : !! ebands<ebands_t>=the ebands_t datatype
3835 : !! cryst<crystal_t>=Info on unit cell and symmetries.
3836 : !! filepath=File name for output data.
3837 : !! prtnest = flags governing the format of the output file. see mknesting.
3838 : !! 1 for X-Y format, 2 for XCrysden format (XSF)
3839 : !! tsmear=Broadening used to approximation the delta function.
3840 : !! fermie_nest
3841 : !! qpath_vertices = vertices of the reciprocal space trajectory
3842 : !!
3843 : !! OUTPUT
3844 : !! Return non-zero exist status if netsting factor cannot be produced.
3845 : !! The errmsg string gives information on the error.
3846 : !!
3847 : !! SIDE EFFECTS
3848 : !! Write data to file.
3849 : !!
3850 : !! SOURCE
3851 :
3852 2 : integer function ebands_write_nesting(ebands,cryst,filepath,prtnest,tsmear,fermie_nest,qpath_vertices,errmsg) result(skip)
3853 :
3854 : !Arguments ------------------------------------
3855 : class(ebands_t),intent(in) :: ebands
3856 : type(crystal_t),intent(in) :: cryst
3857 : integer,intent(in) :: prtnest
3858 : real(dp),intent(in) :: tsmear,fermie_nest
3859 : character(len=*),intent(in) :: filepath
3860 : character(len=*),intent(out) :: errmsg
3861 : !arrays
3862 : real(dp),intent(in) :: qpath_vertices(:,:)
3863 :
3864 : !Local variables-------------------------------
3865 : !scalaras
3866 : integer :: ikpt,spin,iband,nqpath
3867 : real(dp) :: invgauwidth,prefact,fermie
3868 : !arrays
3869 1 : real(dp), allocatable :: fs_weights(:,:,:)
3870 :
3871 : ! *********************************************************************
3872 :
3873 1 : skip = 0; errmsg = ""
3874 30 : if (any(ebands%nband /= ebands%nband(1))) then
3875 : errmsg = 'mknesting can not handle variable nband(1:nkpt). Skipped.'//&
3876 0 : ch10//' Correct input file to get nesting output'
3877 0 : skip = 1; return
3878 : end if
3879 :
3880 1 : if (ebands%nshiftk /= 1) then
3881 0 : errmsg = 'mknesting does not support nshiftk > 1. Change ngkpt and shiftk to have only one shift after inkpts'
3882 0 : skip = 1; return
3883 : end if
3884 :
3885 : ! FIXME: needs to be generalized to complete the k grid for one of the arguments to mknesting
3886 1 : fermie = ebands%fermie
3887 1 : nqpath = size(qpath_vertices, dim=2)
3888 :
3889 : ! Compute weights. Set sigma to 0.1 eV is tsmear is zero
3890 1 : invgauwidth = one / (0.1_dp * eV_Ha); if (tsmear > tol10) invgauwidth = one / tsmear
3891 1 : prefact = one / sqrt(pi) * invgauwidth
3892 :
3893 5 : ABI_MALLOC(fs_weights, (ebands%nband(1), ebands%nkpt, ebands%nsppol))
3894 :
3895 2 : do spin=1,ebands%nsppol
3896 31 : do ikpt=1,ebands%nkpt
3897 175 : do iband=1,ebands%nband(1)
3898 : fs_weights(iband, ikpt, spin) = prefact * &
3899 174 : exp(-(invgauwidth*(ebands%eig(iband,ikpt,spin)-(fermie + fermie_nest)))**2)
3900 : end do
3901 : end do
3902 : end do
3903 :
3904 1 : if (any(ebands%kptopt == [3, 4])) then ! no symmetry
3905 : call mknesting(ebands%nkpt,ebands%kptns,ebands%kptrlatt,ebands%nband(1),fs_weights,nqpath,&
3906 0 : qpath_vertices,1,[zero, zero, zero],filepath,cryst%gprimd,cryst%gmet,prtnest,identity_3d)
3907 : else
3908 : call mknesting(ebands%nkpt,ebands%kptns,ebands%kptrlatt,ebands%nband(1),fs_weights,nqpath,&
3909 : qpath_vertices,1, [zero, zero, zero], filepath,cryst%gprimd,cryst%gmet,prtnest,identity_3d,&
3910 1 : nsym=cryst%nsym, symrec=cryst%symrec)
3911 : end if
3912 :
3913 1 : ABI_FREE(fs_weights)
3914 :
3915 1 : end function ebands_write_nesting
3916 : !!***
3917 :
3918 : !----------------------------------------------------------------------
3919 :
3920 : !!****f* m_ebands/ebands_expandk
3921 : !! NAME
3922 : !! ebands_expandk
3923 : !!
3924 : !! FUNCTION
3925 : !! Return a new object of type ebands_t corresponding to a list of k-points
3926 : !! specified in input. Symmetry properties of the eigenvectors are used to
3927 : !! symmetrize energies and occupation numbers.
3928 : !!
3929 : !! INPUTS
3930 : !! inb<ebands_t>=Initial band structure with energies in the IBZ.
3931 : !! ecut_eff=Effective cutoff energy i.e. ecut * dilatmx**2
3932 : !! force_istwfk1=If True, istwfk if forced to 1 for all the k-points in the BZ.
3933 : !!
3934 : !! OUTPUT
3935 : !! dksqmax=maximal value of the norm**2 of the difference between
3936 : !! a kpt in the BZ and the closest k-point found in the inb%kpts set, using symmetries.
3937 : !! bz2ibz(nkpt2,6)=describe k point number of kpt1 that allows to
3938 : !! generate wavefunctions closest to given kpt2
3939 : !! bz2ibz(:,1)=k point number of kptns1
3940 : !! bz2ibz(:,2)=symmetry operation to be applied to kpt1, to give kpt1a
3941 : !! (if 0, means no symmetry operation, equivalent to identity )
3942 : !! bz2ibz(:,3:5)=shift in reciprocal space to be given to kpt1a,
3943 : !! to give kpt1b, that is the closest to kpt2.
3944 : !! bz2ibz(:,6)=1 if time-reversal was used to generate kpt1a from kpt1, 0 otherwise
3945 : !! outb<ebands_t>=band structure with energies in the BZ.
3946 : !!
3947 : !! SOURCE
3948 :
3949 8 : subroutine ebands_expandk(inb, cryst, ecut_eff, force_istwfk1, dksqmax, bz2ibz, outb)
3950 :
3951 : !Arguments ------------------------------------
3952 : !scalars
3953 : class(ebands_t),intent(in) :: inb
3954 : real(dp),intent(in) :: ecut_eff
3955 : real(dp),intent(out) :: dksqmax
3956 : logical,intent(in) :: force_istwfk1
3957 : class(ebands_t),intent(out) :: outb
3958 : class(crystal_t),intent(in) :: cryst
3959 : !arrays
3960 : integer,allocatable,intent(out) :: bz2ibz(:,:)
3961 :
3962 : !Local variables-------------------------------
3963 : !scalars
3964 : integer,parameter :: istwfk_1=1,kptopt3=3
3965 : integer :: nkfull,timrev,bantot,sppoldbl,npw_k,nsppol,istw
3966 : integer :: ik_ibz,ikf,isym,itimrev,spin,mband,my_nkibz,comm
3967 : logical :: isirred_k
3968 : !character(len=500) :: msg
3969 : !arrays
3970 : integer :: g0(3)
3971 8 : integer,allocatable :: istwfk(:),nband(:,:),npwarr(:),kg_k(:,:)
3972 8 : real(dp),allocatable :: kfull(:,:),doccde(:),eig(:),occ(:),wtk(:),my_kibz(:,:)
3973 8 : real(dp),allocatable :: doccde_3d(:,:,:),eig_3d(:,:,:),occ_3d(:,:,:)
3974 : ! *********************************************************************
3975 :
3976 8 : ABI_CHECK(inb%kptopt /= 0, "ebands_expandk does not support kptopt == 0")
3977 :
3978 8 : comm = xmpi_comm_self
3979 8 : nsppol = inb%nsppol
3980 :
3981 : ! Note kptopt=3
3982 : call kpts_ibz_from_kptrlatt(cryst, inb%kptrlatt, kptopt3, inb%nshiftk, inb%shiftk, &
3983 8 : my_nkibz, my_kibz, wtk, nkfull, kfull) ! new_kptrlatt, new_shiftk)
3984 :
3985 8 : ABI_FREE(my_kibz)
3986 8 : ABI_FREE(wtk)
3987 :
3988 : ! Construct full BZ and create mapping BZ --> IBZ
3989 : ! Note:
3990 : ! - we don't change the value of nsppol hence sppoldbl is set to 1
3991 : ! - we use symrel so that bz2ibz can be used to reconstruct the wavefunctions.
3992 : !
3993 8 : sppoldbl = 1 !; if (any(cryst%symafm == -1) .and. inb%nsppol == 1) sppoldbl=2
3994 24 : ABI_MALLOC(bz2ibz, (nkfull*sppoldbl,6))
3995 :
3996 8 : timrev = kpts_timrev_from_kptopt(inb%kptopt)
3997 : call listkk(dksqmax, cryst%gmet, bz2ibz, inb%kptns, kfull, inb%nkpt, nkfull, cryst%nsym, &
3998 8 : sppoldbl, cryst%symafm, cryst%symrel, timrev, comm, use_symrec=.False.)
3999 :
4000 24 : ABI_MALLOC(wtk, (nkfull))
4001 696 : wtk = one / nkfull ! weights normalized to one
4002 :
4003 24 : ABI_MALLOC(istwfk, (nkfull))
4004 32 : ABI_MALLOC(nband, (nkfull, nsppol))
4005 16 : ABI_MALLOC(npwarr, (nkfull))
4006 :
4007 128 : if (any(cryst%symrel(:,:,1) /= identity_3d) .and. any(abs(cryst%tnons(:,1)) > tol10) ) then
4008 0 : ABI_ERROR('The first symmetry is not the identity operator!')
4009 : end if
4010 :
4011 696 : do ikf=1,nkfull
4012 688 : ik_ibz = bz2ibz(ikf,1)
4013 688 : isym = bz2ibz(ikf,2)
4014 688 : itimrev = bz2ibz(ikf,6)
4015 2752 : g0 = bz2ibz(ikf,3:5) ! IS(k_ibz) + g0 = k_bz
4016 2300 : isirred_k = (isym == 1 .and. itimrev == 0 .and. all(g0 == 0))
4017 :
4018 1376 : do spin=1,nsppol
4019 1376 : nband(ikf,spin) = inb%nband(ik_ibz+(spin-1)*inb%nkpt)
4020 : end do
4021 :
4022 696 : if (force_istwfk1) then
4023 688 : call get_kg(kfull(:,ikf),istwfk_1,ecut_eff,cryst%gmet,npw_k,kg_k)
4024 688 : ABI_FREE(kg_k)
4025 688 : istwfk(ikf) = 1
4026 688 : npwarr(ikf) = npw_k
4027 : else
4028 0 : if (isirred_k) then
4029 0 : istwfk(ikf) = inb%istwfk(ik_ibz)
4030 0 : npwarr(ikf) = inb%npwarr(ik_ibz)
4031 : else
4032 0 : istw = set_istwfk(kfull(:,ikf))
4033 0 : call get_kg(kfull(:,ikf),istw,ecut_eff,cryst%gmet,npw_k,kg_k)
4034 0 : ABI_FREE(kg_k)
4035 0 : istwfk(ikf) = istw
4036 0 : npwarr(ikf) = npw_k
4037 : end if
4038 : end if
4039 : end do
4040 :
4041 : ! Recostruct eig, occ and doccde in the BZ.
4042 1400 : bantot = sum(nband); mband = maxval(nband)
4043 :
4044 40 : ABI_MALLOC(doccde_3d, (mband, nkfull, nsppol))
4045 32 : ABI_MALLOC(eig_3d, (mband, nkfull, nsppol))
4046 32 : ABI_MALLOC(occ_3d, (mband, nkfull, nsppol))
4047 :
4048 16 : do spin=1,nsppol
4049 704 : do ikf=1,nkfull
4050 688 : ik_ibz = bz2ibz(ikf,1)
4051 11184 : doccde_3d(:,ikf,spin) = inb%doccde(:,ik_ibz,spin)
4052 11184 : eig_3d(:,ikf,spin) = inb%eig(:,ik_ibz,spin)
4053 11192 : occ_3d(:,ikf,spin) = inb%occ(:,ik_ibz,spin)
4054 : end do
4055 : end do
4056 :
4057 : ! Have to pack data to call ebands_init (I wonder who decided to use vectors!)
4058 24 : ABI_MALLOC(doccde, (bantot))
4059 16 : ABI_MALLOC(eig, (bantot))
4060 16 : ABI_MALLOC(occ, (bantot))
4061 :
4062 8 : call pack_eneocc(nkfull, nsppol, mband, nband, bantot, doccde_3d, doccde)
4063 8 : call pack_eneocc(nkfull, nsppol, mband, nband, bantot, eig_3d, eig)
4064 8 : call pack_eneocc(nkfull, nsppol, mband, nband, bantot, occ_3d, occ)
4065 :
4066 8 : ABI_FREE(doccde_3d)
4067 8 : ABI_FREE(eig_3d)
4068 8 : ABI_FREE(occ_3d)
4069 :
4070 : call outb%init(bantot, inb%nelect, inb%ne_qFD, inb%nh_qFD, inb%ivalence, doccde, eig, istwfk, kfull, &
4071 : nband, nkfull, npwarr, nsppol, inb%nspinor, inb%tphysel, inb%tsmear, inb%occopt, occ, wtk, &
4072 8 : inb%cellcharge, kptopt3, inb%kptrlatt_orig, inb%nshiftk_orig, inb%shiftk_orig, inb%kptrlatt, inb%nshiftk, inb%shiftk)
4073 :
4074 : ! The expansion changes only the k-point representation. Preserve the Fermi
4075 : ! energies stored in the input band structure instead of keeping the zero
4076 : ! values assigned by ebands_init.
4077 8 : outb%fermie = inb%fermie
4078 8 : outb%fermih = inb%fermih
4079 :
4080 8 : ABI_FREE(istwfk)
4081 8 : ABI_FREE(nband)
4082 8 : ABI_FREE(npwarr)
4083 8 : ABI_FREE(doccde)
4084 8 : ABI_FREE(eig)
4085 8 : ABI_FREE(occ)
4086 8 : ABI_FREE(wtk)
4087 8 : ABI_FREE(kfull)
4088 :
4089 8 : end subroutine ebands_expandk
4090 : !!***
4091 :
4092 : !----------------------------------------------------------------------
4093 :
4094 : !!****f* m_ebands/ebands_downsample
4095 : !! NAME
4096 : !! ebands_downsample
4097 : !!
4098 : !! FUNCTION
4099 : !! Return a new ebands_t object of type ebands_t with a coarser IBZ contained in the initial one.
4100 : !!
4101 : !! INPUTS
4102 : !! cryst<crystal_t>=Info on unit cell and symmetries.
4103 : !! in_kptrlatt(3,3)=Defines the sampling of the "small" IBZ. Must be submesh of the "fine" mesh.
4104 : !! in_nshiftk= Number of shifts in the coarse k-mesh
4105 : !! in_shiftk(3, in_nshiftk) = Shifts of the coarse k-mesh
4106 : !!
4107 : !! SOURCE
4108 :
4109 3 : type(ebands_t) function ebands_downsample(self, cryst, in_kptrlatt, in_nshiftk, in_shiftk) result(new)
4110 :
4111 : !Arguments ------------------------------------
4112 : !scalars
4113 : integer,intent(in) :: in_nshiftk
4114 : class(ebands_t),intent(in) :: self
4115 : type(crystal_t),intent(in) :: cryst
4116 : !arrays
4117 : integer,intent(in) :: in_kptrlatt(3,3)
4118 : real(dp),intent(in) :: in_shiftk(3, in_nshiftk)
4119 :
4120 : !Local variables-------------------------------
4121 : !scalars
4122 : integer,parameter :: sppoldbl1 = 1
4123 : integer :: new_nkbz , timrev, bantot, new_nkibz, ik_ibz, ikf, spin,mband, comm
4124 : real(dp) :: dksqmax
4125 : character(len=500) :: msg
4126 : !arrays
4127 3 : integer,allocatable :: ibz_c2f(:,:)
4128 : integer :: new_kptrlatt(3,3)
4129 3 : integer,allocatable :: istwfk(:),nband(:,:),npwarr(:)
4130 3 : real(dp),allocatable :: new_kbz(:,:), new_wtk(:), new_kibz(:,:), doccde(:), eig(:), occ(:)
4131 3 : real(dp),allocatable :: doccde_3d(:,:,:), eig_3d(:,:,:), occ_3d(:,:,:), new_shiftk(:,:)
4132 : ! *********************************************************************
4133 :
4134 3 : comm = xmpi_comm_self
4135 :
4136 : ! Find IBZ associated to the new mesh.
4137 : call kpts_ibz_from_kptrlatt(cryst, in_kptrlatt, self%kptopt, in_nshiftk, in_shiftk, &
4138 3 : new_nkibz, new_kibz, new_wtk, new_nkbz, new_kbz, new_kptrlatt=new_kptrlatt, new_shiftk=new_shiftk)
4139 :
4140 : ! Construct mapping IBZ_coarse --> IBZ_fine
4141 : ! We don't change the value of nsppol hence sppoldbl1 is set to 1
4142 9 : ABI_MALLOC(ibz_c2f, (new_nkibz*sppoldbl1, 6))
4143 :
4144 3 : timrev = kpts_timrev_from_kptopt(self%kptopt)
4145 : call listkk(dksqmax, cryst%gmet, ibz_c2f, self%kptns, new_kibz, self%nkpt, new_nkibz, cryst%nsym, &
4146 3 : sppoldbl1, cryst%symafm, cryst%symrel, timrev, comm, use_symrec=.False.)
4147 :
4148 3 : if (dksqmax > tol12) then
4149 : write(msg, '(a,es16.6,6a)' )&
4150 0 : "At least one of the k-points could not be generated from a symmetrical one. dksqmax: ",dksqmax, ch10,&
4151 0 : "kptrlatt of input ebands: ",trim(ltoa(pack(self%kptrlatt, mask=.True.))),ch10, &
4152 0 : "downsampled K-mesh: ",trim(ltoa(pack(in_kptrlatt, mask=.True.)))
4153 0 : ABI_ERROR(msg)
4154 : end if
4155 :
4156 9 : ABI_MALLOC(istwfk, (new_nkibz))
4157 12 : ABI_MALLOC(nband, (new_nkibz, self%nsppol))
4158 6 : ABI_MALLOC(npwarr, (new_nkibz))
4159 :
4160 81 : do ik_ibz=1,new_nkibz
4161 78 : ikf = ibz_c2f(ik_ibz, 1)
4162 156 : do spin=1,self%nsppol
4163 156 : nband(ik_ibz, spin) = self%nband(ikf + (spin-1) * self%nkpt)
4164 : end do
4165 78 : istwfk(ik_ibz) = self%istwfk(ikf)
4166 81 : npwarr(ik_ibz) = self%npwarr(ikf)
4167 : end do
4168 :
4169 : ! Recostruct eig, occ and doccde in the new IBZ.
4170 165 : bantot = sum(nband); mband = maxval(nband)
4171 :
4172 15 : ABI_MALLOC(doccde_3d, (mband, new_nkibz, self%nsppol))
4173 12 : ABI_MALLOC(eig_3d, (mband, new_nkibz, self%nsppol))
4174 12 : ABI_MALLOC(occ_3d, (mband, new_nkibz, self%nsppol))
4175 :
4176 6 : do spin=1,self%nsppol
4177 84 : do ik_ibz=1,new_nkibz
4178 78 : ikf = ibz_c2f(ik_ibz, 1)
4179 606 : doccde_3d(:, ik_ibz, spin) = self%doccde(:, ikf, spin)
4180 606 : eig_3d(:, ik_ibz, spin) = self%eig(:, ikf, spin)
4181 609 : occ_3d(:, ik_ibz, spin) = self%occ(:, ikf, spin)
4182 : end do
4183 : end do
4184 :
4185 : ! Have to pack data to call ebands_init (I wonder who decided to use vectors!)
4186 9 : ABI_MALLOC(doccde, (bantot))
4187 6 : ABI_MALLOC(eig, (bantot))
4188 6 : ABI_MALLOC(occ, (bantot))
4189 :
4190 3 : call pack_eneocc(new_nkibz, self%nsppol, mband, nband, bantot, doccde_3d, doccde)
4191 3 : call pack_eneocc(new_nkibz, self%nsppol, mband, nband, bantot, eig_3d, eig)
4192 3 : call pack_eneocc(new_nkibz, self%nsppol, mband, nband, bantot, occ_3d, occ)
4193 :
4194 3 : ABI_FREE(doccde_3d)
4195 3 : ABI_FREE(eig_3d)
4196 3 : ABI_FREE(occ_3d)
4197 :
4198 : call new%init(bantot, self%nelect, self%ne_qFD, self%nh_qFD, self%ivalence, doccde, eig, istwfk, new_kibz, &
4199 : nband, new_nkibz, npwarr, self%nsppol, self%nspinor, self%tphysel, self%tsmear, self%occopt, occ, new_wtk, &
4200 3 : self%cellcharge, self%kptopt, in_kptrlatt, in_nshiftk, self%shiftk, new_kptrlatt, size(new_shiftk, dim=2), new_shiftk)
4201 :
4202 3 : new%fermie = self%fermie
4203 3 : new%fermih = self%fermih
4204 :
4205 3 : ABI_FREE(istwfk)
4206 3 : ABI_FREE(nband)
4207 3 : ABI_FREE(npwarr)
4208 3 : ABI_FREE(doccde)
4209 3 : ABI_FREE(eig)
4210 3 : ABI_FREE(occ)
4211 3 : ABI_FREE(new_kibz)
4212 3 : ABI_FREE(new_kbz)
4213 3 : ABI_FREE(new_wtk)
4214 3 : ABI_FREE(new_shiftk)
4215 3 : ABI_FREE(ibz_c2f)
4216 :
4217 3 : end function ebands_downsample
4218 : !!***
4219 :
4220 : !----------------------------------------------------------------------
4221 :
4222 : !!****f* m_ebands/ebands_chop
4223 : !! NAME
4224 : !! ebands_chop
4225 : !!
4226 : !! FUNCTION
4227 : !! Return a new ebands_t object with a selected number of bands between bstart and bstop
4228 : !!
4229 : !! INPUTS
4230 : !!
4231 : !! SOURCE
4232 :
4233 15 : type(ebands_t) function ebands_chop(self, bstart, bstop) result(new)
4234 :
4235 : !Arguments ------------------------------------
4236 : !scalars
4237 : class(ebands_t),intent(in) :: self
4238 : integer,intent(in) :: bstart, bstop
4239 :
4240 : !Local variables ------------------------------
4241 : integer :: mband, nkpt, nsppol
4242 : ! *********************************************************************
4243 :
4244 15 : ABI_CHECK_IRANGE(bstart, 1, self%mband, "Invalid bstart")
4245 15 : ABI_CHECK_IRANGE(bstop, 1, self%mband, "Invalid bstop")
4246 15 : ABI_CHECK_ILEQ(bstart, bstop, "bstart should be <= bstop")
4247 :
4248 : ! First copy the bands
4249 15 : call self%copy(new)
4250 :
4251 : ! Now chop them
4252 15 : ABI_FREE(new%eig)
4253 15 : ABI_FREE(new%occ)
4254 15 : ABI_FREE(new%doccde)
4255 :
4256 15 : mband = bstop - bstart + 1
4257 15 : nkpt = self%nkpt
4258 15 : nsppol = self%nsppol
4259 :
4260 75 : ABI_MALLOC(new%eig, (mband, nkpt, nsppol))
4261 60 : ABI_MALLOC(new%occ, (mband, nkpt, nsppol))
4262 60 : ABI_MALLOC(new%doccde, (mband, nkpt, nsppol))
4263 :
4264 15 : new%mband = mband
4265 3928 : new%nband = mband
4266 22951 : new%eig = self%eig(bstart:bstop,:,:)
4267 22951 : new%occ = self%occ(bstart:bstop,:,:)
4268 22951 : new%doccde = self%doccde(bstart:bstop,:,:)
4269 :
4270 3928 : new%bantot = sum(new%nband)
4271 :
4272 15 : end function ebands_chop
4273 : !!***
4274 :
4275 : !----------------------------------------------------------------------
4276 :
4277 : !!****f* m_ebands/ebands_sort
4278 : !! NAME
4279 : !! ebands_sort
4280 : !!
4281 : !! FUNCTION
4282 : !! Sort eigvalues_k in ascending order and reorder arrays depending on nband_k
4283 : !! Mainly used when interpolating band energies as the interpolator may not produce ordered eigenvalues
4284 : !! and there are routines whose implementation assumes eig(b) <= eig(b+1)
4285 : !!
4286 : !! SOURCE
4287 :
4288 6 : subroutine ebands_sort(self)
4289 :
4290 : !Arguments ------------------------------------
4291 : class(ebands_t),intent(inout) :: self
4292 :
4293 : !Local variables-------------------------------
4294 : !scalars
4295 : integer :: spin, ik_ibz, band, nband_k
4296 : !arrays
4297 12 : integer :: iperm_k(self%mband)
4298 : ! *********************************************************************
4299 :
4300 12 : do spin=1,self%nsppol
4301 1044 : do ik_ibz=1,self%nkpt
4302 1032 : nband_k = self%nband(ik_ibz + (spin - 1) * self%nkpt)
4303 27436 : iperm_k = [(band, band=1, nband_k)]
4304 1032 : call sort_dp(nband_k, self%eig(:, ik_ibz, spin), iperm_k, tol12)
4305 :
4306 : ! Shuffle other arrays depending on nband_k
4307 27436 : self%occ(1:nband_k, ik_ibz, spin) = self%occ(iperm_k(1:nband_k), ik_ibz, spin)
4308 27442 : self%doccde(1:nband_k, ik_ibz, spin) = self%doccde(iperm_k(1:nband_k), ik_ibz, spin)
4309 : !if (allocated(self%velocity)) then
4310 : ! self%velocity(:, 1:nband_k, ik_ibz, spin) = self%velocity(:, iperm_k(1:nband_k), ik_ibz, spin)
4311 : !end if
4312 : end do
4313 : end do
4314 :
4315 6 : end subroutine ebands_sort
4316 : !!***
4317 :
4318 : !!****f* m_ebands/ebands_has_enough_bands_for_ef
4319 : !! NAME
4320 : !! ebands_has_enough_bands_for_ef
4321 : !!
4322 : !! FUNCTION
4323 : !! Check if nband is "large enough" to compute the Fermi level Ef(T).
4324 : !!
4325 : !! OUTPUT
4326 : !! msg: error/warning message.
4327 : !! ierr:
4328 : !! > 0: if critical error that should trigger abortion.
4329 : !! < 0: if non-critical error that should trigger warning
4330 : !! = 0: everything seems ok.
4331 : !!
4332 : !! NOTES
4333 : !! The logic here is far from perfect since what really matter is not the number of bands but the
4334 : !! electronic DOS in the conduction region. Systems with a large DOS require more bands
4335 : !! for an accurate evaluation of Ef(T). For simplicity, we just use a simple scaling factor `fact`
4336 : !! that mutiplies the number of electrons.
4337 : !!
4338 : !! SOURCE
4339 :
4340 64 : integer function ebands_has_enough_bands_for_ef(ebands, msg) result(ierr)
4341 :
4342 : !Arguments ------------------------------------
4343 : !scalars
4344 : class(ebands_t),intent(in) :: ebands
4345 : character(len=*),intent(out) :: msg
4346 :
4347 : !Local variables-------------------------------
4348 : real(dp), parameter :: fact = 1.2_dp
4349 : integer :: nbv
4350 : ! *********************************************************************
4351 :
4352 64 : ierr = 0; msg = ""
4353 :
4354 : ! We do the math assuming a semiconductor (spin unpolarized if nsppol == 2)
4355 64 : nbv = ebands%nelect / 2; if (ebands%nspinor == 2) nbv = ebands%nelect
4356 :
4357 64 : if (ebands%mband <= nbv) then
4358 : ! Catch the worst-case-scenario in which only occupied states in a semiconductor are provided.
4359 1 : ierr = 1
4360 1 : msg = sjoin("In order to compute Ef(T) you should use nband > ", itoa(ceiling(ebands%nelect)))
4361 1 : return
4362 : end if
4363 :
4364 63 : if (ebands%mband <= ceiling(fact * nbv)) then
4365 0 : ierr = -1
4366 0 : msg = "nband might be too small to compute Ef(T). Try to increase nband."
4367 : end if
4368 :
4369 64 : end function ebands_has_enough_bands_for_ef
4370 : !!***
4371 :
4372 : !----------------------------------------------------------------------
4373 :
4374 : !!****f* m_ebands/ebands_interp_kmesh
4375 : !! NAME
4376 : !! ebands_interp_kmesh
4377 : !!
4378 : !! FUNCTION
4379 : !! Interpolate energies on a k-mesh.
4380 : !!
4381 : !! INPUTS
4382 : !! ebands<ebands_t> = Object with input energies.
4383 : !! cryst<crystal_t> = Crystalline structure.
4384 : !! params(:):
4385 : !! params(0): interpolation type. 1 for star-functions
4386 : !! 2 for star-functions with group velocities
4387 : !! if star-functions:
4388 : !! params(2): Ratio between star functions and ab-initio k-points.
4389 : !! params(3:4): Activate Fourier filtering (Eq 9 of PhysRevB.61.1639) if params(2) > tol6
4390 : !! params(3)=rcut, params(4) = rsigma
4391 : !! intp_kptrlatt(3,3) = New k-mesh
4392 : !! intp_nshiftk= Number of shifts in new k-mesh.
4393 : !! intp_shiftk(3,intp_nshiftk) = Shifts in new k-mesh.
4394 : !! band_range(2)=Initial and final band index. If [0,0], all bands are used
4395 : !! This is a global variable i.e. all MPI procs must call the routine with the same value.
4396 : !! comm=MPI communicator
4397 : !! [out_prefix]: optional string prefix used to write netcdf file.
4398 : !! [malloc_only]: if true, create new bands object but don't interpolate eigenvalues.
4399 : !!
4400 : !! OUTPUT
4401 : !! New ebands_t object with interpolated energies.
4402 : !!
4403 : !! NOTES
4404 : !! Fermi level and occupation factors of the interpolated bands are not recomputed by this routine.
4405 : !! This operation is delegated to the caller.
4406 : !!
4407 : !! SOURCE
4408 :
4409 8 : type(ebands_t) function ebands_interp_kmesh(ebands, cryst, params, intp_kptrlatt, intp_nshiftk, intp_shiftk, band_range, comm, &
4410 : out_prefix, malloc_only) result(new)
4411 :
4412 : !Arguments ------------------------------------
4413 : !scalars
4414 : class(ebands_t),intent(in) :: ebands
4415 : integer,intent(in) :: intp_nshiftk,comm
4416 : type(crystal_t),intent(in) :: cryst
4417 : character(len=*),optional,intent(in) :: out_prefix
4418 : logical,optional,intent(in) :: malloc_only
4419 : !arrays
4420 : integer,intent(in) :: intp_kptrlatt(3,3),band_range(2)
4421 : real(dp),intent(in) :: params(:)
4422 : real(dp),intent(in) :: intp_shiftk(3,intp_nshiftk)
4423 :
4424 : !Local variables-------------------------------
4425 : !scalars
4426 : integer,parameter :: master = 0
4427 : integer :: ik_ibz,spin,new_bantot,new_mband,cplex,itype,nb,ib
4428 : integer :: nprocs,my_rank,cnt,ierr,band,new_nkbz,new_nkibz,new_nshiftk, ncid
4429 4 : type(skw_t) :: skw
4430 : !arrays
4431 : integer :: new_kptrlatt(3,3),my_bblock(2)
4432 4 : integer,allocatable :: new_istwfk(:),new_nband(:,:),new_npwarr(:)
4433 4 : real(dp),allocatable :: new_shiftk(:,:),new_kibz(:,:),new_kbz(:,:),new_wtk(:)
4434 4 : real(dp),allocatable :: new_doccde(:),new_eig(:),new_occ(:)
4435 : ! *********************************************************************
4436 :
4437 4 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
4438 :
4439 4 : my_bblock = band_range; if (all(band_range == 0)) my_bblock = [1, ebands%mband]
4440 4 : nb = my_bblock(2) - my_bblock(1) + 1
4441 :
4442 : ! Get ibz, new shifts and new kptrlatt.
4443 : call kpts_ibz_from_kptrlatt(cryst, intp_kptrlatt, ebands%kptopt, intp_nshiftk, intp_shiftk, &
4444 4 : new_nkibz, new_kibz, new_wtk, new_nkbz, new_kbz, new_kptrlatt=new_kptrlatt, new_shiftk=new_shiftk)
4445 4 : new_nshiftk = size(new_shiftk, dim=2)
4446 :
4447 : ! Initialize new ebands_t in new IBZ
4448 12 : ABI_MALLOC(new_istwfk, (new_nkibz))
4449 236 : new_istwfk = 1
4450 : !do ik_ibz=1,new_nkibz
4451 : ! new_istwfk(ik_ibz) = set_istwfk(new%kptns(:, ik_ibz))
4452 : !end do
4453 16 : ABI_MALLOC(new_nband, (new_nkibz, ebands%nsppol))
4454 240 : new_nband = nb
4455 8 : ABI_MALLOC(new_npwarr, (new_nkibz))
4456 268 : new_npwarr = maxval(ebands%npwarr)
4457 240 : new_bantot = sum(new_nband); new_mband = maxval(new_nband)
4458 3898 : ABI_CALLOC(new_doccde, (new_bantot))
4459 3894 : ABI_CALLOC(new_eig, (new_bantot))
4460 3894 : ABI_CALLOC(new_occ, (new_bantot))
4461 :
4462 : call new%init(new_bantot, ebands%nelect, ebands%ne_qFD,ebands%nh_qFD,ebands%ivalence,&
4463 : new_doccde, new_eig, new_istwfk, new_kibz,&
4464 : new_nband, new_nkibz, new_npwarr, ebands%nsppol, ebands%nspinor, ebands%tphysel, ebands%tsmear,&
4465 : ebands%occopt, new_occ, new_wtk, &
4466 4 : ebands%cellcharge, ebands%kptopt, intp_kptrlatt, intp_nshiftk, intp_shiftk, new_kptrlatt, new_nshiftk, new_shiftk)
4467 :
4468 : ! Get fermi level from input ebands.
4469 4 : new%fermie = ebands%fermie
4470 4 : new%fermih = ebands%fermih
4471 :
4472 4 : ABI_FREE(new_kibz)
4473 4 : ABI_FREE(new_wtk)
4474 4 : ABI_FREE(new_shiftk)
4475 4 : ABI_FREE(new_kbz)
4476 4 : ABI_FREE(new_istwfk)
4477 4 : ABI_FREE(new_nband)
4478 4 : ABI_FREE(new_npwarr)
4479 4 : ABI_FREE(new_doccde)
4480 4 : ABI_FREE(new_eig)
4481 4 : ABI_FREE(new_occ)
4482 :
4483 4 : if (present(malloc_only)) then
4484 0 : if (malloc_only) return
4485 : end if
4486 :
4487 : ! Build SKW object for all bands.
4488 4 : itype = nint(params(1))
4489 4 : if (itype == 1 .or. itype == 2) then
4490 4 : cplex = 1; if (kpts_timrev_from_kptopt(ebands%kptopt) == 0) cplex = 2
4491 4 : skw = skw_new(cryst, params(2:), cplex, ebands%mband, ebands%nkpt, ebands%nsppol, ebands%kptns, ebands%eig, my_bblock, comm)
4492 : !if (itype == 2) then
4493 : ! ABI_CALLOC(new%velocity,(3,new%mband,new%nkpt,new%nsppol))
4494 : !end if
4495 : else
4496 0 : ABI_ERROR(sjoin("Wrong einterp params(1):", itoa(itype)))
4497 : end if
4498 :
4499 : ! Interpolate eigenvalues and velocities.
4500 4126 : new%eig = zero; cnt = 0
4501 8 : do spin=1,new%nsppol
4502 240 : do ik_ibz=1,new%nkpt
4503 4122 : do ib=1,nb
4504 3886 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! Mpi parallelism.
4505 : ! Note the difference between band and ib index if band_range.
4506 3886 : band = my_bblock(1) + ib - 1
4507 232 : select case (itype)
4508 : case (1)
4509 3886 : call skw%eval_bks(band, new%kptns(:,ik_ibz), spin, new%eig(ib,ik_ibz,spin))
4510 : !case (2)
4511 : ! call skw%eval_bks(band, new%kptns(:,ik_ibz), spin, new%eig(ib,ik_ibz,spin), new%velocity(:,ib,ik_ibz,spin))
4512 : case default
4513 3886 : ABI_ERROR(sjoin("Wrong params(1):", itoa(itype)))
4514 : end select
4515 : end do
4516 : end do
4517 : end do
4518 4 : call xmpi_sum(new%eig, comm, ierr)
4519 : !if (itype == 2) call xmpi_sum(new%velocity, comm, ierr)
4520 :
4521 : ! Sort eigvalues_k in ascending order to be compatible with other ebands routines.
4522 4 : call new%sort()
4523 : !call new%update_occ(dtset%spinmagntarget, prtvol=dtset%prtvol)
4524 :
4525 4 : if (my_rank == master .and. itype == 1 .and. present(out_prefix)) then
4526 : ! Write ESKW file with crystal and (interpolated) band structure energies.
4527 : !call wrtout(ab_out, sjoin("- Writing interpolated bands to file:", strcat(prefix, tag)))
4528 0 : NCF_CHECK(nctk_open_create(ncid, strcat(out_prefix, "_ESKW.nc"), xmpi_comm_self))
4529 0 : NCF_CHECK(cryst%ncwrite(ncid))
4530 0 : NCF_CHECK(ebands_ncwrite(new, ncid))
4531 0 : NCF_CHECK(nf90_close(ncid))
4532 : end if
4533 :
4534 4 : call skw%free()
4535 :
4536 12 : end function ebands_interp_kmesh
4537 : !!***
4538 :
4539 : !----------------------------------------------------------------------
4540 :
4541 : !!****f* m_ebands/ebands_interp_kpath
4542 : !! NAME
4543 : !! ebands_interp_kpath
4544 : !!
4545 : !! FUNCTION
4546 : !! Interpolate energies on a k-path
4547 : !!
4548 : !! INPUTS
4549 : !! ebands<ebands_t> = Object with input energies.
4550 : !! cryst<crystal_t> = Crystalline structure.
4551 : !! kpath<kpath_t> = Object describing the k-path
4552 : !! params(:):
4553 : !! params(1): 1 for SKW.
4554 : !! band_range(2)=Initial and final band index to be interpolated. [0,0] if all bands are used.
4555 : !! This is a global variable i.e. all MPI procs must call the routine with the same value.
4556 : !! comm=MPI communicator
4557 : !! [malloc_only]: if true, create new bands object but don't interpolate eigenvalues.
4558 : !!
4559 : !! OUTPUT
4560 : !! New ebands_t object with interpolated energies.
4561 : !!
4562 : !! SOURCE
4563 :
4564 4 : type(ebands_t) function ebands_interp_kpath(ebands, cryst, kpath, params, band_range, comm, malloc_only) result(new)
4565 :
4566 : !Arguments ------------------------------------
4567 : !scalars
4568 : class(ebands_t),intent(in) :: ebands
4569 : integer,intent(in) :: comm
4570 : type(crystal_t),intent(in) :: cryst
4571 : type(kpath_t),intent(in) :: kpath
4572 : logical,optional,intent(in) :: malloc_only
4573 : !arrays
4574 : integer,intent(in) :: band_range(2)
4575 : real(dp),intent(in) :: params(:)
4576 :
4577 : !Local variables-------------------------------
4578 : !scalars
4579 : integer,parameter :: new_nshiftk=1
4580 : integer :: ik_ibz,spin,new_bantot,new_mband,cplex
4581 : integer :: nprocs,my_rank,cnt,ierr,band,new_nkibz,itype,nb,ib, new_kptopt
4582 2 : type(skw_t) :: skw
4583 : !arrays
4584 : integer,parameter :: new_kptrlatt(3,3)=0
4585 : integer :: my_bblock(2)
4586 2 : integer,allocatable :: new_istwfk(:),new_nband(:,:),new_npwarr(:)
4587 : real(dp),parameter :: new_shiftk(3,1) = zero
4588 2 : real(dp),allocatable :: new_wtk(:),new_doccde(:),new_eig(:),new_occ(:)
4589 : ! *********************************************************************
4590 :
4591 2 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
4592 :
4593 6 : my_bblock = band_range; if (all(band_range == 0)) my_bblock = [1, ebands%mband]
4594 2 : nb = my_bblock(2) - my_bblock(1) + 1
4595 :
4596 2 : if (ebands%nkpt == 1) then
4597 0 : ABI_WARNING("Cannot interpolate band energies when nkpt = 1. Returning")
4598 0 : return
4599 : end if
4600 :
4601 : ! Initialize new ebands_t.
4602 2 : new_nkibz = kpath%npts
4603 6 : ABI_MALLOC(new_istwfk, (new_nkibz))
4604 802 : new_istwfk = 1
4605 8 : ABI_MALLOC(new_nband, (new_nkibz, ebands%nsppol))
4606 804 : new_nband = nb
4607 4 : ABI_MALLOC(new_npwarr, (new_nkibz))
4608 837 : new_npwarr = maxval(ebands%npwarr)
4609 804 : new_bantot = sum(new_nband); new_mband = maxval(new_nband)
4610 8806 : ABI_CALLOC(new_eig, (new_bantot))
4611 8804 : ABI_CALLOC(new_doccde, (new_bantot))
4612 8804 : ABI_CALLOC(new_occ, (new_bantot))
4613 806 : ABI_CALLOC(new_wtk, (new_nkibz))
4614 :
4615 : ! Needed by AbiPy to understand that we have a k-path instead of a mesh.
4616 2 : new_kptopt = -kpath%nbounds
4617 :
4618 : call new%init(new_bantot, ebands%nelect, ebands%ne_qFD,ebands%nh_qFD,ebands%ivalence, &
4619 : new_doccde, new_eig, new_istwfk, kpath%points, &
4620 : new_nband, new_nkibz, new_npwarr, ebands%nsppol, ebands%nspinor, ebands%tphysel, ebands%tsmear, &
4621 : ebands%occopt, new_occ, new_wtk,&
4622 2 : ebands%cellcharge, new_kptopt, new_kptrlatt, new_nshiftk, new_shiftk, new_kptrlatt, new_nshiftk, new_shiftk)
4623 :
4624 2 : new%fermie = ebands%fermie
4625 2 : new%fermih = ebands%fermih
4626 :
4627 2 : ABI_FREE(new_wtk)
4628 2 : ABI_FREE(new_istwfk)
4629 2 : ABI_FREE(new_nband)
4630 2 : ABI_FREE(new_npwarr)
4631 2 : ABI_FREE(new_doccde)
4632 2 : ABI_FREE(new_eig)
4633 2 : ABI_FREE(new_occ)
4634 :
4635 2 : if (present(malloc_only)) then
4636 0 : if (malloc_only) return
4637 : end if
4638 :
4639 : ! Build SKW object for all bands.
4640 2 : itype = nint(params(1))
4641 2 : select case (itype)
4642 : case (1)
4643 2 : cplex = 1; if (kpts_timrev_from_kptopt(ebands%kptopt) == 0) cplex = 2
4644 : skw = skw_new(cryst, params(2:), cplex, ebands%mband, ebands%nkpt, ebands%nsppol, ebands%kptns, ebands%eig, &
4645 2 : my_bblock, comm)
4646 :
4647 : case default
4648 2 : ABI_ERROR(sjoin("Wrong einterp params(1):", itoa(itype)))
4649 : end select
4650 :
4651 : ! Interpolate eigenvalues.
4652 9604 : new%eig = zero; cnt = 0
4653 4 : do spin=1,new%nsppol
4654 804 : do ik_ibz=1,new%nkpt
4655 9602 : do ib=1,nb
4656 8800 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! Mpi parallelism.
4657 : ! Note the difference between band and ib index if band_range.
4658 8800 : band = my_bblock(1) + ib - 1
4659 800 : select case (itype)
4660 : case (1)
4661 8800 : call skw%eval_bks(band, new%kptns(:,ik_ibz), spin, new%eig(ib,ik_ibz,spin))
4662 : case default
4663 8800 : ABI_ERROR(sjoin("Wrong einterp params(1):", itoa(itype)))
4664 : end select
4665 : end do
4666 : end do
4667 : end do
4668 2 : call xmpi_sum(new%eig, comm, ierr)
4669 :
4670 : ! Sort eigvalues_k in ascending order to be compatible with other ebands routines.
4671 2 : call new%sort()
4672 2 : call skw%free()
4673 :
4674 6 : end function ebands_interp_kpath
4675 : !!***
4676 :
4677 : !----------------------------------------------------------------------
4678 :
4679 : !!****f* m_ebands/ebands_get_edos_matrix_elements
4680 : !! NAME
4681 : !! ebands_get_edos_matrix_elements
4682 : !!
4683 : !! FUNCTION
4684 : !! Compute electron DOS and weighted e-DOS with weights given by precomputed scalar, vectorial
4685 : !! or tensorial matrix elements.
4686 : !! Weights are provided in input as (..., num_entries, bsize, nkpt, nsppol) tables, see below.
4687 : !!
4688 : !! INPUTS
4689 : !! ebands<ebands_t>=Band structure object.
4690 : !! cryst<cryst_t>=Info on the crystalline structure.
4691 : !! bsize=Number of bands in bks_vals, bks_vecs and bks_tens
4692 : !! Not necessarily equal to ebands%mband when brange is used.
4693 : !! nvals=Number of scalar entries. Maybe zero
4694 : !! bks_vals=Scalar matrix elements
4695 : !! nvecs=Number of 3d-vectorial entries. Maybe zero
4696 : !! bks_vecs=Vectorial matrix elements in Cartesian Coordinates
4697 : !! ntens=Number of 3x3 tensorial entries in Cartesian coordinates. Maybe zero
4698 : !! bks_tens= Tensorial matrix elements (3x3) in Cartesian Coordinates
4699 : !! intmeth=
4700 : !! 1 for Gaussian,
4701 : !! 2 or -2 for tetrahedra (-2 if Blochl corrections must be included).
4702 : !! If nkpt == 1 (Gamma only), the routine fallbacks to the Gaussian method.
4703 : !! step=Step on the linear mesh in Ha. If < 0, the routine will use the mean of the energy level spacing
4704 : !! broad=Gaussian broadening, If < 0, the routine will use a default
4705 : !! value for the broadening computed from the mean of the energy level spacing.
4706 : !! No meaning for tetrahedra
4707 : !! comm=MPI communicator
4708 : !! [brange(2)]=Minimum and maximum band index. Default if not present is `full band range`.
4709 : !! If given bsize must be equal: to brange(2) - brange(1) + 1
4710 : !! [erange(2)]=Minimum and maximum energy to be considered. Default if not present is `full energy range`.
4711 : !!
4712 : !! OUTPUT
4713 : !! out_valsdos: (nw, 2, nvals, nsppol) array with DOS for scalar quantities if nvals > 0
4714 : !! out_vecsdos: (nw, 2, 3, nvecs, nsppol)) array with DOS weighted by vectorial terms if nvecs > 0
4715 : !! out_tensdos: (nw, 2,3, 3, ntens, nsppol) array with DOS weighted by tensorial terms if ntens > 0
4716 : !!
4717 : !! All these arrays are allocated by the routine. The number of points is available in edos%nw.
4718 : !! (nw, 1, ...) stores the weighted DOS (w-DOS)
4719 : !! (nw, 2, ...) stores the integrated w-DOS
4720 : !!
4721 : !! SOURCE
4722 :
4723 13 : type(edos_t) function ebands_get_edos_matrix_elements(ebands, cryst, bsize, &
4724 13 : nvals, bks_vals, nvecs, bks_vecs, ntens, bks_tens, &
4725 : intmeth, step, broad, out_valsdos, out_vecsdos, out_tensdos, comm, &
4726 : brange, erange) result(edos)
4727 :
4728 : !Arguments ------------------------------------
4729 : !scalars
4730 : class(ebands_t),intent(in) :: ebands
4731 : integer,intent(in) :: bsize, nvals, nvecs, ntens, intmeth, comm
4732 : real(dp),intent(in) :: step, broad
4733 : type(crystal_t),intent(in) :: cryst
4734 : !arrays
4735 : integer,optional,intent(in) :: brange(2)
4736 : real(dp),optional,intent(in) :: erange(2)
4737 : real(dp),intent(in) :: bks_vals(nvals, bsize, ebands%nkpt, ebands%nsppol)
4738 : real(dp),intent(in) :: bks_vecs(3, nvecs, bsize, ebands%nkpt, ebands%nsppol)
4739 : real(dp),intent(in) :: bks_tens(3, 3, ntens, bsize, ebands%nkpt, ebands%nsppol)
4740 : real(dp),allocatable,intent(out) :: out_valsdos(:,:,:,:), out_vecsdos(:,:,:,:,:), out_tensdos(:,:,:,:,:,:)
4741 :
4742 : !Local variables-------------------------------
4743 : !scalars
4744 : integer :: nproc, my_rank, nw, spin, band, ib, ik_ibz, cnt, idat, ierr, bcorr, time_opt
4745 : integer :: ii, jj, ief, ihf, bmin_, bmax_
4746 : real(dp),parameter :: max_occ1 = one
4747 : real(dp) :: emax, emin, wtk, max_occ
4748 : real(dp) :: cpu, wall, gflops
4749 : logical :: check_erange
4750 : character(len=500) :: msg
4751 13 : type(htetra_t) :: tetra
4752 : !arrays
4753 26 : real(dp) :: eminmax_spin(2,ebands%nsppol), vsum(3), tsum(3,3)
4754 13 : real(dp),allocatable :: wme0(:),tmp_eigen(:), weights(:,:)
4755 : ! *********************************************************************
4756 :
4757 13 : call cwtime(cpu, wall, gflops, "start")
4758 :
4759 13 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
4760 :
4761 13 : edos%nkibz = ebands%nkpt; edos%nsppol = ebands%nsppol; edos%nspinor = ebands%nspinor
4762 13 : edos%intmeth = intmeth
4763 13 : edos%nelect = ebands%nelect
4764 13 : if (ebands%nkpt == 1) then
4765 0 : ABI_COMMENT("Cannot use tetrahedra for e-DOS when nkpt == 1. Switching to gaussian method")
4766 0 : edos%intmeth = 1
4767 : end if
4768 :
4769 13 : edos%broad = broad; edos%step = step
4770 :
4771 : ! Define band range.
4772 13 : bmin_ = 1; bmax_ = ebands%mband
4773 13 : if (present(brange)) then
4774 13 : bmin_ = brange(1); bmax_ = brange(2)
4775 : end if
4776 :
4777 13 : ABI_CHECK_IRANGE(bmin_, 1, ebands%mband, "Wrong bmin:")
4778 13 : ABI_CHECK_IRANGE(bmax_, bmin_, ebands%mband, "Wrong bmax:")
4779 13 : ABI_CHECK_IRANGE(bsize, 1, ebands%mband, "Wrong bsize:")
4780 :
4781 13 : if (present(erange)) then
4782 : ! use optional args if provided.
4783 13 : emin = erange(1)
4784 13 : emax = erange(2)
4785 13 : check_erange = .True.
4786 : else
4787 : ! Compute the linear mesh so that it encloses all bands.
4788 0 : eminmax_spin = ebands_get_minmax(ebands, "eig")
4789 0 : emin = minval(eminmax_spin(1, :)); emin = emin - 0.1_dp * abs(emin)
4790 0 : emax = maxval(eminmax_spin(2, :)); emax = emax + 0.1_dp * abs(emax)
4791 0 : check_erange = .False.
4792 : end if
4793 :
4794 13 : nw = nint((emax - emin) / edos%step) + 1
4795 13 : edos%nw = nw
4796 :
4797 39 : ABI_MALLOC(edos%mesh, (nw))
4798 5576 : edos%mesh = arth(emin, edos%step, nw)
4799 :
4800 65 : ABI_CALLOC(edos%gef, (0:edos%nsppol))
4801 52 : ABI_CALLOC(edos%ghf, (0:edos%nsppol))
4802 11178 : ABI_CALLOC(edos%dos, (nw, 0:edos%nsppol))
4803 11165 : ABI_CALLOC(edos%idos, (nw, 0:edos%nsppol))
4804 :
4805 : ! Allocate output arrays depending on input.
4806 13 : if (nvals > 0) then
4807 51890 : ABI_CALLOC(out_valsdos, (nw, 2, nvals, ebands%nsppol))
4808 : endif
4809 13 : if (nvecs > 0) then
4810 0 : ABI_CALLOC(out_vecsdos, (nw, 2, 3, nvecs, ebands%nsppol))
4811 : end if
4812 13 : if (ntens > 0) then
4813 667514 : ABI_CALLOC(out_tensdos, (nw, 2, 3, 3, ntens, ebands%nsppol))
4814 : end if
4815 :
4816 13 : time_opt = 0 ! This to preserve the previous behaviour in which TR was not used.
4817 :
4818 : !call wrtout(std_out, " Computing DOS weighted by matrix elements.")
4819 0 : select case (intmeth)
4820 : case (1)
4821 : ! Gaussian
4822 0 : ABI_MALLOC(wme0, (nw))
4823 0 : cnt = 0
4824 0 : do spin=1,ebands%nsppol
4825 0 : do ik_ibz=1,ebands%nkpt
4826 0 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism
4827 0 : wtk = ebands%wtk(ik_ibz)
4828 0 : do band=bmin_,bmax_
4829 0 : ib = band - bmin_ + 1
4830 :
4831 0 : if (check_erange) then
4832 0 : if (ebands%eig(band, ik_ibz, spin) < emin - five * broad) cycle
4833 0 : if (ebands%eig(band, ik_ibz, spin) > emax + five * broad) cycle
4834 : end if
4835 :
4836 0 : wme0 = edos%mesh - ebands%eig(band, ik_ibz, spin)
4837 0 : wme0 = gaussian(wme0, broad) * wtk
4838 0 : edos%dos(:,spin) = edos%dos(:,spin) + wme0(:)
4839 :
4840 : ! scalars
4841 0 : do idat=1,nvals
4842 0 : out_valsdos(:, 1, idat, spin) = out_valsdos(:,1, idat, spin) + wme0(:) * bks_vals(idat, ib, ik_ibz, spin)
4843 : ! FIXME: This is quite inefficient! Integration should be performed outside!
4844 0 : call simpson_int(nw, step, out_valsdos(:,1, idat, spin), out_valsdos(:,2,idat,spin))
4845 : end do
4846 :
4847 : ! vectors
4848 0 : do idat=1,nvecs
4849 : ! get components, symmetrize and accumulate.
4850 0 : vsum = cryst%symmetrize_cart_vec3(bks_vecs(:, idat, ib, ik_ibz, spin), time_opt)
4851 0 : do ii=1,3
4852 0 : out_vecsdos(:, 1, ii, idat, spin) = out_vecsdos(:, 1, ii, idat, spin) + wme0(:) * vsum(ii)
4853 0 : call simpson_int(nw, step, out_vecsdos(:,1,ii,idat,spin), out_vecsdos(:,2,ii,idat,spin))
4854 : end do
4855 : end do
4856 :
4857 : ! tensor
4858 0 : do idat=1,ntens
4859 : ! get components, symmetrize and accumulate.
4860 0 : tsum = cryst%symmetrize_cart_tens33(bks_tens(:, :, idat, ib, ik_ibz, spin), time_opt)
4861 0 : do ii=1,3
4862 0 : do jj=1,3
4863 0 : out_tensdos(:,1,jj,ii,idat,spin) = out_tensdos(:,1,jj,ii,idat,spin) + wme0(:) * tsum(jj,ii)
4864 0 : call simpson_int(nw, step, out_tensdos(:,1,jj,ii,idat,spin), out_tensdos(:,2,jj,ii,idat,spin))
4865 : end do
4866 : end do
4867 : end do
4868 :
4869 : end do !band
4870 : end do !ik_ibz
4871 : end do !spin
4872 :
4873 0 : ABI_FREE(wme0)
4874 0 : call xmpi_sum(edos%dos, comm, ierr)
4875 0 : if (nvals > 0) call xmpi_sum(out_valsdos, comm, ierr)
4876 0 : if (nvecs > 0) call xmpi_sum(out_vecsdos, comm, ierr)
4877 0 : if (ntens > 0) call xmpi_sum(out_tensdos, comm, ierr)
4878 :
4879 : case (2, -2)
4880 : ! Consistency test
4881 3569 : ABI_CHECK(all(ebands%nband == ebands%nband(1)), 'For tetrahedra, nband(:) must be constant')
4882 :
4883 : ! Build tetra object.
4884 : tetra = tetra_from_kptrlatt(cryst, ebands%kptopt, ebands%kptrlatt, &
4885 13 : ebands%nshiftk, ebands%shiftk, ebands%nkpt, ebands%kptns, comm, msg, ierr)
4886 13 : ABI_CHECK(ierr == 0, msg)
4887 :
4888 : ! For each spin and band, interpolate over kpoints,
4889 : ! calculate integration weights and DOS contribution.
4890 39 : ABI_MALLOC(tmp_eigen, (ebands%nkpt))
4891 39 : ABI_MALLOC(weights, (nw, 2))
4892 :
4893 : ! Blochl's corrections?
4894 13 : bcorr = 0; if (intmeth == -2) bcorr = 1
4895 :
4896 13 : cnt = 0
4897 26 : do spin=1,ebands%nsppol
4898 48 : do band=bmin_,bmax_
4899 : ! For each band get its contribution
4900 3705 : tmp_eigen = ebands%eig(band,:,spin)
4901 22 : ib = band - bmin_ + 1
4902 :
4903 22 : if (check_erange) then
4904 22 : if (all(tmp_eigen < emin)) cycle
4905 1273 : if (all(tmp_eigen > emax)) cycle
4906 : end if
4907 :
4908 3696 : do ik_ibz=1,ebands%nkpt
4909 3661 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism
4910 :
4911 3661 : call tetra%get_onewk(ik_ibz, bcorr, nw, ebands%nkpt, tmp_eigen, emin, emax, max_occ1, weights)
4912 1617091 : weights = weights * ebands%wtk(ik_ibz)
4913 :
4914 : ! Compute DOS and IDOS
4915 806715 : edos%dos(:,spin) = edos%dos(:,spin) + weights(:, 1)
4916 806715 : edos%idos(:,spin) = edos%idos(:,spin) + weights(:, 2)
4917 :
4918 : ! scalar
4919 : !$OMP PARALLEL DO
4920 45313 : do idat=1,nvals
4921 9193225 : out_valsdos(:, :, idat, spin) = out_valsdos(:, :, idat, spin) + weights(:, :) * bks_vals(idat, ib, ik_ibz, spin)
4922 : end do
4923 :
4924 : ! vector
4925 : !$OMP PARALLEL DO PRIVATE(vsum)
4926 3661 : do idat=1,nvecs
4927 : ! get components, symmetrize and accumulate.
4928 0 : vsum = cryst%symmetrize_cart_vec3(bks_vecs(:, idat, ib, ik_ibz, spin), time_opt)
4929 3661 : do ii=1,3
4930 0 : out_vecsdos(:, :, ii, idat, spin) = out_vecsdos(:, :, ii, idat, spin) + weights(:, :) * vsum(ii)
4931 : end do
4932 : end do
4933 :
4934 : ! tensor
4935 : !$OMP PARALLEL DO PRIVATE(tsum)
4936 52657 : do idat=1,ntens
4937 : ! get components, symmetrize and accumulate.
4938 48974 : tsum = cryst%symmetrize_cart_tens33(bks_tens(:, :, idat, ib, ik_ibz, spin), time_opt)
4939 199557 : do ii=1,3
4940 636662 : do jj=1,3
4941 111960636 : out_tensdos(:, :, jj, ii, idat, spin) = out_tensdos(:, :, jj, ii, idat, spin) + weights(:, :) * tsum(jj,ii)
4942 : end do
4943 : end do
4944 : end do
4945 :
4946 : end do ! ik_ibz
4947 : end do ! band
4948 : end do ! spin
4949 :
4950 : ! Free memory
4951 13 : ABI_FREE(weights)
4952 13 : ABI_FREE(tmp_eigen)
4953 13 : call tetra%free()
4954 :
4955 13 : call xmpi_sum(edos%dos, comm, ierr)
4956 13 : call xmpi_sum(edos%idos, comm, ierr)
4957 13 : if (nvals > 0) call xmpi_sum(out_valsdos, comm, ierr)
4958 13 : if (nvecs > 0) call xmpi_sum(out_vecsdos, comm, ierr)
4959 26 : if (ntens > 0) call xmpi_sum(out_tensdos, comm, ierr)
4960 :
4961 : case default
4962 13 : ABI_ERROR(sjoin("Wrong integration method:", itoa(intmeth)))
4963 : end select
4964 :
4965 : ! Compute total DOS and IDOS
4966 13 : max_occ = two / (ebands%nspinor * ebands%nsppol)
4967 11113 : edos%dos(:, 0) = max_occ * sum(edos%dos(:,1:), dim=2)
4968 :
4969 13 : if (intmeth == 1) then
4970 0 : do spin=1,edos%nsppol
4971 0 : call simpson_int(nw, edos%step, edos%dos(:,spin), edos%idos(:,spin))
4972 : end do
4973 : end if
4974 11113 : edos%idos(:, 0) = max_occ * sum(edos%idos(:,1:), dim=2)
4975 :
4976 : ! Use bisection to find the Fermi level.
4977 : ! Warning: this code assumes idos[i+1] >= idos[i]. This condition may not be
4978 : ! fulfilled if we use tetra and this is the reason why we have filtered the DOS.
4979 13 : if (ebands%occopt == 9) then
4980 0 : ihf = bisect(edos%idos(:,0), ebands%nelect-ebands%nh_qFD)
4981 0 : ief = bisect(edos%idos(:,0), ebands%nelect+ebands%ne_qFD)
4982 : else
4983 13 : ief = bisect(edos%idos(:,0), ebands%nelect)
4984 13 : ihf = ief
4985 : end if
4986 :
4987 : ! Handle out of range condition.
4988 13 : if (ief == 0 .or. ief == nw) then
4989 : write(msg,"(a, f14.2, 4a)") &
4990 12 : "Bisection could not find an initial guess for the Fermi level with nelect: ",ebands%nelect, ch10, &
4991 12 : "Possible reasons: not enough bands for DOS or wrong number of electrons.", ch10, &
4992 24 : "Returning from ebands_get_edos_matrix_elements without setting edos%ief !"
4993 12 : ABI_WARNING(msg)
4994 12 : return
4995 : end if
4996 :
4997 1 : if (ihf == 0 .or. ihf == nw) then
4998 : write(msg,"(3a)")&
4999 0 : "Bisection could not find an initial guess for the holes Fermi level!",ch10,&
5000 0 : "Possible reasons: not enough bands or wrong number of holes"
5001 0 : ABI_WARNING(msg)
5002 0 : return
5003 : end if
5004 :
5005 : ! TODO: Use linear interpolation to find an improved estimate of the Fermi level?
5006 1 : edos%ief = ief
5007 1 : edos%ihf = ihf
5008 3 : do spin=0,edos%nsppol
5009 2 : edos%gef(spin) = edos%dos(ief,spin)
5010 3 : edos%ghf(spin) = edos%dos(ihf,spin)
5011 : end do
5012 :
5013 1 : call cwtime_report(" ebands_get_edos_matrix_elements", cpu, wall, gflops)
5014 :
5015 26 : end function ebands_get_edos_matrix_elements
5016 : !!***
5017 :
5018 : !----------------------------------------------------------------------
5019 :
5020 : !!****f* m_ebands/ebands_get_jdos
5021 : !! NAME
5022 : !! ebands_get_jdos
5023 : !!
5024 : !! FUNCTION
5025 : !! Compute the joint density of states.
5026 : !!
5027 : !! INPUTS
5028 : !! ebands<ebands_t>=Band structure object.
5029 : !! cryst<cryst_t>=Info on the crystalline structure.
5030 : !! intmeth= 1 for gaussian, 2 or -2 for tetrahedra (-2 if Blochl corrections must be included).
5031 : !! step=Step on the linear mesh in Ha. If <0, the routine will use the mean of the energy level spacing
5032 : !! broad=Gaussian broadening, If <0, the routine will use a default
5033 : !! value for the broadening computed from the mean of the energy level spacing.
5034 : !! No meaning if tetra method
5035 : !! comm=MPI communicator
5036 : !!
5037 : !! OUTPUT
5038 : !!
5039 : !! SOURCE
5040 :
5041 0 : type(jdos_t) function ebands_get_jdos(ebands, cryst, intmeth, step, broad, comm, ierr) result (jdos)
5042 :
5043 : !Arguments ------------------------------------
5044 : !scalars
5045 : class(ebands_t),intent(in) :: ebands
5046 : integer,intent(in) :: intmeth,comm
5047 : integer,intent(out) :: ierr
5048 : real(dp),intent(in) :: step,broad
5049 : type(crystal_t),intent(in) :: cryst
5050 :
5051 : !Local variables-------------------------------
5052 : !scalars
5053 : integer :: ik_ibz,ibc,ibv,spin,nw,nband_k,nbv,nproc,my_rank,cnt,mpierr,bcorr !iw, unt,
5054 : real(dp) :: wtk,wmax
5055 0 : type(htetra_t) :: tetra
5056 : character(len=500) :: msg
5057 : !character(len=fnlen) :: path
5058 : !arrays
5059 0 : integer :: val_idx(ebands%nkpt,ebands%nsppol)
5060 0 : real(dp) :: eminmax(2,ebands%nsppol)
5061 0 : real(dp),allocatable :: cvmw(:),wdt(:,:)
5062 : ! *********************************************************************
5063 :
5064 0 : ierr = 0
5065 0 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
5066 :
5067 0 : jdos%nsppol = ebands%nsppol
5068 0 : jdos%nkibz = ebands%nkpt
5069 :
5070 : ! Find the valence band index for each k and spin.
5071 0 : val_idx = ebands_get_valence_idx(ebands)
5072 :
5073 0 : do spin=1,ebands%nsppol
5074 0 : if (any(val_idx(:,spin) /= val_idx(1,spin))) then
5075 : write(msg,'(a,i0,a)')&
5076 0 : 'Trying to compute JDOS with a metallic band structure for spin: ',spin,&
5077 0 : 'Assuming you know what you are doing, continuing anyway! '
5078 0 : ABI_COMMENT(msg)
5079 : end if
5080 : end do
5081 :
5082 : ! Compute the linear mesh so that it encloses all bands.
5083 : !if (.not. present(mesh)) then
5084 0 : eminmax = ebands_get_minmax(ebands, "eig")
5085 0 : wmax = maxval(eminmax(2,:) - eminmax(1,:))
5086 0 : nw = nint(wmax/step) + 1
5087 0 : ABI_MALLOC(jdos%mesh, (nw))
5088 0 : jdos%mesh = arth(zero, step, nw)
5089 :
5090 0 : jdos%nw = nw
5091 0 : jdos%intmeth = intmeth
5092 0 : jdos%broad = broad
5093 :
5094 : !if (ebands%nkpt == 1) then
5095 : ! ABI_COMMENT("Cannot use tetrahedra for e-DOS when nkpt == 1. Switching to gaussian method")
5096 : ! jdos%intmeth = 1
5097 : !end if
5098 :
5099 0 : ABI_CALLOC(jdos%values, (nw, ebands%nsppol))
5100 :
5101 0 : select case (intmeth)
5102 : case (1)
5103 : ! Gaussian
5104 0 : ABI_MALLOC(cvmw, (nw))
5105 :
5106 0 : cnt = 0
5107 0 : do spin=1,ebands%nsppol
5108 0 : do ik_ibz=1,ebands%nkpt
5109 0 : wtk = ebands%wtk(ik_ibz)
5110 0 : nband_k = ebands%nband(ik_ibz + (spin-1)*ebands%nkpt)
5111 0 : nbv = val_idx(ik_ibz, spin)
5112 :
5113 0 : do ibv=1,nbv
5114 0 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
5115 0 : do ibc=nbv+1,nband_k
5116 0 : cvmw = ebands%eig(ibc,ik_ibz,spin) - ebands%eig(ibv,ik_ibz,spin) - jdos%mesh
5117 0 : jdos%values(:, spin) = jdos%values(:, spin) + wtk * gaussian(cvmw, broad)
5118 : end do
5119 : end do
5120 :
5121 : end do ! ik_ibz
5122 : end do ! spin
5123 :
5124 0 : ABI_FREE(cvmw)
5125 0 : call xmpi_sum(jdos%values, comm, mpierr)
5126 :
5127 : case (2, -2)
5128 : ! Tetrahedron method
5129 0 : if (any(ebands%nband /= ebands%nband(1)) ) then
5130 0 : ABI_WARNING('For tetrahedra, nband(:) must be constant')
5131 0 : ierr = ierr + 1
5132 : end if
5133 0 : if (ierr/=0) return
5134 :
5135 : tetra = tetra_from_kptrlatt(cryst, ebands%kptopt, ebands%kptrlatt, &
5136 0 : ebands%nshiftk, ebands%shiftk, ebands%nkpt, ebands%kptns, comm, msg, ierr)
5137 0 : if (ierr /= 0) then
5138 0 : call tetra%free(); return
5139 : end if
5140 :
5141 : ! For each spin and band, interpolate over kpoints,
5142 : ! calculate integration weights and DOS contribution.
5143 0 : ABI_MALLOC(cvmw, (jdos%nkibz))
5144 0 : ABI_MALLOC(wdt, (nw, 2))
5145 :
5146 0 : bcorr = 0; if (intmeth == -2) bcorr = 1
5147 0 : cnt = 0
5148 0 : do spin=1,ebands%nsppol
5149 0 : nbv = val_idx(1, spin)
5150 0 : do ibv=1,nbv
5151 0 : do ibc=nbv+1,ebands%mband
5152 : ! For each (c, v) get its contribution
5153 0 : cvmw = ebands%eig(ibc,:,spin) - ebands%eig(ibv,:,spin)
5154 0 : do ik_ibz=1,ebands%nkpt
5155 0 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! mpi-parallelism
5156 :
5157 : ! Calculate integration weights at each irred k-point (Blochl et al PRB 49 16223 [[cite:Bloechl1994a]])
5158 0 : call tetra%get_onewk(ik_ibz, bcorr, nw, ebands%nkpt, cvmw, jdos%mesh(0), jdos%mesh(nw), one, wdt)
5159 0 : jdos%values(:,spin) = jdos%values(:,spin) + wdt(:, 1) * ebands%wtk(ik_ibz)
5160 : end do
5161 : end do ! ibc
5162 : end do ! ibv
5163 : end do ! spin
5164 :
5165 0 : call xmpi_sum(jdos%values, comm, mpierr)
5166 :
5167 : ! Free memory
5168 0 : ABI_FREE(wdt)
5169 0 : ABI_FREE(cvmw)
5170 0 : call tetra%free()
5171 :
5172 : case default
5173 0 : ABI_ERROR(sjoin("Wrong integration method:", itoa(intmeth)))
5174 : end select
5175 :
5176 0 : if (ebands%nsppol == 1) then
5177 0 : jdos%values(0,:) = two * jdos%values(1,:)
5178 : else
5179 0 : jdos%values(0,:) = sum(jdos%values(1:2, :), dim=2)
5180 : end if
5181 :
5182 : ! Write data.
5183 : !if (my_rank == 0) then
5184 : ! path = "jdos_gauss.data"; if (intmeth == 2) path = "jdos_tetra.data"
5185 : ! if (open_file(path, msg, newunit=unt, form="formatted", action="write") /= 0) then
5186 : ! ABI_ERROR(msg)
5187 : ! end if
5188 : ! do iw=1,nw
5189 : ! write(unt,*)jdos%mesh(iw),(jdos(iw,spin), spin=1,ebands%nsppol)
5190 : ! end do
5191 : ! close(unt)
5192 : !end if
5193 :
5194 0 : end function ebands_get_jdos
5195 : !!***
5196 :
5197 : !----------------------------------------------------------------------
5198 :
5199 : !!****f* m_ebands/jdos_ncwrite
5200 : !! NAME
5201 : !! jdos_ncwrite
5202 : !!
5203 : !! FUNCTION
5204 : !! Write JDOS to netcdf file.
5205 : !!
5206 : !! INPUTS
5207 : !! ncid=NC file handle.
5208 : !! [prefix]=String prepended to netcdf dimensions/variables (HDF5 poor-man groups)
5209 : !! Empty string if not specified.
5210 : !!
5211 : !! SOURCE
5212 :
5213 0 : integer function jdos_ncwrite(jdos, ncid, prefix) result(ncerr)
5214 :
5215 : !Arguments ------------------------------------
5216 : !scalars
5217 : class(jdos_t),intent(inout) :: jdos
5218 : integer,intent(in) :: ncid
5219 : character(len=*),optional,intent(in) :: prefix
5220 :
5221 : !Local variables-------------------------------
5222 : character(len=500) :: prefix_
5223 : ! *********************************************************************
5224 :
5225 0 : prefix_ = ""; if (present(prefix)) prefix_ = trim(prefix)
5226 :
5227 : ! Define dimensions.
5228 : ncerr = nctk_def_dims(ncid, [ &
5229 0 : nctkdim_t("nsppol_plus1", jdos%nsppol + 1), nctkdim_t("jdos_nw", jdos%nw)], defmode=.True., prefix=prefix_)
5230 0 : NCF_CHECK(ncerr)
5231 :
5232 : ! Define variables
5233 0 : NCF_CHECK(nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "jdos_intmeth", "jdos_nkibz"], prefix=prefix_))
5234 0 : NCF_CHECK(nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "jdos_broad"], prefix=prefix_))
5235 :
5236 : ncerr = nctk_def_arrays(ncid, [ &
5237 : nctkarr_t("jdos_mesh", "dp", "jdos_nw"), &
5238 : nctkarr_t("jdos_values", "dp", "jdos_nw, nsppol_plus1") &
5239 0 : ], prefix=prefix_)
5240 0 : NCF_CHECK(ncerr)
5241 :
5242 : ! Write data.
5243 0 : NCF_CHECK(nctk_set_datamode(ncid))
5244 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("jdos_intmeth")), jdos%intmeth))
5245 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("jdos_nkibz")), jdos%nkibz))
5246 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("jdos_broad")), jdos%broad))
5247 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("jdos_mesh")), jdos%mesh))
5248 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, pre("edos_values")), jdos%values))
5249 :
5250 : contains
5251 0 : pure function pre(istr) result(ostr)
5252 : character(len=*),intent(in) :: istr
5253 : character(len=len_trim(prefix_) + len_trim(istr)+1) :: ostr
5254 0 : ostr = trim(prefix_) // trim(istr)
5255 0 : end function pre
5256 :
5257 : end function jdos_ncwrite
5258 : !!***
5259 :
5260 : !----------------------------------------------------------------------
5261 :
5262 : !!****f* m_ebands/jdos_free
5263 : !! NAME
5264 : !! jdos_free
5265 : !!
5266 : !! FUNCTION
5267 : !! Free memory
5268 : !!
5269 : !! SOURCE
5270 :
5271 0 : subroutine jdos_free(jdos)
5272 :
5273 : !Arguments ------------------------------------
5274 : class(jdos_t),intent(inout) :: jdos
5275 : ! *********************************************************************
5276 :
5277 0 : ABI_SFREE(jdos%mesh)
5278 0 : ABI_SFREE(jdos%values)
5279 :
5280 0 : end subroutine jdos_free
5281 : !!***
5282 :
5283 : !----------------------------------------------------------------------
5284 :
5285 : !!****f* m_ebands/ebands_prtbltztrp
5286 : !! NAME
5287 : !! ebands_prtbltztrp
5288 : !!
5289 : !! FUNCTION
5290 : !! Output files for BoltzTraP code, which integrates Boltzmann transport quantities
5291 : !! over the Fermi surface for different T and chemical potentials. Abinit provides
5292 : !! all necessary input files: struct, energy, input file, and def file for the unit
5293 : !! definitions of fortran files in BT.
5294 : !! See http://www.icams.de/content/departments/ams/madsen/boltztrap.html
5295 : !!
5296 : !! INPUTS
5297 : !! ebands<ebands_t>=Band structure object.
5298 : !! cryst<cryst_t>=Info on the crystalline structure.
5299 : !! fname_radix = radix of file names for output
5300 : !!
5301 : !! OUTPUT
5302 : !! (only writing, printing)
5303 : !!
5304 : !! SOURCE
5305 :
5306 0 : subroutine ebands_prtbltztrp(ebands, crystal, fname_radix, tau_k)
5307 :
5308 : !Arguments ------------------------------------
5309 : !scalars
5310 : class(ebands_t),intent(in) :: ebands
5311 : type(crystal_t),intent(in) :: crystal
5312 : character(len=fnlen), intent(in) :: fname_radix
5313 : !arrays
5314 : real(dp), intent(in), optional :: tau_k(ebands%nsppol,ebands%nkpt,ebands%mband)
5315 :
5316 : !Local variables-------------------------------
5317 : !scalars
5318 : integer :: iout, isym, iband, isppol, ikpt, nsppol, nband
5319 : real(dp),parameter :: ha2ryd=two
5320 : real(dp) :: ewindow
5321 : character(len=fnlen) :: filename
5322 : character(len=2) :: so_suffix
5323 : character(len=500) :: msg
5324 : !arrays
5325 4 : real(dp) :: nelec(ebands%nsppol)
5326 4 : character(len=3) :: spinsuffix(ebands%nsppol)
5327 : ! *************************************************************************
5328 :
5329 : !MG FIXME The number of electrons is wrong if the file is produced in a NSCF run.
5330 : ! See https://forum.abinit.org/viewtopic.php?f=19&t=3339
5331 :
5332 : ! CP test to prevent use in case occopt = 9
5333 2 : if (ebands%occopt==9) then
5334 0 : write(msg,'(a)') "Boltztrap outputting not possible with occopt = 9 at the moment"
5335 0 : ABI_ERROR(msg)
5336 : end if
5337 :
5338 2 : nelec = ebands_nelect_per_spin(ebands)
5339 2 : nsppol = ebands%nsppol
5340 2 : nband = ebands%nband(1)
5341 :
5342 2 : so_suffix=""
5343 2 : if (nsppol > 1 .or. ebands%nspinor > 1) so_suffix="so"
5344 :
5345 2 : if (nsppol == 1) then
5346 2 : spinsuffix(1) = "ns_"
5347 : else
5348 0 : spinsuffix = ["up_", "dn_"]
5349 : end if
5350 :
5351 4 : do isppol=1,nsppol
5352 :
5353 : !input file for boltztrap: general info, Ef, Nelec, etc...
5354 2 : filename= trim(fname_radix)//"_"//trim(spinsuffix(isppol))//"BLZTRP.intrans"
5355 2 : if (open_file(filename, msg, newunit=iout, form='formatted') /= 0) then
5356 0 : ABI_ERROR(msg)
5357 : end if
5358 :
5359 62 : ewindow = 1.1_dp * (ebands%fermie-minval(ebands%eig(1, :, isppol)))
5360 2 : write (iout, '(a)') "GENE # Format of input: generic format, with Symmetries"
5361 2 : write (iout, '(a)') "0 0 0 0.0 # iskip (not presently used) idebug setgap shiftgap"
5362 2 : write (iout, '(E15.5,a,2F10.4,a)') ebands%fermie*ha2ryd, " 0.0005 ", ewindow*ha2ryd, nelec(isppol), &
5363 4 : & " # Fermilevel (Ry), energy grid spacing, energy span around Fermilevel, number of electrons for this spin"
5364 2 : write (iout, '(a)') "CALC # CALC (calculate expansion coeff), NOCALC read from file"
5365 2 : write (iout, '(a)') "3 # lpfac, number of latt-points per k-point"
5366 2 : write (iout, '(a)') "BOLTZ # run mode (only BOLTZ is supported)"
5367 2 : write (iout, '(a)') ".15 # (efcut) energy range of chemical potential"
5368 2 : write (iout, '(a)') "300. 10. # Tmax, temperature grid spacing"
5369 2 : write (iout, '(2a)') "-1 # energyrange of bands given ",&
5370 4 : & "individual DOS output sig_xxx and dos_xxx (xxx is band number)"
5371 2 : write (iout, '(a)') "HISTO # DOS calculation method. Other possibility is TETRA"
5372 2 : write (iout, '(a)') "No # not using model for relaxation time"
5373 2 : write (iout, '(a)') "3 # Number of doping levels coefficients will be output for"
5374 2 : write (iout, '(a)') "-1.e16 0.0d0 1.e16 # Values of doping levels (in carriers / cm^3"
5375 2 : close(iout)
5376 :
5377 : !files file, with association of all units for Boltztrap
5378 2 : filename= trim(fname_radix)//"_"//trim(spinsuffix(isppol))//"BLZTRP.def"
5379 2 : if (open_file(filename, msg, newunit=iout, form='formatted') /= 0) then
5380 0 : ABI_ERROR(msg)
5381 : end if
5382 :
5383 2 : write (iout, '(3a)') "5, '", trim(fname_radix)//"_"//trim(spinsuffix(isppol))//"BLZTRP.intrans', 'old', 'formatted',0"
5384 2 : write (iout, '(3a)') "6, '", trim(fname_radix)//"_BLZTRP", ".outputtrans', 'unknown', 'formatted',0"
5385 2 : write (iout, '(3a)') "20,'", trim(fname_radix)//"_BLZTRP", ".struct', 'old', 'formatted',0"
5386 2 : write (iout, '(3a)') "10,'", trim(fname_radix)//"_BLZTRP."//trim(spinsuffix(isppol))//"energy"//trim(so_suffix),&
5387 4 : & "', 'old', 'formatted',0"
5388 2 : if (present (tau_k)) then
5389 0 : write (iout, '(3a)') "11,'", trim(fname_radix)//"_BLZTRP", ".tau_k', 'old', 'formatted',0"
5390 : end if
5391 2 : write (iout, '(3a)') "48,'", trim(fname_radix)//"_BLZTRP", ".engre', 'unknown', 'unformatted',0"
5392 2 : write (iout, '(3a)') "49,'", trim(fname_radix)//"_BLZTRP", ".transdos', 'unknown', 'formatted',0"
5393 2 : write (iout, '(3a)') "50,'", trim(fname_radix)//"_BLZTRP", ".sigxx', 'unknown', 'formatted',0"
5394 2 : write (iout, '(3a)') "51,'", trim(fname_radix)//"_BLZTRP", ".sigxxx', 'unknown', 'formatted',0"
5395 2 : write (iout, '(3a)') "21,'", trim(fname_radix)//"_BLZTRP", ".trace', 'unknown', 'formatted',0"
5396 2 : write (iout, '(3a)') "22,'", trim(fname_radix)//"_BLZTRP", ".condtens', 'unknown', 'formatted',0"
5397 2 : write (iout, '(3a)') "24,'", trim(fname_radix)//"_BLZTRP", ".halltens', 'unknown', 'formatted',0"
5398 2 : write (iout, '(3a)') "25,'", trim(fname_radix)//"_BLZTRP", ".trace_fixdoping', 'unknown', 'formatted',0"
5399 2 : write (iout, '(3a)') "26,'", trim(fname_radix)//"_BLZTRP", ".condtens_fixdoping', 'unknown', 'formatted',0"
5400 2 : write (iout, '(3a)') "27,'", trim(fname_radix)//"_BLZTRP", ".halltens_fixdoping', 'unknown', 'formatted',0"
5401 2 : write (iout, '(3a)') "30,'", trim(fname_radix)//"_BLZTRP", "_BZ.dx', 'unknown', 'formatted',0"
5402 2 : write (iout, '(3a)') "31,'", trim(fname_radix)//"_BLZTRP", "_fermi.dx', 'unknown', 'formatted',0"
5403 2 : write (iout, '(3a)') "32,'", trim(fname_radix)//"_BLZTRP", "_sigxx.dx', 'unknown', 'formatted',0"
5404 2 : write (iout, '(3a)') "33,'", trim(fname_radix)//"_BLZTRP", "_sigyy.dx', 'unknown', 'formatted',0"
5405 2 : write (iout, '(3a)') "34,'", trim(fname_radix)//"_BLZTRP", "_sigzz.dx', 'unknown', 'formatted',0"
5406 2 : write (iout, '(3a)') "35,'", trim(fname_radix)//"_BLZTRP", "_band.dat', 'unknown', 'formatted',0"
5407 2 : write (iout, '(3a)') "36,'", trim(fname_radix)//"_BLZTRP", "_band.gpl', 'unknown', 'formatted',0"
5408 2 : write (iout, '(3a)') "37,'", trim(fname_radix)//"_BLZTRP", "_deriv.dat', 'unknown', 'formatted',0"
5409 2 : write (iout, '(3a)') "38,'", trim(fname_radix)//"_BLZTRP", "_mass.dat', 'unknown', 'formatted',0"
5410 :
5411 4 : close(iout)
5412 : end do !isppol
5413 :
5414 : !file is for geometry symmetries etc
5415 2 : filename= trim(fname_radix)//"_BLZTRP.struct"
5416 2 : if (open_file(filename, msg, newunit=iout, form='formatted') /= 0) then
5417 0 : ABI_ERROR(msg)
5418 : end if
5419 :
5420 2 : write (iout, '(a)') "BoltzTraP geometry file generated by ABINIT."
5421 :
5422 : !here we need to print out the unit cell vectors
5423 2 : write (iout, '(3E20.10)') crystal%rprimd(:,1)
5424 2 : write (iout, '(3E20.10)') crystal%rprimd(:,2)
5425 2 : write (iout, '(3E20.10)') crystal%rprimd(:,3)
5426 2 : write (iout, '(I7)') crystal%nsym
5427 :
5428 98 : do isym=1,crystal%nsym
5429 : write (iout,'(3(3I5,2x), a, I5)') &
5430 96 : & crystal%symrel(1,:,isym), &
5431 96 : & crystal%symrel(2,:,isym), &
5432 96 : & crystal%symrel(3,:,isym), &
5433 194 : & ' ! symmetry rotation matrix isym = ', isym
5434 : end do
5435 :
5436 2 : close (iout)
5437 :
5438 : ! second file is for eigenvalues
5439 : ! two file names for each spin, if necessary
5440 4 : do isppol=1,nsppol
5441 2 : filename=trim(fname_radix)//"_BLZTRP."//spinsuffix(isppol)//"energy"//trim(so_suffix)
5442 :
5443 2 : if (open_file (filename, msg, newunit=iout, form='formatted') /= 0) then
5444 0 : ABI_ERROR(msg)
5445 : end if
5446 :
5447 2 : write (iout, '(a,I5)') "BoltzTraP eigen-energies file generated by ABINIT. ispin = ", isppol
5448 : write (iout, '(I7, I7, E20.10, a)') &
5449 2 : & ebands%nkpt, nsppol, ha2ryd*ebands%fermie, ' ! nk, nspin, Fermi level(Ry) : energies below in Ry'
5450 :
5451 60 : do ikpt=1,ebands%nkpt
5452 : ! these need to be in reduced coordinates
5453 : write (iout, '(3E20.10, I7, a)') &
5454 58 : & ebands%kptns(1,ikpt), ebands%kptns(2,ikpt), ebands%kptns(3,ikpt), nband, ' ! kpt nband'
5455 582 : do iband=1,nband
5456 : ! output in Rydberg
5457 580 : write (iout, '(E20.10)') ha2ryd*ebands%eig(iband, ikpt, isppol)
5458 : end do
5459 : end do
5460 :
5461 4 : close (iout)
5462 : end do
5463 :
5464 : !this file is for tau_k
5465 2 : if (present (tau_k)) then
5466 0 : do isppol = 1, nsppol
5467 0 : filename= trim(fname_radix)//"_"//spinsuffix(isppol)//"BLZTRP.tau_k"
5468 0 : if (open_file(filename, msg, newunit=iout, form='formatted') /= 0) then
5469 0 : ABI_ERROR(msg)
5470 : end if
5471 :
5472 0 : write (iout, '(a)') "BoltzTraP tau_k file generated by ANADDB."
5473 : write (iout, '(I7, I7, E20.10, a)')&
5474 0 : & ebands%nkpt, nsppol, ha2ryd*ebands%fermie, ' ! nk, nspin, Fermi level(Ry) : energies below in Ry'
5475 :
5476 0 : do ikpt=1,ebands%nkpt
5477 : ! these need to be in reduced coordinates
5478 : write (iout, '(3E20.10, I7, a)') &
5479 0 : & ebands%kptns(1,ikpt), ebands%kptns(2,ikpt), ebands%kptns(3,ikpt), nband, ' ! kpt nband'
5480 0 : do iband=1,nband
5481 : ! output in eV
5482 0 : write (iout, '(E20.10)') tau_k(isppol,ikpt,iband)
5483 : end do
5484 : end do
5485 0 : close (iout)
5486 : end do
5487 :
5488 : end if
5489 :
5490 2 : end subroutine ebands_prtbltztrp
5491 : !!***
5492 :
5493 : !!****f* m_ebands/ebands_prtbltztrp_tau_out
5494 : !! NAME
5495 : !! ebands_prtbltztrp_tau_out
5496 : !!
5497 : !! FUNCTION
5498 : !! output files for BoltzTraP code, which integrates Boltzmann transport quantities
5499 : !! over the Fermi surface for different T and chemical potentials. Abinit provides
5500 : !! all necessary input files: struct, energy, input file, and def file for the unit
5501 : !! definitions of fortran files in BT.
5502 : !! See http://www.icams.de/content/departments/ams/madsen/boltztrap.html
5503 : !! Output T-depedent tau_k, modified from ebands_prtbltztrp
5504 : !!
5505 : !! INPUTS
5506 : !! eigen(mband*nkpt*nsppol) = array for holding eigenvalues (hartree)
5507 : !! fermie = Fermi level
5508 : !! fname_radix = radix of file names for output
5509 : !! nband = number of bands
5510 : !! nkpt = number of k points.
5511 : !! nsppol = 1 for unpolarized, 2 for spin-polarized
5512 : !! nsym = number of symmetries in space group
5513 : !! rprimd(3,3) = dimensional primitive translations for real space (bohr)
5514 : !! symrel = symmetry operations in reduced coordinates, real space
5515 : !! to be used in future xred(3,natom) = reduced dimensionless atomic coordinates
5516 : !!
5517 : !! OUTPUT
5518 : !! (only writing, printing)
5519 : !!
5520 : !! SOURCE
5521 :
5522 0 : subroutine ebands_prtbltztrp_tau_out(eigen, tempermin, temperinc, ntemper, fermie, fname_radix, kpt, &
5523 0 : nband, nelec, nkpt, nspinor, nsppol, nsym, rprimd, symrel, tau_k)
5524 :
5525 : !Arguments ------------------------------------
5526 : !scalars
5527 : integer, intent(in) :: nsym, nband, nkpt, nsppol, nspinor, ntemper
5528 : real(dp), intent(in) :: tempermin, temperinc, nelec
5529 : character(len=fnlen), intent(in) :: fname_radix
5530 : !arrays
5531 : real(dp), intent(in) :: fermie(ntemper)
5532 : integer, intent(in) :: symrel(3,3,nsym)
5533 : real(dp), intent(in) :: kpt(3,nkpt)
5534 : real(dp), intent(in) :: eigen(nband, nkpt, nsppol)
5535 : real(dp), intent(in) :: rprimd(3,3)
5536 : real(dp), intent(in) :: tau_k(ntemper,nsppol,nkpt,nband)
5537 :
5538 : !Local variables-------------------------------
5539 : !scalars
5540 : integer :: iout, isym, iband, isppol, ikpt, itemp
5541 : real(dp) :: Temp
5542 : real(dp),parameter :: ha2ryd = two
5543 : character(len=500) :: msg
5544 : character(len=fnlen) :: filename,appendix
5545 : ! *************************************************************************
5546 :
5547 : !input file for boltztrap: general info, Ef, Nelec, etc...
5548 0 : do itemp = 1, ntemper
5549 0 : write(appendix,"(i0)") itemp
5550 0 : filename= trim(fname_radix)//"_BLZTRP.intrans_"//trim(appendix)
5551 0 : if (open_file(filename, msg, newunit=iout, form="formatted", action="write") /= 0) then
5552 0 : ABI_ERROR(msg)
5553 : end if
5554 :
5555 0 : write (iout, '(a)') "GENE # Format of input: generic format, with Symmetries"
5556 0 : write (iout, '(a)') "0 0 0 0.0 # iskip (not presently used) idebug setgap shiftgap"
5557 0 : write (iout, '(E15.5,a,F10.4,a)') fermie(itemp)*two, " 0.0005 0.4 ", nelec, &
5558 0 : " # Fermilevel (Ry), energy grid spacing, energy span around Fermilevel, number of electrons"
5559 0 : write (iout, '(a)') "CALC # CALC (calculate expansion coeff), NOCALC read from file"
5560 0 : write (iout, '(a)') "3 # lpfac, number of latt-points per k-point"
5561 0 : write (iout, '(a)') "BOLTZ # run mode (only BOLTZ is supported)"
5562 0 : write (iout, '(a)') ".15 # (efcut) energy range of chemical potential"
5563 : write (iout, '(2f8.2,a)')&
5564 0 : tempermin+temperinc*dble(itemp),tempermin+temperinc*dble(itemp), " # Tmax, temperature grid spacing"
5565 0 : write (iout, '(2a)') "-1 # energyrange of bands given ",&
5566 0 : "individual DOS output sig_xxx and dos_xxx (xxx is band number)"
5567 0 : write (iout, '(a)') "TETRA # DOS calculation method. Other possibility is TETRA"
5568 0 : write (iout, '(a)') "No # not using model for relaxation time"
5569 0 : write (iout, '(a)') "3 # Number of doping levels coefficients will be output for"
5570 0 : write (iout, '(a)') "-1.e16 0.0d0 1.e16 # Values of doping levels (in carriers / cm^3"
5571 0 : close(iout)
5572 : end do
5573 :
5574 : !files file, with association of all units for Boltztrap
5575 0 : filename= trim(fname_radix)//"_BLZTRP.def"
5576 0 : if (open_file(filename, msg, newunit=iout, form="formatted", action="write") /= 0) then
5577 0 : ABI_ERROR(msg)
5578 : end if
5579 0 : write (iout, '(3a)') "5, '", trim(fname_radix)//"_BLZTRP", ".intrans', 'old', 'formatted',0"
5580 0 : write (iout, '(3a)') "6, '", trim(fname_radix)//"_BLZTRP", ".outputtrans', 'unknown', 'formatted',0"
5581 0 : write (iout, '(3a)') "20,'", trim(fname_radix)//"_BLZTRP", ".struct', 'old', 'formatted',0"
5582 0 : if (nspinor == 1) then
5583 0 : write (iout, '(3a)') "10,'", trim(fname_radix)//"_BLZTRP", ".energy', 'old', 'formatted',0"
5584 0 : else if (nspinor == 2) then
5585 0 : write (iout, '(3a)') "10,'", trim(fname_radix)//"_BLZTRP", ".energyso', 'old', 'formatted',0"
5586 : end if
5587 0 : write (iout, '(3a)') "10,'", trim(fname_radix)//"_BLZTRP", ".energy', 'old', 'formatted',0"
5588 0 : write (iout, '(3a)') "11,'", trim(fname_radix)//"_BLZTRP", ".tau_k', 'old', 'formatted',0"
5589 0 : write (iout, '(3a)') "48,'", trim(fname_radix)//"_BLZTRP", ".engre', 'unknown', 'unformatted',0"
5590 0 : write (iout, '(3a)') "49,'", trim(fname_radix)//"_BLZTRP", ".transdos', 'unknown', 'formatted',0"
5591 0 : write (iout, '(3a)') "50,'", trim(fname_radix)//"_BLZTRP", ".sigxx', 'unknown', 'formatted',0"
5592 0 : write (iout, '(3a)') "51,'", trim(fname_radix)//"_BLZTRP", ".sigxxx', 'unknown', 'formatted',0"
5593 0 : write (iout, '(3a)') "21,'", trim(fname_radix)//"_BLZTRP", ".trace', 'unknown', 'formatted',0"
5594 0 : write (iout, '(3a)') "22,'", trim(fname_radix)//"_BLZTRP", ".condtens', 'unknown', 'formatted',0"
5595 0 : write (iout, '(3a)') "24,'", trim(fname_radix)//"_BLZTRP", ".halltens', 'unknown', 'formatted',0"
5596 0 : write (iout, '(3a)') "25,'", trim(fname_radix)//"_BLZTRP", ".trace_fixdoping', 'unknown', 'formatted',0"
5597 0 : write (iout, '(3a)') "26,'", trim(fname_radix)//"_BLZTRP", ".condtens_fixdoping', 'unknown', 'formatted',0"
5598 0 : write (iout, '(3a)') "27,'", trim(fname_radix)//"_BLZTRP", ".halltens_fixdoping', 'unknown', 'formatted',0"
5599 0 : write (iout, '(3a)') "30,'", trim(fname_radix)//"_BLZTRP", "_BZ.dx', 'unknown', 'formatted',0"
5600 0 : write (iout, '(3a)') "31,'", trim(fname_radix)//"_BLZTRP", "_fermi.dx', 'unknown', 'formatted',0"
5601 0 : write (iout, '(3a)') "32,'", trim(fname_radix)//"_BLZTRP", "_sigxx.dx', 'unknown', 'formatted',0"
5602 0 : write (iout, '(3a)') "33,'", trim(fname_radix)//"_BLZTRP", "_sigyy.dx', 'unknown', 'formatted',0"
5603 0 : write (iout, '(3a)') "34,'", trim(fname_radix)//"_BLZTRP", "_sigzz.dx', 'unknown', 'formatted',0"
5604 0 : write (iout, '(3a)') "35,'", trim(fname_radix)//"_BLZTRP", "_band.dat', 'unknown', 'formatted',0"
5605 0 : write (iout, '(3a)') "36,'", trim(fname_radix)//"_BLZTRP", "_band.gpl', 'unknown', 'formatted',0"
5606 0 : write (iout, '(3a)') "37,'", trim(fname_radix)//"_BLZTRP", "_deriv.dat', 'unknown', 'formatted',0"
5607 0 : write (iout, '(3a)') "38,'", trim(fname_radix)//"_BLZTRP", "_mass.dat', 'unknown', 'formatted',0"
5608 0 : close(iout)
5609 :
5610 : !file is for geometry symmetries etc
5611 0 : filename= trim(fname_radix)//"_BLZTRP.struct"
5612 0 : if (open_file(filename, msg, newunit=iout, form="formatted", action="write") /= 0) then
5613 0 : ABI_ERROR(msg)
5614 : end if
5615 0 : write (iout, '(a)') "BoltzTraP geometry file generated by ABINIT."
5616 :
5617 : !here we need to print out the unit cell vectors
5618 0 : write (iout, '(3E20.10)') rprimd(:,1)
5619 0 : write (iout, '(3E20.10)') rprimd(:,2)
5620 0 : write (iout, '(3E20.10)') rprimd(:,3)
5621 0 : write (iout, '(I7)') nsym
5622 :
5623 0 : do isym=1, nsym
5624 : write (iout,'(3(3I5,2x), a, I5)') &
5625 0 : symrel(1,:,isym), symrel(2,:,isym), symrel(3,:,isym), ' ! symmetry rotation matrix isym = ', isym
5626 : end do
5627 0 : close (iout)
5628 :
5629 : !second file is for eigenvalues
5630 0 : if (nspinor == 1) then
5631 0 : filename= trim(fname_radix)//"_BLZTRP.energy"
5632 0 : else if (nspinor == 2) then
5633 0 : filename= trim(fname_radix)//"_BLZTRP.energyso"
5634 : end if
5635 :
5636 0 : if (open_file(filename, msg, newunit=iout, form="formatted", action="write") /= 0) then
5637 0 : ABI_ERROR(msg)
5638 : end if
5639 0 : write (iout, '(a)') "BoltzTraP eigen-energies file generated by ABINIT."
5640 0 : write (iout, '(I7, I7, E20.10, a)') nkpt, nsppol, ha2ryd*fermie(1), ' ! nk, nspin, Fermi level(Ry) : energies below in Ry'
5641 0 : do isppol = 1, nsppol
5642 0 : do ikpt = 1, nkpt
5643 : ! these need to be in reduced coordinates
5644 0 : write (iout, '(3E20.10, I7, a)') kpt(1,ikpt), kpt(2,ikpt), kpt(3,ikpt), nband, ' ! kpt nband'
5645 0 : do iband = 1, nband
5646 : ! output in eV
5647 0 : write (iout, '(E20.10)') ha2ryd*eigen(iband, ikpt, isppol)
5648 : end do
5649 : end do
5650 : end do
5651 0 : close (iout)
5652 :
5653 : !this file is for tau_k
5654 0 : do itemp = 1, ntemper
5655 0 : Temp=tempermin+temperinc*dble(itemp)
5656 :
5657 0 : write(appendix,"(i0)") itemp
5658 0 : filename= trim(fname_radix)//"_BLZTRP.tau_k_"//trim(appendix)
5659 0 : if (open_file(filename, msg, newunit=iout, form="formatted", action="write") /= 0) then
5660 0 : ABI_ERROR(msg)
5661 : end if
5662 0 : write (iout, '(a,f12.6)') "BoltzTraP tau_k file generated by ANADDB for T= ", Temp
5663 0 : write (iout, '(I7, I7, E20.10, a)') nkpt, nsppol, ha2ryd*fermie(itemp), &
5664 0 : ' ! nk, nspin, Fermi level(Ry) : energies below in Ry'
5665 0 : do isppol = 1, nsppol
5666 0 : do ikpt = 1, nkpt
5667 : ! these need to be in reduced coordinates
5668 0 : write (iout, '(3E20.10, I7, a)') kpt(1,ikpt), kpt(2,ikpt), kpt(3,ikpt), nband, ' ! kpt nband'
5669 0 : do iband = 1, nband
5670 : ! output in sec
5671 0 : write (iout, '(E20.10)') tau_k(itemp,isppol,ikpt,iband)
5672 : end do
5673 : end do
5674 : end do
5675 0 : close (iout)
5676 : end do
5677 :
5678 0 : end subroutine ebands_prtbltztrp_tau_out
5679 : !!***
5680 :
5681 : !----------------------------------------------------------------------
5682 :
5683 : !!****f* m_ebands/ebands_write
5684 : !! NAME
5685 : !! ebands_write
5686 : !!
5687 : !! FUNCTION
5688 : !! Driver routine to write bands in different (txt) formats.
5689 : !! This routine should be called by a single processor.
5690 : !!
5691 : !! INPUTS
5692 : !! prtebands=Flag selecting the output format:
5693 : !! 0 --> None
5694 : !! 1 --> xmgrace
5695 : !! 2 --> gnuplot (not coded yet)
5696 : !! 3 --> EIG format (not coded yet)
5697 : !! prefix=Prefix for output filename.
5698 : !! [kptbounds(:,:)]=Optional argument giving the extrema of the k-path.
5699 : !!
5700 : !! OUTPUT
5701 : !! Only writing.
5702 : !!
5703 : !! SOURCE
5704 :
5705 5506 : subroutine ebands_write(ebands, prtebands, prefix, kptbounds)
5706 :
5707 : !Arguments ------------------------------------
5708 : !scalars
5709 : class(ebands_t),intent(in) :: ebands
5710 : integer,intent(in) :: prtebands
5711 : character(len=*),intent(in) :: prefix
5712 : real(dp),optional,intent(in) :: kptbounds(:,:)
5713 : ! *********************************************************************
5714 :
5715 5506 : select case (prtebands)
5716 : case (0)
5717 4200 : return
5718 : case (1)
5719 : !call wrtout(std_out, sjoin(" Writing interpolated bands to:", path)
5720 4200 : if (present(kptbounds)) then
5721 130 : call ebands%write_xmgrace(strcat(prefix, "_EBANDS.agr"), kptbounds=kptbounds)
5722 : else
5723 4070 : call ebands%write_xmgrace(strcat(prefix, "_EBANDS.agr"))
5724 : end if
5725 : case (2)
5726 : !call wrtout(std_out, sjoin(" Writing interpolated bands to:", path)
5727 6 : if (present(kptbounds)) then
5728 4 : call ebands%write_gnuplot(prefix, kptbounds=kptbounds)
5729 : else
5730 2 : call ebands%write_gnuplot(prefix)
5731 : end if
5732 : case default
5733 5506 : ABI_WARNING(sjoin("Unsupported value for prtebands:", itoa(prtebands)))
5734 : end select
5735 :
5736 : end subroutine ebands_write
5737 : !!***
5738 :
5739 : !----------------------------------------------------------------------
5740 :
5741 : !!****f* m_ebands/ebands_write_xmgrace
5742 : !! NAME
5743 : !! ebands_write_xmgrace
5744 : !!
5745 : !! FUNCTION
5746 : !! Write bands in Xmgrace format. This routine should be called by a single processor.
5747 : !! Use the driver `ebands_write` to support different formats.
5748 : !!
5749 : !! INPUTS
5750 : !! filename=Filename
5751 : !! [kptbounds(:,:)]=Optional argument giving the extrema of the k-path.
5752 : !!
5753 : !! OUTPUT
5754 : !! Only writing
5755 : !!
5756 : !! SOURCE
5757 :
5758 4200 : subroutine ebands_write_xmgrace(ebands, filename, kptbounds)
5759 :
5760 : !Arguments ------------------------------------
5761 : !scalars
5762 : class(ebands_t),intent(in) :: ebands
5763 : character(len=*),intent(in) :: filename
5764 : real(dp),optional,intent(in) :: kptbounds(:,:)
5765 :
5766 : !Local variables-------------------------------
5767 : !scalars
5768 : integer :: unt,ik,spin,band,ii,start,nkbounds
5769 : character(len=500) :: msg
5770 : !arrays
5771 : integer :: g0(3)
5772 4200 : integer,allocatable :: bounds2kpt(:)
5773 : ! *********************************************************************
5774 :
5775 4200 : nkbounds = 0
5776 4200 : if (present(kptbounds)) then
5777 390 : if (product(shape(kptbounds)) > 0 ) then
5778 : ! Find correspondence between kptbounds and k-points in ebands.
5779 130 : nkbounds = size(kptbounds, dim=2)
5780 390 : ABI_MALLOC(bounds2kpt, (nkbounds))
5781 420 : bounds2kpt = 1; start = 1
5782 420 : do ii=1,nkbounds
5783 3231 : do ik=start,ebands%nkpt
5784 3101 : if (isamek(ebands%kptns(:, ik), kptbounds(:, ii), g0)) then
5785 239 : bounds2kpt(ii) = ik; start = ik + 1; exit
5786 : end if
5787 : end do
5788 : end do
5789 : end if
5790 : end if
5791 :
5792 4200 : if (open_file(filename, msg, newunit=unt, form="formatted", action="write") /= 0) then
5793 0 : ABI_ERROR(msg)
5794 : end if
5795 :
5796 4200 : write(unt,'(a)') "# Grace project file"
5797 4200 : write(unt,'(a)') "# Generated by Abinit"
5798 : write(unt,'(4(a,i0))') &
5799 4200 : "# mband: ",ebands%mband,", nkpt: ",ebands%nkpt,", nsppol: ",ebands%nsppol,", nspinor: ",ebands%nspinor
5800 : write(unt,'(a,f8.2,a,i0,2(a,f8.2))') &
5801 4200 : "# nelect: ",ebands%nelect,", occopt: ",ebands%occopt,", tsmear: ",ebands%tsmear,", tphysel: ",ebands%tphysel
5802 4200 : write(unt,'(a,f8.2,a)') "# Energies are in eV. Zero set to efermi, previously it was at: ",ebands%fermie * Ha_eV, " [eV]"
5803 4200 : write(unt,'(a)')"# List of k-points and their index (C notation i.e. count from 0)"
5804 47951 : do ik=1,ebands%nkpt
5805 47951 : write(unt, "(a)")sjoin("#", itoa(ik-1), ktoa(ebands%kptns(:,ik)))
5806 : end do
5807 4200 : write(unt,'(a)') "@page size 792, 612"
5808 4200 : write(unt,'(a)') "@page scroll 5%"
5809 4200 : write(unt,'(a)') "@page inout 5%"
5810 4200 : write(unt,'(a)') "@link page off"
5811 4200 : write(unt,'(a)') "@with g0"
5812 4200 : write(unt,'(a)') "@world xmin 0.00"
5813 4200 : write(unt,'(a,i0)') '@world xmax ',ebands%nkpt
5814 459988 : write(unt,'(a,es16.8)') '@world ymin ',minval((ebands%eig - ebands%fermie) * Ha_eV)
5815 459988 : write(unt,'(a,es16.8)') '@world ymax ',maxval((ebands%eig - ebands%fermie) * Ha_eV)
5816 4200 : write(unt,'(a)') '@default linewidth 1.5'
5817 4200 : write(unt,'(a)') '@xaxis tick on'
5818 4200 : write(unt,'(a)') '@xaxis tick major 1'
5819 4200 : write(unt,'(a)') '@xaxis tick major color 1'
5820 4200 : write(unt,'(a)') '@xaxis tick major linestyle 3'
5821 4200 : write(unt,'(a)') '@xaxis tick major grid on'
5822 4200 : write(unt,'(a)') '@xaxis tick spec type both'
5823 4200 : write(unt,'(a)') '@xaxis tick major 0, 0'
5824 4200 : if (nkbounds /= 0) then
5825 130 : write(unt,'(a,i0)') '@xaxis tick spec ',nkbounds
5826 420 : do ik=1,nkbounds
5827 : !write(unt,'(a,i0,a,a)') '@xaxis ticklabel ',ik-1,',', "foo"
5828 420 : write(unt,'(a,i0,a,i0)') '@xaxis tick major ',ik-1,' , ',bounds2kpt(ik) - 1
5829 : end do
5830 : end if
5831 4200 : write(unt,'(a)') '@xaxis ticklabel char size 1.500000'
5832 4200 : write(unt,'(a)') '@yaxis tick major 10'
5833 4200 : write(unt,'(a)') '@yaxis label "Band Energy [eV]"'
5834 4200 : write(unt,'(a)') '@yaxis label char size 1.500000'
5835 4200 : write(unt,'(a)') '@yaxis ticklabel char size 1.500000'
5836 4200 : ii = -1
5837 8907 : do spin=1,ebands%nsppol
5838 55132 : do band=1,ebands%mband
5839 46225 : ii = ii + 1
5840 50932 : write(unt,'(a,i0,a,i0)') '@ s',ii,' line color ',spin
5841 : end do
5842 : end do
5843 4200 : ii = -1
5844 8907 : do spin=1,ebands%nsppol
5845 55132 : do band=1,ebands%mband
5846 46225 : ii = ii + 1
5847 46225 : write(unt,'(a,i0)') '@target G0.S',ii
5848 46225 : write(unt,'(a)') '@type xy'
5849 451857 : do ik=1,ebands%nkpt
5850 451857 : write(unt,'(i0,1x,es16.8)') ik-1, (ebands%eig(band, ik, spin) - ebands%fermie) * Ha_eV
5851 : end do
5852 50932 : write(unt,'(a)') '&'
5853 : end do
5854 : end do
5855 :
5856 4200 : close(unt)
5857 :
5858 4200 : ABI_SFREE(bounds2kpt)
5859 :
5860 4200 : end subroutine ebands_write_xmgrace
5861 : !!***
5862 :
5863 : !----------------------------------------------------------------------
5864 :
5865 : !!****f* m_ebands/ebands_write_gnuplot
5866 : !! NAME
5867 : !! ebands_write_gnuplot
5868 : !!
5869 : !! FUNCTION
5870 : !! Write bands in gnuplot format. This routine should be called by a single processor.
5871 : !! Use the driver `ebands_write` to support different formats.
5872 : !!
5873 : !! INPUTS
5874 : !! prefix=prefix for files (.data, .gnuplot)
5875 : !! [kptbounds(:,:)]=Optional argument giving the extrema of the k-path.
5876 : !!
5877 : !! OUTPUT
5878 : !! Only writing
5879 : !!
5880 : !! SOURCE
5881 :
5882 6 : subroutine ebands_write_gnuplot(ebands, prefix, kptbounds)
5883 :
5884 : !Arguments ------------------------------------
5885 : !scalars
5886 : class(ebands_t),intent(in) :: ebands
5887 : character(len=*),intent(in) :: prefix
5888 : real(dp),optional,intent(in) :: kptbounds(:,:)
5889 :
5890 : !Local variables-------------------------------
5891 : !scalars
5892 : integer :: unt,gpl_unt,ik,spin,ii,start,nkbounds
5893 : character(len=500) :: msg,fmt
5894 : character(len=fnlen) :: datafile,basefile
5895 : !arrays
5896 : integer :: g0(3)
5897 6 : integer,allocatable :: bounds2kpt(:)
5898 : ! *********************************************************************
5899 :
5900 6 : nkbounds = 0
5901 6 : if (present(kptbounds)) then
5902 12 : if (product(shape(kptbounds)) > 0 ) then
5903 : ! Find correspondence between kptbounds and k-points in ebands.
5904 4 : nkbounds = size(kptbounds, dim=2)
5905 12 : ABI_MALLOC(bounds2kpt, (nkbounds))
5906 51 : bounds2kpt = 1; start = 1
5907 51 : do ii=1,nkbounds
5908 1504 : do ik=start,ebands%nkpt
5909 1500 : if (isamek(ebands%kptns(:, ik), kptbounds(:, ii), g0)) then
5910 36 : bounds2kpt(ii) = ik; start = ik + 1; exit
5911 : end if
5912 : end do
5913 : end do
5914 : end if
5915 : end if
5916 :
5917 6 : datafile = strcat(prefix, "_EBANDS.data")
5918 6 : if (open_file(datafile, msg, newunit=unt, form="formatted", action="write") /= 0) then
5919 0 : ABI_ERROR(msg)
5920 : end if
5921 6 : if (open_file(strcat(prefix, "_EBANDS.gnuplot"), msg, newunit=gpl_unt, form="formatted", action="write") /= 0) then
5922 6 : ABI_ERROR(msg)
5923 : end if
5924 6 : basefile = basename(datafile)
5925 :
5926 6 : write(unt,'(a)') "# Electron band structure data file"
5927 6 : write(unt,'(a)') "# Generated by Abinit"
5928 : write(unt,'(4(a,i0))') &
5929 6 : "# mband: ",ebands%mband,", nkpt: ",ebands%nkpt,", nsppol: ",ebands%nsppol,", nspinor: ",ebands%nspinor
5930 : write(unt,'(a,f8.2,a,i0,2(a,f8.2))') &
5931 6 : "# nelect: ",ebands%nelect,", occopt: ",ebands%occopt,", tsmear: ",ebands%tsmear,", tphysel: ",ebands%tphysel
5932 6 : write(unt,'(a,f8.2,a)') "# Energies are in eV. Zero set to efermi, Previously it was at: ",ebands%fermie * Ha_eV, " [eV]"
5933 6 : write(unt,'(a)')"# List of k-points and their index (C notation i.e. count from 0)"
5934 1267 : do ik=1,ebands%nkpt
5935 1267 : write(unt, "(a)")sjoin("#", itoa(ik-1), ktoa(ebands%kptns(:,ik)))
5936 : end do
5937 :
5938 6 : fmt = sjoin("(i0,1x,", itoa(ebands%mband), "(es16.8,1x))")
5939 6 : write(unt,'(a)') ' '
5940 12 : do spin=1,ebands%nsppol
5941 6 : write(unt,'(a,i0)') '# [kpt-index, band_1, band_2 ...] for spin: ',spin
5942 1267 : do ik=1,ebands%nkpt
5943 13647 : write(unt,fmt) ik-1, (ebands%eig(:, ik, spin) - ebands%fermie) * Ha_eV
5944 : end do
5945 12 : write(unt,'(a)') ' '
5946 : end do
5947 :
5948 : ! gnuplot script file
5949 6 : write(gpl_unt,'(a)') '# File to plot phonon bandstructure with gnuplot'
5950 6 : write(gpl_unt,'(a)') "#set terminal postscript eps enhanced color font 'Times-Roman,26' lw 2"
5951 6 : write(gpl_unt,'(a)') '#use the next lines to make a nice figure for a paper'
5952 6 : write(gpl_unt,'(a)') '#set term postscript enhanced eps color lw 0.5 dl 0.5'
5953 6 : write(gpl_unt,'(a)') '#set pointsize 0.275'
5954 6 : write(gpl_unt,'(a)') 'set palette defined ( 0 "blue", 3 "green", 6 "yellow", 10 "red" )'
5955 6 : write(gpl_unt,'(a)') 'unset key'
5956 6 : write(gpl_unt,'(a)') '# can make pointsize smaller (~0.5). Too small and nothing is printed'
5957 6 : write(gpl_unt,'(a)') 'set pointsize 0.8'
5958 6 : write(gpl_unt,'(a)') 'set view 0,0'
5959 6 : write(gpl_unt,'(a,i0,a)') 'set xrange [0:',ebands%nkpt-1,']'
5960 : write(gpl_unt,'(2(a,es16.8),a)')&
5961 27300 : 'set yrange [',minval((ebands%eig - ebands%fermie) * Ha_eV),':',maxval((ebands%eig - ebands%fermie) * Ha_eV),']'
5962 6 : write(gpl_unt,'(a)') 'set xlabel "Momentum"'
5963 6 : write(gpl_unt,'(a)') 'set ylabel "Energy [eV]"'
5964 6 : write(gpl_unt,'(a)') strcat('set title "', replace(basefile, "_", "\\_"), '"')
5965 6 : if (nkbounds == 0) then
5966 2 : write(gpl_unt,'(a)') 'set grid xtics'
5967 : else
5968 4 : write(gpl_unt,"(a)")"# Add vertical lines in correspondence of high-symmetry points."
5969 4 : write(gpl_unt,'(a)') 'unset xtics'
5970 51 : do ii=1,nkbounds
5971 : write(gpl_unt,"(a,2(i0,a))") &
5972 51 : "set arrow from ",bounds2kpt(ii)-1,",graph(0,0) to ",bounds2kpt(ii)-1,",graph(1,1) nohead ls 'dashed'"
5973 : !write(gpl_unt,"(a)")sjoin("set xtics add('kname'", itoa(bounds2kpt(ii)-1), ")")
5974 : end do
5975 :
5976 : end if
5977 6 : write(gpl_unt,"(a)")sjoin("mband =", itoa(ebands%mband))
5978 6 : write(gpl_unt,"(a)")strcat('plot for [i=2:mband] "', basefile, '" u 1:i every :1 with lines linetype -1')
5979 6 : if (ebands%nsppol == 2) then
5980 0 : write(gpl_unt,"(a)")strcat('replot for [i=2:mband] "', basefile, '" u 1:i every :2 with lines linetype 4')
5981 : end if
5982 6 : write(gpl_unt, "(a)")"pause -1"
5983 :
5984 6 : close(unt)
5985 6 : close(gpl_unt)
5986 :
5987 6 : ABI_SFREE(bounds2kpt)
5988 :
5989 6 : end subroutine ebands_write_gnuplot
5990 : !!***
5991 :
5992 : !----------------------------------------------------------------------
5993 :
5994 : !!****f* m_ebands/ebands_interpolate_kpath
5995 : !!
5996 : !! NAME
5997 : !! ebands_interpolate_kpath
5998 : !!
5999 : !! FUNCTION
6000 : !!
6001 : !! INPUTS
6002 : !! dtset<dataset_type>=Abinit dataset
6003 : !! band_range(2)=Initial and final band index to be interpolated. [0,0] if all bands are used.
6004 : !! This is a global variable i.e. all MPI procs must call the routine with the same value.
6005 : !!
6006 : !! OUTPUT
6007 : !!
6008 : !! SOURCE
6009 :
6010 2 : subroutine ebands_interpolate_kpath(ebands, dtset, cryst, band_range, prefix, comm)
6011 :
6012 : !Arguments ------------------------------------
6013 : !scalars
6014 : class(ebands_t),intent(in) :: ebands
6015 : type(dataset_type),intent(in) :: dtset
6016 : type(crystal_t),intent(in) :: cryst
6017 : integer,intent(in) :: comm
6018 : character(len=*),intent(in) :: prefix
6019 : !arrays
6020 : integer,intent(in) :: band_range(2)
6021 :
6022 : !Local variables-------------------------------
6023 : !scalars
6024 : integer,parameter :: master = 0, intp_nshiftk1 = 1
6025 : integer :: my_rank, ndivsm, nbounds, itype !, spin, ik, ib, ii, jj, ierr
6026 2 : type(ebands_t) :: ebands_kpath
6027 2 : type(kpath_t) :: kpath
6028 : character(len=500) :: tag !msg
6029 : !arrays
6030 2 : real(dp),allocatable :: bounds(:,:)
6031 : ! *********************************************************************
6032 :
6033 2 : my_rank = xmpi_comm_rank(comm)
6034 :
6035 : itype = nint(dtset%einterp(1)); tag = "_SKW"
6036 2 : tag = "_INTERP"
6037 :
6038 : ! Generate k-path
6039 2 : ndivsm = dtset%ndivsm
6040 2 : if (ndivsm <= 0) then
6041 0 : ABI_COMMENT("Setting ndivsm to 20 because variable is not given in input file")
6042 0 : ndivsm = 20
6043 : end if
6044 2 : nbounds = dtset%nkpath
6045 2 : if (nbounds <= 0) then
6046 0 : ABI_COMMENT("Using hard-coded k-path because nkpath not present in input file.")
6047 0 : nbounds = 5
6048 0 : ABI_MALLOC(bounds, (3, 5))
6049 0 : bounds = reshape([zero, zero, zero, half, zero, zero, zero, half, zero, zero, zero, zero, zero, zero, half], [3,5])
6050 : else
6051 2 : call alloc_copy(dtset%kptbounds, bounds)
6052 : end if
6053 :
6054 2 : call kpath%init(bounds, cryst%gprimd, ndivsm)
6055 4 : call kpath%print([std_out], header="Interpolating energies on k-path")
6056 2 : ABI_FREE(bounds)
6057 :
6058 : ! Interpolate bands on k-path.
6059 2 : ebands_kpath = ebands_interp_kpath(ebands, cryst, kpath, dtset%einterp, band_range, comm)
6060 :
6061 2 : if (my_rank == master) then
6062 2 : call wrtout(ab_out, sjoin("- Writing interpolated bands to file:", strcat(prefix, tag)))
6063 2 : call ebands_kpath%write(dtset%prtebands, strcat(prefix, tag), kptbounds=kpath%bounds)
6064 : end if
6065 :
6066 2 : call ebands_kpath%free()
6067 2 : call kpath%free()
6068 :
6069 2 : end subroutine ebands_interpolate_kpath
6070 : !!***
6071 :
6072 : !----------------------------------------------------------------------
6073 :
6074 : !!****f* m_ebands/klinterp_new
6075 : !! NAME
6076 : !! klinterp_new
6077 : !!
6078 : !! FUNCTION
6079 : !!
6080 : !! INPUTS
6081 : !!
6082 : !! OUTPUT
6083 : !!
6084 : !! SOURCE
6085 :
6086 0 : type(klinterp_t) function klinterp_new(cryst, kptrlatt, nshiftk, shiftk, kptopt, kibz, &
6087 0 : bsize, nkibz, nsppol, ndat, values_bksd, comm) result(new)
6088 :
6089 : !Arguments ------------------------------------
6090 : !scalars
6091 : type(crystal_t),intent(in) :: cryst
6092 : integer,intent(in) :: nshiftk, kptopt, bsize, nkibz, nsppol, ndat, comm
6093 : !arrays
6094 : integer,intent(in) :: kptrlatt(3,3)
6095 : real(dp),intent(in) :: kibz(3, nkibz), shiftk(3,nshiftk), values_bksd(bsize, nkibz, nsppol, ndat)
6096 :
6097 : !Local variables-------------------------------
6098 : !scalars
6099 : integer,parameter :: sppoldbl1 = 1
6100 : integer :: ierr, nkfull, ikf, ik_ibz, timrev, ix, iy, iz, nkx, nky, nkz !spin, band, idat
6101 : real(dp) :: dksqmax
6102 : character(len=500) :: msg
6103 : !arrays
6104 0 : integer,allocatable :: bz2ibz(:,:)
6105 : real(dp) :: kpt(3)
6106 0 : real(dp),allocatable :: kfull(:,:)
6107 : ! *********************************************************************
6108 :
6109 : ! Check input parameters
6110 0 : ierr = 0
6111 0 : if (nkibz == 1) then
6112 0 : ABI_ERROR_NOSTOP("Cannot interpolate with a single k-point", ierr)
6113 : end if
6114 0 : if (.not. isdiagmat(kptrlatt)) then
6115 0 : ABI_ERROR_NOSTOP('kptrlatt is not diagonal. Multiple shifts are not allowed', ierr)
6116 : end if
6117 0 : if (nshiftk /= 1) then
6118 0 : ABI_ERROR_NOSTOP('Multiple shifts not allowed', ierr)
6119 : end if
6120 0 : if (any(abs(shiftk(:, 1)) > tol8)) then
6121 0 : ABI_ERROR_NOSTOP("shifted k-mesh not implemented", ierr)
6122 : end if
6123 :
6124 0 : if (ierr /= 0) then
6125 0 : ABI_ERROR("Linear interpolation cannot be performed. See messages above.")
6126 : end if
6127 :
6128 0 : nkx = kptrlatt(1, 1)
6129 0 : nky = kptrlatt(2, 2)
6130 0 : nkz = kptrlatt(3, 3)
6131 :
6132 0 : new%nkx = nkx; new%nky = nky; new%nkz = nkz
6133 0 : new%bsize = bsize; new%nsppol = nsppol; new%ndat = ndat
6134 :
6135 : ! Build list of k-points in the conventional unit cell.
6136 : ! (x,y,z) ordered as required by interpolation routine
6137 0 : nkfull = nkx * nky * nkz
6138 0 : ABI_MALLOC(kfull, (3, nkfull))
6139 0 : ikf = 0
6140 0 : do iz=1,nkz
6141 0 : kpt(3) = (iz - 1 + shiftk(3, 1)) / nkz
6142 0 : do iy=1,nky
6143 0 : kpt(2) = (iy - 1 + shiftk(2, 1)) / nky
6144 0 : do ix=1,nkx
6145 0 : kpt(1) = (ix - 1 + shiftk(1, 1)) / nkx
6146 0 : ikf = ikf + 1
6147 0 : kfull(:, ikf) = kpt
6148 : end do
6149 : end do
6150 : end do
6151 :
6152 : ! Build mapping kfull --> IBZ
6153 0 : timrev = kpts_timrev_from_kptopt(kptopt)
6154 0 : ABI_MALLOC(bz2ibz, (nkfull*sppoldbl1, 6))
6155 :
6156 : call listkk(dksqmax, cryst%gmet, bz2ibz, kibz, kfull, nkibz, nkfull, cryst%nsym,&
6157 0 : sppoldbl1, cryst%symafm, cryst%symrec, timrev, comm, use_symrec=.True.)
6158 :
6159 0 : ABI_FREE(kfull)
6160 :
6161 0 : if (dksqmax > tol12) then
6162 : write(msg, '(3a,es16.6,4a)' )&
6163 0 : 'At least one of the k points could not be generated from a symmetrical one.',ch10,&
6164 0 : 'dksqmax: ',dksqmax,ch10,&
6165 0 : 'Action: check k-point input variables',ch10,&
6166 0 : ' e.g. kptopt or shiftk might be wrong in the present dataset or the preparatory one.'
6167 0 : ABI_ERROR(msg)
6168 : end if
6169 :
6170 0 : ABI_CALLOC(new%data_uk_bsd, (nkx, nky, nkz, bsize, nsppol, ndat))
6171 :
6172 : ! Build array in the full BZ to prepare call to interpol3d_0d.
6173 : ikf = 0
6174 0 : do iz=1,nkz
6175 0 : do iy=1,nky
6176 0 : do ix=1,nkx
6177 0 : ikf = ikf + 1
6178 0 : ik_ibz = bz2ibz(ikf, 1)
6179 0 : new%data_uk_bsd(ix, iy, iz, 1:bsize, 1:nsppol, 1:ndat) = values_bksd(1:bsize, ik_ibz, 1:nsppol, 1:ndat)
6180 : end do
6181 : end do
6182 : end do
6183 :
6184 0 : ABI_FREE(bz2ibz)
6185 :
6186 0 : end function klinterp_new
6187 : !!***
6188 :
6189 : !----------------------------------------------------------------------
6190 :
6191 : !!****f* m_ebands/klinterp_free
6192 : !! NAME
6193 : !! klinterp_free
6194 : !!
6195 : !! FUNCTION
6196 : !! Free dynamic memory.
6197 : !!
6198 : !! INPUTS
6199 : !!
6200 : !! OUTPUT
6201 : !!
6202 : !! SOURCE
6203 :
6204 0 : subroutine klinterp_free(self)
6205 :
6206 : !Arguments ------------------------------------
6207 : class(klinterp_t),intent(inout) :: self
6208 : ! *********************************************************************
6209 :
6210 0 : ABI_SFREE(self%data_uk_bsd)
6211 :
6212 0 : end subroutine klinterp_free
6213 : !!***
6214 :
6215 : !----------------------------------------------------------------------
6216 :
6217 : !!****f* m_ebands/klinterp_eval_bsd
6218 : !! NAME
6219 : !! klinterp_eval_bsd
6220 : !!
6221 : !! FUNCTION
6222 : !!
6223 : !! INPUTS
6224 : !!
6225 : !! OUTPUT
6226 : !!
6227 : !! SOURCE
6228 :
6229 0 : subroutine klinterp_eval_bsd(self, kpt, vals_bsd)
6230 :
6231 : !Arguments ------------------------------------
6232 : !scalars
6233 : class(klinterp_t),intent(in) :: self
6234 : real(dp),intent(in) :: kpt(3)
6235 : real(dp),intent(out) :: vals_bsd(self%bsize, self%nsppol, self%ndat)
6236 :
6237 : !Local variables-------------------------------
6238 : integer :: spin, idat, band
6239 : !integer :: ir1, ir2, ir3, pr1, pr2, pr3
6240 : real(dp) :: val !, vv(8)
6241 : real(dp) :: kwrap(3), shift(3)
6242 : ! *********************************************************************
6243 :
6244 0 : call wrap2_zero_one(kpt, kwrap, shift)
6245 : !write(std_out, *)"kwrap:", kwrap
6246 :
6247 : ! ir1,ir2,ir3 = bottom left neighbor
6248 : ! pr1,pr2,pr3 = top right neighbor
6249 : !call interpol3d_indices(kwrap, self%nkx, self%nky, self%nkz, ir1, ir2, ir3, pr1, pr2, pr3)
6250 :
6251 0 : do idat=1,self%ndat
6252 0 : do spin=1,self%nsppol
6253 0 : do band=1,self%bsize
6254 0 : val = interpol3d_0d(kwrap, self%nkx, self%nky, self%nkz, self%data_uk_bsd(:,:,:,band, spin, idat))
6255 :
6256 : !if (val <= zero) then
6257 : ! vv(1) = self%data_uk_bsd(ir1, ir2, ir3, band, spin, idat)
6258 : ! vv(2) = self%data_uk_bsd(pr1, ir2, ir3, band, spin, idat)
6259 : ! vv(3) = self%data_uk_bsd(ir1, pr2, ir3, band, spin, idat)
6260 : ! vv(4) = self%data_uk_bsd(ir1, ir2, pr3, band, spin, idat)
6261 : ! vv(5) = self%data_uk_bsd(pr1, pr2, ir3, band, spin, idat)
6262 : ! vv(6) = self%data_uk_bsd(ir1, pr2, pr3, band, spin, idat)
6263 : ! vv(7) = self%data_uk_bsd(pr1, ir2, pr3, band, spin, idat)
6264 : ! vv(8) = self%data_uk_bsd(pr1, pr2, pr3, band, spin, idat)
6265 : ! val = maxval(vv)
6266 : !end if
6267 :
6268 0 : vals_bsd(band, spin, idat) = val
6269 : end do
6270 : end do
6271 : end do
6272 :
6273 0 : end subroutine klinterp_eval_bsd
6274 : !!***
6275 :
6276 : !!****f* m_ebands/ebands_get_carriers
6277 : !! NAME
6278 : !! ebands_get_carriers
6279 : !!
6280 : !! FUNCTION
6281 : !! Compute number of electrons (e) and holes (h) per unit cell from a given list of `ntemp`
6282 : !! temperatures `kTmesh` and chemical potentials `mu_e`.
6283 : !! Return n_ehst(2, nsppol, ntemp) where the first dimension if for electrons/holes.
6284 : !! If nsppol == 2, the second dimension is the number of e/h for spin else the total number of e/h summed over spins.
6285 : !! To discern between electrons and holes in semiconductors we assume that ef is inside the gap.
6286 : !!
6287 : !! SOURCE
6288 :
6289 15 : subroutine ebands_get_carriers(self, ntemp, kTmesh, mu_e, n_ehst)
6290 :
6291 : !Arguments ------------------------------------
6292 : !scalars
6293 : class(ebands_t),intent(in) :: self
6294 : integer,intent(in) :: ntemp
6295 : !arrays
6296 : real(dp),intent(in) :: kTmesh(ntemp), mu_e(ntemp)
6297 : real(dp),intent(out) :: n_ehst(2, self%nsppol, ntemp)
6298 :
6299 : !Local variables-------------------------------
6300 : integer :: spin, ik_ibz, ib, itemp
6301 : real(dp) :: max_occ, wtk, eig_nk
6302 : !*********************************************************************
6303 :
6304 15 : max_occ = two / (self%nspinor * self%nsppol)
6305 271 : n_ehst = zero
6306 :
6307 30 : do spin=1,self%nsppol
6308 3602 : do ik_ibz=1,self%nkpt
6309 3572 : wtk = self%wtk(ik_ibz)
6310 20875 : do ib=1, self%nband(ik_ibz + (spin-1) * self%nkpt)
6311 17288 : eig_nk = self%eig(ib, ik_ibz, spin)
6312 :
6313 122868 : do itemp=1,ntemp
6314 119296 : if (eig_nk >= mu_e(itemp)) then
6315 : ! electron (assuming ef inside the gap if semiconductor)
6316 : n_ehst(1, spin, itemp) = n_ehst(1, spin, itemp) + &
6317 20486 : wtk * occ_fd(eig_nk, kTmesh(itemp), mu_e(itemp)) * max_occ
6318 : else
6319 : ! holes
6320 : n_ehst(2, spin, itemp) = n_ehst(2, spin, itemp) + &
6321 81522 : wtk * (one - occ_fd(eig_nk, kTmesh(itemp), mu_e(itemp))) * max_occ
6322 : end if
6323 : end do
6324 :
6325 : end do
6326 : end do
6327 : end do
6328 :
6329 15 : end subroutine ebands_get_carriers
6330 : !!***
6331 :
6332 0 : end module m_ebands
6333 : !!***
|
