TABLE OF CONTENTS
- ABINIT/m_sigmaph
- m_sigmaph/qpoints_oracle
- m_sigmaph/sigmaph
- m_sigmaph/sigmaph_compare
- m_sigmaph/sigmaph_free
- m_sigmaph/sigmaph_gather_and_write
- m_sigmaph/sigmaph_get_all_qweights
- m_sigmaph/sigmaph_get_ebands
- m_sigmaph/sigmaph_new
- m_sigmaph/sigmaph_print
- m_sigmaph/sigmaph_read
- m_sigmaph/sigmaph_setup_kcalc
- m_sigmaph/sigmaph_setup_qloop
- m_sigmaph/sigmaph_skip_phmode
- m_sigmaph/sigmaph_t
- m_sigmaph/sigmaph_write
ABINIT/m_sigmaph [ Modules ]
NAME
m_sigmaph
FUNCTION
Compute the matrix elements of the Fan-Migdal Debye-Waller self-energy in the KS basis set.
COPYRIGHT
Copyright (C) 2008-2024 ABINIT group (MG, HM) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt .
SOURCE
16 #if defined HAVE_CONFIG_H 17 #include "config.h" 18 #endif 19 20 #include "abi_common.h" 21 22 module m_sigmaph 23 24 use defs_basis 25 use, intrinsic :: iso_c_binding 26 use m_abicore 27 #ifdef HAVE_MPI2 28 use mpi 29 #endif 30 use m_xmpi 31 use m_mpinfo 32 use m_errors 33 use m_hide_blas 34 use m_copy 35 use m_ifc 36 use m_ebands 37 use m_wfk 38 use m_ddb 39 use m_ddk 40 use m_dvdb 41 use m_fft 42 use m_hamiltonian 43 use m_pawcprj 44 use m_wfd 45 use m_skw 46 use m_krank 47 use m_lgroup 48 use m_ephwg 49 use m_sort 50 use m_hdr 51 use m_sigtk 52 use m_ephtk 53 use m_eph_double_grid 54 use netcdf 55 use m_nctk 56 use m_rf2 57 use m_dtset 58 use m_dtfil 59 use m_clib 60 use m_mkffnl 61 62 use defs_abitypes, only : mpi_type 63 use defs_datatypes, only : ebands_t, pseudopotential_type 64 use m_time, only : cwtime, cwtime_report, timab, sec2str 65 use m_fstrings, only : itoa, ftoa, sjoin, ktoa, ltoa, strcat 66 use m_numeric_tools, only : arth, c2r, get_diag, linfit, iseven, simpson_cplx, simpson, print_arr, inrange 67 use m_io_tools, only : iomode_from_fname, file_exists, is_open, open_file, flush_unit 68 use m_special_funcs, only : gaussian 69 use m_fftcore, only : ngfft_seq, sphereboundary, get_kg, kgindex 70 use m_cgtk, only : cgtk_rotate, cgtk_change_gsphere 71 use m_cgtools, only : cg_zdotc, cg_real_zdotc, cg_zgemm, fxphas_seq 72 use m_crystal, only : crystal_t 73 use m_kpts, only : kpts_ibz_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map 74 use m_occ, only : occ_fd, occ_be !occ_dfde, 75 use m_kg, only : getph, mkkpg 76 use m_bz_mesh, only : isamek 77 use m_getgh1c, only : getgh1c, rf_transgrid_and_pack, getgh1c_setup 78 use m_ioarr, only : read_rhor 79 use m_paw_sphharm, only : ylm_angular_mesh 80 use m_pawang, only : pawang_type 81 use m_pawrad, only : pawrad_type 82 use m_pawtab, only : pawtab_type 83 use m_pawrhoij, only : pawrhoij_type 84 use m_pawfgr, only : pawfgr_type 85 use m_dfpt_cgwf, only : dfpt_cgwf 86 use m_phonons, only : phstore_t, phstore_new 87 88 implicit none 89 90 private
m_sigmaph/qpoints_oracle [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
qpoints_oracle
FUNCTION
This function tries to predict the **full** list of q-points in the BZ needed to compute the lifetimes once we know sigma%nkcalc. It uses an energy window computed from the max phonon frequency multiplied by sigma%phwinfact. INPUT cryst=Crystalline structure ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) qpts(3, nqpt)= nqpt= Number of points in qpts nqbz=Number of q-points in BZ. qbz(3, nbz) = full BZ comm=MPI communicator.
OUTPUT
qselect(nqpt)
SOURCE
5602 subroutine qpoints_oracle(sigma, dtset, cryst, ebands, qpts, nqpt, nqbz, qbz, qselect, comm) 5603 5604 !Arguments ------------------------------------ 5605 !scalars 5606 class(sigmaph_t),intent(in) :: sigma 5607 type(dataset_type),intent(in) :: dtset 5608 type(crystal_t),intent(in) :: cryst 5609 type(ebands_t),intent(in) :: ebands 5610 integer,intent(in) :: nqpt, nqbz, comm 5611 !arrays 5612 real(dp),intent(in) :: qpts(3,nqpt), qbz(3,nqbz) 5613 integer,intent(out) :: qselect(nqpt) 5614 5615 !Local variables ------------------------------ 5616 !scalars 5617 integer,parameter :: master = 0 5618 integer :: spin, ikcalc, ik_ibz, iq_bz, ierr, db_iqpt, ibsum_kq, ikq_ibz, ikq_bz 5619 integer :: cnt, my_rank, nprocs, ib_k, band_ks, nkibz, nkbz, kq_rank, qptopt, qtimrev 5620 real(dp) :: eig0nk, eig0mkq, ediff, cpu, wall, gflops 5621 character(len=5000) :: msg 5622 type(krank_t) :: krank, qrank 5623 !arrays 5624 integer :: g0(3), qptrlatt(3,3) 5625 integer,allocatable :: qbz_count(:), qbz2qpt(:,:), bz2ibz(:,:) 5626 real(dp) :: kq(3), kk(3) 5627 real(dp),allocatable :: wtk(:), kibz(:,:), kbz(:,:) 5628 5629 ! ************************************************************************* 5630 5631 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 5632 5633 call cwtime(cpu, wall, gflops, "start") 5634 call wrtout(std_out, & 5635 sjoin(" qpoints_oracle: predicting number q-points for tau with eph_phwinfact:", ftoa(sigma%phwinfact))) 5636 5637 ! Get full BZ associated to ebands 5638 call kpts_ibz_from_kptrlatt(cryst, ebands%kptrlatt, ebands%kptopt, ebands%nshiftk, ebands%shiftk, & 5639 nkibz, kibz, wtk, nkbz, kbz, bz2ibz=bz2ibz) 5640 call cwtime_report(" kpts_ibz_from_kptrlatt", cpu, wall, gflops) 5641 5642 ABI_FREE(wtk) 5643 ABI_FREE(kibz) 5644 ABI_CHECK(nkibz == ebands%nkpt, "nkibz != ebands%nkpt") 5645 5646 ! Make full k-point rank arrays 5647 krank = krank_new(nkbz, kbz) 5648 call cwtime_report(" krank_new", cpu, wall, gflops) 5649 5650 ! This loop is Expensive with a 288^3 5651 ! qbz_count_loop completed. cpu: 03:16 [minutes] , wall: 03:16 [minutes] <<< TIME 5652 ! qbz_count completed. cpu: 04:41 [minutes] , wall: 04:40 [minutes] <<< TIME 5653 ABI_ICALLOC(qbz_count, (nqbz)) 5654 cnt = 0 5655 do spin=1,sigma%nsppol 5656 do ikcalc=1,sigma%nkcalc 5657 cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism inside comm 5658 kk = sigma%kcalc(:, ikcalc) 5659 ik_ibz = sigma%kcalc2ibz(ikcalc, 1) 5660 do iq_bz=1,nqbz 5661 if (qbz_count(iq_bz) /= 0) cycle ! No need to check this q-point again. 5662 kq = kk + qbz(:, iq_bz) 5663 kq_rank = krank%get_rank(kq) 5664 ikq_bz = krank%invrank(kq_rank) 5665 ABI_CHECK(ikq_bz > 0, sjoin("Cannot find kq: ", ktoa(kq))) 5666 ABI_CHECK(isamek(kq, kbz(:, ikq_bz), g0), "Wrong invrank") 5667 !ikq_ibz = bz2ibz(ikq_bz,1) 5668 ikq_ibz = bz2ibz(1, ikq_bz) 5669 do ib_k=1,sigma%nbcalc_ks(ikcalc, spin) 5670 band_ks = ib_k + sigma%bstart_ks(ikcalc, spin) - 1 5671 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 5672 do ibsum_kq=sigma%bsum_start, sigma%bsum_stop 5673 eig0mkq = ebands%eig(ibsum_kq, ikq_ibz, spin) 5674 ediff = eig0nk - eig0mkq 5675 ! Perform check on the energy difference to exclude this q-point. 5676 if (abs(ediff) <= sigma%phwinfact * sigma%wmax) qbz_count(iq_bz) = qbz_count(iq_bz) + 1 5677 end do 5678 end do 5679 end do 5680 end do 5681 end do 5682 call cwtime_report(" qbz_count_loop", cpu, wall, gflops) 5683 5684 ABI_FREE(kbz) 5685 ABI_FREE(bz2ibz) 5686 call krank%free() 5687 5688 call xmpi_sum(qbz_count, comm, ierr) 5689 call cwtime_report(" qbz_count", cpu, wall, gflops) 5690 5691 ! Get mapping QBZ --> List of q-points involved in e-ph scattering for e/h in pockets. 5692 ! Assume qptopt == kptopt unless value is specified in input 5693 ABI_MALLOC(qbz2qpt, (6, nqbz)) 5694 5695 qptrlatt = 0; qptrlatt(1,1) = sigma%ngqpt(1); qptrlatt(2,2) = sigma%ngqpt(2); qptrlatt(3,3) = sigma%ngqpt(3) 5696 qrank = krank_from_kptrlatt(nqpt, qpts, qptrlatt, compute_invrank=.False.) 5697 qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 5698 qtimrev = kpts_timrev_from_kptopt(qptopt) 5699 5700 if (kpts_map("symrec", qtimrev, cryst, qrank, nqbz, qbz, qbz2qpt) /= 0) then 5701 write(msg, '(3a)' )& 5702 "At least one of the q-points could not be generated from a symmetrical one in the DVDB.", ch10, & 5703 "Action: check your DVDB file and use eph_task to interpolate the potentials on a denser q-mesh." 5704 ABI_ERROR(msg) 5705 end if 5706 call qrank%free() 5707 5708 call cwtime_report(" oracle_listkk_qbz_qpts", cpu, wall, gflops) 5709 5710 ! Compute qselect using qbz2qpt. 5711 qselect = 0 5712 do iq_bz=1,nqbz 5713 if (qbz_count(iq_bz) == 0) cycle 5714 db_iqpt = qbz2qpt(1, iq_bz) 5715 qselect(db_iqpt) = qselect(db_iqpt) + 1 5716 end do 5717 5718 ABI_FREE(qbz_count) 5719 ABI_FREE(qbz2qpt) 5720 5721 if (my_rank == master) then 5722 cnt = count(qselect /= 0) 5723 write(std_out, "(a, i0, a, f5.1, a)")" qpoints_oracle: calculation of tau_nk will need: ", cnt, & 5724 " q-points in the IBZ. (nqibz_eff / nqibz): ", (100.0_dp * cnt) / sigma%nqibz, " [%]" 5725 end if 5726 5727 end subroutine qpoints_oracle
m_sigmaph/sigmaph [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph
FUNCTION
Compute phonon-contribution to the electron self-energy.
INPUTS
wfk0_path=String with the path to the GS unperturbed WFK file. ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes. dtset<dataset_type>=All input variables for this dataset. ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) dvdb<dbdb_type>=Database with the DFPT SCF potentials. ifc<ifc_type>=interatomic force constants and corresponding real space grid info. wfk_hdr=Header of the WFK file. pawfgr <type(pawfgr_type)>=fine grid parameters and related data pawang<pawang_type)>=PAW angular mesh and related data. pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data. pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data. psps<pseudopotential_type>=Variables related to pseudopotentials. comm=MPI communicator.
OUTPUT
SOURCE
627 subroutine sigmaph(wfk0_path, dtfil, ngfft, ngfftf, dtset, cryst, ebands, dvdb, ifc, wfk_hdr, & 628 pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm) 629 630 !Arguments ------------------------------------ 631 !scalars 632 character(len=*),intent(in) :: wfk0_path 633 integer,intent(in) :: comm 634 type(datafiles_type),intent(in) :: dtfil 635 type(dataset_type),intent(in) :: dtset 636 type(crystal_t),intent(in) :: cryst 637 type(ebands_t),intent(in) :: ebands 638 type(dvdb_t),intent(inout) :: dvdb 639 type(pawang_type),intent(in) :: pawang 640 type(pseudopotential_type),intent(in) :: psps 641 type(pawfgr_type),intent(in) :: pawfgr 642 type(ifc_type),intent(in) :: ifc 643 type(hdr_type),intent(in) :: wfk_hdr 644 type(mpi_type),intent(inout) :: mpi_enreg 645 !arrays 646 integer,intent(in) :: ngfft(18),ngfftf(18) 647 type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw) 648 type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw) 649 650 !Local variables ------------------------------ 651 !scalars 652 integer,parameter :: tim_getgh1c1 = 1, berryopt0 = 0, istw1 = 1, ider0 = 0, idir0 = 0, istwfk1 = 1 653 integer,parameter :: useylmgr = 0, useylmgr1 =0, master = 0, ndat1 = 1 654 integer,parameter :: igscq0 = 0, icgq0 = 0, usedcwavef0 = 0, nbdbuf0 = 0, quit0 = 0, cplex1 = 1, pawread0 = 0 655 integer :: band_me, nband_me 656 integer :: my_rank,nsppol,nkpt,iq_ibz,iq_ibz_k,my_npert ! iq_ibz_frohl,iq_bz_frohl, 657 integer :: cplex,db_iqpt,natom,natom3,ipc,nspinor,nprocs, qptopt ! = 1 658 integer :: ibsum_kq, ib_k, u1c_ib_k, band_ks, u1_band, ibsum, ii, jj, iw !ib_kq, 659 !integer :: u1_master, ip 660 integer :: mcgq, mgscq, ig, ispinor, ifft !nband_kq, 661 integer :: idir,ipert,ip1,ip2,idir1,ipert1,idir2,ipert2 662 integer :: ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, isym_q, trev_q 663 integer :: iq_ibz_fine,ikq_ibz_fine,ikq_bz_fine 664 integer :: my_spin, spin, istwf_k, istwf_kq, istwf_kqirr, npw_k, npw_kq, npw_kqirr 665 integer :: mpw,ierr,it,imyq,band, ignore_kq, ignore_ibsum_kq 666 integer :: n1,n2,n3,n4,n5,n6,nspden,nu, iang 667 integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1 668 integer :: nfft,nfftf,mgfft,mgfftf,nkpg,nkpg1,nq,cnt,imyp, q_start, q_stop, restart 669 integer :: tot_nlines_done, nlines_done, nline_in, grad_berry_size_mpw1, enough_stern 670 integer :: nbcalc_ks,nbsum,bsum_start, bsum_stop, bstart_ks,my_ikcalc,ikcalc,bstart,bstop,iatom, sendcount 671 integer :: comm_rpt, osc_npw 672 integer :: ffnlk_request, ffnl1_request, nelem, cgq_request 673 real(dp) :: cpu,wall,gflops,cpu_all,wall_all,gflops_all,cpu_ks,wall_ks,gflops_ks,cpu_dw,wall_dw,gflops_dw 674 real(dp) :: cpu_setk, wall_setk, gflops_setk, cpu_qloop, wall_qloop, gflops_qloop, gf_val 675 real(dp) :: ecut,eshift,weight_q,rfact,gmod2,hmod2,ediff,weight, inv_qepsq, simag, q0rad, out_resid 676 real(dp) :: vkk_norm, vkq_norm, osc_ecut, bz_vol 677 complex(dpc) :: cfact,dka,dkap,dkpa,dkpap, cnum, sig_cplx, cfact2 678 logical :: isirr_k, isirr_kq, gen_eigenpb, q_is_gamma, isirr_q, use_ifc_fourq, use_u1c_cache, intra_band, same_band 679 logical :: zpr_frohl_sphcorr_done 680 type(wfd_t) :: wfd 681 type(gs_hamiltonian_type) :: gs_hamkq 682 type(rf_hamiltonian_type) :: rf_hamkq 683 type(sigmaph_t) :: sigma, sigma_restart 684 type(ddkop_t) :: ddkop 685 type(rf2_t) :: rf2 686 type(crystal_t) :: pot_cryst 687 type(hdr_type) :: pot_hdr 688 type(phstore_t) :: phstore 689 type(u1cache_t) :: u1c 690 character(len=5000) :: msg 691 character(len=fnlen) :: sigeph_filepath 692 !arrays 693 integer :: g0_k(3),g0_kq(3), units(2), work_ngfft(18), gmax(3) 694 integer,allocatable :: bands_treated_now(:) 695 integer(i1b),allocatable :: itreatq_dvdb(:) 696 integer,allocatable :: gtmp(:,:),kg_k(:,:),kg_kq(:,:),nband(:,:), qselect(:), wfd_istwfk(:) 697 integer,allocatable :: gbound_kq(:,:), osc_gbound_q(:,:), osc_gvecq(:,:), osc_indpw(:), rank_band(:), root_bcalc(:) 698 integer,allocatable :: ibzspin_2ikcalc(:,:) 699 integer, allocatable :: recvcounts(:), displs(:) 700 real(dp) :: kk(3),kq(3),kk_ibz(3),kq_ibz(3),qpt(3),qpt_cart(3),phfrq(3*cryst%natom), dotri(2),qq_ibz(3) 701 real(dp) :: vk(3), vkq(3), tsec(2), eminmax(2) 702 real(dp) :: zpr_frohl_sphcorr(3*cryst%natom), vec_natom3(2, 3*cryst%natom) 703 real(dp) :: wqnu,nqnu,gkq2,gkq2_pf,eig0nk,eig0mk,eig0mkq,f_mkq, f_nk 704 real(dp) :: gdw2, gdw2_stern, rtmp 705 real(dp),allocatable,target :: cgq(:,:,:) 706 real(dp),allocatable :: displ_cart(:,:,:,:),displ_red(:,:,:,:) 707 real(dp),allocatable :: grad_berry(:,:),kinpw1(:),kpg1_k(:,:),kpg_k(:,:),dkinpw(:) 708 real(dp),allocatable :: ffnlk(:,:,:,:),ffnl1(:,:,:,:),ph3d(:,:,:),ph3d1(:,:,:),v1scf(:,:,:,:) 709 real(dp),allocatable :: gkq_atm(:,:,:),gkq_nu(:,:,:),gkq0_atm(:,:,:,:), gaussw_qnu(:) 710 real(dp),allocatable :: gscq(:,:,:), out_eig1_k(:), cg1s_kq(:,:,:,:), h1kets_kq_allperts(:,:,:,:) 711 real(dp),allocatable :: dcwavef(:, :), gh1c_n(:, :), ghc(:,:), gsc(:,:), stern_ppb(:,:,:,:), stern_dw(:,:,:,:) 712 logical,allocatable :: ihave_ikibz_spin(:,:), bks_mask(:,:,:),keep_ur(:,:,:) 713 real(dp),allocatable :: bra_kq(:,:),kets_k(:,:,:),h1kets_kq(:,:,:,:),cgwork(:,:) 714 real(dp),allocatable :: ph1d(:,:),vlocal(:,:,:,:),vlocal1(:,:,:,:,:) 715 real(dp),allocatable :: ylm_kq(:,:),ylm_k(:,:),ylmgr_kq(:,:,:) 716 real(dp),allocatable :: vtrial(:,:),gvnlx1(:,:),gvnlxc(:,:),work(:,:,:,:), vcar_ibz(:,:,:,:) 717 real(dp),allocatable :: gs1c(:,:),nqnu_tlist(:),dtw_weights(:,:),dt_tetra_weights(:,:,:),dwargs(:),alpha_mrta(:) 718 real(dp),allocatable :: delta_e_minus_emkq(:), gkq_allgather(:,:,:),f_tlist_b(:,:) 719 !real(dp),allocatable :: phfreqs_qibz(:,:), pheigvec_qibz(:,:,:,:), eigvec_qpt(:,:,:) 720 real(dp) :: ylmgr_dum(1,1,1) 721 logical,allocatable :: osc_mask(:) 722 real(dp),allocatable :: gkq2_lr(:,:,:) 723 complex(dpc) :: cp3(3) 724 complex(dpc),allocatable :: osc_ks(:,:), fmw_frohl_sphcorr(:,:,:,:), cfact_wr(:), tpp_red(:,:) 725 complex(gwpc),allocatable :: ur_k(:,:), ur_kq(:), work_ur(:), workq_ug(:) 726 type(pawcprj_type),allocatable :: cwaveprj0(:,:), cwaveprj(:,:) 727 type(pawrhoij_type),allocatable :: pawrhoij(:) 728 #if defined HAVE_MPI && !defined HAVE_MPI2_INPLACE 729 integer :: me 730 real(dp),allocatable :: cgq_buf(:) 731 real(dp),pointer :: cgq_ptr(:) 732 #endif 733 734 !************************************************************************ 735 736 if (psps%usepaw == 1) then 737 ABI_ERROR("PAW not implemented") 738 ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/)) 739 end if 740 741 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 742 call cwtime(cpu_all, wall_all, gflops_all, "start") 743 744 units = [std_out, ab_out] 745 746 ! Copy important dimensions 747 natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor 748 nspden = dtset%nspden; nkpt = ebands%nkpt 749 750 ! FFT meshes from input file, not necessarly equal to the ones found in the external files. 751 nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3)) 752 nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3)) 753 n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3) 754 n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6) 755 756 ! Get one-dimensional structure factor information on the coarse grid. 757 ABI_MALLOC(ph1d, (2,3*(2*mgfft+1)*natom)) 758 call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred) 759 760 ecut = dtset%ecut ! dtset%dilatmx 761 762 ! Check if a previous netcdf file is present and restart the calculation 763 ! Here we try to read an existing SIGEPH file if eph_restart == 1. 764 ! and we compare the variables with the state of the code (i.e. new sigmaph generated in sigmaph_new) 765 restart = 0; ierr = 1; sigeph_filepath = strcat(dtfil%filnam_ds(4), "_SIGEPH.nc") 766 if (my_rank == master .and. dtset%eph_restart == 1) then 767 sigma_restart = sigmaph_read(sigeph_filepath, dtset, xmpi_comm_self, msg, ierr) 768 end if 769 770 ! Construct object to store final results. 771 sigma = sigmaph_new(dtset, ecut, cryst, ebands, ifc, dtfil, comm) 772 773 if (my_rank == master .and. dtset%eph_restart == 1) then 774 if (ierr == 0) then 775 if (any(sigma_restart%qp_done /= 1)) then 776 call sigma%compare(sigma_restart) 777 ! Get list of QP states that have been computed. 778 sigma%qp_done = sigma_restart%qp_done 779 restart = 1 780 call wrtout(units, "- Restarting from previous SIGEPH.nc file") 781 call wrtout(units, sjoin("- Number of k-points completed:", itoa(count(sigma%qp_done == 1)), "/", itoa(sigma%nkcalc))) 782 else 783 restart = 0; sigma%qp_done = 0 784 msg = sjoin("Found SIGEPH.nc file with all QP entries already computed.", ch10, & 785 "Will overwrite:", sigeph_filepath, ch10, & 786 "Keeping backup copy in:", strcat(sigeph_filepath, ".bkp")) 787 call wrtout(ab_out, sjoin("WARNING: ", msg)) 788 ABI_WARNING(msg) 789 ! Keep backup copy 790 ABI_CHECK(clib_rename(sigeph_filepath, strcat(sigeph_filepath, ".bkp")) == 0, "Failed to rename SIGPEPH file.") 791 end if 792 end if 793 call sigma_restart%free() 794 end if 795 796 call xmpi_bcast(restart, master, comm, ierr) 797 call xmpi_bcast(sigma%qp_done, master, comm, ierr) 798 799 if (restart == 0) then 800 call sigma%write(dtset, cryst, ebands, wfk_hdr, dtfil, comm) 801 else 802 ! Open file inside ncwrite_comm to perform parallel IO if kpt parallelism. 803 if (sigma%ncwrite_comm%value /= xmpi_comm_null) then 804 NCF_CHECK(nctk_open_modify(sigma%ncid, sigeph_filepath, sigma%ncwrite_comm%value)) 805 NCF_CHECK(nctk_set_datamode(sigma%ncid)) 806 end if 807 end if 808 809 if (.not. sigma%imag_only .and. sigma%frohl_model /= 0 .and. .not. dvdb%has_zeff) sigma%frohl_model = 0 810 811 if (my_rank == master) then 812 call sigma%print(dtset, ab_out) 813 call sigma%print(dtset, std_out) 814 end if 815 my_npert = sigma%my_npert 816 817 ! This is the maximum number of PWs for all possible k+q treated. 818 mpw = sigma%mpw; gmax = sigma%gmax 819 820 ! Init work_ngfft 821 gmax = gmax + 4 ! FIXME: this is to account for umklapp, shouls also consider Gamma-only and istwfk 822 gmax = 2*gmax + 1 823 call ngfft_seq(work_ngfft, gmax) 824 !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3) 825 ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6))) 826 827 ! Initialize the wave function descriptor. 828 ! Each node has all k-points and spins and bands between my_bsum_start and my_bsum_stop 829 ABI_MALLOC(nband, (nkpt, nsppol)) 830 ABI_MALLOC(bks_mask, (dtset%mband, nkpt, nsppol)) 831 ABI_MALLOC(keep_ur, (dtset%mband, nkpt ,nsppol)) 832 833 nband = dtset%mband; bks_mask = .False.; keep_ur = .False. 834 835 ! Mapping Sigma_{k,s} states to IBZ. -1 if not computed 836 ABI_MALLOC(ibzspin_2ikcalc, (nkpt, nsppol)) 837 ibzspin_2ikcalc = -1 838 839 ! Each node needs the wavefunctions for Sigma_{nk} 840 ! TODO: kcalc should depend on the spin! 841 do spin=1,sigma%nsppol 842 do ikcalc=1,sigma%nkcalc 843 ik_ibz = sigma%kcalc2ibz(ikcalc, 1) 844 bstart = sigma%bstart_ks(ikcalc, spin) 845 bstop = bstart + sigma%nbcalc_ks(ikcalc, spin) - 1 846 bks_mask(bstart:bstop, ik_ibz, spin) = .True. 847 ibzspin_2ikcalc(ik_ibz, spin) = ikcalc 848 end do 849 end do 850 851 ! For the imaginay part, add bands outside the energy window to account for ph absorption/emission 852 if (sigma%imag_only .and. sigma%qint_method == 1) then 853 call wrtout(std_out, " Including restricted set of states within energy window around relevant states.", newlines=1) 854 do spin=1,sigma%nsppol 855 do ik_ibz=1,ebands%nkpt 856 do band=sigma%my_bsum_start, sigma%my_bsum_stop 857 eig0mk = ebands%eig(band, ik_ibz, spin) 858 if (eig0mk >= sigma%elow - sigma%phwinfact * sigma%wmax .and. & 859 eig0mk <= sigma%ehigh + sigma%phwinfact * sigma%wmax) then 860 bks_mask(band, ik_ibz ,spin) = .True. 861 end if 862 end do 863 end do 864 end do 865 ! Uncomment these lines to disable energy window trick and allocate all bands. 866 !if (dtset%userie == 123) then 867 ! call wrtout(std_out, " Storing all bands between my_bsum_start and my_bsum_stop.") 868 ! bks_mask(sigma%my_bsum_start:sigma%my_bsum_stop, : ,:) = .True. 869 !end if 870 else 871 bks_mask(sigma%my_bsum_start:sigma%my_bsum_stop, : ,:) = .True. 872 endif 873 874 !if (dtset%userie == 124) then 875 ! ! Uncomment this line to have all states on each MPI rank. 876 ! bks_mask = .True.; call wrtout(std_out, " Storing all bands for debugging purposes.") 877 !end if 878 879 ! This table is needed when computing the imaginary part: 880 ! k+q states outside the energy window are not read hence their contribution won't be included. 881 ! Error is small provided calculation is close to convergence. 882 ! To reduce the error one should increase the value of phwinfact 883 ABI_MALLOC(ihave_ikibz_spin, (nkpt, nsppol)) 884 ihave_ikibz_spin = .False. 885 do spin=1,sigma%nsppol 886 do ik_ibz=1,ebands%nkpt 887 if (any(bks_mask(:, ik_ibz, spin))) ihave_ikibz_spin(ik_ibz, spin) = .True. 888 end do 889 end do 890 891 ! Impose istwfk=1 for all k points. This is also done in respfn (see inkpts) 892 ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1. 893 ABI_MALLOC(wfd_istwfk, (nkpt)) 894 wfd_istwfk = 1 895 896 call wfd_init(wfd, cryst, pawtab, psps, keep_ur, dtset%mband, nband, nkpt, nsppol, bks_mask,& 897 nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,& 898 dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm) 899 900 call wfd%print(header="Wavefunctions for self-energy calculation.", mode_paral='PERS') 901 902 ABI_FREE(nband) 903 ABI_FREE(bks_mask) 904 ABI_FREE(keep_ur) 905 ABI_FREE(wfd_istwfk) 906 907 ! Read wavefunctions. 908 call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path)) 909 910 ! if PAW, one has to solve a generalized eigenproblem 911 ! Be careful here because I will need sij_opt == -1 912 usecprj = 0 913 gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1 914 915 ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj)) 916 ABI_MALLOC(cwaveprj, (natom, nspinor*usecprj)) 917 ABI_MALLOC(displ_cart, (2, 3, cryst%natom, natom3)) 918 ABI_MALLOC(displ_red, (2, 3, cryst%natom, natom3)) 919 ABI_MALLOC(tpp_red, (natom3, natom3)) 920 ABI_MALLOC(gbound_kq, (2*wfd%mgfft+8, 2)) 921 ABI_MALLOC(osc_gbound_q, (2*wfd%mgfft+8, 2)) 922 923 osc_ecut = dtset%eph_ecutosc 924 if (osc_ecut > zero) then 925 call wrtout(std_out, sjoin("Computing oscillator matrix elements with ecut.", ftoa(osc_ecut))) 926 ABI_CHECK(osc_ecut <= wfd%ecut, "osc_ecut cannot be greater than dtset%ecut") 927 else if (osc_ecut < zero) then 928 call wrtout(std_out, sjoin("Including G vectors inside a sphere with ecut.", ftoa(osc_ecut))) 929 end if 930 931 ! ============================ 932 ! Compute vnk matrix elements 933 ! ============================ 934 ABI_MALLOC(cgwork, (2, mpw*wfd%nspinor)) 935 ABI_CALLOC(sigma%vcar_calc, (3, sigma%max_nbcalc, sigma%nkcalc, nsppol)) 936 937 ddkop = ddkop_new(dtset, cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft) 938 939 if (sigma%mrta == 0) then 940 call cwtime(cpu_ks, wall_ks, gflops_ks, "start", msg=" Computing v_nk matrix elements for all states in Sigma_nk...") 941 ! Consider only the nk states in Sigma_nk 942 ! All sigma_nk states are available on each node so MPI parallelization is easy. 943 cnt = 0 944 do spin=1,nsppol 945 do ikcalc=1,sigma%nkcalc 946 kk = sigma%kcalc(:, ikcalc) 947 bstart_ks = sigma%bstart_ks(ikcalc, spin) 948 ik_ibz = sigma%kcalc2ibz(ikcalc, 1) 949 npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz) 950 call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k) 951 952 do ib_k=1,sigma%nbcalc_ks(ikcalc, spin) 953 cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism. 954 band_ks = ib_k + bstart_ks - 1 955 call wfd%copy_cg(band_ks, ik_ibz, spin, cgwork) 956 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 957 sigma%vcar_calc(:, ib_k, ikcalc, spin) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cgwork, cwaveprj0) 958 end do 959 960 end do 961 end do 962 call xmpi_sum(sigma%vcar_calc, comm, ierr) 963 964 else 965 call cwtime(cpu_ks, wall_ks, gflops_ks, "start", msg=" Computing v_nk matrix elements for all states in the IBZ...") 966 967 ! Imaginary part with MRTA. Here we need v_kq as well. 968 ! Usually kq is one of the kcalc points except when nk is close to the edge of the sigma_erange window. 969 ! due to ph absorption/emission. 970 ! In this case, indeed, we may need a kq state that is not in the initial kcalc set. 971 ! 972 ! Solution: 973 ! 1) precompute group velocities in the IBZ and the ihave_ikibz_spin file (common to all procs) 974 ! 2) Fill sigma%vcar_calc needed by the transport driver from the vcar_ibz array 975 ! 3) Use symmetries to reconstruct v_kq from vcar_ibz 976 ! 977 ! NB: All procs store in memory the same set of Bloch states. 978 979 ABI_CALLOC(vcar_ibz, (3, sigma%bsum_start:sigma%bsum_stop, nkpt, nsppol)) 980 981 cnt = 0 982 do spin=1,nsppol 983 do ik_ibz=1,ebands%nkpt 984 kk = ebands%kptns(:, ik_ibz) 985 npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz) 986 ikcalc = ibzspin_2ikcalc(ik_ibz, spin) 987 if (.not. ihave_ikibz_spin(ik_ibz, spin)) cycle 988 if (npw_k == 1) cycle 989 cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism. 990 991 call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k) 992 993 do band_ks=sigma%bsum_start,sigma%bsum_stop 994 if (.not. wfd%ihave_ug(band_ks, ik_ibz, spin)) cycle 995 call wfd%copy_cg(band_ks, ik_ibz, spin, cgwork) 996 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 997 vk = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cgwork, cwaveprj0) 998 vcar_ibz(:, band_ks, ik_ibz, spin) = vk 999 if (ikcalc /= -1) then 1000 ! This IBZ k-point is in the kcalc set --> Store vk in vcar_calc 1001 bstart_ks = sigma%bstart_ks(ikcalc, spin) 1002 bstop = bstart_ks + sigma%nbcalc_ks(ikcalc, spin) - 1 1003 if (band_ks >= bstart_ks .and. band_ks <= bstop) then 1004 ib_k = band_ks - bstart_ks + 1 1005 sigma%vcar_calc(:, ib_k, ikcalc, spin) = vk 1006 end if 1007 end if 1008 end do 1009 end do 1010 end do 1011 call xmpi_sum(sigma%vcar_calc, comm, ierr) 1012 call xmpi_sum(vcar_ibz, comm, ierr) 1013 endif 1014 1015 ! Write v_nk to disk. 1016 if (my_rank == master) then 1017 NCF_CHECK(nf90_put_var(sigma%ncid, nctk_idname(sigma%ncid, "vcar_calc"), sigma%vcar_calc)) 1018 end if 1019 1020 ABI_FREE(cgwork) 1021 call ddkop%free() 1022 call cwtime_report(" Velocities", cpu_ks, wall_ks, gflops_ks) 1023 1024 ! Precompute phonon frequencies and eigenvectors in the IBZ. 1025 ! These quantities are then used to symmetrize quantities for q in the IBZ(k) in order 1026 ! to reduce the number of calls to ifc%fourq (expensive if dipdip == 1) 1027 1028 use_ifc_fourq = .False. !use_ifc_fourq = .True. !use_ifc_fourq = dtset%userib == 123 1029 phstore = phstore_new(cryst, ifc, sigma%nqibz, sigma%qibz, use_ifc_fourq, sigma%pert_comm%value) 1030 call cwtime_report(" phonons in the IBZ", cpu_ks, wall_ks, gflops_ks) 1031 1032 ! Radius of sphere with volume equivalent to the micro zone. 1033 q0rad = two_pi * (three / (four_pi * cryst%ucvol * sigma%nqbz)) ** third 1034 bz_vol = two_pi**3 / cryst%ucvol 1035 1036 ! if (sigma%frohl_model == 1 .and. .not. sigma%imag_only) then 1037 ! ! Prepare treatment of Frohlich divergence in the ZPR with spherical integration in the microzone around Gamma. 1038 ! ! Correction does not depend on (n,k) so we can precompute values at this level. 1039 ! call wrtout(std_out, " Computing spherical average to treat Frohlich divergence ...") 1040 ! zpr_frohl_sphcorr = zero 1041 ! ! Angular integration 1042 ! do iang=1,sigma%angl_size 1043 ! if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism 1044 ! qpt_cart = sigma%qvers_cart(:, iang); inv_qepsq = one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart)) 1045 ! call ifc%fourq(cryst, qpt_cart, phfrq, displ_cart, nanaqdir="cart") 1046 ! 1047 ! ! Acoustic modes are ignored here 1048 ! do nu=4,natom3 1049 ! wqnu = phfrq(nu); if (sigma%skip_phmode(nu, wqnu, dtset%eph_phrange_w)) cycle 1050 ! ! cnum = q.\sum_k Z_k.d(q,nu) 1051 ! cp3 = czero 1052 ! do iatom=1, natom 1053 ! cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dpc)) 1054 ! end do 1055 ! cnum = dot_product(qpt_cart, cp3) 1056 ! ! Compute spherical average. 1057 ! zpr_frohl_sphcorr(nu) = zpr_frohl_sphcorr(nu) + sigma%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq ** 2 / wqnu ** 2 1058 ! end do 1059 ! end do ! iang 1060 ! call xmpi_sum(zpr_frohl_sphcorr, comm, ierr) 1061 ! 1062 ! zpr_frohl_sphcorr = zpr_frohl_sphcorr * eight * pi / cryst%ucvol * (three / (four_pi * cryst%ucvol * sigma%nqbz)) ** third 1063 ! !zpr_frohl_sphcorr = zpr_frohl_sphcorr * four * q0rad / cryst%ucvol 1064 ! if (my_rank == master) then 1065 ! write(ab_out, "(/,a)")" Frohlich model integrated inside the small q-sphere around Gamma: " 1066 ! write(ab_out,"(2(a,i0,1x),/)")" ntheta: ", sigma%ntheta, ", nphi: ", sigma%nphi 1067 ! write(ab_out, "(a)")" This correction is used to accelerate the convergence of the ZPR with the q-point sampling " 1068 ! write(ab_out, "(a)")" Note that this term tends to zero for N_q --> oo " 1069 ! write(ab_out, "(a)")" so it is different from the integral of the Frohlich potential in the full BZ." 1070 ! do nu=1,natom3 1071 ! if (abs(zpr_frohl_sphcorr(nu)) < tol12) cycle 1072 ! write(ab_out, "(a,f8.1,a,i0,a,f8.1,a)")& 1073 ! " ZPR Spherical correction:", zpr_frohl_sphcorr(nu) * Ha_meV, " (meV) for ph-mode: ", & 1074 ! nu, ", w_qnu:", phfrq(nu) * Ha_meV, " (meV)" 1075 ! end do 1076 ! write(ab_out, "(a)")ch10 1077 ! end if 1078 ! end if 1079 1080 ! Prepare call to getgh1c 1081 usevnl = 0 1082 optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C> 1083 optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C> 1084 opt_gvnlx1 = 0 ! gvnlx1 is output 1085 1086 ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4))) 1087 1088 ! This part is taken from dfpt_vtorho 1089 !==== Initialize most of the Hamiltonian (and derivative) ==== 1090 ! 1) Allocate all arrays and initialize quantities that do not depend on k and spin. 1091 ! 2) Perform the setup needed for the non-local factors: 1092 ! 1093 ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk. 1094 ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients. 1095 1096 call init_hamiltonian(gs_hamkq, psps, pawtab, nspinor, nsppol, nspden, natom,& 1097 dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg,& 1098 comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab,& 1099 usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option) 1100 1101 ! Allocate work space arrays. 1102 ! vtrial and vlocal are required for Sternheimer (H0). DFPT routines do not need it. 1103 ! Note nvloc in vlocal (we will select one/four spin components afterwards) 1104 ABI_CALLOC(vtrial, (nfftf, nspden)) 1105 ABI_CALLOC(vlocal, (n4, n5, n6, gs_hamkq%nvloc)) 1106 1107 if (dtset%eph_stern /= 0) then 1108 ! Read GS POT (vtrial) from input POT file 1109 ! In principle one may store vtrial in the DVDB but getpot_filepath is simpler to implement. 1110 call wrtout(units, sjoin(" Reading GS KS potential for Sternheimer from: ", dtfil%filpotin)) 1111 call read_rhor(dtfil%filpotin, cplex1, nspden, nfftf, ngfftf, pawread0, mpi_enreg, vtrial, pot_hdr, pawrhoij, comm, & 1112 allow_interp=.True.) 1113 pot_cryst = pot_hdr%get_crystal() 1114 if (cryst%compare(pot_cryst, header=" Comparing input crystal with POT crystal") /= 0) then 1115 ABI_ERROR("Crystal structure from WFK and POT do not agree! Check messages above!") 1116 end if 1117 call pot_cryst%free(); call pot_hdr%free() 1118 end if 1119 1120 if (sigma%nwr > 0) then 1121 ABI_MALLOC(cfact_wr, (sigma%nwr)) 1122 end if 1123 ABI_MALLOC(nqnu_tlist, (sigma%ntemp)) 1124 1125 ! Allocate workspace arrays for Eliashberg calculation. 1126 if (dtset%prteliash /= 0) then 1127 ABI_MALLOC(dtw_weights, (sigma%phmesh_size, 2)) 1128 ABI_MALLOC(dwargs, (sigma%phmesh_size)) 1129 if (sigma%a2f_ne > 0) then 1130 ABI_MALLOC(delta_e_minus_emkq, (sigma%a2f_ne)) 1131 end if 1132 end if 1133 1134 ! Array used to store delta(w - w_{q\nu}) with delta replaced by gaussian. 1135 ABI_MALLOC(gaussw_qnu, (sigma%phmesh_size)) 1136 1137 if (dtset%eph_prtscratew == 1) then 1138 ABI_MALLOC(sigma%scratew, (sigma%phmesh_size, sigma%ntemp, sigma%max_nbcalc, 2)) 1139 end if 1140 1141 ! Open the DVDB file 1142 call dvdb%open_read(ngfftf, xmpi_comm_self) 1143 1144 if (sigma%pert_comm%nproc > 1) then 1145 ! Activate parallelism over perturbations 1146 call dvdb%set_pert_distrib(sigma%my_npert, natom3, sigma%my_pinfo, sigma%pert_table, sigma%pert_comm%value) 1147 end if 1148 1149 ! Find correspondence IBZ --> set of q-points in DVDB. 1150 ! Activate FT interpolation automatically if required q-points in the IBZ are not found in the DVDB. 1151 sigma%use_ftinterp = .False. 1152 ABI_MALLOC(sigma%qibz2dvdb, (sigma%nqibz)) 1153 if (dvdb%find_qpts(sigma%nqibz, sigma%qibz, sigma%qibz2dvdb, comm) /= 0) then 1154 call wrtout(units, " Cannot find eph_ngqpt_fine q-points in DVDB --> Activating Fourier interpolation.") 1155 sigma%use_ftinterp = .True. 1156 else 1157 call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.") 1158 sigma%use_ftinterp = .False. 1159 end if 1160 1161 if (sigma%use_ftinterp) then 1162 ! Use ddb_ngqpt q-mesh to compute the real-space represention of DFPT v1scf potentials to prepare Fourier interpolation. 1163 ! R-points are distributed inside comm_rpt 1164 ! Note that when R-points are distributed inside qpt_comm we cannot interpolate potentials on-the-fly 1165 ! inside the loop over q-points. 1166 ! In this case, indeed, the interpolation must be done in sigma_setup_qloop once we know the q-points contributing 1167 ! to the integral and the potentials must be cached. 1168 !FIXME: qpt_comm is buggy. 1169 !if (sigma%imag_only) comm_rpt = xmpi_comm_self 1170 !comm_rpt = sigma%bsum_comm%value 1171 comm_rpt = xmpi_comm_self 1172 qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 1173 call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt) 1174 1175 ! Build q-cache in the *dense* IBZ using the global mask qselect and itreat_qibz. 1176 ABI_MALLOC(qselect, (sigma%nqibz)) 1177 qselect = 1 1178 if (sigma%imag_only .and. sigma%qint_method == 1) then 1179 call qpoints_oracle(sigma, dtset, cryst, ebands, sigma%qibz, sigma%nqibz, sigma%nqbz, sigma%qbz, qselect, comm) 1180 end if 1181 call dvdb%ftqcache_build(nfftf, ngfftf, sigma%nqibz, sigma%qibz, dtset%dvdb_qcache_mb, qselect, sigma%itreat_qibz, comm) 1182 1183 else 1184 ABI_MALLOC(qselect, (dvdb%nqpt)) 1185 qselect = 1 1186 ! Try to predict the q-points required to compute tau. 1187 if (sigma%imag_only .and. sigma%qint_method == 1) then 1188 call qpoints_oracle(sigma, dtset, cryst, ebands, dvdb%qpts, dvdb%nqpt, sigma%nqbz, sigma%qbz, qselect, comm) 1189 end if 1190 end if 1191 1192 call dvdb%print(prtvol=dtset%prtvol) 1193 1194 if (.not. sigma%use_ftinterp) then 1195 ! Need to translate itreat_qibz into itreatq_dvdb. 1196 ABI_ICALLOC(itreatq_dvdb, (dvdb%nqpt)) 1197 do iq_ibz=1,sigma%nqibz 1198 if (sigma%itreat_qibz(iq_ibz) == 0) cycle 1199 db_iqpt = sigma%qibz2dvdb(iq_ibz) 1200 ABI_CHECK(db_iqpt /= -1, sjoin("Could not find IBZ q-point:", ktoa(sigma%qibz(:, iq_ibz)), "in the DVDB file.")) 1201 itreatq_dvdb(db_iqpt) = 1 1202 end do 1203 call dvdb%qcache_read(nfftf, ngfftf, dtset%dvdb_qcache_mb, qselect, itreatq_dvdb, comm) 1204 ABI_FREE(itreatq_dvdb) 1205 end if 1206 1207 ABI_FREE(qselect) 1208 zpr_frohl_sphcorr = zero; zpr_frohl_sphcorr_done = .False. 1209 1210 ! Loop over k-points in Sigma_nk. Loop over spin is internal as we operate on nspden components at once. 1211 do my_ikcalc=1,sigma%my_nkcalc 1212 !if (my_ikcalc > 1) exit 1213 ikcalc = sigma%my_ikcalc(my_ikcalc) 1214 1215 ! Check if this (kpoint, spin) was already calculated 1216 if (all(sigma%qp_done(ikcalc, :) == 1)) cycle 1217 call cwtime(cpu_ks, wall_ks, gflops_ks, "start") 1218 1219 !call abimem_report("begin kcalc_loop", std_out) 1220 !call wrtout(std_out, sjoin("xmpi_count_requests", itoa(xmpi_count_requests))) 1221 1222 ! Find IBZ(k) for q-point integration. 1223 call cwtime(cpu_setk, wall_setk, gflops_setk, "start") 1224 ! FIXME invert spin but checks shape of the different arrays! 1225 call sigma%setup_kcalc(dtset, cryst, ebands, ikcalc, dtset%prtvol, sigma%pqb_comm%value) 1226 1227 ! Symmetry indices for kk. 1228 kk = sigma%kcalc(:, ikcalc) 1229 ik_ibz = sigma%kcalc2ibz(ikcalc, 1); isym_k = sigma%kcalc2ibz(ikcalc, 2) 1230 trev_k = sigma%kcalc2ibz(ikcalc, 6); g0_k = sigma%kcalc2ibz(ikcalc, 3:5) 1231 isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0)) 1232 ABI_CHECK(isirr_k, "For the time being the k-point in Sigma_{nk} must be in the IBZ") 1233 kk_ibz = ebands%kptns(:,ik_ibz) 1234 npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz) 1235 1236 ! Allocate PW-arrays. Note mpw in kg_kq 1237 ABI_MALLOC(kg_k, (3, npw_k)) 1238 kg_k = wfd%kdata(ik_ibz)%kg_k 1239 ABI_MALLOC(kg_kq, (3, mpw)) 1240 1241 ! Spherical Harmonics for useylm == 1. 1242 ABI_MALLOC(ylm_k, (mpw, psps%mpsang**2 * psps%useylm)) 1243 ABI_MALLOC(ylm_kq, (mpw, psps%mpsang**2 * psps%useylm)) 1244 ABI_MALLOC(ylmgr_kq, (mpw, 3, psps%mpsang**2 * psps%useylm * useylmgr1)) 1245 1246 ! Compute k+G vectors 1247 nkpg = 3*dtset%nloalg(3) 1248 ABI_MALLOC(kpg_k, (npw_k, nkpg)) 1249 if (nkpg > 0) call mkkpg(kg_k, kpg_k, kk, nkpg, npw_k) 1250 1251 ! Compute nonlocal form factors ffnlk at (k+G) 1252 ABI_MALLOC(ffnlk, (npw_k, 1, psps%lmnmax, psps%ntypat)) 1253 1254 call mkffnl_objs(cryst, psps, 1, ffnlk, ider0, idir0, kg_k, kpg_k, kk, nkpg, npw_k, ylm_k, ylmgr_dum, & 1255 comm=sigma%pert_comm%value, request=ffnlk_request) 1256 1257 call cwtime_report(" Setup kcalc", cpu_setk, wall_setk, gflops_setk) 1258 1259 ! TODO: Spin should be treated in a more flexible and scalable way --> kcalc and bdgw should depend on spin. 1260 ! Introduce other comm and cartesian dimension for spin 1261 do my_spin=1,sigma%my_nspins 1262 spin = sigma%my_spins(my_spin) 1263 1264 ! Check if this kpoint and spin was already calculated 1265 if (sigma%qp_done(ikcalc, spin) == 1) cycle 1266 1267 !call timab(1900, 1, tsec) 1268 ! Bands in Sigma_nk to compute and number of bands in sum over states. 1269 bstart_ks = sigma%bstart_ks(ikcalc, spin) 1270 nbcalc_ks = sigma%nbcalc_ks(ikcalc, spin) 1271 bsum_start = sigma%bsum_start; bsum_stop = sigma%bsum_stop 1272 nbsum = sigma%nbsum 1273 ABI_MALLOC(root_bcalc, (nbcalc_ks)) 1274 1275 ! Zero self-energy matrix elements. Build frequency mesh for nk states. 1276 sigma%vals_e0ks = zero; sigma%dvals_de0ks = zero; sigma%dw_vals = zero 1277 sigma%fan_vals = zero; sigma%fan_stern_vals = zero; sigma%dw_stern_vals = zero 1278 if (sigma%mrta > 0) then 1279 sigma%linewidth_mrta = zero 1280 ABI_MALLOC(alpha_mrta, (nbcalc_ks)) 1281 end if 1282 1283 ! Prepare computation of Sigma_{nk}(w) and spectral function. 1284 if (sigma%nwr > 0) then 1285 sigma%vals_wr = zero 1286 do ib_k=1,nbcalc_ks 1287 band_ks = ib_k + bstart_ks - 1 1288 ! Build linear mesh **centered** around the KS energy. 1289 eig0nk = ebands%eig(band_ks, ik_ibz, spin) - sigma%wr_step * (sigma%nwr / 2) 1290 sigma%wrmesh_b(:,ib_k) = arth(eig0nk, sigma%wr_step, sigma%nwr) 1291 end do 1292 end if 1293 1294 ! Prepare Eliasberg functions. 1295 if (dtset%prteliash /= 0) then 1296 ABI_SFREE(sigma%gf_nnuq) 1297 ABI_CALLOC(sigma%gf_nnuq, (nbcalc_ks, natom3, sigma%nqibz_k, 3)) 1298 if (dtset%prteliash == 3) sigma%a2few = zero 1299 end if 1300 1301 ! Zeroing array used to compute spectral decomposition of 1/tau as a function of ph omega. 1302 if (dtset%eph_prtscratew == 1) sigma%scratew = zero 1303 1304 ! Allocate eph matrix elements. 1305 ABI_MALLOC(gkq_atm, (2, nbcalc_ks, natom3)) 1306 ABI_MALLOC(gkq_nu, (2, nbcalc_ks, natom3)) 1307 ABI_MALLOC(gkq_allgather, (2, nbcalc_ks * natom3, 2)) 1308 1309 ! Allocate arrays for Debye-Waller 1310 if (.not. sigma%imag_only) then 1311 ABI_CALLOC_OR_DIE(gkq0_atm, (2, nbcalc_ks, sigma%my_bsum_start:sigma%my_bsum_stop, natom3), ierr) 1312 if (dtset%eph_stern /= 0) then 1313 ABI_CALLOC(stern_dw, (2, natom3, natom3, nbcalc_ks)) 1314 enough_stern = 0 1315 use_u1c_cache = merge(.True., .False., dtset%eph_stern == 1) 1316 tot_nlines_done = 0 1317 end if 1318 end if 1319 1320 ! Integrate delta functions inside miniBZ around Gamma. 1321 ! TODO: Remove? 1322 !if (sigma%frohl_model == 1 .and. sigma%imag_only) then 1323 ! call eval_sigfrohl_deltas(sigma, cryst, ifc, ebands, ikcalc, spin, dtset%prtvol, sigma%pqb_comm%value) 1324 !end if 1325 1326 if (sigma%frohl_model == 1 .and. .not. sigma%imag_only) then 1327 call wrtout(std_out, " Computing spherical average to treat Frohlich divergence in Sigma^{FM}") 1328 ABI_MALLOC(f_tlist_b, (sigma%ntemp, nbcalc_ks)) 1329 1330 if (sigma%nwr > 0) then 1331 do ib_k=1,nbcalc_ks 1332 band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin) 1333 do it=1,sigma%ntemp 1334 f_tlist_b(it,ib_k) = occ_fd(eig0nk, sigma%kTmesh(it), sigma%mu_e(it)) 1335 end do 1336 end do 1337 ! This integral depends on the (n, k) state 1338 ABI_CALLOC(fmw_frohl_sphcorr, (sigma%nwr, natom3, sigma%ntemp, nbcalc_ks)) 1339 end if 1340 1341 ! Angular integration. 1342 if (.not. zpr_frohl_sphcorr_done) zpr_frohl_sphcorr = zero 1343 1344 do iang=1,sigma%angl_size 1345 if (sigma%kcalc_comm%skip(iang)) cycle ! MPI parallelism inside kcalc_comm 1346 qpt_cart = sigma%qvers_cart(:, iang); inv_qepsq = one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart)) 1347 call ifc%fourq(cryst, qpt_cart, phfrq, displ_cart, nanaqdir="cart") 1348 1349 ! Acoustic modes are ignored here. 1350 do nu=4,natom3 1351 wqnu = phfrq(nu); if (sigma%skip_phmode(nu, wqnu, dtset%eph_phrange_w)) cycle 1352 ! Get phonon occupation for all temperatures. 1353 nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero) 1354 1355 ! cnum = q.\sum_k Z_k.d_k(q,nu) 1356 cp3 = czero 1357 do iatom=1, natom 1358 cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dpc)) 1359 end do 1360 cnum = dot_product(qpt_cart, cp3); if (abs(cnum) < tol12) cycle 1361 1362 ! Compute spherical average for ZPR 1363 if (.not. zpr_frohl_sphcorr_done) then 1364 zpr_frohl_sphcorr(nu) = zpr_frohl_sphcorr(nu) + sigma%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq ** 2 / wqnu ** 2 1365 end if 1366 1367 if (sigma%nwr > 0) then 1368 ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega) 1369 weight = four_pi * sigma%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq ** 2 / wqnu 1370 do ib_k=1,nbcalc_ks 1371 band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin) 1372 do it=1,sigma%ntemp 1373 f_nk = f_tlist_b(it,ib_k) 1374 nqnu = nqnu_tlist(it) 1375 fmw_frohl_sphcorr(:,nu,it,ib_k) = fmw_frohl_sphcorr(:,nu,it,ib_k) + & 1376 ((nqnu + f_nk ) / (sigma%wrmesh_b(:,ib_k) - eig0nk + wqnu + sigma%ieta) + & 1377 (nqnu - f_nk + one) / (sigma%wrmesh_b(:,ib_k) - eig0nk - wqnu + sigma%ieta) ) * weight 1378 end do ! it 1379 end do ! ib_k 1380 end if 1381 end do ! nu 1382 end do ! iang 1383 ABI_FREE(f_tlist_b) 1384 1385 if (.not. zpr_frohl_sphcorr_done) then 1386 call xmpi_sum(zpr_frohl_sphcorr, sigma%kcalc_comm%value, ierr) 1387 zpr_frohl_sphcorr = zpr_frohl_sphcorr * eight * pi / cryst%ucvol * & 1388 (three / (four_pi * cryst%ucvol * sigma%nqbz)) ** third 1389 !zpr_frohl_sphcorr = zpr_frohl_sphcorr * four * q0rad / cryst%ucvol 1390 zpr_frohl_sphcorr_done = .True. 1391 end if 1392 1393 if (sigma%nwr > 0) then 1394 call xmpi_sum(fmw_frohl_sphcorr, sigma%kcalc_comm%value, ierr) 1395 fmw_frohl_sphcorr = fmw_frohl_sphcorr * (four_pi/cryst%ucvol)**2 * q0rad * half / bz_vol 1396 end if 1397 1398 if (my_rank == master .and. is_open(ab_out)) then 1399 write(ab_out, "(/,a)")" Frohlich model integrated inside the small q-sphere around Gamma." 1400 write(ab_out,"(2(a,i0,1x),/)")" Angular mesh with ntheta: ", sigma%ntheta, ", nphi: ", sigma%nphi 1401 write(ab_out, "(2a)")" Phonon-resolved contributions to Sigma^{FM}(w=e_KS):", ch10 1402 do nu=1,natom3 1403 if (abs(zpr_frohl_sphcorr(nu)) < tol12) cycle 1404 write(ab_out, "(1x,f8.1,a,i0)")zpr_frohl_sphcorr(nu) * Ha_meV, " (meV) for ph-mode: ", nu 1405 end do 1406 write(ab_out, "(a)")ch10 1407 1408 !if (sigma%nwr > 0) then 1409 !do ib_k=1,nbcalc_ks 1410 ! band_ks = ib_k + bstart_ks - 1 1411 ! write(ab_out, "(a, i0)")" Spherical correction to Sigma^{FM}(w=e_KS) for band: ", band_ks 1412 ! do nu=1,natom3 1413 ! do it=1,sigma%ntemp 1414 ! iw = 1 + (sigma%nwr / 2) !; iw = 1 1415 ! if (abs(fmw_frohl_sphcorr(iw,nu,it,ib_k)) < tol12) cycle 1416 ! write(ab_out, "(2(f8.1),2(a,i0))") & 1417 ! fmw_frohl_sphcorr(iw,nu,it,ib_k) * Ha_meV, " (meV) for ph-mode: ",nu, ", itemp: ", it 1418 ! end do 1419 ! end do 1420 !end do 1421 !write(ab_out, "(a)")ch10 1422 !end if 1423 end if 1424 end if 1425 1426 ! Load ground-state wavefunctions for which corrections are wanted (available on each node) 1427 ! and save KS energies in sigma%e0vals 1428 ! Note: One should rotate the wavefunctions if kk is not in the IBZ (not implemented) 1429 ABI_MALLOC(kets_k, (2, npw_k*nspinor, nbcalc_ks)) 1430 ABI_MALLOC(sigma%e0vals, (nbcalc_ks)) 1431 1432 if (osc_ecut /= zero) then 1433 ABI_MALLOC(ur_k, (wfd%nfft*nspinor, nbcalc_ks)) 1434 ABI_MALLOC(ur_kq, (wfd%nfft*nspinor)) 1435 ABI_MALLOC(work_ur, (wfd%nfft*nspinor)) 1436 ABI_MALLOC(gkq2_lr, (sigma%eph_doublegrid%ndiv, nbcalc_ks, sigma%my_npert)) 1437 end if 1438 1439 do ib_k=1,nbcalc_ks 1440 band_ks = ib_k + bstart_ks - 1 1441 call wfd%copy_cg(band_ks, ik_ibz, spin, kets_k(1, 1, ib_k)) 1442 sigma%e0vals(ib_k) = ebands%eig(band_ks, ik_ibz, spin) 1443 if (osc_ecut > zero) call wfd%get_ur(band_ks, ik_ibz, spin, ur_k(1, ib_k)) 1444 end do 1445 1446 ! Distribute q-points, compute tetra weigths. 1447 call sigmaph_setup_qloop(sigma, dtset, cryst, ebands, dvdb, spin, ikcalc, nfftf, ngfftf, sigma%pqb_comm%value) 1448 !call timab(1900, 2, tsec) 1449 1450 ! ========================================== 1451 ! Integration over my q-points in the IBZ(k) 1452 ! ========================================== 1453 call cwtime(cpu_qloop, wall_qloop, gflops_qloop, "start") 1454 ignore_kq = 0; ignore_ibsum_kq = 0 1455 1456 do imyq=1,sigma%my_nqibz_k 1457 call cwtime(cpu, wall, gflops, "start") 1458 iq_ibz_k = sigma%myq2ibz_k(imyq) 1459 qpt = sigma%qibz_k(:, iq_ibz_k) 1460 q_is_gamma = sum(qpt**2) < tol14 1461 1462 iq_ibz = sigma%ind_ibzk2ibz(1, iq_ibz_k) 1463 isym_q = sigma%ind_ibzk2ibz(2, iq_ibz_k) 1464 trev_q = sigma%ind_ibzk2ibz(6, iq_ibz_k) 1465 ! Don't test if umklapp == 0 because we use the periodic gauge: phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G) 1466 isirr_q = (isym_q == 1 .and. trev_q == 0) 1467 !qq_ibz = sigma%qibz(:, iq_ibz) 1468 1469 ! Find k + q in the extended zone and extract symmetry info. 1470 ! Be careful here because there are two umklapp vectors to be considered as: 1471 ! 1472 ! k + q = k_bz + g0_bz = IS(k_ibz) + g0_ibz + g0_bz 1473 ! 1474 kq = kk + qpt 1475 ikq_ibz = sigma%indkk_kq(1, iq_ibz_k); isym_kq = sigma%indkk_kq(2, iq_ibz_k) 1476 trev_kq = sigma%indkk_kq(6, iq_ibz_k); g0_kq = sigma%indkk_kq(3:5, iq_ibz_k) 1477 isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0)) 1478 kq_ibz = ebands%kptns(:, ikq_ibz) 1479 !nband_kq = ebands%nband(ikq_ibz + (spin-1) * ebands%nkpt) 1480 1481 ! This can happen if we have loaded the wavefunctions inside the energy range. 1482 if (sigma%imag_only .and. .not. ihave_ikibz_spin(ikq_ibz, spin)) then 1483 ignore_kq = ignore_kq + 1; cycle 1484 end if 1485 1486 ! ==================================== 1487 ! Get DFPT potentials for this q-point 1488 ! ==================================== 1489 if (sigma%use_ftinterp) then 1490 ! Use Fourier interpolation to get DFPT potentials for this qpt (hopefully in cache). 1491 db_iqpt = sigma%ind_ibzk2ibz(1, iq_ibz_k) 1492 qq_ibz = sigma%qibz(:, db_iqpt) 1493 call dvdb%get_ftqbz(cryst, qpt, qq_ibz, sigma%ind_ibzk2ibz(:, iq_ibz_k), cplex, nfftf, ngfftf, v1scf, & 1494 sigma%pert_comm%value) 1495 else 1496 ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations. 1497 ! This call allocates v1scf(cplex, nfftf, nspden, my_npert)) 1498 db_iqpt = sigma%ind_q2dvdb_k(1, iq_ibz_k) 1499 ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qpt), "in DVDB file.")) 1500 call dvdb%readsym_qbz(cryst, qpt, sigma%ind_q2dvdb_k(:,iq_ibz_k), cplex, nfftf, ngfftf, v1scf, sigma%pert_comm%value) 1501 end if 1502 1503 ! Rotate phonon frequencies and displacements for q in BZ. Non-blocking operation inside pert_comm 1504 !call timab(1901, 1, tsec) 1505 1506 call phstore%async_rotate(cryst, ifc, iq_ibz, sigma%qibz(:, iq_ibz), qpt, isym_q, trev_q) 1507 !call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red, comm=sigma%pert_comm%value) 1508 1509 ! Double grid stuff 1510 if (sigma%use_doublegrid) then 1511 call sigma%eph_doublegrid%get_mapping(kk, kq, qpt) 1512 !iq_bz_frohl = sigma%eph_doublegrid%get_index(qpt, 2) 1513 !iq_ibz_frohl = sigma%eph_doublegrid%bz2ibz_dense(iq_bz_frohl) 1514 end if 1515 1516 ! Map q to qibz for tetrahedron 1517 if (sigma%qint_method > 0) then 1518 if (.not. sigma%use_doublegrid) then 1519 iq_ibz_fine = iq_ibz_k 1520 if (sigma%symsigma == 0) iq_ibz_fine = sigma%ephwg%lgk%find_ibzimage(qpt) 1521 ABI_CHECK(iq_ibz_fine /= -1, sjoin("Cannot find q-point in IBZ(k):", ktoa(qpt))) 1522 if (abs(sigma%symsigma) == 1) then 1523 if (.not. all(abs(sigma%qibz_k(:, iq_ibz_fine) - sigma%ephwg%lgk%ibz(:, iq_ibz_fine)) < tol12)) then 1524 ABI_ERROR("Mismatch in qpoints.") 1525 end if 1526 end if 1527 endif 1528 end if 1529 1530 ! Get npw_kq, kg_kq for k+q. 1531 if (isirr_kq) then 1532 ! Copy u_kq(G) 1533 istwf_kq = wfd%istwfk(ikq_ibz); npw_kq = wfd%npwarr(ikq_ibz) 1534 ABI_CHECK(mpw >= npw_kq, "mpw < npw_kq") 1535 kg_kq(:,1:npw_kq) = wfd%kdata(ikq_ibz)%kg_k 1536 else 1537 ! Reconstruct u_kq(G) from the IBZ image. 1538 istwf_kq = 1 1539 call get_kg(kq, istwf_kq, ecut, cryst%gmet, npw_kq, gtmp) 1540 ABI_CHECK(mpw >= npw_kq, "mpw < npw_kq") 1541 kg_kq(:,1:npw_kq) = gtmp(:,:npw_kq) 1542 ABI_FREE(gtmp) 1543 end if 1544 !call timab(1901, 2, tsec) 1545 !call timab(1902, 1, tsec) 1546 1547 istwf_kqirr = wfd%istwfk(ikq_ibz); npw_kqirr = wfd%npwarr(ikq_ibz) 1548 ABI_MALLOC(bra_kq, (2, npw_kq*nspinor)) 1549 ABI_MALLOC(cgwork, (2, npw_kqirr*nspinor)) 1550 1551 if (osc_ecut /= zero) then 1552 ! Finds the boundary of the basis sphere of G vectors (for this kq point) 1553 ! for use in improved zero padding of ffts in 3 dimensions. 1554 call sphereboundary(gbound_kq, istwf_kq, kg_kq, wfd%mgfft, npw_kq) 1555 1556 ! Compute "small" G-sphere centered on qpt and gbound for zero-padded FFT for oscillators. 1557 call get_kg(qpt, istw1, abs(osc_ecut), cryst%gmet, osc_npw, osc_gvecq) 1558 call sphereboundary(osc_gbound_q, istw1, osc_gvecq, wfd%mgfft, osc_npw) 1559 1560 ! Compute correspondence G-sphere --> FFT mesh. 1561 ABI_MALLOC(osc_indpw, (osc_npw)) 1562 ABI_MALLOC(osc_mask, (osc_npw)) 1563 call kgindex(osc_indpw, osc_gvecq, osc_mask, wfd%mpi_enreg, ngfft, osc_npw) 1564 ABI_FREE(osc_mask) 1565 1566 ABI_MALLOC(workq_ug, (npw_kq*nspinor)) 1567 ABI_MALLOC(osc_ks, (osc_npw*nspinor, nbcalc_ks)) 1568 end if 1569 1570 ! Allocate array to store H1 |psi_nk> for all 3*natom perturbations 1571 ABI_MALLOC_OR_DIE(h1kets_kq, (2, npw_kq*nspinor, my_npert, nbcalc_ks), ierr) 1572 1573 ! Allocate vlocal1 with correct cplex. Note nvloc 1574 ABI_MALLOC_OR_DIE(vlocal1, (cplex*n4, n5, n6, gs_hamkq%nvloc, my_npert), ierr) 1575 1576 ABI_MALLOC(gs1c, (2, npw_kq*nspinor*((sij_opt+1)/2))) 1577 ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor)) 1578 1579 ! Set up the spherical harmonics (Ylm) at k and k+q. See also dfpt_looppert 1580 !if (psps%useylm == 1) then 1581 ! optder = 0; if (useylmgr == 1) optder = 1 1582 ! call initylmg(cryst%gprimd, kg_k, kk, mkmem1, mpi_enreg, psps%mpsang, mpw, nband, mkmem1, & 1583 ! [npw_k], dtset%nsppol, optder, cryst%rprimd, ylm_k, ylmgr) 1584 ! call initylmg(cryst%gprimd, kg_kq, kq, mkmem1, mpi_enreg, psps%mpsang, mpw, nband, mkmem1, & 1585 ! [npw_kq], dtset%nsppol, optder, cryst%rprimd, ylm_kq, ylmgr_kq) 1586 !end if 1587 1588 ! Compute k+q+G vectors 1589 nkpg1 = 3*dtset%nloalg(3) 1590 ABI_MALLOC(kpg1_k, (npw_kq, nkpg1)) 1591 if (nkpg1 > 0) call mkkpg(kg_kq, kpg1_k, kq, nkpg1, npw_kq) 1592 1593 ! Compute nonlocal form factors ffnl1 at (k+q+G) 1594 ABI_MALLOC(ffnl1, (npw_kq, 1, psps%lmnmax, psps%ntypat)) 1595 1596 call mkffnl_objs(cryst, psps, 1, ffnl1, ider0, idir0, kg_kq, kpg1_k, kq, nkpg1, npw_kq, ylm_kq, ylmgr_kq, & 1597 comm=sigma%pert_comm%value, request=ffnl1_request) 1598 1599 if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then 1600 ! Build global array with GS wavefunctions cg_kq at k+q to prepare call to dfpt_cgwf. 1601 ! NB: bsum_range is not compatible with Sternheimer. 1602 ! There's a check at the level of the parser in chkinp. 1603 1604 call timab(1908, 1, tsec) 1605 ABI_CALLOC(cg1s_kq, (2, npw_kq*nspinor, natom3, nbcalc_ks)) 1606 1607 ! NOTE that in the present version we need to gather all nbsum bands 1608 ! on each core before calling dfpt_cgwf. 1609 ! In principle one can call dfpt_cgwf in band-para mode but then 1610 ! we are obliged to call the sternheimer solver with one psi1 and all procs in bsum_comm 1611 ! just to to be able to apply the projector operator. 1612 ! The present version is not memory efficient and leads to a big load imbalance if 1613 ! bsum%comm%nproc > nband_calc_ks 1614 1615 !#define DEV_BAND_PARA 1616 1617 #ifdef DEV_BAND_PARA 1618 nband_me = sigma%my_bsum_stop - sigma%my_bsum_start + 1 1619 #else 1620 nband_me = nbsum 1621 #endif 1622 1623 ABI_MALLOC(cgq, (2, npw_kq * nspinor, nband_me)) 1624 ABI_MALLOC(gscq, (2, npw_kq * nspinor, nband_me*psps%usepaw)) 1625 1626 do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop 1627 1628 1629 1630 if (isirr_kq) then 1631 call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, bra_kq) 1632 else 1633 ! Reconstruct u_kq(G) from the IBZ image. 1634 call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, cgwork) 1635 call cgtk_rotate(cryst, kq_ibz, isym_kq, trev_kq, g0_kq, nspinor, ndat1, & 1636 npw_kqirr, wfd%kdata(ikq_ibz)%kg_k, & 1637 npw_kq, kg_kq, istwf_kqirr, istwf_kq, cgwork, bra_kq, work_ngfft, work) 1638 end if 1639 1640 #ifdef DEV_BAND_PARA 1641 ii = ibsum_kq - sigma%my_bsum_start + 1 1642 cgq(:,:,ii) = bra_kq 1643 #else 1644 cgq(:, :, ibsum_kq) = bra_kq 1645 #endif 1646 end do 1647 1648 cgq_request = xmpi_request_null 1649 1650 #ifndef DEV_BAND_PARA 1651 if (sigma%bsum_comm%nproc > 1) then 1652 ! If band parallelism, need to gather all bands nbsum bands. 1653 ! FIXME: This part is network intensive, one can avoid it by calling dfpt_cgwf in band-para mode. 1654 !call xmpi_sum(cgq, sigma%bsum_comm%value, ierr) 1655 !call xmpi_isum_ip(cgq, sigma%bsum_comm%value, cgq_request, ierr) 1656 1657 nelem = 2 * npw_kq * nspinor 1658 call sigma%bsum_comm%prep_gatherv(nelem, sigma%nbsum_rank(:,1), sendcount, recvcounts, displs) 1659 #ifdef HAVE_MPI 1660 !call MPI_ALLGATHERV(MPI_IN_PLACE, sendcount, MPI_DOUBLE_PRECISION, cgq, recvcounts, displs, & 1661 ! MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, ierr) 1662 1663 #if defined HAVE_MPI2_INPLACE 1664 call MPI_IALLGATHERV(MPI_IN_PLACE, sendcount, MPI_DOUBLE_PRECISION, cgq, recvcounts, displs, & 1665 MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, cgq_request, ierr) 1666 #else 1667 ABI_MALLOC(cgq_buf,(sendcount)) 1668 me=1+xmpi_comm_rank(sigma%bsum_comm%value) 1669 cgq_buf(1:sendcount)=cgq_ptr(displs(me)+1:displs(me)+sendcount) 1670 call c_f_pointer(c_loc(cgq),cgq_ptr,[2*npw_kq*nspinor*nband_me]) 1671 call MPI_IALLGATHERV(cgq_buf, sendcount, MPI_DOUBLE_PRECISION, cgq_ptr, recvcounts, displs, & 1672 MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, cgq_request, ierr) 1673 ABI_FREE(cgq_buf) 1674 #endif 1675 call xmpi_requests_add(+1) 1676 #endif 1677 1678 ABI_FREE(recvcounts) 1679 ABI_FREE(displs) 1680 end if 1681 #endif 1682 call timab(1908, 2, tsec) 1683 end if ! eph_stern 1684 1685 ! Loop over all 3*natom perturbations (Each core prepares its own potentials) 1686 ! In the inner loop, we calculate H1 * psi_k, stored in h1kets_kq on the k+q sphere. 1687 do imyp=1,my_npert 1688 idir = sigma%my_pinfo(1, imyp); ipert = sigma%my_pinfo(2, imyp); ipc = sigma%my_pinfo(3, imyp) 1689 1690 ! Set up local potential vlocal1 with proper dimensioning, from vtrial1 taking into account the spin. 1691 ! Each CPU prepares its own potentials. 1692 call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_hamkq%nvloc, & 1693 pawfgr, mpi_enreg, vtrial, v1scf(:,:,:,imyp), vlocal, vlocal1(:,:,:,:,imyp)) 1694 1695 ! Continue to initialize the Hamiltonian (call it here to support dfpt_cgwf Sternheimer). 1696 call gs_hamkq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.) 1697 1698 ! Prepare application of the NL part. 1699 call init_rf_hamiltonian(cplex, gs_hamkq, ipert, rf_hamkq, has_e1kbsc=.true.) 1700 call rf_hamkq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,imyp), with_nonlocal=.true.) 1701 1702 if (ffnlk_request /= xmpi_request_null) call xmpi_wait(ffnlk_request, ierr) 1703 if (ffnl1_request /= xmpi_request_null) call xmpi_wait(ffnl1_request, ierr) 1704 1705 ! This call is not optimal because there are quantities in out that do not depend on idir,ipert 1706 call getgh1c_setup(gs_hamkq, rf_hamkq, dtset, psps, kk, kq, idir, ipert, & ! In 1707 cryst%natom, cryst%rmet, cryst%gprimd, cryst%gmet, istwf_k, & ! In 1708 npw_k, npw_kq, useylmgr1, kg_k, ylm_k, kg_kq, ylm_kq, ylmgr_kq, & ! In 1709 dkinpw, nkpg, nkpg1, kpg_k, kpg1_k, kinpw1, ffnlk, ffnl1, ph3d, ph3d1, & ! Out 1710 reuse_kpg_k=1, reuse_kpg1_k=1, reuse_ffnlk=1, reuse_ffnl1=1) ! Reuse some arrays 1711 1712 ! Compute H(1) applied to GS wavefunction Psi_nk(0) 1713 do ib_k=1,nbcalc_ks 1714 if (sigma%bsum_comm%skip(ib_k, root=root_bcalc(ib_k))) cycle ! MPI parallelism inside bsum_comm 1715 ! Store rank treating ib_k in root_bcalc 1716 band_ks = ib_k + bstart_ks - 1 1717 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 1718 ! Use scissor shift on 0-order eigenvalue 1719 eshift = eig0nk - dtset%dfpt_sciss 1720 1721 call getgh1c(berryopt0, kets_k(:,:,ib_k), cwaveprj0, h1kets_kq(:,:,imyp, ib_k), & 1722 grad_berry, gs1c, gs_hamkq, gvnlx1, idir, ipert, eshift, mpi_enreg, optlocal, & 1723 optnl, opt_gvnlx1, rf_hamkq, sij_opt, tim_getgh1c1, usevnl) 1724 end do 1725 1726 do ib_k=1,nbcalc_ks 1727 call xmpi_bcast(h1kets_kq(:,:,imyp,ib_k), root_bcalc(ib_k), sigma%bsum_comm%value, ierr) 1728 end do 1729 1730 if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then 1731 call timab(1909, 1, tsec) 1732 ! Activate Sternheimer. Note that we are still inside the MPI loop over my_npert. 1733 ! NB: Assume adiabatic AHC expression to compute the contribution of states above nbsum. 1734 1735 #ifdef DEV_BAND_PARA 1736 ! Prepare band parallelism in dfpt_cgwf via mpi_enreg. 1737 mpi_enreg%comm_band = sigma%bsum_comm%value 1738 mpi_enreg%me_band = sigma%bsum_comm%me 1739 mpi_enreg%nproc_band = sigma%bsum_comm%nproc 1740 #endif 1741 1742 ABI_CALLOC(out_eig1_k, (2*nbsum**2)) 1743 ABI_MALLOC(dcwavef, (2, npw_kq*nspinor*usedcwavef0)) 1744 ABI_MALLOC(gh1c_n, (2, npw_kq*nspinor)) 1745 ABI_MALLOC(ghc, (2, npw_kq*nspinor)) 1746 ABI_MALLOC(gsc, (2, npw_kq*nspinor)) 1747 ABI_MALLOC(gvnlxc, (2, npw_kq*nspinor)) 1748 1749 ! TODO: grad_berry is problematic because in dfpt_cgwf, the array is declared with 1750 ! 1751 ! real(dp),intent(in) :: grad_berry(2,mpw1*nspinor,nband) 1752 ! 1753 ! and 1754 ! 1755 ! npw1_k = number of plane waves at this k+q point 1756 ! 1757 ! So in principle we should allocate lot of memory to avoid bound checking error! 1758 ! For the time being use mpw1 = 0 because mpw1 is not used in this call to dfpt_cgwf 1759 ! still it's clear that the treatment of this array must be completely refactored in the DFPT code. 1760 ! 1761 grad_berry_size_mpw1 = 0 1762 1763 !TODO: to distribute cgq and kets memory, use mband_mem per core in band comm, but coordinate everyone with 1764 ! the following array (as opposed to the distribution of cg1 which is done in the normal dfpt calls 1765 ABI_MALLOC(bands_treated_now, (nbsum)) 1766 ABI_MALLOC (rank_band, (nbsum)) 1767 rank_band = 0 1768 1769 nline_in = min(100, npw_kq); if (dtset%nline > nline_in) nline_in = min(dtset%nline, npw_kq) 1770 1771 #ifndef DEV_BAND_PARA 1772 ! Wait for gatherv operation 1773 if (cgq_request /= xmpi_request_null) call xmpi_wait(cgq_request, ierr) 1774 #endif 1775 1776 do ib_k=1,nbcalc_ks 1777 band_ks = ib_k + bstart_ks - 1 1778 bands_treated_now(:) = 0; bands_treated_now(band_ks) = 1 1779 1780 #ifdef DEV_BAND_PARA 1781 ! Init rank_band and band_me from nbsum_rank. 1782 rank_band = -1; band_me = 1 1783 do ip=1,sigma%bsum_comm%nproc 1784 ii = sigma%nbsum_rank(ip,2) 1785 jj = sigma%nbsum_rank(ip,2) + sigma%nbsum_rank(ip,1) -1 1786 rank_band(ii:jj) = ip - 1 1787 if (inrange(band_ks, [ii, jj])) u1_master = ip - 1 1788 end do 1789 if (inrange(band_ks, [sigma%my_bsum_start, sigma%my_bsum_stop])) then 1790 band_me = band_ks - sigma%my_bsum_start + 1 1791 u1_band = band_ks 1792 else 1793 band_me = 1 1794 u1_band = -band_ks 1795 end if 1796 #else 1797 rank_band = 0 1798 band_me = band_ks 1799 u1_band = band_ks 1800 if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm 1801 #endif 1802 1803 ! Init entry in cg1s_kq, either from cache or with zeros. 1804 if (use_u1c_cache) then 1805 u1c_ib_k = u1c%find_band(band_ks) 1806 if (u1c_ib_k /= -1) then 1807 call cgtk_change_gsphere(nspinor, & 1808 u1c%prev_npw_kq, istwfk1, u1c%prev_kg_kq, u1c%prev_cg1s_kq(1,1,ipc,u1c_ib_k), & 1809 npw_kq, istwfk1, kg_kq, cg1s_kq(1,1,ipc,ib_k), work_ngfft, work) 1810 else 1811 cg1s_kq(:,:,ipc,ib_k) = zero 1812 end if 1813 1814 else 1815 cg1s_kq(:,:,ipc,ib_k) = zero 1816 end if 1817 1818 mcgq = npw_kq * nspinor * nband_me 1819 mgscq = npw_kq * nspinor * nband_me * psps%usepaw 1820 nlines_done = 0 1821 call timab(1909, 2, tsec) 1822 1823 call dfpt_cgwf(u1_band, band_me, rank_band, bands_treated_now, berryopt0, & 1824 cgq, cg1s_kq(:,:,ipc,ib_k), kets_k(:,:,ib_k), & ! Important stuff 1825 cwaveprj, cwaveprj0, rf2, dcwavef, & 1826 ebands%eig(:, ik_ibz, spin), ebands%eig(:, ikq_ibz, spin), out_eig1_k, & 1827 ghc, gh1c_n, grad_berry, gsc, gscq, & 1828 gs_hamkq, gvnlxc, gvnlx1, icgq0, idir, ipert, igscq0, & 1829 mcgq, mgscq, mpi_enreg, grad_berry_size_mpw1, cryst%natom, nbsum, nband_me, & 1830 nbdbuf0, nline_in, npw_k, npw_kq, nspinor, & 1831 opt_gvnlx1, dtset%prtvol, quit0, out_resid, rf_hamkq, dtset%dfpt_sciss, -one, dtset%tolwfr, & 1832 usedcwavef0, dtset%wfoptalg, nlines_done) 1833 1834 tot_nlines_done = tot_nlines_done + nlines_done 1835 1836 #ifdef DEV_BAND_PARA 1837 call xmpi_bcast(cg1s_kq(:,:,ipc,ib_k), u1_master, sigma%bsum_comm%value, ierr) 1838 #endif 1839 1840 ! Handle possible convergence error. 1841 if (u1_band > 0) then 1842 if (out_resid > dtset%tolwfr) then 1843 write(msg, "(a,i0,a, 2(a,es13.5), 2a,i0,a)") & 1844 " Sternheimer didn't convergence for band: ", band_ks, ch10, & 1845 " resid:", out_resid, " >= tolwfr: ", dtset%tolwfr, ch10, & 1846 " after nline: ", nlines_done, " iterations. Increase nline and/or tolwfr." 1847 ABI_ERROR(msg) 1848 else if (out_resid < zero) then 1849 ABI_ERROR(sjoin(" resid: ", ftoa(out_resid), ", nlines_done:", itoa(nlines_done))) 1850 end if 1851 1852 if (my_rank == master .and. (enough_stern <= 5 .or. dtset%prtvol > 10)) then 1853 write(std_out, "(2(a,es13.5),a,i0)") & 1854 " Sternheimer converged with resid: ", out_resid, " <= tolwfr: ", dtset%tolwfr, & 1855 " after nlines_done: ", nlines_done 1856 enough_stern = enough_stern + 1 1857 end if 1858 end if 1859 end do ! ib_k 1860 1861 #ifdef DEV_BAND_PARA 1862 ! Revert changes in mpi_enreg. 1863 mpi_enreg%comm_band = xmpi_comm_self 1864 mpi_enreg%me_band = 0 1865 mpi_enreg%nproc_band = 1 1866 #endif 1867 1868 ABI_FREE(bands_treated_now) 1869 ABI_FREE(rank_band) 1870 ABI_FREE(out_eig1_k) 1871 ABI_FREE(dcwavef) 1872 ABI_FREE(gh1c_n) 1873 ABI_FREE(ghc) 1874 ABI_FREE(gsc) 1875 ABI_FREE(gvnlxc) 1876 if (imyp == my_npert) then 1877 ABI_FREE(cgq) 1878 ABI_FREE(gscq) 1879 end if 1880 !call timab(1909, 2, tsec) 1881 end if ! sternheimer 1882 1883 call rf_hamkq%free() 1884 ABI_FREE(kinpw1) 1885 ABI_FREE(dkinpw) 1886 ABI_FREE(ph3d) 1887 ABI_SFREE(ph3d1) 1888 end do ! imyp (loop over perturbations) 1889 1890 !call timab(1902, 2, tsec) 1891 ABI_FREE(gs1c) 1892 ABI_FREE(gvnlx1) 1893 ABI_FREE(vlocal1) 1894 ABI_FREE(v1scf) 1895 1896 ! Wait from phonon frequencies and displacements inside pert_comm 1897 call phstore%wait(cryst, phfrq, displ_cart, displ_red) 1898 1899 if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then 1900 call timab(1910, 1, tsec) 1901 ! Add contribution to Fan-Migdal self-energy coming from Sternheimer. 1902 ! NB: All procs inside (bsum_comm x pert_comm) enter here! 1903 1904 ! Store |Psi_1> to init Sternheimer solver for the next q-point. 1905 call u1c%store(qpt, npw_kq, nspinor, natom3, bstart_ks, nbcalc_ks, kg_kq, cg1s_kq) 1906 1907 ! h1kets_kq are MPI distributed inside pert_comm but we need off-diagonal pp' terms --> collect results. 1908 ABI_CALLOC(h1kets_kq_allperts, (2, npw_kq*nspinor, natom3, nbcalc_ks)) 1909 1910 ! Compute S_pp' = <D_{qp} vscf u_nk|u'_{nk+q p'}> 1911 ABI_CALLOC(stern_ppb, (2, natom3, natom3, nbcalc_ks)) 1912 1913 do ib_k=1,nbcalc_ks 1914 if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm 1915 1916 call xmpi_sum(cg1s_kq(:,:,:,ib_k), sigma%pert_comm%value, ierr) 1917 1918 ! TODO 1919 !nelem = 2*npw_kq*nspinor*sigma%my_npert 1920 !call MPI_ALLGATHER(MPI_IN_PLACE, nelem, MPI_DOUBLE_PRECISION, cg1s_kq(:,:,:,ib_k), nelem, & 1921 ! MPI_DOUBLE_PRECISION, sigma%pert_comm%value, ierr) 1922 1923 call xmpi_allgather(h1kets_kq(:,:,:,ib_k), 2*npw_kq*nspinor*sigma%my_npert, & 1924 h1kets_kq_allperts(:,:,:,ib_k), sigma%pert_comm%value, ierr) 1925 1926 call cg_zgemm("C", "N", npw_kq*nspinor, natom3, natom3, & 1927 h1kets_kq_allperts(:,:,:,ib_k), cg1s_kq(:,:,:,ib_k), stern_ppb(:,:,:,ib_k)) 1928 1929 ! Save data for Debye-Waller that is performed outside the q-loop. 1930 if (q_is_gamma) stern_dw(:,:,:,ib_k) = stern_ppb(:,:,:,ib_k) 1931 end do 1932 1933 ABI_FREE(cg1s_kq) 1934 ABI_FREE(h1kets_kq_allperts) 1935 1936 if (q_is_gamma) call xmpi_sum(stern_dw, sigma%bsum_comm%value, ierr) 1937 1938 ! Compute contribution to Fan-Migdal for M > sigma%nbsum 1939 do imyp=1,my_npert 1940 nu = sigma%my_pinfo(3, imyp) 1941 wqnu = phfrq(nu); if (sigma%skip_phmode(nu, wqnu, dtset%eph_phrange_w)) cycle 1942 1943 ! Get phonon occupation for all temperatures. 1944 nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero) 1945 1946 do ib_k=1,nbcalc_ks 1947 if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm 1948 1949 ! sum_{pp'} d_p* Stern_{pp'} d_p' with d = displ_red(:,:,:,nu) and S = stern_ppb(:,:,:,ib_k) 1950 vec_natom3 = zero 1951 call cg_zgemm("N", "N", natom3, natom3, 1, stern_ppb(:,:,:,ib_k), displ_red(:,:,:,nu), vec_natom3) 1952 dotri = cg_zdotc(natom3, displ_red(:,:,:,nu), vec_natom3) 1953 !write(std_out, *)"dotri:", dotri 1954 rfact = dotri(1) 1955 !rfact = cg_real_zdotc(natom3, displ_red(:,:,:,nu), vec_natom3) 1956 rfact = rfact * sigma%wtq_k(iq_ibz_k) / (two * wqnu) 1957 1958 do it=1,sigma%ntemp 1959 rtmp = (two * nqnu_tlist(it) + one) * rfact 1960 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + rtmp 1961 sigma%fan_vals(it, ib_k) = sigma%fan_vals(it, ib_k) + rtmp 1962 sigma%fan_stern_vals(it, ib_k) = sigma%fan_stern_vals(it, ib_k) + rtmp 1963 ! Add static term from Sternheimer to Sigma(w) as well. 1964 if (sigma%nwr > 0) sigma%vals_wr(:, it, ib_k) = sigma%vals_wr(:, it, ib_k) + rtmp 1965 !if (sigma%nwr > 0) sigma%vals_wr(:, it, ib_k) = sigma%vals_wr(:, it, ib_k) + gkq2 * cfact_wr(:) 1966 end do 1967 1968 ! TODO Eliashberg functions with Sternheimer 1969 !if (dtset%prteliash /= 0) then 1970 !end if 1971 end do 1972 end do 1973 1974 ABI_FREE(stern_ppb) 1975 call timab(1910, 2, tsec) 1976 end if ! eph_stern /= 0 1977 1978 ! ============================================== 1979 ! Sum over m bands parallelized inside bsum_comm 1980 ! ============================================== 1981 call timab(1903, 1, tsec) 1982 1983 do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop 1984 call timab(1904, 1, tsec) 1985 ! This can happen if we have loaded the wavefunctions inside the energy range. 1986 if (sigma%imag_only .and. sigma%qint_method == 1) then 1987 if (.not. wfd%ihave_ug(ibsum_kq, ikq_ibz, spin)) then 1988 ignore_ibsum_kq = ignore_ibsum_kq + 1; cycle 1989 end if 1990 end if 1991 1992 ! Symmetrize k+q wavefunctions in the BZ from IBZ (if needed). 1993 if (isirr_kq) then 1994 ! Copy u_kq(G) 1995 call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, bra_kq) 1996 else 1997 ! Reconstruct u_kq(G) from the IBZ image. 1998 ! Use cgwork as workspace array, results stored in bra_kq 1999 ! g0_kq = g0ibz_kq + g0bz_kq 2000 call wfd%copy_cg(ibsum_kq, ikq_ibz, spin, cgwork) 2001 call cgtk_rotate(cryst, kq_ibz, isym_kq, trev_kq, g0_kq, nspinor, ndat1, & 2002 npw_kqirr, wfd%kdata(ikq_ibz)%kg_k, & 2003 npw_kq, kg_kq, istwf_kqirr, istwf_kq, cgwork, bra_kq, work_ngfft, work) 2004 end if 2005 2006 ! Get gkk(kcalc, q, idir_ipert) in the atomic representation. 2007 ! No need to handle istwf_kq because it's always 1. 2008 gkq_atm = zero; cnt = 0 2009 do imyp=1,my_npert 2010 ipc = sigma%my_pinfo(3, imyp) 2011 ! Calculate <u_(band,k+q)^(0)|H_(k+q,k)^(1)|u_(band,k)^(0)> for this pert (NC psps) istwf_k always 1 2012 do ib_k=1,nbcalc_ks 2013 gkq_atm(:, ib_k, ipc) = cg_zdotc(npw_kq*nspinor, bra_kq, h1kets_kq(:,:,imyp,ib_k)) 2014 cnt = cnt + 1 2015 gkq_allgather(:,cnt, 1) = gkq_atm(:, ib_k, ipc) 2016 end do 2017 !call cg_zgemv("C", npw_kq*nspinor, nbcalc_ks, h1kets_kq(:,:,:,imyp), bra_kq, gkq_atm(:,:,ipc)) 2018 end do 2019 call timab(1904, 2, tsec) 2020 call timab(1905, 1, tsec) 2021 !ii = nbcalc_ks * my_npert 2022 !call cg_zgemm("H", "N", npw_kq*nspinor, ii, ii, h1kets_kq, bra_kq, gkq_atm) 2023 !call cg_zgemm("H", "N", npw_kq*nspinor, ii, ii, bra_kq, h1kets_kq, gkq_atm) 2024 2025 ! Get gkk(kcalc, q, nu) in the phonon representation. 2026 ! Need to gather all perts distributed in pert_comm 2027 if (sigma%pert_comm%nproc > 1) then 2028 call xmpi_allgather(gkq_allgather(:,:,1), 2 * nbcalc_ks * my_npert, gkq_allgather(:,:,2), & 2029 sigma%pert_comm%value, ierr) 2030 do cnt=1,nbcalc_ks*natom3 2031 ipc = 1 + (cnt - 1) / nbcalc_ks 2032 ib_k = 1 + mod(cnt - 1, nbcalc_ks) 2033 gkq_atm(:, ib_k, ipc) = gkq_allgather(:, cnt, 2) 2034 end do 2035 end if 2036 2037 call ephtk_gkknu_from_atm(1, nbcalc_ks, 1, natom, gkq_atm, phfrq, displ_red, gkq_nu) 2038 2039 ! bsum_2 and bsum_3 are hotspots. 2040 call timab(1905, 2, tsec) 2041 call timab(1906, 1, tsec) 2042 2043 ! Save e-ph matrix elements for Debye-Waller computation that will be performed outside the q-loop. 2044 ! gkq0_atm(2, nbcalc_ks, bsum_start:bsum_stop, natom3) 2045 if (q_is_gamma .and. .not. sigma%imag_only) gkq0_atm(:, :, ibsum_kq, :) = gkq_atm 2046 2047 if (osc_ecut > zero) then 2048 workq_ug = cmplx(bra_kq(1, :), bra_kq(2, :), kind=gwpc) 2049 call fft_ug(npw_kq, wfd%nfft, nspinor, ndat1, wfd%mgfft, wfd%ngfft, & 2050 istwf_kq, kg_kq, gbound_kq, workq_ug, ur_kq) 2051 2052 ! We need <k+q| e^{iq+G}|k> --> compute <k| e^{-i(q+G)}|k+q> with FFT and take CC. 2053 do ib_k=1,nbcalc_ks 2054 work_ur = ur_kq * conjg(ur_k(:, ib_k)) 2055 ! Call zero-padded FFT routine. 2056 call fftpad(work_ur, ngfft, n1, n2, n3, n1, n2, n3, nspinor, wfd%mgfft, -1, osc_gbound_q) 2057 2058 ! Need results on the G-sphere --> Transfer data from FFT to G-sphere. 2059 do ispinor=1,nspinor 2060 do ig=1,osc_npw 2061 ifft = osc_indpw(ig) + (ispinor-1) * wfd%nfft 2062 osc_ks(ig + (ispinor -1) * osc_npw, ib_k) = conjg(work_ur(ifft)) 2063 end do 2064 end do 2065 2066 !band_ks = ib_k + bstart_ks - 1 2067 !if (ibsum_kq == band_ks) then 2068 !if (ibsum_kq == band_ks .and. all(abs(qpt) < tol12)) then 2069 ! write(std_out,"(a,i0,2a)")" Ene and Oscillator for band: ", band_ks, ", and q-point: ", trim(ktoa(qpt)) 2070 ! write(std_out,*)ebands%eig(band_ks, ik_ibz, spin) * Ha_eV, osc_ks(:2,ib_k) 2071 !end if 2072 end do 2073 end if 2074 2075 eig0mkq = ebands%eig(ibsum_kq, ikq_ibz, spin) 2076 2077 ! q-weight for naive integration 2078 weight_q = sigma%wtq_k(iq_ibz_k) 2079 2080 if (sigma%mrta > 0) then 2081 ! Compute v_kq 2082 ! If k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q). 2083 ! Use transpose(R) because we are using the tables for the wavefunctions 2084 ! In this case listkk has been called with symrel and use_symrec=False 2085 ! so q_bz = S^T q_ibz where S is the isym_kq symmetry 2086 vkq = vcar_ibz(:, ibsum_kq, ikq_ibz, spin) 2087 if (.not. isirr_kq) then 2088 vkq = matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vkq) 2089 if (trev_kq /= 0) vkq = -vkq 2090 vkq_norm = sqrt(dot_product(vk, vk)) 2091 end if 2092 2093 ! Precompute alpha MRTA coefficients for all nk states. 2094 do ib_k=1,nbcalc_ks 2095 vk = sigma%vcar_calc(:, ib_k, ikcalc, spin) 2096 vkk_norm = sqrt(dot_product(vk, vk)) 2097 alpha_mrta(ib_k) = one ! zero 2098 if (vkk_norm > tol6) alpha_mrta(ib_k) = one - dot_product(vkq, vk) / vkk_norm ** 2 2099 !if (vkk_norm > tol6 .and. vkq_norm > tol6) then 2100 ! alpha_mrta(ib_k) = one - dot_product(vkq, vk) / (vkk_norm * vk_norm) 2101 !end if 2102 end do 2103 end if 2104 call timab(1906, 2, tsec) 2105 call timab(1907, 1, tsec) 2106 2107 ! Accumulate contribution to the FM self-energy 2108 do imyp=1,my_npert 2109 nu = sigma%my_pinfo(3, imyp) 2110 ! Ignore unstable modes or modes that should be skipped. 2111 wqnu = phfrq(nu); if (sigma%skip_phmode(nu, wqnu, dtset%eph_phrange_w)) cycle 2112 2113 if (dtset%eph_prtscratew == 1) then 2114 ! Precompute delta(w-w_qnu) 2115 gaussw_qnu = gaussian(sigma%phmesh - wqnu, dtset%ph_smear) 2116 end if 2117 2118 ! For each band in Sigma_{nk} 2119 do ib_k=1,nbcalc_ks 2120 band_ks = ib_k + bstart_ks - 1 2121 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 2122 gkq2 = weight_q * (gkq_nu(1,ib_k,nu) ** 2 + gkq_nu(2,ib_k,nu) ** 2) 2123 ediff = eig0nk - eig0mkq 2124 intra_band = q_is_gamma .and. ediff <= TOL_EDIFF 2125 same_band = ibsum_kq == band_ks 2126 2127 ! Optionally, accumulate contribution to Eliashberg functions 2128 if (dtset%prteliash /= 0) then 2129 ! EPH strength with delta(e_{nk} - e_{m\kq}) 2130 rfact = gaussian(eig0nk - eig0mkq, dtset%tsmear) 2131 sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 1) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 1) + & 2132 rfact * (gkq_nu(1, ib_k, nu) ** 2 + gkq_nu(2, ib_k, nu) ** 2) 2133 2134 ! Treat contribution to Eliashberg function due to Fan term. 2135 if (ediff > wqnu) then 2136 rfact = one / ediff 2137 else 2138 ! Non adiabatic regime --> Add complex shift. 2139 ! Note however that the expression for this flavor of Eliashberg function relies on adiabaticity. 2140 rfact = real(one / (ediff + sigma%ieta)) 2141 end if 2142 2143 gf_val = gkq_nu(1, ib_k, nu) ** 2 + gkq_nu(2, ib_k, nu) ** 2 2144 if (intra_band .and. sigma%frohl_model == 1) then 2145 gf_val = zero; if (same_band) gf_val = zpr_frohl_sphcorr(nu) * (four_pi / three * q0rad ** 3) 2146 end if 2147 2148 sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 2) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 2) + gf_val * rfact 2149 ! TODO: Add Sternheimer contribution 2150 2151 if (dtset%prteliash == 3) then 2152 ! Accumulate: |g(k,q)|^2 delta(e - e_{m\kq}) delta(w - w_\qnu} 2153 delta_e_minus_emkq = gaussian(sigma%a2f_emesh - eig0mkq, dtset%tsmear) 2154 dwargs = sigma%phmesh - phfrq(nu) 2155 dtw_weights(:, 1) = gaussian(dwargs, dtset%ph_smear) 2156 do iw=1,sigma%phmesh_size 2157 sigma%a2few(:, iw, ib_k) = sigma%a2few(:, iw, ib_k) + & 2158 delta_e_minus_emkq(:) * dtw_weights(iw, 1) * gf_val * sigma%wtq_k(iq_ibz_k) 2159 end do 2160 end if 2161 end if ! prteliash /= 0 2162 2163 do it=1,sigma%ntemp 2164 ! Compute electronic occ for this T (note mu_e(it) Fermi level) 2165 nqnu = occ_be(wqnu, sigma%kTmesh(it), zero) 2166 f_nk = occ_fd(eig0nk, sigma%kTmesh(it), sigma%mu_e(it)) 2167 f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it)) 2168 2169 ! Here we have to handle 3 different logical values leading to 9 different cases: 2170 ! 2171 ! qint_method 0 1 2172 ! use_doublegrid .true. .false. 2173 ! imag_only .true. .false. 2174 ! 2175 ! We will write this with nested conditionals using the order above 2176 2177 if (sigma%qint_method == 0) then 2178 ! ========= 2179 ! zcut mode 2180 ! ========= 2181 2182 if (sigma%use_doublegrid) then 2183 cfact = zero 2184 do jj=1,sigma%eph_doublegrid%ndiv 2185 ! Double Grid shared points weights 2186 ikq_bz_fine = sigma%eph_doublegrid%mapping(2, jj) 2187 weight = sigma%eph_doublegrid%weights_dense(ikq_bz_fine) 2188 2189 ! Electronic eigenvalue 2190 ikq_ibz_fine = sigma%eph_doublegrid%mapping(5, jj) 2191 eig0mkq = sigma%eph_doublegrid%ebands_dense%eig(ibsum_kq, ikq_ibz_fine, spin) 2192 f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it)) 2193 2194 ! Phonon frequency 2195 iq_ibz_fine = sigma%eph_doublegrid%mapping(6, jj) 2196 wqnu = sigma%ephwg%phfrq_ibz(iq_ibz_fine, nu) 2197 nqnu = occ_be(wqnu, sigma%kTmesh(it), zero) 2198 2199 if (dtset%eph_ahc_type == 1) then 2200 cfact = cfact + & 2201 ((nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + & 2202 (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta) ) * weight 2203 else 2204 cfact = cfact + ((two * nqnu + one) / (eig0nk - eig0mkq + sigma%ieta)) * weight 2205 endif 2206 enddo 2207 else 2208 ! No double-grid. 2209 if (dtset%eph_ahc_type == 1) then 2210 cfact = (nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + & 2211 (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta) 2212 else 2213 cfact = (two * nqnu + one) / (eig0nk - eig0mkq + sigma%ieta) 2214 endif 2215 endif 2216 ! 2217 if (sigma%imag_only) then 2218 simag = gkq2 * aimag(cfact) 2219 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag 2220 if (sigma%mrta > 0) then 2221 sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k) 2222 end if 2223 2224 if (dtset%eph_prtscratew == 1) then 2225 sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu 2226 sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k) 2227 end if 2228 2229 else 2230 ! Re + Im self-energy 2231 sig_cplx = gkq2 * cfact 2232 if (intra_band .and. sigma%frohl_model == 1) then 2233 ! Treat Frohlich divergence with spherical integration around the Gamma point. 2234 ! In principle one should rescale by the number of degenerate states but it's 2235 ! easier to move all the weight to a single band. 2236 sig_cplx = czero; if (same_band) sig_cplx = zpr_frohl_sphcorr(nu) * (two * f_mkq - one) 2237 end if 2238 2239 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + sig_cplx 2240 sigma%fan_vals(it, ib_k) = sigma%fan_vals(it, ib_k) + sig_cplx 2241 end if 2242 2243 else 2244 2245 ! =================== 2246 ! Tetrahedron method 2247 ! =================== 2248 if (sigma%use_doublegrid) then 2249 ! Tetra + double grid 2250 2251 do jj=1,sigma%eph_doublegrid%ndiv 2252 ! Double Grid shared points weights 2253 ikq_bz_fine = sigma%eph_doublegrid%mapping(2, jj) 2254 weight = sigma%eph_doublegrid%weights_dense(ikq_bz_fine) 2255 2256 ! Electronic eigenvalue 2257 ikq_ibz_fine = sigma%eph_doublegrid%mapping(5, jj) 2258 eig0mkq = sigma%eph_doublegrid%ebands_dense%eig(ibsum_kq, ikq_ibz_fine, spin) 2259 f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it)) 2260 2261 ! Phonon frequency 2262 iq_ibz_fine = sigma%eph_doublegrid%mapping(6, jj) 2263 wqnu = sigma%ephwg%phfrq_ibz(iq_ibz_fine,nu) 2264 nqnu = occ_be(wqnu, sigma%kTmesh(it), zero) 2265 2266 ! Add Frohlich contribution 2267 gkq2_pf = gkq2 2268 if (osc_ecut /= zero) gkq2_pf = gkq2_pf + weight_q * gkq2_lr(jj,ib_k,imyp) 2269 2270 if (sigma%imag_only) then 2271 ! Note pi factor from Sokhotski-Plemelj theorem. 2272 simag = gkq2_pf * pi * ( & 2273 (nqnu + f_mkq ) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, jj) + & 2274 (nqnu - f_mkq + one) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, jj) ) * weight 2275 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag 2276 if (sigma%mrta > 0) then 2277 sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k) 2278 end if 2279 2280 if (dtset%eph_prtscratew == 1) then 2281 sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu 2282 sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k) 2283 end if 2284 2285 else 2286 ! Re + Sigma with tetra and double grid 2287 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + gkq2_pf * ( & 2288 (nqnu + f_mkq ) * sigma%cweights(1, 1, ib_k, imyp, ibsum_kq, imyq, jj) + & 2289 (nqnu - f_mkq + one) * sigma%cweights(1, 2, ib_k, imyp, ibsum_kq, imyq, jj) ) * weight 2290 end if 2291 end do 2292 2293 else 2294 2295 ! Tetrahedron method WITHOUT double grid. 2296 if (sigma%imag_only) then 2297 ! Imag part 2298 simag = gkq2 * pi * ( & 2299 (nqnu + f_mkq ) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, 1) + & 2300 (nqnu - f_mkq + one) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, 1) ) 2301 2302 if (intra_band .and. sigma%frohl_model == 1) then 2303 ! Treat Frohlich divergence with spherical integration of deltas around the Gamma point. 2304 ! In principle one should rescale by the number of degenerate states but it's 2305 ! easier to move all the weight to a single band 2306 ! TODO: Check the sign, use convention for retarded function 2307 simag = zero 2308 if (same_band) simag = -pi * sum(sigma%frohl_deltas_sphcorr(1:2, it, ib_k, nu), dim=1) 2309 end if 2310 2311 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag 2312 if (sigma%mrta > 0) then 2313 sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k) 2314 end if 2315 2316 if (dtset%eph_prtscratew == 1) then 2317 sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu 2318 sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k) 2319 end if 2320 2321 if (dtset%ibte_prep > 0) then 2322 ! Save scattering rates. 2323 sigma%srate(ibsum_kq, ib_k, it, imyq) = sigma%srate(ibsum_kq, ib_k, it, imyq) + & 2324 gkq2 * two_pi * ( & 2325 (nqnu - f_nk + one) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, 1) + & 2326 (nqnu + f_nk ) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, 1) ) 2327 end if 2328 2329 else 2330 ! Re + Sigma with tetra and WITHOUT double grid 2331 sig_cplx = gkq2 * ( & 2332 (nqnu + f_mkq ) * sigma%cweights(1, 1, ib_k, imyp, ibsum_kq, imyq, 1) + & 2333 (nqnu - f_mkq + one) * sigma%cweights(1, 2, ib_k, imyp, ibsum_kq, imyq, 1) ) 2334 2335 if (intra_band .and. sigma%frohl_model == 1) then 2336 ! Treat Frohlich divergence with spherical integration around the Gamma point. 2337 ! In principle one should rescale by the number of degenerate states but it's 2338 ! easier to move all the weight to a single band 2339 sig_cplx = czero 2340 if (same_band) sig_cplx = zpr_frohl_sphcorr(nu) * (two * f_mkq - one) 2341 end if 2342 2343 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + sig_cplx 2344 endif 2345 end if 2346 end if 2347 2348 ! Derivative of sigma 2349 ! TODO: should calculate this with the double grid as well 2350 if (.not. sigma%imag_only) then 2351 ! Accumulate d(Re Sigma) / dw(w=eKS) for state ib_k 2352 !cfact(x) = (nqnu + f_mkq ) / (x - eig0mkq + wqnu + sigma%ieta) + & 2353 ! (nqnu - f_mkq + one) / (x - eig0mkq - wqnu + sigma%ieta) 2354 gmod2 = (eig0nk - eig0mkq + wqnu) ** 2 2355 hmod2 = (eig0nk - eig0mkq - wqnu) ** 2 2356 rfact = (nqnu + f_mkq ) * (-gmod2 + aimag(sigma%ieta)**2) / (gmod2 + aimag(sigma%ieta)**2) ** 2 + & 2357 (nqnu - f_mkq + one) * (-hmod2 + aimag(sigma%ieta)**2) / (hmod2 + aimag(sigma%ieta)**2) ** 2 2358 sigma%dvals_de0ks(it, ib_k) = sigma%dvals_de0ks(it, ib_k) + gkq2 * rfact 2359 !cfact = (nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + & 2360 ! (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta) 2361 !sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + gkq2 * cfact 2362 2363 !cfact = (eig0nk - eig0mkq + wqnu + sigma%ieta) 2364 !gmod2 = cfact * dconjg(cfact) 2365 !cfact = (eig0nk - eig0mkq - wqnu + sigma%ieta) 2366 !hmod2 = cfact * dconjg(cfact) 2367 !sigma%dvals_de0ks(it, ib_k) = sigma%dvals_de0ks(it, ib_k) + gkq2 * ( & 2368 ! (nqnu + f_mkq) * (gmod2 - two * (eig0nk - eig0mkq + wqnu) ** 2) / gmod2 ** 2 + & 2369 ! (nqnu - f_mkq + one) * (hmod2 - two * (eig0nk - eig0mkq - wqnu) ** 2) / hmod2 ** 2 & 2370 !) 2371 2372 ! Accumulate Sigma(w) for state ib_k if spectral function is wanted. 2373 if (sigma%nwr > 0) then 2374 if (sigma%qint_method == 1) then 2375 ! Tetra 2376 cfact_wr(:) = (nqnu + f_mkq ) * sigma%cweights(2:, 1, ib_k, imyp, ibsum_kq, imyq, 1) + & 2377 (nqnu - f_mkq + one) * sigma%cweights(2:, 2, ib_k, imyp, ibsum_kq, imyq, 1) 2378 else 2379 ! Zcut 2380 cfact_wr(:) = (nqnu + f_mkq ) / (sigma%wrmesh_b(:,ib_k) - eig0mkq + wqnu + sigma%ieta) + & 2381 (nqnu - f_mkq + one) / (sigma%wrmesh_b(:,ib_k) - eig0mkq - wqnu + sigma%ieta) 2382 end if 2383 cfact_wr(:) = gkq2 * cfact_wr(:) 2384 2385 if (intra_band .and. sigma%frohl_model == 1) then 2386 ! Add Frohlich correction to Sigma_nk(w) 2387 cfact_wr(:) = zero; if (same_band) cfact_wr(:) = fmw_frohl_sphcorr(:,nu,it,ib_k) 2388 end if 2389 2390 sigma%vals_wr(:,it,ib_k) = sigma%vals_wr(:,it,ib_k) + cfact_wr(:) 2391 end if ! nwr > 0 2392 end if 2393 2394 end do ! it 2395 end do ! ib_k 2396 end do ! imyp 2397 call timab(1907, 2, tsec) 2398 2399 end do ! ibsum_kq (sum over bands at k+q) 2400 call timab(1903, 2, tsec) 2401 2402 ABI_FREE(bra_kq) 2403 ABI_FREE(cgwork) 2404 ABI_FREE(h1kets_kq) 2405 ABI_FREE(kpg1_k) 2406 ABI_FREE(ffnl1) 2407 2408 if (osc_ecut /= zero) then 2409 ABI_FREE(osc_gvecq) 2410 ABI_FREE(osc_indpw) 2411 ABI_FREE(osc_ks) 2412 ABI_FREE(workq_ug) 2413 end if 2414 2415 if (imyq <= 10 .or. mod(imyq, 100) == 0) then 2416 write(msg,'(4(a,i0),a)') " k-point [",my_ikcalc,"/",sigma%my_nkcalc, "] q-point [",imyq,"/",sigma%my_nqibz_k,"]" 2417 call cwtime_report(msg, cpu, wall, gflops) 2418 end if 2419 end do ! iq_ibz_k (sum over q-points in IBZ_k) 2420 2421 call cwtime_report(" Fan-Migdal q-loop", cpu_qloop, wall_qloop, gflops_qloop) 2422 2423 ! Print cache stats. 2424 if (sigma%use_ftinterp) then 2425 call dvdb%ft_qcache%report_stats() 2426 if (dvdb%ft_qcache%v1scf_3natom_request /= xmpi_request_null) call xmpi_wait(dvdb%ft_qcache%v1scf_3natom_request, ierr) 2427 else 2428 call dvdb%qcache%report_stats() 2429 end if 2430 2431 ABI_FREE(sigma%e0vals) 2432 ABI_FREE(kets_k) 2433 ABI_FREE(gkq_atm) 2434 ABI_FREE(gkq_nu) 2435 ABI_FREE(gkq_allgather) 2436 ABI_SFREE(fmw_frohl_sphcorr) 2437 2438 if (osc_ecut /= zero) then 2439 ABI_FREE(ur_k) 2440 ABI_FREE(ur_kq) 2441 ABI_FREE(work_ur) 2442 ABI_FREE(gkq2_lr) 2443 end if 2444 2445 ! ========================= 2446 ! Compute Debye-Waller term 2447 ! ========================= 2448 if (.not. sigma%imag_only) then 2449 call cwtime(cpu_dw, wall_dw, gflops_dw, "start", msg=" Computing Debye-Waller within the rigid ion approximation...") 2450 ! Collect gkq0_atm inside qpt_comm 2451 ! FIXME: In principle it's sufficient to broadcast from itreated_q0 inside qpt_comm 2452 ! Yet, q-points are not equally distributed so this synch is detrimental. 2453 2454 call cwtime(cpu, wall, gflops, "start") 2455 call xmpi_sum(gkq0_atm, sigma%qpt_comm%value, ierr) 2456 if (dtset%eph_stern /= 0) call xmpi_sum(stern_dw, sigma%qpt_comm%value, ierr) 2457 call cwtime_report(" DW MPI synch before q-loop", cpu, wall, gflops) 2458 2459 ! Integral over IBZ(k) distributed inside qpt_comm 2460 nq = sigma%nqibz; if (sigma%symsigma == 0) nq = sigma%nqbz 2461 if (abs(sigma%symsigma) == +1) nq = sigma%nqibz_k 2462 call xmpi_split_work(nq, sigma%qpt_comm%value, q_start, q_stop) 2463 2464 do iq_ibz_k=q_start,q_stop 2465 call cwtime(cpu, wall, gflops, "start") 2466 2467 if (abs(sigma%symsigma) == 1) then 2468 ! Sum over IBZ_k 2469 qpt = sigma%qibz_k(:, iq_ibz_k); weight_q = sigma%wtq_k(iq_ibz_k) 2470 iq_ibz = sigma%ind_ibzk2ibz(1, iq_ibz_k) 2471 isym_q = sigma%ind_ibzk2ibz(2, iq_ibz_k) 2472 trev_q = sigma%ind_ibzk2ibz(6, iq_ibz_k) 2473 ! Don't test if umklapp == 0 because we use the periodic gauge: phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G) 2474 isirr_q = (isym_q == 1 .and. trev_q == 0) 2475 2476 ! Sum over IBZ 2477 ! TODO: This should be much faster but it should be tested. 2478 !qpt = sigma%qibz(:,iq_ibz_k); weight_q = sigma%wtq(iq_ibz_k) 2479 2480 call phstore%async_rotate(cryst, ifc, iq_ibz, sigma%qibz(:, iq_ibz), qpt, isym_q, trev_q) 2481 call phstore%wait(cryst, phfrq, displ_cart, displ_red) 2482 2483 ! Get phonons for this q-point. 2484 !call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red, comm=sigma%pert_comm%value) 2485 2486 else 2487 ! Sum over full BZ 2488 qpt = sigma%qbz(:, iq_ibz_k); weight_q = one / sigma%nqbz 2489 2490 ! Get phonons for this q-point. 2491 call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red, comm=sigma%pert_comm%value) 2492 end if 2493 2494 ! Sum over my phonon modes for this q-point. 2495 do imyp=1,my_npert 2496 nu = sigma%my_pinfo(3, imyp) 2497 ! Ignore acoustic or unstable modes. 2498 wqnu = phfrq(nu); if (sigma%skip_phmode(nu, wqnu, dtset%eph_phrange_w)) cycle 2499 2500 ! Get phonon occupation for all temperatures. 2501 nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero) 2502 2503 ! Compute T_pp'(q,nu) matrix in reduced coordinates. 2504 do ip2=1,natom3 2505 idir2 = mod(ip2-1, 3) + 1; ipert2 = (ip2 - idir2) / 3 + 1 2506 do ip1=1,natom3 2507 idir1 = mod(ip1-1, 3) + 1; ipert1 = (ip1 - idir1) / 3 + 1 2508 ! (k,a) (k,a')* + (k',a) (k',a')* 2509 dka = dcmplx(displ_red(1, idir1, ipert1, nu), displ_red(2, idir1, ipert1, nu)) 2510 dkap = dcmplx(displ_red(1, idir2, ipert1, nu), displ_red(2, idir2, ipert1, nu)) 2511 dkpa = dcmplx(displ_red(1, idir1, ipert2, nu), displ_red(2, idir1, ipert2, nu)) 2512 dkpap = dcmplx(displ_red(1, idir2, ipert2, nu), displ_red(2, idir2, ipert2, nu)) 2513 tpp_red(ip1, ip2) = dka * dconjg(dkap) + dkpa * dconjg(dkpap) 2514 end do 2515 end do 2516 2517 ! Sum over my bands and add (static) DW contribution for the different temperatures. 2518 do ibsum=sigma%my_bsum_start, sigma%my_bsum_stop 2519 eig0mk = ebands%eig(ibsum, ik_ibz, spin) 2520 2521 ! For each n in Sigma_nk 2522 do ib_k=1,nbcalc_ks 2523 band_ks = ib_k + bstart_ks - 1 2524 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 2525 ! 2526 ! Compute DW term following XG paper. Check prefactor. 2527 ! gkq0_atm(2, nbcalc_ks, bsum_start:bsum_stop, natom3) 2528 gdw2 = zero 2529 do ip2=1,natom3 2530 do ip1=1,natom3 2531 cfact = ( & 2532 + gkq0_atm(1, ib_k, ibsum, ip1) * gkq0_atm(1, ib_k, ibsum, ip2) & 2533 + gkq0_atm(2, ib_k, ibsum, ip1) * gkq0_atm(2, ib_k, ibsum, ip2) & 2534 + gkq0_atm(1, ib_k, ibsum, ip2) * gkq0_atm(1, ib_k, ibsum, ip1) & 2535 + gkq0_atm(2, ib_k, ibsum, ip2) * gkq0_atm(2, ib_k, ibsum, ip1) & 2536 ) 2537 ! 2538 gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact) 2539 end do 2540 end do 2541 gdw2 = gdw2 / (four * two * wqnu) 2542 ! 2543 if (dtset%eph_stern /= 0 .and. ibsum == bsum_stop) then 2544 ! Compute DW term for m > nband 2545 cfact = zero 2546 do ip2=1,natom3 2547 do ip1=1,natom3 2548 cfact = cfact + tpp_red(ip1, ip2) * cmplx(stern_dw(1,ip1,ip2,ib_k), stern_dw(2,ip1,ip2,ib_k), kind=dpc) 2549 end do 2550 end do 2551 ! There's no 1/two here because I don't symmetrize the expression. 2552 ! TODO: Test symmetrization, real quantity? add support for the different Eliashberg functions with Stern 2553 gdw2_stern = real(cfact) / (four * wqnu) 2554 end if 2555 ! 2556 ! Handle n == m and degenerate states. 2557 ediff = eig0nk - eig0mk ! SP: one cannot cycle here because the Sternheimer contribution needs to be computed 2558 ! 2559 ! Optionally, accumulate DW contribution to Eliashberg functions. 2560 if (dtset%prteliash /= 0) then 2561 if (abs(ediff) > EPHTK_WTOL) then 2562 sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 3) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 3) - gdw2 / ediff 2563 end if 2564 end if 2565 ! 2566 ! Accumulate DW for each T, add it to Sigma(e0) and Sigma(w) as well 2567 ! - (2 n_{q\nu} + 1) * gdw2 / (e_nk - e_mk) 2568 do it = 1, sigma%ntemp 2569 if (abs(ediff) > EPHTK_WTOL) then 2570 cfact = - weight_q * gdw2 * (two * nqnu_tlist(it) + one) / (ediff + sigma%ieta) 2571 else 2572 cfact = zero 2573 endif 2574 if (dtset%eph_stern /= 0 .and. ibsum == bsum_stop) then 2575 ! Add contribution due to the Sternheimer. ediff is absorbed in Sternheimer. 2576 cfact = cfact - weight_q * gdw2_stern * (two * nqnu_tlist(it) + one) 2577 cfact2 = - weight_q * gdw2_stern * (two * nqnu_tlist(it) + one) 2578 rfact = real(cfact2) 2579 sigma%dw_stern_vals(it, ib_k) = sigma%dw_stern_vals(it, ib_k) + rfact 2580 end if 2581 rfact = real(cfact) 2582 sigma%dw_vals(it, ib_k) = sigma%dw_vals(it, ib_k) + rfact 2583 sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + rfact 2584 if (sigma%nwr > 0) sigma%vals_wr(:, it, ib_k) = sigma%vals_wr(:, it, ib_k) + rfact 2585 end do 2586 2587 end do ! ib_k 2588 end do ! ibsum 2589 2590 end do ! nu 2591 2592 !if (nq < 1000 .or. (nq > 1000 .and. mod(iq_ibz_k, 200) == 0) .or. iq_ibz_k <= nprocs) then 2593 ii = iq_ibz_k - q_start 2594 if (ii <= 5 .or. mod(ii, 100) == 0) then 2595 write(msg,'(4(a,i0),a,f8.2)') " k-point [",my_ikcalc,"/",sigma%my_nkcalc, "] q-point [",iq_ibz_k,"/",nq,"]" 2596 call cwtime_report(msg, cpu, wall, gflops) 2597 end if 2598 end do ! iq_ibz_k 2599 2600 ABI_FREE(gkq0_atm) 2601 ABI_SFREE(stern_dw) 2602 call cwtime_report(" Debye-Waller", cpu_dw, wall_dw, gflops_dw, end_str=ch10) 2603 end if ! not %imag_only 2604 2605 if (dtset%prteliash /= 0) then 2606 ! Compute Eliashberg function. 2607 call cwtime(cpu, wall, gflops, "start", msg=sjoin(" Computing Eliashberg function with nomega: ", & 2608 itoa(sigma%phmesh_size))) 2609 2610 if (dtset%prteliash == 3) call xmpi_sum(sigma%a2few, sigma%pqb_comm%value, ierr) 2611 2612 ! Collect all terms on each node so that we can MPI-parallelize easily inside pqb_comm 2613 ! Note that: gf_nnuq does not include the q-weights from the integration. 2614 call xmpi_sum(sigma%gf_nnuq, sigma%pqb_comm%value, ierr) 2615 sigma%gfw_vals = zero 2616 2617 if (sigma%qint_method == 0 .or. sigma%symsigma == 0) then 2618 ! Compute Eliashberg function with gaussian method and ph_smear smearing. 2619 do iq_ibz_k=1,sigma%nqibz_k 2620 if (sigma%pqb_comm%skip(iq_ibz_k)) cycle ! MPI parallelism inside pqb_comm 2621 2622 ! Recompute phonons (cannot use sigma%ephwg in this case) 2623 call ifc%fourq(cryst, sigma%qibz_k(:,iq_ibz_k), phfrq, displ_cart) 2624 do nu=1,natom3 2625 dwargs = sigma%phmesh - phfrq(nu) 2626 dtw_weights(:, 1) = gaussian(dwargs, dtset%ph_smear) 2627 do ib_k=1,nbcalc_ks 2628 do ii=1,3 2629 sigma%gfw_vals(:, ii, ib_k) = sigma%gfw_vals(:, ii, ib_k) + & 2630 sigma%gf_nnuq(ib_k, nu, iq_ibz_k, ii) * dtw_weights(:, 1) * sigma%wtq_k(iq_ibz_k) 2631 end do 2632 end do 2633 end do 2634 end do 2635 2636 else 2637 ! Compute Eliashberg function with tetrahedron method. 2638 eminmax = [sigma%phmesh(1), sigma%phmesh(sigma%phmesh_size)] 2639 ABI_MALLOC(dt_tetra_weights, (sigma%phmesh_size, sigma%nqibz_k, 2)) 2640 do nu=1,natom3 2641 ! All procs compute weights. 2642 call sigma%ephwg%get_deltas_qibzk(nu, sigma%phmesh_size, eminmax, sigma%bcorr, dt_tetra_weights, & 2643 sigma%pqb_comm%value, with_qweights=.True.) 2644 2645 do iq_ibz_k=1,sigma%nqibz_k 2646 if (sigma%pqb_comm%skip(iq_ibz_k)) cycle ! MPI parallelism inside pqb_comm 2647 do ib_k=1,nbcalc_ks 2648 do ii=1,3 2649 sigma%gfw_vals(:, ii, ib_k) = sigma%gfw_vals(:, ii, ib_k) + & 2650 sigma%gf_nnuq(ib_k, nu, iq_ibz_k, ii) * dt_tetra_weights(:, iq_ibz_k, 1) 2651 end do 2652 end do 2653 end do 2654 end do 2655 ABI_FREE(dt_tetra_weights) 2656 end if 2657 2658 ! Collect final results. 2659 call xmpi_sum(sigma%gfw_vals, sigma%pqb_comm%value, ierr) 2660 call cwtime_report(" Eliashberg function", cpu, wall, gflops) 2661 end if 2662 2663 !ivals2 = [ignore_ks, ignore_ibsum_kq] 2664 !call xmpi_sum_master(ivals, master, sigma%pqb_comm%value) 2665 if (my_rank == master) then 2666 if (ignore_kq /= 0) write(std_out, "(a, 1x, i0)")" Number of ignored k+q points:", ignore_kq 2667 if (ignore_ibsum_kq /= 0) write(std_out, "(a, 1x, i0)")" Number of ignored (k+q, m) states:", ignore_ibsum_kq 2668 !if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then 2669 ! call wrtout(std_out, sjoin(" Total number of NSCF Sternheimer iterations:", itoa(tot_nlines_done))) 2670 !end if 2671 end if 2672 2673 ! Collect results inside pqb_comm and write results for this (k-point, spin) to NETCDF file. 2674 call sigma%gather_and_write(dtset, ebands, ikcalc, spin, sigma%pqb_comm%value) 2675 2676 ABI_SFREE(alpha_mrta) 2677 ABI_SFREE(root_bcalc) 2678 end do ! spin 2679 2680 ABI_FREE(kg_k) 2681 ABI_FREE(kg_kq) 2682 ABI_FREE(ylm_k) 2683 ABI_FREE(ylm_kq) 2684 ABI_FREE(ylmgr_kq) 2685 ABI_FREE(kpg_k) 2686 ABI_FREE(ffnlk) 2687 2688 !call abimem_report("end kcalc_loop", std_out) 2689 !call wrtout(std_out, sjoin("xmpi_count_requests", itoa(xmpi_count_requests))) 2690 2691 call cwtime_report(" One ikcalc k-point", cpu_ks, wall_ks, gflops_ks) 2692 end do ! ikcalc 2693 2694 call cwtime_report(" Sigma_eph full calculation", cpu_all, wall_all, gflops_all, end_str=ch10) 2695 2696 ! Free memory 2697 ABI_FREE(ihave_ikibz_spin) 2698 ABI_FREE(grad_berry) 2699 ABI_FREE(vtrial) 2700 ABI_FREE(work) 2701 ABI_FREE(ph1d) 2702 ABI_FREE(vlocal) 2703 ABI_FREE(nqnu_tlist) 2704 ABI_FREE(displ_cart) 2705 ABI_FREE(displ_red) 2706 ABI_FREE(tpp_red) 2707 ABI_SFREE(cfact_wr) 2708 ABI_SFREE(dwargs) 2709 ABI_SFREE(dtw_weights) 2710 ABI_SFREE(delta_e_minus_emkq) 2711 ABI_FREE(gbound_kq) 2712 ABI_FREE(osc_gbound_q) 2713 ABI_FREE(ibzspin_2ikcalc) 2714 ABI_FREE(gaussw_qnu) 2715 ABI_SFREE(vcar_ibz) 2716 2717 call gs_hamkq%free() 2718 call wfd%free() 2719 call pawcprj_free(cwaveprj0) 2720 ABI_FREE(cwaveprj0) 2721 call pawcprj_free(cwaveprj) 2722 ABI_FREE(cwaveprj) 2723 call phstore%free() 2724 call u1c%free() 2725 call sigma%free() 2726 2727 ! This to make sure that the parallel output of SIGEPH is completed 2728 call xmpi_barrier(comm) 2729 call cwtime_report(" sigmaph: MPI barrier before returning.", cpu_all, wall_all, gflops_all, end_str=ch10, comm=comm) 2730 2731 end subroutine sigmaph
m_sigmaph/sigmaph_compare [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_compare
FUNCTION
Compare the headers of two sigmaph_t instances
INPUTS
SOURCE
4173 subroutine sigmaph_compare(self, other) 4174 4175 !Arguments ------------------------------------ 4176 class(sigmaph_t),intent(in) :: self, other 4177 4178 !Local variables------------------------------- 4179 integer :: ierr 4180 4181 ! ************************************************************************* 4182 ierr = 0 4183 4184 ABI_CHECK_NOSTOP(self%nkcalc == other%nkcalc, "Difference found in nkcalc.", ierr) 4185 ABI_CHECK_NOSTOP(self%max_nbcalc == other%max_nbcalc, "Difference found in max_nbcalc.", ierr) 4186 ABI_CHECK_NOSTOP(self%nsppol == other%nsppol, "Difference found in nsppol.", ierr) 4187 ABI_CHECK_NOSTOP(self%ntemp == other%ntemp, "Difference found in ntemp.", ierr) 4188 ABI_CHECK_NOSTOP(self%nqibz == other%nqibz, "Difference found in nqibz.", ierr) 4189 ABI_CHECK_NOSTOP(self%nqbz == other%nqbz, "Difference found in nqbz.", ierr) 4190 4191 ! ====================================================== 4192 ! Read data that does not depend on the (kpt, spin) loop. 4193 ! ====================================================== 4194 ABI_CHECK_NOSTOP(self%symsigma == other%symsigma, "Different value found for symsigma.", ierr) 4195 ABI_CHECK_NOSTOP(self%nbsum == other%nbsum, "Different value found for nbsum.", ierr) 4196 ABI_CHECK_NOSTOP(self%bsum_start == other%bsum_start, "Different value found for bsum_start.", ierr) 4197 ABI_CHECK_NOSTOP(self%bsum_stop == other%bsum_stop, "Different value found for bsum_stop.", ierr) 4198 ABI_CHECK_NOSTOP(self%qint_method == other%qint_method, "Different value found for qint_method", ierr) 4199 !ABI_CHECK_NOSTOP(self%frohl_model == other%frohl_model, "Different value found for frohl_model.", ierr) 4200 ABI_CHECK_NOSTOP(self%imag_only .eqv. other%imag_only, "Difference found in imag_only", ierr) 4201 ABI_CHECK_NOSTOP(self%wr_step == other%wr_step, "Different value found for wr_step", ierr) 4202 ABI_CHECK_NOSTOP(self%ieta == other%ieta, "Different value found for zcut.", ierr) 4203 4204 ABI_CHECK_NOSTOP(all(self%ngqpt == other%ngqpt), "Different value found for ngqpt", ierr) 4205 ABI_CHECK_NOSTOP(all(self%bstart_ks == other%bstart_ks), "Different value found for bstart_ks", ierr) 4206 ABI_CHECK_NOSTOP(all(self%nbcalc_ks == other%nbcalc_ks), "Different value found for bstop_ks", ierr) 4207 ABI_CHECK_NOSTOP(all(self%kcalc == other%kcalc), "Different value found for kcalc", ierr) 4208 ABI_CHECK_NOSTOP(all(self%kcalc2ibz == other%kcalc2ibz), "Different value found for kcalc2ibz", ierr) 4209 ABI_CHECK_NOSTOP(all(self%kTmesh == other%kTmesh), "Different value found for kTmesh", ierr) 4210 ABI_CHECK_NOSTOP(all(self%mu_e == other%mu_e), "Different value found for mu_e", ierr) 4211 4212 ABI_CHECK(ierr == 0, "Fatal error in sigmaph_compare, see previous messages!") 4213 4214 end subroutine sigmaph_compare
m_sigmaph/sigmaph_free [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_free
FUNCTION
Deallocate dynamic memory
INPUTS
SOURCE
4228 subroutine sigmaph_free(self) 4229 4230 !Arguments ------------------------------------ 4231 class(sigmaph_t),intent(inout) :: self 4232 4233 !Local variables------------------------------- 4234 !integer :: ii, jj 4235 4236 ! ************************************************************************* 4237 4238 ! integer 4239 ABI_SFREE(self%bstart_ks) 4240 ABI_SFREE(self%bstop_ks) 4241 ABI_SFREE(self%nbcalc_ks) 4242 ABI_SFREE(self%kcalc2ibz) 4243 ABI_SFREE(self%my_ikcalc) 4244 ABI_SFREE(self%my_spins) 4245 ABI_SFREE(self%myq2ibz_k) 4246 ABI_SFREE(self%itreat_qibz) 4247 ABI_SFREE(self%my_pinfo) 4248 ABI_SFREE(self%pert_table) 4249 ABI_SFREE(self%phmodes_skip) 4250 ABI_SFREE(self%ind_qbz2ibz) 4251 ABI_SFREE(self%indkk_kq) 4252 ABI_SFREE(self%ind_q2dvdb_k) 4253 ABI_SFREE(self%ind_ibzk2ibz) 4254 ABI_SFREE(self%qibz2dvdb) 4255 ABI_SFREE(self%lgk_sym2glob) 4256 ABI_SFREE(self%nbsum_rank) 4257 4258 ! real 4259 ABI_SFREE(self%kcalc) 4260 ABI_SFREE(self%kTmesh) 4261 ABI_SFREE(self%mu_e) 4262 ABI_SFREE(self%e0vals) 4263 ABI_SFREE(self%vcar_calc) 4264 ABI_SFREE(self%linewidth_mrta) 4265 ABI_SFREE(self%cweights) 4266 ABI_SFREE(self%deltaw_pm) 4267 ABI_SFREE(self%wrmesh_b) 4268 ABI_SFREE(self%qvers_cart) 4269 ABI_SFREE(self%angwgth) 4270 ABI_SFREE(self%frohl_deltas_sphcorr) 4271 ABI_SFREE(self%qp_done) 4272 ABI_SFREE(self%qbz) 4273 ABI_SFREE(self%qibz) 4274 ABI_SFREE(self%wtq) 4275 ABI_SFREE(self%qibz_k) 4276 ABI_SFREE(self%wtq_k) 4277 ABI_SFREE(self%srate) 4278 ABI_SFREE(self%phmesh) 4279 ABI_SFREE(self%gf_nnuq) 4280 ABI_SFREE(self%scratew) 4281 4282 ! complex 4283 ABI_SFREE(self%vals_e0ks) 4284 ABI_SFREE(self%fan_vals) 4285 ABI_SFREE(self%fan_stern_vals) 4286 ABI_SFREE(self%dvals_de0ks) 4287 ABI_SFREE(self%dw_vals) 4288 ABI_SFREE(self%dw_stern_vals) 4289 ABI_SFREE(self%vals_wr) 4290 ABI_SFREE(self%gfw_vals) 4291 ABI_SFREE(self%a2f_emesh) 4292 ABI_SFREE(self%a2few) 4293 4294 ! datatypes. 4295 if (allocated(self%degtab)) then 4296 call degtab_array_free(self%degtab) 4297 ABI_FREE(self%degtab) 4298 end if 4299 4300 call self%ephwg%free() 4301 call self%eph_doublegrid%free() 4302 4303 ! Deallocate MPI communicators 4304 call self%pert_comm%free() 4305 call self%qpt_comm%free() 4306 call self%bsum_comm%free() 4307 call self%qb_comm%free() 4308 call self%kcalc_comm%free() 4309 call self%spin_comm%free() 4310 call self%pqb_comm%free() 4311 call self%ncwrite_comm%free() 4312 4313 ! Close netcdf file. 4314 if (self%ncid /= nctk_noid) then 4315 NCF_CHECK(nf90_close(self%ncid)) 4316 end if 4317 4318 end subroutine sigmaph_free
m_sigmaph/sigmaph_gather_and_write [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_gather_and_write
FUNCTION
Gather results from the MPI processes. Then master rank does:
1. Computes QP energies, Z factor and spectral function (if required).
2. Saves results to file.
INPUTS
ebands<ebands_t>=KS band energies. ikcalc=Index of the computed k-point spin=Spin index. prtvol= Verbosity level comm=MPI communicator.
SOURCE
4840 subroutine sigmaph_gather_and_write(self, dtset, ebands, ikcalc, spin, comm) 4841 4842 !Arguments ------------------------------------ 4843 type(dataset_type),intent(in) :: dtset 4844 integer,intent(in) :: ikcalc, spin, comm 4845 class(sigmaph_t),target,intent(inout) :: self 4846 type(ebands_t),intent(in) :: ebands 4847 4848 !Local variables------------------------------- 4849 integer,parameter :: master = 0, max_ntemp = 50 4850 integer :: ideg,ib,it,ii,iw,nstates,ierr,my_rank,band_ks,ik_ibz,ibc,ib_val,ib_cond,jj 4851 integer :: nq_ibzk_eff, nelem, imyq, iq_ibz_k, sr_ncid 4852 logical :: iwrite 4853 real(dp) :: ravg,kse,kse_prev,dw,fan0,ks_gap,kse_val,kse_cond,qpe_oms,qpe_oms_val,qpe_oms_cond 4854 real(dp) :: cpu, wall, gflops, invsig2fmts, tau, ravg2 4855 complex(dpc) :: sig0c,zc,qpe,qpe_prev,qpe_val,qpe_cond,cavg1,cavg2,cavg3,cavg4 4856 !character(len=5000) :: msg 4857 integer :: grp_ncid, ncerr 4858 !arrays 4859 integer, allocatable :: recvcounts(:), displs(:), nq_rank(:), kq_symtab(:,:), my_kq_symtab(:,:) 4860 integer, ABI_CONTIGUOUS pointer :: bids(:) 4861 real(dp) :: qp_gaps(self%ntemp),qpoms_gaps(self%ntemp) 4862 real(dp),allocatable :: aw(:,:,:), a2few_avg(:,:), gather_srate(:,:,:,:), grp_srate(:,:,:,:) 4863 real(dp) :: ks_enes(self%max_nbcalc), ze0_vals(self%ntemp, self%max_nbcalc) 4864 real(dp) :: gfw_avg(self%phmesh_size, 3) 4865 complex(dpc) :: qpoms_enes(self%ntemp, self%max_nbcalc),qp_enes(self%ntemp, self%max_nbcalc) 4866 4867 ! ************************************************************************* 4868 4869 ! Could use non-blocking communications and double buffer technique to reduce synchronisation cost... 4870 call cwtime(cpu, wall, gflops, "start", msg=" Gathering results. Waiting for other MPI processes...") 4871 4872 ! Here comm corresponds to sigma%pqb_comm%value 4873 my_rank = xmpi_comm_rank(comm) 4874 iwrite = self%ncwrite_comm%value /= xmpi_comm_null 4875 call xmpi_sum_master(self%vals_e0ks, master, comm, ierr) 4876 call xmpi_sum_master(self%fan_vals, master, comm, ierr) 4877 call xmpi_sum_master(self%fan_stern_vals, master, comm, ierr) 4878 call xmpi_sum_master(self%dvals_de0ks, master, comm, ierr) 4879 call xmpi_sum_master(self%dw_vals, master, comm, ierr) 4880 call xmpi_sum_master(self%dw_stern_vals, master, comm, ierr) 4881 if (self%nwr > 0) call xmpi_sum_master(self%vals_wr, master, comm, ierr) 4882 if (self%mrta > 0) call xmpi_sum_master(self%linewidth_mrta, master, comm, ierr) 4883 if (dtset%eph_prtscratew == 1) then 4884 ! Collect spectral decomposition of scattering rates, multiply by two since so far we have stored Imag(Sigma) (ph_w) 4885 call xmpi_sum_master(self%scratew, master, comm, ierr) 4886 self%scratew = two * self%scratew 4887 end if 4888 4889 if (dtset%ibte_prep > 0) then 4890 ! FIXME: Handle kpoint/spin parallelism. 4891 ! (%bsum_start:%bsum_stop, %nbcalc_ks(ikcalc, spin), %ntemp, %nqibz_k)) 4892 ! Sum over phonon modes 4893 call xmpi_sum(self%srate, self%pert_comm%value, ierr) 4894 !call xmpi_sum(self%srate, self%pb_comm%value), ierr) 4895 4896 ! Use gatherv to collect data and tables on the IO proc i.e. the master proc in qpt_comm. 4897 ! Only the number of q-points changes across the qpt-procs and this is the last dimension. 4898 ! nq_ibzk_eff is the total number of effective q-points in the IBZ(k). 4899 ABI_CALLOC(nq_rank, (self%qpt_comm%nproc)) 4900 call xmpi_allgather(self%my_nqibz_k, nq_rank, self%qpt_comm%value, ierr) 4901 4902 nq_ibzk_eff = sum(nq_rank) 4903 nelem = self%nbsum * self%nbcalc_ks(ikcalc, spin) * self%ntemp 4904 !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs) 4905 ABI_MALLOC(recvcounts, (self%qpt_comm%nproc)) 4906 ABI_MALLOC(displs, (self%qpt_comm%nproc)) 4907 4908 recvcounts = nelem * nq_rank(:) 4909 displs(1) = 0 4910 do ii=2,self%qpt_comm%nproc 4911 displs(ii) = sum(nq_rank(1:ii-1)) * nelem 4912 end do 4913 4914 ABI_MALLOC(gather_srate, (self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp, nq_ibzk_eff)) 4915 4916 call xmpi_gatherv(self%srate, nelem * self%my_nqibz_k, gather_srate, recvcounts, displs, master, self%qpt_comm%value, ierr) 4917 !ABI_CHECK(all(abs(gather_srate - self%srate) < tol12), "This only if nproc == 1") 4918 !ABI_CHECK(nq_ibzk_eff == self%my_nqibz_k, "This only if nproc == 1") 4919 4920 if (.not. iwrite) then 4921 ABI_FREE(gather_srate) 4922 end if 4923 4924 ABI_MALLOC(my_kq_symtab, (6, self%my_nqibz_k)) 4925 do imyq=1,self%my_nqibz_k 4926 iq_ibz_k = self%myq2ibz_k(imyq) 4927 my_kq_symtab(:, imyq) = self%indkk_kq(:, iq_ibz_k) 4928 end do 4929 4930 !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs) 4931 displs(1) = 0; nelem = 6 4932 do ii=2,self%qpt_comm%nproc 4933 displs(ii) = sum(nq_rank(1:ii-1)) * nelem 4934 end do 4935 recvcounts = nq_rank * nelem 4936 4937 ABI_MALLOC(kq_symtab, (nelem, nq_ibzk_eff)) 4938 call xmpi_gatherv(my_kq_symtab, nelem * self%my_nqibz_k, kq_symtab, recvcounts, displs, master, self%qpt_comm%value, ierr) 4939 !ABI_CHECK(all(abs(kq_symtab - my_kq_symtab) < tol12), "kq_symtab") 4940 4941 if (.not. iwrite) then 4942 ABI_FREE(kq_symtab) 4943 end if 4944 4945 ABI_FREE(nq_rank) 4946 ABI_FREE(my_kq_symtab) 4947 ABI_FREE(recvcounts) 4948 ABI_FREE(displs) 4949 end if 4950 4951 call cwtime_report(" Sigma_nk gather", cpu, wall, gflops, comm=comm) 4952 4953 ! Only procs inside ncwrite_comm perform IO (ab_out and ncid) 4954 if (.not. iwrite) return 4955 4956 ik_ibz = self%kcalc2ibz(ikcalc, 1) 4957 4958 if (self%a2f_ne > 0) then 4959 ABI_MALLOC(a2few_avg, (self%a2f_ne, self%phmesh_size)) 4960 end if 4961 4962 if (self%symsigma == +1) then 4963 ! Average self-energy matrix elements in the degenerate subspace. 4964 do ideg=1,size(self%degtab(ikcalc, spin)%bids) 4965 bids => self%degtab(ikcalc, spin)%bids(ideg)%vals 4966 nstates = size(bids) 4967 4968 ! Symmetrize Eliashberg function 4969 if (dtset%prteliash > 0) then 4970 gfw_avg = sum(self%gfw_vals(:, :, bids(:)), dim=3) / nstates 4971 do ii=1,nstates 4972 self%gfw_vals(:, :, bids(ii)) = gfw_avg 4973 end do 4974 if (self%a2f_ne > 0) then 4975 a2few_avg = sum(self%a2few(:, :, bids(:)), dim=3) / nstates 4976 do ii=1,nstates 4977 self%a2few(:, :, bids(ii)) = a2few_avg 4978 end do 4979 end if 4980 end if 4981 4982 do it=1,self%ntemp 4983 ! Average QP(T) and Z(T). 4984 cavg1 = sum(self%vals_e0ks(it, bids(:))) / nstates 4985 cavg2 = sum(self%dvals_de0ks(it, bids(:))) / nstates 4986 cavg3 = sum(self%fan_vals(it, bids(:))) / nstates 4987 cavg4 = sum(self%fan_stern_vals(it, bids(:))) / nstates 4988 ravg = sum(self%dw_vals(it, bids(:))) / nstates 4989 ravg2 = sum(self%dw_stern_vals(it, bids(:))) / nstates 4990 do ii=1,nstates 4991 self%vals_e0ks(it, bids(ii)) = cavg1 4992 self%dvals_de0ks(it, bids(ii)) = cavg2 4993 self%fan_vals(it, bids(ii)) = cavg3 4994 self%fan_stern_vals(it, bids(ii)) = cavg4 4995 self%dw_vals(it, bids(ii)) = ravg 4996 self%dw_stern_vals(it, bids(ii)) = ravg2 4997 end do 4998 4999 ! Average TAU_MRTA 5000 if (self%mrta > 0) then 5001 ravg = sum(self%linewidth_mrta(it, bids(:))) / nstates 5002 do ii=1,nstates 5003 self%linewidth_mrta(it, bids(ii)) = ravg 5004 end do 5005 end if 5006 5007 if (self%nwr > 0) then 5008 ! Average Sigma(omega, T) 5009 do iw=1,self%nwr 5010 cavg1 = sum(self%vals_wr(iw, it, bids(:))) / nstates 5011 do ii=1,nstates 5012 self%vals_wr(iw, it, bids(ii)) = cavg1 5013 end do 5014 end do 5015 end if 5016 end do ! it 5017 end do ! ideg 5018 end if ! symsigma == +1 5019 5020 ABI_SFREE(a2few_avg) 5021 5022 ! Compute QP energies and Gaps (Note that I'm assuming a non-magnetic semiconductor!) 5023 ib_val = nint(ebands%nelect / (two / ebands%nspinor)); ib_cond = ib_val + 1 5024 kse_val = huge(one) * tol6; kse_cond = huge(one) * tol6 5025 qp_enes = huge(one) * tol6; qpoms_enes = huge(one) * tol6 5026 ks_enes = huge(one) * tol6; ze0_vals = huge(one) * tol6 5027 ks_gap = -one; qpoms_gaps = -one; qp_gaps = -one 5028 5029 ! Write legend. 5030 if (ikcalc == 1 .and. spin == 1) then 5031 write(ab_out,"(a)")repeat("=", 80) 5032 write(ab_out,"(a)")" Final results in eV." 5033 write(ab_out,"(a)")" Notations:" 5034 write(ab_out,"(a)")" eKS: Kohn-Sham energy. eQP: quasi-particle energy." 5035 write(ab_out,"(a)")" eQP - eKS: Difference between the QP and the KS energy." 5036 write(ab_out,"(a)")" SE1(eKS): Real part of the self-energy computed at the KS energy, SE2 for imaginary part." 5037 write(ab_out,"(a)")" Z(eKS): Renormalization factor." 5038 write(ab_out,"(a)")" FAN: Real part of the Fan term at eKS. DW: Debye-Waller term." 5039 write(ab_out,"(a)")" DeKS: KS energy difference between this band and band-1, DeQP same meaning but for eQP." 5040 write(ab_out,"(a)")" OTMS: On-the-mass-shell approximation with eQP ~= eKS + Sigma(omega=eKS)" 5041 write(ab_out,"(a)")" TAU(eKS): Lifetime in femtoseconds computed at the KS energy." 5042 write(ab_out,"(a)")" mu_e: Fermi level for given (T, nelect)" 5043 write(ab_out,"(a)")" " 5044 write(ab_out,"(a)")" " 5045 end if 5046 5047 do it=1,self%ntemp 5048 5049 ! Write header. 5050 if (it <= max_ntemp) then 5051 if (self%nsppol == 1) then 5052 write(ab_out,"(3a,f6.1,a,f8.3)") & 5053 "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", T: ", self%kTmesh(it) / kb_HaK, & 5054 " [K], mu_e: ", self%mu_e(it) * Ha_eV 5055 else 5056 write(ab_out,"(3a,i1,a,f6.1,a,f8.3)") & 5057 "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", spin: ", spin, ", T: ",self%kTmesh(it) / kb_HaK, & 5058 " [K], mu_e: ", self%mu_e(it) * Ha_eV 5059 end if 5060 if (self%imag_only) then 5061 ! TODO: Add tau^SERTA, tau^MRTA, and v tau, ps instead of fmts? 5062 write(ab_out,"(a)")" B eKS SE2(eKS) TAU(eKS) DeKS" 5063 else 5064 write(ab_out,"(a)")" B eKS eQP eQP-eKS SE1(eKS) SE2(eKS) Z(eKS) FAN(eKS) DW DeKS DeQP" 5065 end if 5066 end if 5067 5068 do ibc=1,self%nbcalc_ks(ikcalc, spin) 5069 band_ks = self%bstart_ks(ikcalc, spin) + ibc - 1 5070 kse = ebands%eig(band_ks, ik_ibz, spin) 5071 ks_enes(ibc) = kse 5072 sig0c = self%vals_e0ks(it, ibc) 5073 dw = self%dw_vals(it, ibc) 5074 fan0 = real(sig0c) - dw 5075 ! Compute QP energies with On-the-Mass-Shell approximation and first renormalization i.e. Z(eKS) 5076 ! TODO: Note that here I use the full Sigma including the imaginary part 5077 !zc = one / (one - self%dvals_de0ks(it, ibc)) 5078 zc = one / (one - real(self%dvals_de0ks(it, ibc))) 5079 ze0_vals(it, ibc) = real(zc) 5080 qpe = kse + real(zc) * real(sig0c) 5081 qpe_oms = kse + real(sig0c) 5082 if (ibc == 1) then 5083 kse_prev = kse; qpe_prev = qpe 5084 end if 5085 if (band_ks == ib_val) then 5086 kse_val = kse; qpe_val = qpe; qpe_oms_val = qpe_oms 5087 end if 5088 if (band_ks == ib_cond) then 5089 kse_cond = kse; qpe_cond = qpe; qpe_oms_cond = qpe_oms 5090 end if 5091 5092 if (it <= max_ntemp) then 5093 if (self%imag_only) then 5094 ! 1/tau = 2 Imag(Sigma) 5095 invsig2fmts = Time_Sec * 1e+15 / two 5096 tau = 999999.0_dp 5097 if (abs(aimag(sig0c)) > tol16) tau = invsig2fmts / abs(aimag(sig0c)) 5098 tau = min(tau, 999999.0_dp) 5099 write(ab_out, "(i4,2(f8.3,1x),f8.1,1x,f8.3)") & 5100 band_ks, kse * Ha_eV, aimag(sig0c) * Ha_eV, tau, (kse - kse_prev) * Ha_eV 5101 else 5102 write(ab_out, "(i4, 10(f8.3,1x))") & 5103 band_ks, kse * Ha_eV, real(qpe) * Ha_eV, (real(qpe) - kse) * Ha_eV, & 5104 real(sig0c) * Ha_eV, aimag(sig0c) * Ha_eV, real(zc), & 5105 fan0 * Ha_eV, dw * Ha_eV, (kse - kse_prev) * Ha_eV, real(qpe - qpe_prev) * Ha_eV 5106 end if 5107 end if 5108 5109 if (ibc > 1) then 5110 kse_prev = kse; qpe_prev = qpe 5111 end if 5112 qpoms_enes(it, ibc) = qpe_oms 5113 qp_enes(it, ibc) = qpe 5114 if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then 5115 ! We have enough states to compute the gap. 5116 if (it == 1) ks_gap = kse_cond - kse_val 5117 qpoms_gaps(it) = qpe_oms_cond - qpe_oms_val 5118 qp_gaps(it) = real(qpe_cond - qpe_val) 5119 end if 5120 end do ! ibc 5121 5122 ! Print KS and QP gaps. 5123 if (it <= max_ntemp) then 5124 if (.not. self%imag_only) then 5125 if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then 5126 write(ab_out, "(a)")" " 5127 write(ab_out, "(a,f8.3,1x,2(a,i0),a)")" KS gap: ",ks_gap * Ha_eV, & 5128 "(assuming bval:", ib_val, " ==> bcond:", ib_cond, ")" 5129 write(ab_out, "(2(a,f8.3),a)")" QP gap: ",qp_gaps(it) * Ha_eV," (OTMS: ",qpoms_gaps(it) * Ha_eV, ")" 5130 write(ab_out, "(2(a,f8.3),a)")" QP_gap - KS_gap: ",(qp_gaps(it) - ks_gap) * Ha_eV,& 5131 " (OTMS: ",(qpoms_gaps(it) - ks_gap) * Ha_eV, ")" 5132 write(ab_out, "(a)")" " 5133 end if 5134 else 5135 if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then 5136 write(ab_out, "(a)")" " 5137 write(ab_out, "(a,f8.3,1x,2(a,i0),a)")" KS gap: ",ks_gap * Ha_eV, "(assuming bval:",ib_val," ==> bcond:",ib_cond,")" 5138 write(ab_out, "(a)")" " 5139 end if 5140 end if 5141 5142 write(ab_out, "(a)")repeat("=", 92) 5143 end if 5144 5145 end do ! it 5146 5147 if (self%ntemp > max_ntemp .and. (ikcalc == 1 .and. spin == 1)) then 5148 write(ab_out, "(a,i0,a)")" No more than ", max_ntemp, " temperatures are written to the main output file." 5149 write(ab_out, "(2a)")" Please use SIGEPH.nc file and AbiPy to analyze the results.",ch10 5150 end if 5151 5152 if (dtset%prtvol > 0 .and. (ikcalc == 1 .and. spin == 1)) then 5153 if (allocated(self%gfw_vals)) then 5154 write(ab_out, "(2a)")" omega and Eliashberg function gf_{nk}(omega) for testing purposes:" 5155 iw = (self%phmesh_size / 2) 5156 do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5) 5157 band_ks = self%bstart_ks(ikcalc, spin) + ib - 1 5158 write(ab_out, "(a, i0)")"For band:", band_ks 5159 do jj=0,1 5160 write(ab_out, "(4(f8.3,2x))")self%phmesh(iw+jj), (self%gfw_vals(iw+jj, ii, ib), ii=1,3) 5161 end do 5162 end do 5163 write(ab_out, "(a)")ch10 5164 end if 5165 5166 if (self%nwr >= 3) then 5167 write(ab_out, "(2a)")ch10," omega and Sigma_nk(omega, T=1) in eV for testing purposes:" 5168 it = 1; iw = (self%nwr / 2) 5169 do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5) 5170 band_ks = self%bstart_ks(ikcalc, spin) + ib - 1 5171 write(ab_out, "(a, i0)")"For band:", band_ks 5172 do ii=0,1 5173 write(ab_out, "(3(f8.3,2x))")self%wrmesh_b(iw+ii, ib) * Ha_eV, self%vals_wr(iw+ii, it, ib) * Ha_eV 5174 end do 5175 end do 5176 write(ab_out, "(a)")ch10 5177 end if 5178 end if 5179 5180 call flush_unit(ab_out) 5181 5182 ! Write self-energy matrix elements for this (kpt, spin) 5183 ! NB: Only master writes 5184 ! (use, intrinsic :: iso_c_binding to associate a real pointer to complex data because netcdf does not support complex types). 5185 ! Well, cannot use c_loc with gcc <= 4.8 due to internal compiler error so use c2r and stack memory. 5186 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), c2r(self%vals_e0ks), start=[1,1,1,ikcalc,spin])) 5187 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), c2r(self%vals_e0ks), start=[1,1,1,ikcalc,spin])) 5188 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "fan_vals"), c2r(self%fan_vals), start=[1,1,1,ikcalc,spin])) 5189 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "fan_stern_vals"), c2r(self%fan_stern_vals), start=[1,1,1,ikcalc,spin])) 5190 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dvals_de0ks"), c2r(self%dvals_de0ks), start=[1,1,1,ikcalc,spin])) 5191 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_vals"), self%dw_vals, start=[1,1,ikcalc,spin])) 5192 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_stern_vals"), self%dw_stern_vals, start=[1,1,ikcalc,spin])) 5193 5194 ! Dump QP energies and gaps for this (kpt, spin) 5195 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_enes"), c2r(qpoms_enes), start=[1,1,1,ikcalc,spin])) 5196 5197 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_enes"), c2r(qp_enes), start=[1,1,1,ikcalc,spin])) 5198 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ze0_vals"), ze0_vals, start=[1,1,ikcalc,spin])) 5199 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_enes"), ks_enes, start=[1,ikcalc,spin])) 5200 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_gaps"), ks_gap, start=[ikcalc,spin])) 5201 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_gaps"), qpoms_gaps, start=[1,ikcalc,spin])) 5202 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_gaps"), qp_gaps, start=[1,ikcalc,spin])) 5203 5204 if (self%mrta > 0) then 5205 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "linewidth_mrta"), self%linewidth_mrta, start=[1,1,ikcalc,spin])) 5206 end if 5207 5208 if (dtset%eph_prtscratew == 1) then 5209 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "scratew"), self%scratew, start=[1,1,1,1,ikcalc,spin])) 5210 end if 5211 5212 !if (self%frohl_model == 1 .and. self%imag_only) then 5213 ! ncerr = nf90_put_var(self%ncid, nctk_idname(self%ncid, "frohl_deltas_sphcorr"), & 5214 ! self%frohl_deltas_sphcorr, start=[1,1,1,1, ikcalc, spin]) 5215 ! NCF_CHECK(ncerr) 5216 !end if 5217 5218 ! Write frequency dependent data. 5219 if (self%nwr > 0) then 5220 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "wrmesh_b"), self%wrmesh_b, start=[1,1,ikcalc,spin])) 5221 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_wr"), c2r(self%vals_wr), start=[1,1,1,1,ikcalc,spin])) 5222 5223 ! Compute spectral function. 5224 ! A = -1/pi [Im Sigma(ww)] / ([ww - ee - Re Sigma(ww)] ** 2 + Im Sigma(ww) ** 2]) 5225 ABI_MALLOC(aw, (self%nwr, self%ntemp, self%max_nbcalc)) 5226 do ib=1,self%nbcalc_ks(ikcalc, spin) 5227 band_ks = self%bstart_ks(ikcalc, spin) + ib - 1 5228 kse = ebands%eig(band_ks, ik_ibz, spin) 5229 do it=1,self%ntemp 5230 aw(:, it, ib) = -piinv * aimag(self%vals_wr(:, it, ib)) / & 5231 ((self%wrmesh_b(:, ib) - kse - real(self%vals_wr(:, it, ib))) ** 2 + aimag(self%vals_wr(:, it, ib)) ** 2) 5232 end do 5233 end do 5234 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "spfunc_wr"), aw, start=[1, 1, 1, ikcalc, spin])) 5235 ABI_FREE(aw) 5236 end if 5237 5238 ! Write Eliashberg functions 5239 if (allocated(self%gfw_vals)) then 5240 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "gfw_vals"), self%gfw_vals, start=[1, 1, 1, ikcalc, spin])) 5241 end if 5242 if (allocated(self%a2few)) then 5243 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "a2few"), self%a2few, start=[1, 1, 1, ikcalc, spin])) 5244 end if 5245 5246 if (dtset%ibte_prep > 0) then 5247 call wrtout(std_out, " Writing scattering matrix elements to disk...") 5248 ! Get ncid of group used to store scattering rate (ragged array implemented with netcdf groups). 5249 ! FIXME: Unfortunately, this algo cannot be used if parallelism over kcalc/spin is on since 5250 ! we have to change the metadata at runtime. 5251 sr_ncid = self%ncid 5252 NCF_CHECK(nf90_inq_ncid(sr_ncid, strcat("srate_k", itoa(ikcalc), "_s", itoa(spin)), grp_ncid)) 5253 5254 ! Define dimensions and arrays inside group at runtime 5255 ncerr = nctk_def_dims(grp_ncid, [ & 5256 nctkdim_t("lgk_nsym", self%lgk_nsym), & 5257 nctkdim_t("nbcalc", self%nbcalc_ks(ikcalc, spin)), & 5258 nctkdim_t("nbsum", self%bsum_stop - self%bsum_start + 1), & 5259 nctkdim_t("nq_ibzk_eff", nq_ibzk_eff) & 5260 ], defmode=.True.) 5261 NCF_CHECK(ncerr) 5262 5263 ncerr = nctk_def_arrays(grp_ncid, [ & 5264 nctkarr_t("lgk_sym2glob", "int", "two, lgk_nsym"), & 5265 nctkarr_t("kq_symtab", "int", "six, nq_ibzk_eff"), & 5266 nctkarr_t("srate", "dp", "nq_ibzk_eff, nbsum, nbcalc, ntemp") & 5267 ]) 5268 NCF_CHECK(ncerr) 5269 5270 ! Write data. 5271 NCF_CHECK(nctk_set_datamode(sr_ncid)) 5272 NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "lgk_sym2glob"), self%lgk_sym2glob)) 5273 NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "kq_symtab"), kq_symtab)) 5274 ABI_FREE(kq_symtab) 5275 5276 ! Move q-points to first dimensions before writing. 5277 ABI_MALLOC(grp_srate, (nq_ibzk_eff, self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp)) 5278 do ii=1,nq_ibzk_eff 5279 grp_srate(ii,:,:,:) = gather_srate(:,:,:,ii) 5280 end do 5281 NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "srate"), grp_srate)) 5282 ABI_FREE(gather_srate) 5283 ABI_FREE(grp_srate) 5284 end if 5285 5286 ! Write restart flag 5287 self%qp_done(ikcalc, spin) = 1 5288 NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_done"), 1, start=[ikcalc, spin])) 5289 5290 ! Dump the cache to file. This is necessary to ensure we can restart. 5291 NCF_CHECK(nf90_sync(self%ncid)) 5292 5293 call cwtime_report(" Sigma_nk netcdf output", cpu, wall, gflops) 5294 5295 end subroutine sigmaph_gather_and_write
m_sigmaph/sigmaph_get_all_qweights [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_get_all_qweights
FUNCTION
Compute all the weights for q-space integration using the tetrahedron method
INPUTS
cryst<crystal_t>=Crystalline structure ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) spin: Spin index ikcalc: Index of the self-energy k-point in the kcalc array. comm: MPI communicator
OUTPUT
SOURCE
5431 subroutine sigmaph_get_all_qweights(sigma, cryst, ebands, spin, ikcalc, comm) 5432 5433 !Arguments ------------------------------------ 5434 !scalars 5435 class(sigmaph_t),intent(inout) :: sigma 5436 type(ebands_t),intent(in) :: ebands 5437 type(crystal_t),intent(in) :: cryst 5438 integer,intent(in) :: ikcalc, spin, comm 5439 5440 !Local variables ------------------------------ 5441 !scalars 5442 integer :: nu, ibsum_kq, ik_ibz, bstart_ks, nbcalc_ks, my_rank, natom3 5443 integer :: nprocs, imyp, imyq, ndiv, bsum_start, bsum_stop, ib_k, band_ks 5444 integer :: iq_ibz_fine,iq_bz_fine,iq_ibz,jj, nz 5445 real(dp) :: weight, cpu,wall, gflops, eig0nk 5446 !arrays 5447 real(dp) :: kk(3), kq(3), qpt(3), dpm(2) 5448 real(dp),allocatable :: tmp_deltaw_pm(:,:,:) 5449 complex(dpc),allocatable :: zvals(:,:), tmp_cweights(:,:,:,:) 5450 5451 ! ************************************************************************* 5452 5453 call cwtime(cpu, wall, gflops, "start") 5454 5455 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 5456 5457 kk = sigma%kcalc(:, ikcalc) 5458 ik_ibz = sigma%kcalc2ibz(ikcalc, 1) 5459 nbcalc_ks = sigma%nbcalc_ks(ikcalc, spin) 5460 bstart_ks = sigma%bstart_ks(ikcalc, spin) 5461 bsum_start = sigma%bsum_start; bsum_stop = sigma%bsum_stop 5462 natom3 = 3 * cryst%natom 5463 ndiv = 1; if (sigma%use_doublegrid) ndiv = sigma%eph_doublegrid%ndiv 5464 5465 ABI_CHECK(abs(sigma%symsigma) == 1, "symsigma 0 with tetra not implemented") 5466 5467 if (sigma%imag_only) then 5468 ! Weights for Im (tetrahedron, eta --> 0) 5469 ABI_REMALLOC(sigma%deltaw_pm, (2, nbcalc_ks, sigma%my_npert, bsum_start:bsum_stop, sigma%my_nqibz_k, ndiv)) 5470 sigma%deltaw_pm = zero 5471 5472 ! Temporary weights (on the fine IBZ_k mesh if double grid is used) 5473 ABI_MALLOC(tmp_deltaw_pm, (1, sigma%ephwg%nq_k, 2)) 5474 5475 ! Loop over bands to sum 5476 do ibsum_kq=sigma%bsum_start, sigma%bsum_stop 5477 ! Loop over my phonon modes 5478 do imyp=1,sigma%my_npert 5479 nu = sigma%my_pinfo(3, imyp) 5480 5481 ! HM: This one should be faster but uses more memory, I compute for each ib instead 5482 ! Compute weights inside qb_comm 5483 !call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, nbcalc_ks, & 5484 ! ebands%eig(bstart_ks:bstart_ks+nbcalc_ks, ik_ibz, spin), & 5485 ! sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value) 5486 5487 ! loop over bands in self-energy matrix elements. 5488 do ib_k=1,nbcalc_ks 5489 band_ks = ib_k + bstart_ks - 1 5490 eig0nk = ebands%eig(band_ks, ik_ibz, spin) 5491 5492 ! Compute weights inside qb_comm 5493 call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, 1, [eig0nk], sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value) 5494 5495 ! For all the q-points that I am going to calculate 5496 do imyq=1,sigma%my_nqibz_k 5497 iq_ibz = sigma%myq2ibz_k(imyq) 5498 5499 if (sigma%use_doublegrid) then 5500 ! For all the q-points in the microzone 5501 ! This is done again in the main sigmaph routine 5502 qpt = sigma%qibz_k(:,iq_ibz) 5503 kq = kk + qpt 5504 call sigma%eph_doublegrid%get_mapping(kk, kq, qpt) 5505 do jj=1,sigma%eph_doublegrid%ndiv 5506 iq_bz_fine = sigma%eph_doublegrid%mapping(3,jj) 5507 iq_ibz_fine = sigma%eph_doublegrid%bz2lgkibz(iq_bz_fine) 5508 weight = sigma%ephwg%lgk%weights(iq_ibz_fine) 5509 !dpm = tmp_deltaw_pm(ib_k, iq_ibz_fine, :) 5510 dpm = tmp_deltaw_pm(1, iq_ibz_fine, :) 5511 sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, jj) = dpm / weight 5512 end do 5513 else 5514 weight = sigma%ephwg%lgk%weights(iq_ibz) 5515 !dpm = tmp_deltaw_pm(ib_k, iq_ibz, :) 5516 dpm = tmp_deltaw_pm(1, iq_ibz, :) 5517 sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, 1) = dpm / weight 5518 end if 5519 5520 end do 5521 end do 5522 end do 5523 end do 5524 5525 ABI_FREE(tmp_deltaw_pm) 5526 5527 else 5528 ! Both real and imag part --> compute \int 1/z with tetrahedron. 5529 ! Note that we still need a finite i.eta in the expression (hopefully smaller than the default value). 5530 ! Besides we have to take into account the case in which the spectral function is wanted. 5531 ! Derivative wrt omega is still computed with finite i.eta, though. 5532 ABI_CHECK(.not. sigma%use_doublegrid, "double grid for Re-Im not implemented") 5533 5534 ! TODO: This part should be tested. 5535 nz = 1; if (sigma%nwr > 0) nz = 1 + sigma%nwr 5536 ABI_REMALLOC(sigma%cweights, (nz,2,nbcalc_ks,sigma%my_npert,sigma%my_bsum_start:sigma%my_bsum_stop,sigma%my_nqibz_k,ndiv)) 5537 ABI_MALLOC(tmp_cweights, (nz, 2, nbcalc_ks, sigma%nqibz_k)) 5538 5539 ! Initialize z-points for Sigma_{nk} for different n bands. 5540 ABI_MALLOC(zvals, (nz, nbcalc_ks)) 5541 zvals(1, :) = sigma%e0vals + sigma%ieta 5542 if (sigma%nwr > 0) zvals(2:sigma%nwr+1, :) = sigma%wrmesh_b(:, 1:nbcalc_ks) + sigma%ieta 5543 5544 ! Loop over my bands in self-energy sum. 5545 ! TODO: Really slow if nz >> 1. Possible solutions: 5546 ! 1) reduce the number of ibsum_kq bands for which tetra must be used. 5547 ! 2) use spline with non-linear mesh 5548 ! 3) use asyntotic expansion at "large" z 5549 do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop 5550 ! Loop over my phonon modes 5551 do imyp=1,sigma%my_npert 5552 nu = sigma%my_pinfo(3, imyp) 5553 5554 ! cweights(nz, 2, nbsigma, self%nq_k) 5555 call sigma%ephwg%get_zinv_weights(nz, nbcalc_ks, zvals, ibsum_kq, spin, nu, sigma%zinv_opt, tmp_cweights, & 5556 xmpi_comm_self) 5557 !sigma%qpt_comm%value) 5558 !erange= 5559 !use_bzsum=sigma%symsigma == 0) 5560 5561 ! Extract weights for all the q-points that I am going to calculate. 5562 do imyq=1,sigma%my_nqibz_k 5563 iq_ibz = sigma%myq2ibz_k(imyq) 5564 weight = sigma%ephwg%lgk%weights(iq_ibz) 5565 sigma%cweights(:, :, :, imyp, ibsum_kq, imyq, 1) = tmp_cweights(:, :, :, iq_ibz) / weight 5566 end do 5567 end do 5568 end do 5569 5570 ABI_FREE(zvals) 5571 ABI_FREE(tmp_cweights) 5572 end if 5573 5574 call cwtime_report(" get_all_qweights with tetrahedron", cpu, wall, gflops) 5575 5576 end subroutine sigmaph_get_all_qweights
m_sigmaph/sigmaph_get_ebands [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_get_ebands
FUNCTION
Read quantities from the sigmaph to an ebands_t structure and return mapping
INPUTS
ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) opt=integer option selecting what to read on the ebands object. 1-only mapping, 10+n-read n temperature linewidths
SOURCE
4046 type(ebands_t) function sigmaph_get_ebands(self, cryst, ebands, brange, kcalc2ebands, linewidths, velocity, comm) result(new) 4047 4048 !Arguments ----------------------------------------------- 4049 integer,intent(in) :: comm 4050 class(sigmaph_t),intent(in) :: self 4051 type(crystal_t),intent(in) :: cryst 4052 type(ebands_t),intent(in) :: ebands 4053 integer,intent(in) :: brange(2) 4054 integer, allocatable, intent(out) :: kcalc2ebands(:,:) 4055 real(dp), allocatable, intent(out) :: linewidths(:,:,:,:,:), velocity(:,:,:,:) 4056 4057 !Local variables ----------------------------------------- 4058 !scalars 4059 integer,parameter :: master = 0 4060 integer :: spin, ikpt, ikcalc, iband, itemp, nsppol, nkpt, timrev, band_ks, bstart_ks, nbcalc_ks, mband 4061 integer :: bmin, bmax, my_rank, ierr 4062 integer :: ncerr 4063 type(krank_t) :: krank 4064 character(len=5000) :: msg 4065 !arrays 4066 !integer,allocatable :: kcalc2ebands(:,:) 4067 4068 ! ************************************************************************* 4069 4070 my_rank = xmpi_comm_rank(comm) 4071 4072 ! copy useful dimensions 4073 nsppol = self%nsppol; nkpt = ebands%nkpt 4074 4075 ! Map input ebands kpoints to kcalc k-points stored in sigmaph file. 4076 ABI_MALLOC(kcalc2ebands, (6, self%nkcalc)) 4077 timrev = kpts_timrev_from_kptopt(ebands%kptopt) 4078 4079 krank = krank_from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.) 4080 4081 if (kpts_map("symrec", timrev, cryst, krank, self%nkcalc, self%kcalc, kcalc2ebands) /= 0) then 4082 write(msg, '(3a)' ) & 4083 "Error mapping input ebands%kptns to sigmaph kcalc",ch10,& 4084 "the k-point could not be generated from a symmetrical one" 4085 ABI_ERROR(msg) 4086 end if 4087 call krank%free() 4088 4089 ! store mapping to return 4090 !if (present(kcalc2ebands)) then 4091 ! ABI_MALLOC(kcalc2ebands, (self%nkcalc)) 4092 ! kcalc2ebands(:) = indkk(1, :) 4093 !end if 4094 4095 ! Allocate using only the relevant bands for transport 4096 ! including valence states to allow to compute different doping 4097 ! MG: TODO: Do we really need this! 4098 mband = maxval(self%bstop_ks) 4099 new = ebands_chop(ebands, 1, mband) 4100 !mband = ebands%mband 4101 !call ebands_copy(ebands, new) 4102 !bmin = 1; bmax = mband 4103 bmin = brange(1); bmax = brange(2) 4104 4105 ! Read linewidths from sigmaph file. 4106 ! Use global array (mband, nkpt, nsppol) but keep in mind that results in SIGPEPH are packed 4107 ! so that only the relevant k-points are stored on file. 4108 4109 ABI_CALLOC(velocity, (3, bmin:bmax, nkpt, nsppol)) 4110 ABI_CALLOC(linewidths, (self%ntemp, bmin:bmax, nkpt, nsppol, 2)) 4111 4112 if (my_rank == master) then 4113 do spin=1,nsppol 4114 do ikcalc=1,self%nkcalc 4115 bstart_ks = self%bstart_ks(ikcalc, spin) 4116 nbcalc_ks = self%nbcalc_ks(ikcalc, spin) 4117 do iband=1,nbcalc_ks 4118 ! band index in global array. 4119 band_ks = iband + bstart_ks - 1 4120 ! kcalc --> ibz index 4121 ikpt = kcalc2ebands(1, ikcalc) 4122 4123 do itemp=1,self%ntemp 4124 ! Read SERTA lifetimes 4125 ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), & 4126 linewidths(itemp, band_ks, ikpt, spin, 1), start=[2, itemp, iband, ikcalc, spin]) 4127 NCF_CHECK(ncerr) 4128 4129 ! Read MRTA lifetimes 4130 ! TODO: This should be called half_linewidth_mrta since 4131 ! in m_rta we multiply by two to get tau = 1/(2 Imag(sigma)) 4132 if (self%mrta > 0) then 4133 ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "linewidth_mrta"), & 4134 linewidths(itemp, band_ks, ikpt, spin, 2), start=[itemp, iband, ikcalc, spin]) 4135 NCF_CHECK(ncerr) 4136 end if 4137 end do 4138 4139 ! Read band velocities computed only of the kcalc k-points. 4140 ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "vcar_calc"), & 4141 velocity(:, band_ks, ikpt, spin), start=[1, iband, ikcalc, spin]) 4142 NCF_CHECK(ncerr) 4143 end do 4144 end do 4145 end do 4146 end if 4147 4148 !ABI_FREE(indkk) 4149 4150 ! This so that output linewidths are always positive independently 4151 ! of the kind of self-energy used (retarded or advanced) 4152 linewidths = abs(linewidths) 4153 4154 call xmpi_bcast(linewidths, master, comm, ierr) 4155 call xmpi_bcast(velocity, master, comm, ierr) 4156 4157 end function sigmaph_get_ebands
m_sigmaph/sigmaph_new [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_new
FUNCTION
Creation method (allocates memory, initialize data from input vars).
INPUTS
dtset<dataset_type>=All input variables for this dataset. ecut=Cutoff energy for wavefunctions. cryst<crystal_t>=Crystalline structure ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) ifc<ifc_type>=interatomic force constants and corresponding real space grid info. dtfil<datafiles_type>=variables related to files. comm=MPI communicator
SOURCE
2754 type(sigmaph_t) function sigmaph_new(dtset, ecut, cryst, ebands, ifc, dtfil, comm) result(new) 2755 2756 !Arguments ------------------------------------ 2757 integer,intent(in) :: comm 2758 real(dp),intent(in) :: ecut 2759 type(crystal_t),intent(in) :: cryst 2760 type(dataset_type),intent(in) :: dtset 2761 type(ebands_t),intent(in) :: ebands 2762 type(ifc_type),intent(in) :: ifc 2763 !type(dvdb_t),intent(in) :: dvdb 2764 type(datafiles_type),intent(in) :: dtfil 2765 2766 !Local variables ------------------------------ 2767 !scalars 2768 integer,parameter :: master = 0, istwfk1 = 1 2769 integer :: my_rank,ik,my_nshiftq,my_mpw,cnt,nprocs,ik_ibz,ndeg, iq_ibz, qptopt, qtimrev 2770 integer :: onpw, ii, ipw, ierr, spin, gap_err, ikcalc, qprange_, bstop !it, 2771 integer :: jj, bstart, natom, natom3 !, ip, iatom, idir, pertcase, 2772 integer :: isym_k, trev_k, mband, i1,i2,i3, nrest, color 2773 logical :: downsample 2774 character(len=fnlen) :: wfk_fname_dense 2775 character(len=5000) :: msg 2776 real(dp) :: estep, cpu_all, wall_all, gflops_all, cpu, wall, gflops 2777 logical :: changed, isirr_k 2778 type(ebands_t) :: tmp_ebands, ebands_dense 2779 type(gaps_t) :: gaps 2780 type(krank_t) :: krank, qrank 2781 !arrays 2782 integer :: intp_nshiftk 2783 integer :: intp_kptrlatt(3,3), g0_k(3), units(2), indkk_k(6,1), my_gmax(3), band_block(2), qptrlatt(3,3) 2784 integer,allocatable :: temp(:,:), gtmp(:,:),degblock(:,:), degblock_all(:,:,:,:), ndeg_all(:,:), iperm(:) 2785 real(dp):: params(4), my_shiftq(3,1), kk(3), kq(3), intp_shiftk(3) 2786 ! integer :: inwr, jnwr, min_nwr 2787 ! integer :: array_nwr(12) 2788 #ifdef HAVE_MPI 2789 integer,parameter :: ndims = 5 2790 integer :: comm_cart, me_cart 2791 logical :: reorder 2792 integer :: dims(ndims) 2793 logical :: periods(ndims), keepdim(ndims) 2794 #endif 2795 2796 ! ************************************************************************* 2797 2798 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 2799 2800 call cwtime(cpu_all, wall_all, gflops_all, "start") 2801 call cwtime(cpu, wall, gflops, "start") 2802 2803 units = [std_out, ab_out] 2804 2805 ! Copy important dimensions. 2806 new%nsppol = ebands%nsppol; new%nspinor = ebands%nspinor; mband = dtset%mband 2807 natom = cryst%natom; natom3 = cryst%natom * 3 2808 2809 ! Re-Im or Im only? 2810 new%imag_only = .False. 2811 if (dtset%eph_task == -4) then 2812 new%imag_only = .True. 2813 new%mrta = 1 ! Compute lifetimes in the MRTA approximation? Default is yes 2814 !if (dtset%userie == 1) new%mrta = 0 2815 end if 2816 2817 ! TODO: Remove qint_method, use eph_intmeth or perhaps dtset%qint_method dtset%kint_method 2818 ! FIXME: Tetra gives positive SIGE2 while zcut gives negative (retarded) 2819 ! Decide default behaviour for Re-Im/Im 2820 new%qint_method = dtset%eph_intmeth - 1 2821 new%phwinfact = dtset%eph_phwinfact 2822 2823 ! Define option for integration of 1/z with tetrahedron method. 2824 new%zinv_opt = 1; if (dtset%userie /= 0) new%zinv_opt = dtset%userie 2825 2826 ! Broadening parameter from zcut 2827 new%ieta = + j_dpc * dtset%zcut 2828 2829 ! Define q-mesh for integration of the self-energy. 2830 ! Either q-mesh from DVDB (no interpolation) or eph_ngqpt_fine (Fourier interpolation if q not in DDB) 2831 new%ngqpt = dtset%ddb_ngqpt; my_nshiftq = 1; my_shiftq(:,1) = dtset%ddb_shiftq 2832 if (all(dtset%eph_ngqpt_fine /= 0)) then 2833 new%ngqpt = dtset%eph_ngqpt_fine; my_shiftq = 0 2834 end if 2835 2836 ! Setup IBZ, weights and BZ. 2837 ! Assume qptopt == kptopt unless value is specified in input 2838 qptrlatt = 0; qptrlatt(1, 1) = new%ngqpt(1); qptrlatt(2, 2) = new%ngqpt(2); qptrlatt(3, 3) = new%ngqpt(3) 2839 !my_shiftq(:,1) = [0.1, 0, 0] 2840 qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 2841 qtimrev = kpts_timrev_from_kptopt(qptopt) 2842 call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, my_nshiftq, my_shiftq, & 2843 new%nqibz, new%qibz, new%wtq, new%nqbz, new%qbz, bz2ibz=new%ind_qbz2ibz) 2844 2845 ! HM: the bz2ibz produced above is incomplete, I do it here using listkk 2846 ABI_MALLOC(temp, (6, new%nqbz)) 2847 2848 qrank = krank_from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.) 2849 if (kpts_map("symrec", qtimrev, cryst, qrank, new%nqbz, new%qbz, temp) /= 0) then 2850 ABI_ERROR("Cannot map qBZ to qIBZ!") 2851 end if 2852 2853 call qrank%free() 2854 2855 new%ind_qbz2ibz(1,:) = temp(1,:) 2856 new%ind_qbz2ibz(2,:) = temp(2,:) 2857 new%ind_qbz2ibz(3,:) = temp(6,:) 2858 new%ind_qbz2ibz(4,:) = temp(3,:) 2859 new%ind_qbz2ibz(5,:) = temp(4,:) 2860 new%ind_qbz2ibz(6,:) = temp(5,:) 2861 ABI_FREE(temp) 2862 !END DEBUG 2863 2864 ! Build (linear) mesh of K * temperatures. tsmesh(1:3) = [start, step, num] 2865 call dtset%get_ktmesh(new%ntemp, new%kTmesh) 2866 2867 gaps = ebands_get_gaps(ebands, gap_err) 2868 2869 ! Frequency mesh for sigma(w) and spectral functions. 2870 ! TODO: Use GW variables but change default 2871 !dtset%freqspmin 2872 new%nwr = dtset%nfreqsp; new%wr_step = zero 2873 if (new%nwr > 0) then 2874 ! ! For fft to work in some machines nwr must be a multiple of 3 or 5 only 2875 ! array_nwr(:) = 1 2876 ! min_nwr = new%nwr 2877 ! do inwr=1,12 2878 ! do jnwr=1,inwr 2879 ! array_nwr(jnwr) = 3 2880 ! end do 2881 ! if (ABS(product(array_nwr) - new%nwr) < min_nwr .and. product(array_nwr) - new%nwr > zero) min_nwr = product(array_nwr)- new%nwr 2882 ! if (product(array_nwr) > new%nwr) go to 1010 2883 ! do jnwr=1, inwr 2884 ! array_nwr(jnwr) = 5 2885 ! if (ABS(product(array_nwr) - new%nwr) < min_nwr .and. product(array_nwr) - new%nwr > zero) min_nwr = product(array_nwr)- new%nwr 2886 ! end do 2887 ! 2888 ! end do 2889 2890 ! 1010 new%nwr = new%nwr + min_nwr 2891 if (mod(new%nwr, 2) == 0) new%nwr = new%nwr + 1 2892 new%wr_step = two * eV_Ha / (new%nwr - 1) 2893 if (dtset%freqspmax /= zero) new%wr_step = dtset%freqspmax / (new%nwr - 1) 2894 end if 2895 2896 ! ====================================================== 2897 ! Select k-point and bands where corrections are wanted 2898 ! ====================================================== 2899 ! 2900 ! if symsigma == +1, we have to include all degenerate states in the set 2901 ! because the final QP corrections will be obtained by averaging the results in the degenerate subspace. 2902 ! We initialize IBZ(k) here so that we have all the basic dimensions of the run and it's possible 2903 ! to distribuite the calculations among processors. 2904 new%symsigma = dtset%symsigma; new%timrev = kpts_timrev_from_kptopt(ebands%kptopt) 2905 2906 call cwtime_report(" sigmaph_new: k-points", cpu, wall, gflops) 2907 2908 ! TODO: nkcalc should be spin dependent (similar piece of code in m_gwr). 2909 if (dtset%nkptgw /= 0) then 2910 2911 ! Treat the k-points and bands specified in the input file via kptgw and bdgw. 2912 call sigtk_kcalc_from_nkptgw(dtset, mband, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks) 2913 2914 else 2915 2916 if (any(abs(dtset%sigma_erange) > zero)) then 2917 ! Use sigma_erange and (optionally) sigma_ngkpt 2918 call sigtk_kcalc_from_erange(dtset, cryst, ebands, gaps, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks, comm) 2919 2920 else 2921 ! Use qp_range to select the interesting k-points and the corresponding bands. 2922 ! 2923 ! 0 --> Compute the QP corrections only for the fundamental and the direct gap. 2924 ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num` 2925 ! bands above and below the Fermi level. 2926 ! -num --> Compute the QP corrections for all the k-points in the irreducible zone. 2927 ! Include all occupied states and `num` empty states. 2928 2929 qprange_ = dtset%gw_qprange 2930 if (gap_err /= 0 .and. qprange_ == 0) then 2931 ABI_WARNING("Cannot compute fundamental and direct gap (likely metal). Will replace qprange 0 with qprange 1") 2932 qprange_ = 1 2933 end if 2934 2935 if (qprange_ /= 0) then 2936 call sigtk_kcalc_from_qprange(dtset, cryst, ebands, qprange_, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks) 2937 else 2938 ! qprange is not specified in the input. 2939 ! Include direct and fundamental KS gap or include states depending on the position wrt band edges. 2940 call sigtk_kcalc_from_gaps(dtset, ebands, gaps, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks) 2941 end if 2942 end if 2943 2944 end if ! nkptgw /= 0 2945 2946 ! The k-point and the symmetries connecting the BZ k-point to the IBZ. 2947 ABI_MALLOC(new%kcalc2ibz, (new%nkcalc, 6)) 2948 if (abs(new%symsigma) == 1) then 2949 ABI_MALLOC(new%degtab, (new%nkcalc, new%nsppol)) 2950 end if 2951 2952 ! Workspace arrays used to compute degeneracy tables. 2953 ABI_ICALLOC(degblock_all, (2, mband, new%nkcalc, new%nsppol)) 2954 ABI_ICALLOC(ndeg_all, (new%nkcalc, new%nsppol)) 2955 2956 krank = krank_from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.) 2957 ierr = 0 2958 2959 do ikcalc=1,new%nkcalc 2960 if (mod(ikcalc, nprocs) /= my_rank) then 2961 new%kcalc2ibz(ikcalc, :) = 0 2962 new%bstart_ks(ikcalc, :) = 0 2963 new%nbcalc_ks(ikcalc, :) = 0 2964 cycle ! MPI parallelism inside comm 2965 end if 2966 2967 ! Note symrel and use_symrel. 2968 ! These are the conventions for the symmetrization of the wavefunctions used in cgtk_rotate. 2969 kk = new%kcalc(:, ikcalc) 2970 2971 if (kpts_map("symrel", new%timrev, cryst, krank, 1, kk, indkk_k) /= 0) then 2972 write(msg, '(11a)' )& 2973 "The WFK file cannot be used to compute self-energy corrections at k-point: ",trim(ktoa(kk)),ch10,& 2974 "The k-point cannot be generated from a symmetrical one.", ch10,& 2975 "q-mesh: ",trim(ltoa(new%ngqpt)),", k-mesh (from kptrlatt): ",trim(ltoa(get_diag(dtset%kptrlatt))),ch10, & 2976 'Action: check your WFK file and the (k, q) point input variables.' 2977 ABI_ERROR(msg) 2978 end if 2979 2980 ! TODO: Invert dims and update abipy 2981 new%kcalc2ibz(ikcalc, :) = indkk_k(:, 1) 2982 2983 ik_ibz = indkk_k(1,1); isym_k = indkk_k(2,1) 2984 trev_k = indkk_k(6, 1); g0_k = indkk_k(3:5,1) 2985 isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0)) 2986 !kk_ibz = ebands%kptns(:,ik_ibz) 2987 if (.not. isirr_k) then 2988 ABI_WARNING(sjoin("The k-point in Sigma_{nk} must be in the IBZ but got:", ktoa(kk))) 2989 ierr = ierr + 1 2990 end if 2991 2992 ! We will have to average the QP corrections over degenerate states if symsigma=1 is used. 2993 ! Here we make sure that all the degenerate states are included. 2994 ! Store also band indices of the degenerate sets, used to average final results. 2995 if (abs(new%symsigma) == 1) then 2996 cnt = 0 2997 do spin=1,new%nsppol 2998 bstop = new%bstart_ks(ikcalc, spin) + new%nbcalc_ks(ikcalc, spin) - 1 2999 call ebands_enclose_degbands(ebands, ik_ibz, spin, new%bstart_ks(ikcalc, spin), bstop, changed, TOL_EDIFF, & 3000 degblock=degblock) 3001 if (changed) then 3002 new%nbcalc_ks(ikcalc, spin) = bstop - new%bstart_ks(ikcalc, spin) + 1 3003 cnt = cnt + 1 3004 if (cnt < 5) then 3005 write(msg,'(2(a,i0),2a,2(1x,i0))') & 3006 "Not all the degenerate states for ikcalc: ",ikcalc,", spin: ",spin,ch10, & 3007 "were included in the bdgw set. bdgw has been automatically changed to: ",new%bstart_ks(ikcalc, spin), bstop 3008 ABI_COMMENT(msg) 3009 end if 3010 write(msg,'(2(a,i0),2a)') & 3011 "The number of included states: ", bstop, & 3012 " is larger than the number of bands in the input ",dtset%nband(ik_ibz + (spin-1)*ebands%nkpt),ch10,& 3013 "Action: Increase nband." 3014 ABI_CHECK(bstop <= dtset%nband(ik_ibz + (spin-1)*ebands%nkpt), msg) 3015 end if 3016 3017 ! Store band indices used for averaging (shifted by bstart_ks) 3018 ndeg = size(degblock, dim=2) 3019 ndeg_all(ikcalc, spin) = ndeg 3020 degblock_all(:, 1:ndeg, ikcalc, spin) = degblock(:, 1:ndeg) 3021 3022 ABI_FREE(degblock) 3023 end do 3024 end if ! symsigma 3025 end do ! ikcalc 3026 3027 call krank%free() 3028 ABI_CHECK(ierr == 0, "kptgw wavevectors must be in the IBZ read from the WFK file.") 3029 3030 ! Collect data 3031 call xmpi_sum(new%kcalc2ibz, comm, ierr) 3032 call xmpi_sum(new%bstart_ks, comm, ierr) 3033 call xmpi_sum(new%nbcalc_ks, comm, ierr) 3034 3035 ! Build degtab tables. 3036 if (abs(new%symsigma) == 1) then 3037 call xmpi_sum(ndeg_all, comm, ierr) 3038 call xmpi_sum(degblock_all, comm, ierr) 3039 do ikcalc=1,new%nkcalc 3040 do spin=1,new%nsppol 3041 ndeg = ndeg_all(ikcalc, spin) 3042 ABI_MALLOC(new%degtab(ikcalc, spin)%bids, (ndeg)) 3043 do ii=1,ndeg 3044 cnt = degblock_all(2, ii, ikcalc, spin) - degblock_all(1, ii, ikcalc, spin) + 1 3045 ABI_MALLOC(new%degtab(ikcalc, spin)%bids(ii)%vals, (cnt)) 3046 new%degtab(ikcalc, spin)%bids(ii)%vals = [(jj, jj= & 3047 degblock_all(1, ii, ikcalc, spin) - new%bstart_ks(ikcalc, spin) + 1, & 3048 degblock_all(2, ii, ikcalc, spin) - new%bstart_ks(ikcalc, spin) + 1)] 3049 end do 3050 end do 3051 end do 3052 end if 3053 ABI_FREE(degblock_all) 3054 ABI_FREE(ndeg_all) 3055 3056 call cwtime_report(" sigmaph_new: kptgw", cpu, wall, gflops) 3057 3058 ! Now we can finally compute max_nbcalc 3059 new%max_nbcalc = maxval(new%nbcalc_ks) 3060 3061 ABI_MALLOC(new%bstop_ks, (new%nkcalc, new%nsppol)) 3062 new%bstop_ks = new%bstart_ks + new%nbcalc_ks - 1 3063 3064 ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ. 3065 ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work 3066 ! used to symmetrize the wavefunctions in G-space. 3067 ! Note that we loop over the full BZ instead of the IBZ(k) 3068 ! This part is slow for very dense meshes, should try to use a geometrical approach... 3069 3070 new%mpw = 0; new%gmax = 0; cnt = 0 3071 do ik=1,new%nkcalc 3072 kk = new%kcalc(:, ik) 3073 do i3=-1,1 3074 do i2=-1,1 3075 do i1=-1,1 3076 cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism inside comm 3077 kq = kk + half * [i1, i2, i3] 3078 ! TODO: g0 umklapp here can enter into play gmax may not be large enough! 3079 call get_kg(kq, istwfk1, 1.1_dp * ecut, cryst%gmet, onpw, gtmp) 3080 new%mpw = max(new%mpw, onpw) 3081 do ipw=1,onpw 3082 do ii=1,3 3083 new%gmax(ii) = max(new%gmax(ii), abs(gtmp(ii, ipw))) 3084 end do 3085 end do 3086 ABI_FREE(gtmp) 3087 end do 3088 end do 3089 end do 3090 end do 3091 3092 my_mpw = new%mpw; call xmpi_max(my_mpw, new%mpw, comm, ierr) 3093 my_gmax = new%gmax; call xmpi_max(my_gmax, new%gmax, comm, ierr) 3094 3095 call wrtout(std_out, sjoin(' Optimal value of mpw:', itoa(new%mpw), "gmax:", ltoa(new%gmax))) 3096 call cwtime_report(" sigmaph_new: mpw", cpu, wall, gflops) 3097 3098 ! Define number of bands included in self-energy summation as well as the band range. 3099 ! This value depends on the kind of calculation as imag_only can take advantage of 3100 ! the energy window aroud the band edges. 3101 ! 3102 ! Notes about MPI version. 3103 ! If eph_task == -4: 3104 ! Loops are MPI parallelized over bands so that we can distribute memory for wavefunctions over nband. 3105 ! perturbations and q-points in the IBZ can also be distributed. 3106 ! 3107 ! If eph_task == -4: 3108 ! Loops are MPI parallelized over q-points 3109 ! wavefunctions are NOT distributed but only states between my_bsum_start and my_bsum_stop 3110 ! are allocated and read from file. 3111 ! perturbations and q-points in the IBZ can also be distributed. 3112 3113 new%wmax = 1.1_dp * abs(ifc%omega_minmax(2)) 3114 if (new%qint_method == 0) new%wmax = new%wmax + five * dtset%zcut 3115 ! TODO: One should be consistent with tolerances when using tetra + q-point filtering. 3116 !if (new%qint_method == 1) new%wmax = new%wmax + five * dtset%zcut 3117 !new%wmax = new%wmax + five * dtset%zcut 3118 !write(std_out,*)"wmax:", new%wmax * Ha_eV, " (eV)" 3119 3120 new%elow = huge(one); new%ehigh = - huge(one) 3121 do spin=1,new%nsppol 3122 do ikcalc=1,new%nkcalc 3123 ik_ibz = new%kcalc2ibz(ikcalc, 1) 3124 bstart = new%bstart_ks(ikcalc, spin) 3125 bstop = new%bstart_ks(ikcalc, spin) + new%nbcalc_ks(ikcalc, spin) - 1 3126 new%ehigh = max(new%ehigh, maxval(ebands%eig(bstart:bstop, ik_ibz, spin)) + new%wmax) 3127 new%elow = min(new%elow, minval(ebands%eig(bstart:bstop, ik_ibz, spin)) - new%wmax) 3128 end do 3129 end do 3130 !call wrtout(std_out, sjoin("elow:", ftoa(elow), "ehigh:", ftoa(ehigh), "[Ha]")) 3131 3132 if (new%imag_only) then 3133 3134 if (all(dtset%sigma_bsum_range /= 0)) then 3135 new%bsum_start = max(dtset%sigma_bsum_range(1), 1) 3136 new%bsum_stop = min(dtset%sigma_bsum_range(2), mband) 3137 new%nbsum = new%bsum_stop - new%bsum_start + 1 3138 new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop 3139 else 3140 ! Compute the min/max KS energy to be included in the imaginary part. 3141 ! ifc%omega_minmax(2) comes froms the coarse Q-mesh of the DDB so increase it by 10%. 3142 ! Also take into account the Lorentzian function if zcut is used. 3143 ! In principle this should be large enough but it seems that the linewidths in v8[160] are slightly affected. 3144 ! Select indices for energy window. 3145 3146 call ebands_get_bands_from_erange(ebands, new%elow, new%ehigh, new%bsum_start, new%bsum_stop) 3147 new%bsum_stop = min(new%bsum_stop, mband) 3148 ABI_CHECK(new%bsum_start <= new%bsum_stop, "bsum_start > bsum_bstop") 3149 new%nbsum = new%bsum_stop - new%bsum_start + 1 3150 new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop 3151 end if 3152 3153 !if (dtset%useria == 567) then 3154 ! ! Uncomment this part to use all states to debug. 3155 ! call wrtout(units, "- Setting bstart to 1 and bstop to nband for debugging purposes") 3156 ! new%nbsum = mband; new%bsum_start = 1; new%bsum_stop = new%bsum_start + new%nbsum - 1 3157 ! new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop 3158 !end if 3159 3160 else 3161 ! Re + Im 3162 new%bsum_start = 1; new%bsum_stop = mband 3163 if (all(dtset%sigma_bsum_range /= 0)) then 3164 new%bsum_start = max(dtset%sigma_bsum_range(1), 1) 3165 new%bsum_stop = min(dtset%sigma_bsum_range(2), mband) 3166 end if 3167 new%nbsum = new%bsum_stop - new%bsum_start + 1 3168 end if 3169 3170 ! ======================== 3171 ! === MPI DISTRIBUTION === 3172 ! ======================== 3173 ! Init for sequential execution. 3174 new%my_npert = natom3 3175 3176 if (any(dtset%eph_np_pqbks /= 0)) then 3177 ! Use parameters from input file. 3178 new%pert_comm%nproc = dtset%eph_np_pqbks(1) 3179 new%qpt_comm%nproc = dtset%eph_np_pqbks(2) 3180 new%bsum_comm%nproc = dtset%eph_np_pqbks(3) 3181 new%kcalc_comm%nproc = dtset%eph_np_pqbks(4) 3182 new%spin_comm%nproc = dtset%eph_np_pqbks(5) 3183 new%my_npert = natom3 / new%pert_comm%nproc 3184 ABI_CHECK(new%my_npert > 0, "pert_comm_nproc cannot be greater than 3 * natom.") 3185 ABI_CHECK(mod(natom3, new%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3 * natom.") 3186 if (new%imag_only .and. new%bsum_comm%nproc /= 1) then 3187 ABI_ERROR("Nprocs in bsum_comm should be 1 when computing Imag(Sigma)") 3188 end if 3189 else 3190 ! Automatic grid generation. 3191 3192 ! TODO: Spin 3193 ! Automatic grid generation over q-points and spins. 3194 !if (new%nsppol == 2 .and. mod(nprocs, 2) == 0) then 3195 ! spin_comm%nproc = 2 3196 ! new%qpt_comm%nproc = nprocs / 2 3197 !else 3198 ! new%qpt_comm%nproc = nprocs 3199 !end if 3200 3201 ! Handle parallelism over perturbations first. 3202 ! Use MPI communicator to distribute the 3 * natom perturbations to reduce memory requirements for DFPT potentials. 3203 ! Ideally, perturbations are equally distributed --> total number of CPUs should be divisible by 3 * natom. 3204 ! or at least, divisible by one integer i for i in [2, 3 * natom - 1]. 3205 3206 ! Try to have 3 perts per proc first because the q-point parallelism is more efficient. 3207 ! The memory for W(R,r,ipert) will increase though. 3208 !do cnt=natom,2,-1 3209 ! if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then 3210 ! new%pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit 3211 ! end if 3212 !end do 3213 3214 if (new%pert_comm%nproc == 1) then 3215 ! Try again with more procs. 3216 do cnt=natom3,2,-1 3217 if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then 3218 new%pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit 3219 end if 3220 end do 3221 end if 3222 3223 if (new%my_npert == natom3 .and. nprocs > 1) then 3224 ABI_WARNING("The number of MPI procs should be divisible by 3*natom to reduce memory requirements!") 3225 end if 3226 3227 ! Define number of procs for q-points and bands. nprocs is divisible by pert_comm%nproc. 3228 if (new%imag_only) then 3229 ! Just one extra MPI level for q-points. 3230 new%qpt_comm%nproc = nprocs / new%pert_comm%nproc 3231 else 3232 ! Try to distribute equally nbsum first. 3233 nrest = nprocs / new%pert_comm%nproc 3234 do bstop=nrest,1,-1 3235 if (mod(new%nbsum, bstop) == 0 .and. mod(nprocs, new%pert_comm%nproc * bstop) == 0) then 3236 new%bsum_comm%nproc = bstop; new%qpt_comm%nproc = nrest / new%bsum_comm%nproc 3237 exit 3238 end if 3239 end do 3240 end if 3241 end if 3242 3243 ! Consistency check. 3244 if (new%pert_comm%nproc * new%qpt_comm%nproc * new%bsum_comm%nproc * new%kcalc_comm%nproc * new%spin_comm%nproc /= nprocs) then 3245 write(msg, "(a,i0,3a, 6(a,1x,i0))") & 3246 "Cannot create 5d Cartesian grid with total nprocs: ", nprocs, ch10, & 3247 "Idle processes are not supported. The product of the `nprocs_*` vars should be equal to nprocs.", ch10, & 3248 "pert_nproc (", new%pert_comm%nproc, ") x qpt_nproc (", new%qpt_comm%nproc, ") x bsum_nproc (", new%bsum_comm%nproc, & 3249 ") x kcalc_nproc (", new%kcalc_comm%nproc, ") x spin_nproc (", new%spin_comm%nproc, ") != ", nprocs 3250 ABI_ERROR(msg) 3251 end if 3252 3253 new%coords_pqbks = 0 3254 #ifdef HAVE_MPI 3255 ! Create 5d cartesian communicator: 3*natom perturbations, q-points in IBZ, bands in Sigma sum, kpoints in Sigma_k, spins 3256 ! FIXME: Fix spin 3257 periods(:) = .False.; reorder = .False. 3258 dims = [new%pert_comm%nproc, new%qpt_comm%nproc, new%bsum_comm%nproc, new%kcalc_comm%nproc, new%spin_comm%nproc] 3259 ! Try New distrib ? 3260 !dims = [new%pert_comm%nproc, new%bsum_comm%nproc, new%qpt_comm%nproc, new%kcalc_comm%nproc, new%spin_comm%nproc] 3261 3262 call MPI_CART_CREATE(comm, ndims, dims, periods, reorder, comm_cart, ierr) 3263 ! Find the index and coordinates of the current processor 3264 call MPI_COMM_RANK(comm_cart, me_cart, ierr) 3265 call MPI_CART_COORDS(comm_cart, me_cart, ndims, new%coords_pqbks, ierr) 3266 3267 ! Create communicator to distribute natom3 perturbations. 3268 keepdim = .False.; keepdim(1) = .True.; call new%pert_comm%from_cart_sub(comm_cart, keepdim) 3269 ! Create communicator for qpoints in self-energy integration. 3270 keepdim = .False.; keepdim(2) = .True.; call new%qpt_comm%from_cart_sub(comm_cart, keepdim) 3271 ! Create communicator for bands for self-energy summation 3272 keepdim = .False.; keepdim(3) = .True.; call new%bsum_comm%from_cart_sub(comm_cart, keepdim) 3273 ! Create communicator for kpoints. 3274 keepdim = .False.; keepdim(4) = .True.; call new%kcalc_comm%from_cart_sub(comm_cart, keepdim) 3275 ! Create communicator for spins. 3276 keepdim = .False.; keepdim(5) = .True.; call new%spin_comm%from_cart_sub(comm_cart, keepdim) 3277 ! Create communicator for the (band_sum, qpoint_sum) loops 3278 keepdim = .False.; keepdim(2:3) = .True.; call new%qb_comm%from_cart_sub(comm_cart, keepdim) 3279 ! Create communicator for the (perturbation, band_sum, qpoint_sum) 3280 keepdim = .False.; keepdim(1:3) = .True.; call new%pqb_comm%from_cart_sub(comm_cart, keepdim) 3281 3282 call xmpi_comm_free(comm_cart) 3283 #endif 3284 3285 ! Distribute k-points and create mapping to ikcalc index. 3286 call xmpi_split_cyclic(new%nkcalc, new%kcalc_comm%value, new%my_nkcalc, new%my_ikcalc) 3287 ABI_CHECK(new%my_nkcalc > 0, sjoin("nkcalc (", itoa(new%nkcalc), ") < kcalc_comm_nproc (", itoa(new%kcalc_comm%nproc), ")")) 3288 3289 ! Distribute spins and create mapping to spin index. 3290 if (new%nsppol == 2) then 3291 call xmpi_split_block(new%nsppol, new%spin_comm%value, new%my_nspins, new%my_spins) 3292 ABI_CHECK(new%my_nspins > 0, sjoin("nsppol (", itoa(new%nsppol), ") < spin_comm_nproc (", itoa(new%spin_comm%nproc), ")")) 3293 else 3294 ! No nsppol parallelism DOH! 3295 new%my_nspins = 1 3296 ABI_MALLOC(new%my_spins, (new%my_nspins)) 3297 new%my_spins = 1 3298 end if 3299 3300 ! Create MPI communicator for parallel netcdf IO used to write results for the different k-points. 3301 ! This communicator is defined only on the processes that will perform IO. 3302 call new%ncwrite_comm%set_to_null() 3303 3304 if (new%kcalc_comm%nproc == 1 .and. new%spin_comm%nproc == 1) then 3305 ! Easy-peasy: only master in comm_world performs IO. 3306 if (my_rank == master) call new%ncwrite_comm%set_to_self() 3307 else 3308 ! Create subcommunicator by selecting one proc per kpoint-spin subgrid. 3309 ! Since we write to ab_out in sigmaph_gather_and_write, make sure that ab_out is connected! 3310 ! This means Sigma_nk resuls will be spread among multiple ab_out files. 3311 ! Only SIGPEPH.nc will contain all the results. 3312 ! Remember that now all nc define operations must be done inside ncwrite_comm 3313 ! Obviously I'm assuming HDF5 + MPI-IO 3314 ! 3315 ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which the calling 3316 ! MPI process will be placed is MPI_COMM_NULL 3317 3318 color = xmpi_undefined; if (all(new%coords_pqbks(1:3) == 0)) color = 1 3319 call xmpi_comm_split(comm, color, my_rank, new%ncwrite_comm%value, ierr) 3320 if (color == 1) then 3321 new%ncwrite_comm%me = xmpi_comm_rank(new%ncwrite_comm%value) 3322 new%ncwrite_comm%nproc = xmpi_comm_size(new%ncwrite_comm%value) 3323 if (my_rank == master) then 3324 call wrtout(units, & 3325 sjoin("- Using parallelism over k-points/spins. Cannot write full results to main output", ch10, & 3326 "- All procs except master will write to dev_null. Use SIGEPH.nc to analyze results.")) 3327 !write(std_out, *)"ncwrite_comm_me:", new%ncwrite_comm%me, "ncwrite_comm%nproc:", new%ncwrite_comm%nproc 3328 end if 3329 if (.not. is_open(ab_out)) then 3330 !if (open_file(strcat(dtfil%filnam_ds(2), "_rank_", itoa(new%ncwrite_comm%me)), msg, unit=ab_out, & 3331 if (open_file(NULL_FILE, msg, unit=ab_out, form="formatted", action="write", status='unknown') /= 0) then 3332 ABI_ERROR(msg) 3333 end if 3334 end if 3335 else 3336 call new%ncwrite_comm%set_to_null() 3337 end if 3338 end if 3339 3340 ! Build table with list of perturbations treated by this CPU inside pert_comm 3341 call ephtk_set_pertables(cryst%natom, new%my_npert, new%pert_table, new%my_pinfo, new%pert_comm%value) 3342 3343 ! Setup a mask to skip accumulating the contribution of certain phonon modes. 3344 call ephtk_set_phmodes_skip(dtset%natom, dtset%eph_phrange, new%phmodes_skip) 3345 3346 if (.not. new%imag_only) then 3347 ! Split bands among the procs inside bsum_comm using block distribution. 3348 call xmpi_split_work(new%nbsum, new%bsum_comm%value, new%my_bsum_start, new%my_bsum_stop) 3349 if (new%my_bsum_start == new%nbsum + 1) then 3350 ABI_ERROR("sigmaph code does not support idle processes! Decrease ncpus or increase nband or use eph_np_pqbks input var.") 3351 end if 3352 new%my_bsum_start = new%bsum_start + new%my_bsum_start - 1 3353 new%my_bsum_stop = new%bsum_start + new%my_bsum_stop - 1 3354 ABI_MALLOC(new%nbsum_rank, (new%bsum_comm%nproc, 3)) 3355 ii = new%my_bsum_stop - new%my_bsum_start + 1 3356 call xmpi_allgather(ii, new%nbsum_rank(:,1), new%bsum_comm%value, ierr) 3357 ii = new%my_bsum_start 3358 call xmpi_allgather(ii, new%nbsum_rank(:,2), new%bsum_comm%value, ierr) 3359 end if 3360 3361 call wrtout(std_out, sjoin(" Global bands for self-energy sum, bsum_start: ", itoa(new%bsum_start), & 3362 " bsum_bstop:", itoa(new%bsum_stop))) 3363 call wrtout(std_out, sjoin(" Allocating and treating bands from my_bsum_start: ", itoa(new%my_bsum_start), & 3364 " up to my_bsum_stop:", itoa(new%my_bsum_stop))) 3365 3366 ! Distribute DFPT potentials (IBZ q-points) inside qpt_comm. 3367 ! Note that we distribute IBZ instead of the full BZ or the IBZ_k inside the loop over ikcalc. 3368 ! This means that the load won't be equally distributed but memory will scale with qpt_comm%nproc. 3369 ! To reduce load imbalance, we sort the qibz points by norm and use cyclic distribution inside qpt_comm 3370 ABI_ICALLOC(new%itreat_qibz, (new%nqibz)) 3371 call sort_rpts(new%nqibz, new%qibz, cryst%gmet, iperm) 3372 do ii=1,new%nqibz 3373 iq_ibz = iperm(ii) 3374 if (mod(ii, new%qpt_comm%nproc) == new%qpt_comm%me) new%itreat_qibz(iq_ibz) = 1 3375 end do 3376 ABI_FREE(iperm) 3377 3378 call wrtout(std_out, sjoin("P Number of q-points in the IBZ treated by this proc: " ,itoa(count(new%itreat_qibz == 1)))) 3379 3380 ! ================================================================ 3381 ! Allocate arrays used to store final results and set them to zero 3382 ! ================================================================ 3383 ABI_ICALLOC(new%qp_done, (new%nkcalc, new%nsppol)) 3384 ABI_CALLOC(new%vals_e0ks, (new%ntemp, new%max_nbcalc)) 3385 ABI_CALLOC(new%fan_vals, (new%ntemp, new%max_nbcalc)) 3386 ABI_CALLOC(new%fan_stern_vals, (new%ntemp, new%max_nbcalc)) 3387 ABI_CALLOC(new%dvals_de0ks, (new%ntemp, new%max_nbcalc)) 3388 ABI_CALLOC(new%dw_vals, (new%ntemp, new%max_nbcalc)) 3389 ABI_CALLOC(new%dw_stern_vals, (new%ntemp, new%max_nbcalc)) 3390 3391 ! Frequency dependent stuff 3392 if (new%nwr > 0) then 3393 ABI_CALLOC(new%vals_wr, (new%nwr, new%ntemp, new%max_nbcalc)) 3394 ABI_CALLOC(new%wrmesh_b, (new%nwr, new%max_nbcalc)) 3395 end if 3396 3397 ! Compute phonon frequency mesh. 3398 call ifc%get_phmesh(dtset%ph_wstep, new%phmesh_size, new%phmesh) 3399 3400 ! Prepare calculation of generalized Eliashberg functions 3401 ! prteliash == 0 deactivates computation (default). 3402 if (dtset%prteliash /= 0) then 3403 ABI_MALLOC(new%gfw_vals, (new%phmesh_size, 3, new%max_nbcalc)) 3404 end if 3405 3406 new%a2f_ne = 0 3407 if (dtset%prteliash == 3) then 3408 ! TODO: dosdeltae should have a default value. 3409 ! TODO: Use logmesh/double mesh for electrons? 3410 estep = dtset%dosdeltae; if (estep <= zero) estep = 0.05 * eV_Ha 3411 new%a2f_ne = nint((maxval(ebands%eig) - minval(ebands%eig)) / estep) + 1 3412 if (my_rank == master) then 3413 write(std_out, *)" Computing a2f with ", new%a2f_ne, " points for electrons and ", new%phmesh_size, " points for phonons." 3414 write(std_out, *)" doseltae:", estep, ", tsmear:", dtset%tsmear 3415 end if 3416 ABI_MALLOC(new%a2f_emesh, (new%a2f_ne)) 3417 new%a2f_emesh = arth(minval(ebands%eig), estep, new%a2f_ne) 3418 ABI_CALLOC(new%a2few, (new%a2f_ne, new%phmesh_size, new%max_nbcalc)) 3419 end if 3420 3421 call cwtime_report(" MPI setup", cpu, wall, gflops) 3422 3423 ! Initialize object for the computation of integration weights (integration in q-space). 3424 ! Weights can be obtained in different ways: 3425 ! 3426 ! 1. Computed from eigens on the same coarse q-mesh as the one used for the self-energy. 3427 ! 2. Obtained from eigens on a denser q-mesh and then transfered to the coarse q-mesh. 3428 ! In this case the eigens on the dense mesh are either read from an external file (ab-initio) 3429 ! or interpolated on the fly with star-functions. 3430 ! 3431 ! NB: The routines assume that the k-mesh for electrons and the q-mesh for phonons are the same. 3432 ! Thus we need to downsample the k-mesh if it's denser that the q-mesh. 3433 3434 new%use_doublegrid = .False. 3435 3436 ! ================================================================================================ 3437 ! Here we construct ebands_dense for the double grid either from WFK file or via SKW interpolation 3438 ! ================================================================================================ 3439 3440 if (dtset%getwfkfine /= 0 .or. dtset%irdwfkfine /= 0 .or. dtset%getwfkfine_filepath /= ABI_NOFILE) then 3441 3442 ! In principle only getwfkfine_filepath is used 3443 wfk_fname_dense = trim(dtfil%fnameabi_wfkfine) 3444 ABI_CHECK(nctk_try_fort_or_ncfile(wfk_fname_dense, msg) == 0, msg) 3445 call wrtout(units, "- EPH double grid interpolation: will read energies from: "//trim(wfk_fname_dense), newlines=1) 3446 3447 ebands_dense = wfk_read_ebands(wfk_fname_dense, comm) 3448 3449 ! TODO add consistency check: number of bands and kpoints (commensurability) 3450 !if (ebands_dense%is_commensurate(msg) /= 0) 3451 ABI_CHECK_IEQ(ebands_dense%mband, ebands%mband, "Inconsistent number of bands for the fine and dense grid:") 3452 new%use_doublegrid = .True. 3453 3454 else if (any(dtset%bs_interp_kmult /= 0)) then 3455 3456 ! Read bs_interpmult 3457 call wrtout(units, " EPH interpolation: will use star functions interpolation.", newlines=1) 3458 ! Interpolate band energies with star-functions 3459 params = 0; params(1) = 1; params(2) = 5 3460 if (nint(dtset%einterp(1)) == 1) params = dtset%einterp 3461 !write(std_out, "(a, 4(f5.2, 2x))")" SKW parameters for double-grid:", params 3462 3463 !TODO: mband should be min of nband 3464 band_block = [1, ebands%mband] 3465 ! TODO: Now we should use this band range. 3466 ! Note that we start from 1 because we are gonna use ebands_dense to compute the Fermi level. 3467 !band_block = [1, new%bsum_stop] 3468 intp_kptrlatt(:,1) = [ebands%kptrlatt(1,1)*dtset%bs_interp_kmult(1), 0, 0] 3469 intp_kptrlatt(:,2) = [0, ebands%kptrlatt(2,2)*dtset%bs_interp_kmult(2), 0] 3470 intp_kptrlatt(:,3) = [0, 0, ebands%kptrlatt(3,3)*dtset%bs_interp_kmult(3)] 3471 3472 intp_nshiftk = 1; intp_shiftk = zero 3473 ebands_dense = ebands_interp_kmesh(ebands, cryst, params, intp_kptrlatt, & 3474 intp_nshiftk, intp_shiftk, band_block, comm) 3475 new%use_doublegrid = .True. 3476 end if 3477 3478 if (new%use_doublegrid) then 3479 ! Note that we don't recompute %fermie and %occ in ebands_dense, only %nelect must be consistent with the 3480 ! input ebands to handle possible doping 3481 ebands_dense%nelect = ebands%nelect 3482 ebands_dense%fermie = ebands%fermie 3483 if (abs(dtset%mbpt_sciss) > tol6) then 3484 ! Apply the scissor operator to the dense mesh 3485 call wrtout(std_out, sjoin(" Apply the scissor operator to the dense CB with:",ftoa(dtset%mbpt_sciss))) 3486 call ebands_apply_scissors(ebands_dense, dtset%mbpt_sciss) 3487 end if 3488 end if 3489 3490 ! Build object used to compute integration weights taking into account double-grid. 3491 ! Note that we compute the weights only for the states included in the sum 3492 ! bstart and new%bsum_comm select the band range. 3493 ! TODO: 3494 ! 1) Should recheck the case bstart > 1 with star functions as I got weird results. 3495 ! 2) Should refactor ephwg so that only my_npert phonons are stored in the datatype. 3496 bstart = new%bsum_start 3497 3498 if (new%qint_method > 0) then 3499 ! Tetra 3500 if (new%use_doublegrid) then 3501 ! Double-grid technique from ab-initio energies or star-function interpolation. 3502 new%ephwg = ephwg_from_ebands(cryst, ifc, ebands_dense, bstart, new%nbsum, comm) 3503 new%eph_doublegrid = eph_double_grid_new(cryst, ebands_dense, ebands%kptrlatt, ebands_dense%kptrlatt) 3504 else 3505 downsample = any(ebands%kptrlatt /= qptrlatt) .or. ebands%nshiftk /= my_nshiftq 3506 if (ebands%nshiftk == my_nshiftq) downsample = downsample .or. any(ebands%shiftk /= my_shiftq) 3507 if (downsample) then 3508 ABI_COMMENT("K-mesh != Q-mesh for self-energy. Will downsample electron energies.") 3509 tmp_ebands = ebands_downsample(ebands, cryst, qptrlatt, my_nshiftq, my_shiftq) 3510 new%ephwg = ephwg_from_ebands(cryst, ifc, tmp_ebands, bstart, new%nbsum, comm) 3511 call ebands_free(tmp_ebands) 3512 else 3513 new%ephwg = ephwg_from_ebands(cryst, ifc, ebands, bstart, new%nbsum, comm) 3514 end if 3515 end if 3516 3517 else 3518 ! Standard quadrature. 3519 if (new%use_doublegrid) then 3520 new%eph_doublegrid = eph_double_grid_new(cryst, ebands_dense, ebands%kptrlatt, ebands_dense%kptrlatt) 3521 new%ephwg = ephwg_from_ebands(cryst, ifc, ebands_dense, bstart, new%nbsum, comm) 3522 endif 3523 end if 3524 3525 call cwtime_report(" sigmaph_new: after doublegrid", cpu, wall, gflops) 3526 3527 ! Compute the chemical potential at the different physical temperatures with Fermi-Dirac. 3528 ABI_MALLOC(new%mu_e, (new%ntemp)) 3529 new%mu_e(:) = ebands%fermie 3530 3531 if (dtset%eph_fermie == zero) then 3532 ! TODO: Optimize this part 3533 ! grep "TIME" /home/acad/ucl-naps/gbrunin/GaP_FHI/mobility/conv_fine/v9/k144x144x144/q288x288x288/log | grep get_mu get_mu_e completed. cpu: 06:02 [minutes] , wall: 06:02 [minutes] <<< TIME 3534 3535 call cwtime(cpu, wall, gflops, "start") 3536 if (new%use_doublegrid) then 3537 call ebands_get_muT_with_fd(ebands_dense, new%ntemp, new%ktmesh, dtset%spinmagntarget, dtset%prtvol, new%mu_e, comm) 3538 else 3539 call ebands_get_muT_with_fd(ebands, new%ntemp, new%ktmesh, dtset%spinmagntarget, dtset%prtvol, new%mu_e, comm) 3540 end if 3541 3542 call cwtime_report(" get_mu_e", cpu, wall, gflops) 3543 endif 3544 3545 call ebands_free(ebands_dense) 3546 3547 if (my_rank == master) then 3548 msg = "Gaps, band edges and relative position wrt Fermi level" 3549 call gaps%print(unit=std_out, kTmesh=new%ktmesh, mu_e=new%mu_e, header=msg) 3550 call gaps%print(unit=ab_out, kTmesh=new%ktmesh, mu_e=new%mu_e, header=msg) 3551 end if 3552 call gaps%free() 3553 3554 ! Prepare computation of Frohlich self-energy 3555 ! TODO: Reintegrate at least frohl_model 1 for the full self-energy 3556 new%frohl_model = 0 3557 new%ntheta = abs(dtset%eph_frohl_ntheta) 3558 !print *, "ntheta:", new%ntheta; stop 3559 if (.not. new%imag_only .and. new%ntheta > 0) then 3560 new%frohl_model = 1 3561 !if (.not. dvdb%has_zeff) new%frohl_model = 0 3562 end if 3563 3564 if (new%frohl_model /= 0) then 3565 ! Set angular mesh for numerical integration inside micro BZ around Gamma. 3566 new%nphi = 2 * new%ntheta 3567 write(std_out,"(a)")" Activating computation of Frohlich self-energy:" 3568 write(std_out,"(2(a,i0,1x))")" ntheta: ", new%ntheta, "nphi: ", new%nphi 3569 3570 ! Initialize angular mesh qvers_cart and angwgth 3571 ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega) 3572 call ylm_angular_mesh(new%ntheta, new%nphi, new%angl_size, new%qvers_cart, new%angwgth) 3573 end if 3574 3575 if (new%mrta > 0) then 3576 ABI_CALLOC(new%linewidth_mrta, (new%ntemp, new%max_nbcalc)) 3577 end if 3578 3579 call cwtime_report(" sigmaph_new: all", cpu_all, wall_all, gflops_all) 3580 3581 end function sigmaph_new
m_sigmaph/sigmaph_print [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_print
FUNCTION
Print self-energy and QP corrections for given (k-point, spin).
INPUTS
dtset<dataset_type>=All input variables for this dataset. unt=Fortran unit number
SOURCE
5311 subroutine sigmaph_print(self, dtset, unt) 5312 5313 !Arguments ------------------------------------ 5314 integer,intent(in) :: unt 5315 type(dataset_type),intent(in) :: dtset 5316 class(sigmaph_t),intent(in) :: self 5317 5318 !Local variables------------------------------- 5319 integer :: ikc, is, ndiv 5320 character(len=5000) :: msg 5321 5322 ! ************************************************************************* 5323 5324 if (unt == dev_null) return 5325 5326 ! Write dimensions 5327 write(unt,"(/,a)")sjoin(" Number of bands in e-ph self-energy sum:", itoa(self%nbsum)) 5328 write(unt,"(a)")sjoin(" From bsum_start:", itoa(self%bsum_start), "to bsum_stop:", itoa(self%bsum_stop)) 5329 if (dtset%eph_stern /= 0 .and. .not. self%imag_only) then 5330 write(unt, "(a)")" Treating high-energy bands with Sternheimer and static self-energy." 5331 write(unt, "(a, es16.6, a, i0)")" Tolwfr:", dtset%tolwfr, ", nline: ", dtset%nline 5332 end if 5333 write(unt,"(a)")sjoin(" Symsigma: ",itoa(self%symsigma), "Timrev:", itoa(self%timrev)) 5334 if (.not. (self%qint_method == 1 .and. self%imag_only)) then 5335 write(unt,"(a)")sjoin(" Imaginary shift in the denominator (zcut): ", ftoa(aimag(self%ieta) * Ha_eV, fmt="f5.3"), "[eV]") 5336 end if 5337 msg = " Standard quadrature"; if (self%qint_method == 1) msg = " Tetrahedron method" 5338 write(unt, "(2a)")sjoin(" Method for q-space integration:", msg) 5339 if (self%qint_method == 1) then 5340 ndiv = 1; if (self%use_doublegrid) ndiv = self%eph_doublegrid%ndiv 5341 write(unt, "(a, 2(es16.6,1x))")" Tolerance for integration weights < ", dtset%eph_tols_idelta(:) / ndiv 5342 write(unt, "(a, (f5.2,1x))")" eph_phwinfact: ", self%phwinfact 5343 end if 5344 if (self%use_doublegrid) write(unt, "(a, i0)")" Using double grid technique with ndiv: ", self%eph_doublegrid%ndiv 5345 if (self%imag_only) write(unt, "(a)")" Only the Imaginary part of Sigma will be computed." 5346 if (.not. self%imag_only) write(unt, "(a)")" Both Real and Imaginary part of Sigma will be computed." 5347 write(unt,"(a)")sjoin(" Number of frequencies along the real axis:", itoa(self%nwr), & 5348 ", Step:", ftoa(self%wr_step * Ha_eV, fmt="f5.3"), "[eV]") 5349 if (dtset%prteliash /= 0) then 5350 write(unt, "(a)")sjoin(" Number of frequency in generalized Eliashberg functions:", itoa(self%phmesh_size)) 5351 else 5352 write(unt, "(a)")" Number of frequency in generalized Eliashberg functions: 0" 5353 end if 5354 write(unt,"(a)")sjoin(" Number of temperatures:", itoa(self%ntemp), & 5355 "From:", ftoa(self%kTmesh(1) / kb_HaK), "to", ftoa(self%kTmesh(self%ntemp) / kb_HaK), "[K]") 5356 write(unt,"(a)")sjoin(" Ab-initio q-mesh from DDB file:", ltoa(dtset%ddb_ngqpt)) 5357 write(unt,"(a)")sjoin(" Q-mesh used for self-energy integration [ngqpt]:", ltoa(self%ngqpt)) 5358 write(unt,"(a)")sjoin(" Number of q-points in the IBZ:", itoa(self%nqibz)) 5359 write(unt,"(a)")sjoin(" asr:", itoa(dtset%asr), "chneut:", itoa(dtset%chneut)) 5360 write(unt,"(a)")sjoin(" dipdip:", itoa(dtset%dipdip), "symdynmat:", itoa(dtset%symdynmat)) 5361 5362 if (.not. self%imag_only) then 5363 select case (self%frohl_model) 5364 case (0) 5365 !write(unt,"(a)")" No special treatment for the integration of the Frohlich divergence in the microzone around Gamma" 5366 case (1) 5367 write(unt,"(a)")" Integrating Frohlich model in small sphere around Gamma to accelerate qpt convergence" 5368 write(unt,"(2(a,i0,1x))")" Sperical integration performed with: ntheta: ", self%ntheta, ", nphi: ", self%nphi 5369 case default 5370 ABI_ERROR(sjoin("Invalid value of frohl_mode:", itoa(self%frohl_model))) 5371 end select 5372 end if 5373 5374 write(unt,"(a, i0)")" Number of k-points for self-energy corrections: ", self%nkcalc 5375 if (any(abs(dtset%sigma_erange) /= zero)) then 5376 write(unt, "(a, 2(f6.3, 1x), a)")" sigma_erange: ", dtset%sigma_erange(:) * Ha_eV, " (eV)" 5377 end if 5378 if (self%imag_only .and. self%qint_method == 1) then 5379 write(unt,"(a, 2(f5.3, 1x), a)")" Including all final {mk+q} states inside energy window: [", & 5380 self%elow * Ha_eV, self%ehigh * Ha_eV, "] [eV]" 5381 end if 5382 write(unt,"(a)")" List of k-points for self-energy corrections:" 5383 do ikc=1,self%nkcalc 5384 if (ikc > 10) then 5385 write(unt, "(2a)")" nkcalc > 10. Stop printing more k-point information.",ch10 5386 exit 5387 end if 5388 do is=1,self%nsppol 5389 if (self%nsppol == 2) write(unt,"(a,i1,a)")" For spin: ",is, ", ikcalc, spin, kpt, bstart, bstop" 5390 write(unt, "(2(i4,2x),a,2(i4,1x))") & 5391 ikc, is, trim(ktoa(self%kcalc(:,ikc))), self%bstart_ks(ikc,is), self%bstart_ks(ikc,is) + self%nbcalc_ks(ikc,is) - 1 5392 end do 5393 end do 5394 5395 write(unt, "(/,a)")" === MPI parallelism ===" 5396 write(unt, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, & 5397 " up to my_bsum_stop: ", self%my_bsum_stop 5398 write(unt, "(a,i0)")"P Number of CPUs for parallelism over perturbations: ", self%pert_comm%nproc 5399 write(unt, "(a,i0)")"P Number of perturbations treated by this CPU: ", self%my_npert 5400 write(unt, "(a,i0)")"P Number of CPUs for parallelism over q-points: ", self%qpt_comm%nproc 5401 write(unt, "(2(a,i0))")"P Number of q-points in the IBZ treated by this proc: " , & 5402 count(self%itreat_qibz == 1), " of ", self%nqibz 5403 write(unt, "(a,i0)")"P Number of CPUs for parallelism over bands: ", self%bsum_comm%nproc 5404 write(unt, "(a,i0)")"P Number of CPUs for parallelism over spins: ", self%spin_comm%nproc 5405 write(unt, "(a,i0)")"P Number of CPUs for parallelism over k-points: ", self%kcalc_comm%nproc 5406 write(unt, "(2(a,i0),/)")"P Number of k-point in Sigma_nk treated by this proc: ", self%my_nkcalc, " of ", self%nkcalc 5407 5408 end subroutine sigmaph_print
m_sigmaph/sigmaph_read [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_read
FUNCTION
Start an (incomplete) sigmaph instance from a netcdf file. This routine serves only to read some basic dimensions and parameters from the SIGEPH.nc file to 1. Verify whether a restart in sigmaph is possible when eph_restart == 1 2. Use these metadata in the RTA module to prepare the calculation of transport properties.
INPUTS
path= SIGEPH Filename. dtset<dataset_type>=All input variables for this dataset. comm=MPI communicator msg=Error message if ierr /= 0 ierr = Exit status [keep_open]=True to keep the Nc file handle open for further reading. Default: False. [extrael_fermie]: Return the value of (eph_extrael, eph_fermie) read from file. [sigma_ngkpt] = Value read from the ncfile (used in m_rta) [sigma_erange] = Value read from the ncfile (used in m_rta)
SOURCE
3864 type(sigmaph_t) function sigmaph_read(path, dtset, comm, msg, ierr, keep_open, & 3865 extrael_fermie, sigma_ngkpt, sigma_erange) result(new) 3866 3867 !Arguments ------------------------------------ 3868 integer,intent(in) :: comm 3869 integer,intent(out) :: ierr 3870 type(dataset_type),intent(in) :: dtset 3871 character(len=500),intent(out) :: msg 3872 real(dp), optional, intent(out) :: extrael_fermie(2) 3873 logical,optional,intent(in) :: keep_open 3874 integer,optional, intent(out) :: sigma_ngkpt(3) 3875 real(dp),optional,intent(out) :: sigma_erange(2) 3876 3877 !Local variables ------------------------------ 3878 !scalars 3879 integer :: imag_only, eph_task, symdynmat, ph_intmeth, eph_intmeth, eph_transport 3880 integer :: ncid !, varid !, ncerr 3881 real(dp) :: eph_fermie, eph_fsewin, ph_wstep, ph_smear, eta, eph_extrael, eph_fsmear, cpu, wall, gflops 3882 character(len=fnlen) :: path 3883 !arrays 3884 integer :: eph_ngqpt_fine(3), ddb_ngqpt(3), ph_ngqpt(3), my_sigma_ngkpt(3) 3885 real(dp) :: my_sigma_erange(2) 3886 3887 ! ************************************************************************* 3888 3889 ! Open netcdf file 3890 msg = "Netcdf not activated at configure time!" 3891 ierr = 1 3892 ierr = 0 3893 3894 if (.not. file_exists(path)) then 3895 msg = sjoin("Cannot find file", path) 3896 ierr = 1; return 3897 end if 3898 3899 call cwtime(cpu, wall, gflops, "start") 3900 NCF_CHECK(nctk_open_read(ncid, path, comm)) 3901 3902 !TODO? 3903 !NCF_CHECK(cryst%ncread(ncid)) 3904 !NCF_CHECK(ebands_ncread(ebands, ncid)) 3905 3906 ! Read sigma_eph dimensions. 3907 NCF_CHECK(nctk_get_dim(ncid, "nkcalc", new%nkcalc)) 3908 NCF_CHECK(nctk_get_dim(ncid, "max_nbcalc", new%max_nbcalc)) 3909 NCF_CHECK(nctk_get_dim(ncid, "nsppol", new%nsppol)) 3910 NCF_CHECK(nctk_get_dim(ncid, "ntemp", new%ntemp)) 3911 NCF_CHECK(nctk_get_dim(ncid, "nqibz", new%nqibz)) 3912 NCF_CHECK(nctk_get_dim(ncid, "nqbz", new%nqbz)) 3913 !NCF_CHECK(nctk_get_dim(ncid, "nwr", new%nwr)) 3914 !NCF_CHECK(nctk_get_dim(ncid, "phmesh_size", new%phmesh_size)) 3915 3916 ! ====================================================== 3917 ! Read data that does not depend on the (kpt, spin) loop. 3918 ! ====================================================== 3919 NCF_CHECK(nf90_get_var(ncid, vid("symsigma"), new%symsigma)) 3920 NCF_CHECK(nf90_get_var(ncid, vid("nbsum"), new%nbsum)) 3921 NCF_CHECK(nf90_get_var(ncid, vid("bsum_start"), new%bsum_start)) 3922 NCF_CHECK(nf90_get_var(ncid, vid("bsum_stop"), new%bsum_stop)) 3923 3924 NCF_CHECK(nf90_get_var(ncid, vid("qint_method"), new%qint_method)) 3925 !NCF_CHECK(nf90_get_var(ncid, vid("frohl_model"), new%frohl_model)) 3926 NCF_CHECK(nf90_get_var(ncid, vid("imag_only"), imag_only)) 3927 new%imag_only = (imag_only == 1) 3928 NCF_CHECK(nf90_get_var(ncid, vid("mrta"), new%mrta)) 3929 3930 ABI_MALLOC(new%kcalc, (3, new%nkcalc)) 3931 ABI_MALLOC(new%bstart_ks, (new%nkcalc, new%nsppol)) 3932 ABI_MALLOC(new%bstop_ks, (new%nkcalc, new%nsppol)) 3933 ABI_MALLOC(new%nbcalc_ks, (new%nkcalc, new%nsppol)) 3934 ABI_MALLOC(new%mu_e, (new%ntemp)) 3935 ABI_MALLOC(new%kTmesh, (new%ntemp)) 3936 ABI_MALLOC(new%kcalc2ibz, (new%nkcalc, 6)) 3937 3938 NCF_CHECK(nf90_get_var(ncid, vid("ngqpt"), new%ngqpt)) 3939 NCF_CHECK(nf90_get_var(ncid, vid("bstart_ks"), new%bstart_ks)) 3940 NCF_CHECK(nf90_get_var(ncid, vid("nbcalc_ks"), new%nbcalc_ks)) 3941 new%bstop_ks = new%bstart_ks + new%nbcalc_ks - 1 3942 3943 NCF_CHECK(nf90_get_var(ncid, vid("kcalc"), new%kcalc)) 3944 NCF_CHECK(nf90_get_var(ncid, vid("kcalc2ibz"), new%kcalc2ibz)) 3945 NCF_CHECK(nf90_get_var(ncid, vid("kTmesh"), new%kTmesh)) 3946 NCF_CHECK(nf90_get_var(ncid, vid("wr_step"), new%wr_step)) 3947 NCF_CHECK(nf90_get_var(ncid, vid("mu_e"), new%mu_e)) 3948 NCF_CHECK(nf90_get_var(ncid, vid("eta"), eta)) 3949 new%ieta = j_dpc * eta 3950 3951 ! Read the done array used to implement restart capabilities. 3952 ABI_ICALLOC(new%qp_done, (new%nkcalc, new%nsppol)) 3953 NCF_CHECK(nf90_get_var(ncid, vid("qp_done"), new%qp_done)) 3954 3955 ! ============================================================ 3956 ! Read and check consistency against dtset 3957 ! ============================================================ 3958 NCF_CHECK(nf90_get_var(ncid, vid("eph_fsewin"), eph_fsewin)) 3959 NCF_CHECK(nf90_get_var(ncid, vid("eph_fsmear"), eph_fsmear)) 3960 NCF_CHECK(nf90_get_var(ncid, vid("eph_extrael"), eph_extrael)) 3961 NCF_CHECK(nf90_get_var(ncid, vid("eph_fermie"), eph_fermie)) 3962 NCF_CHECK(nf90_get_var(ncid, vid("ph_wstep"), ph_wstep)) 3963 NCF_CHECK(nf90_get_var(ncid, vid("ph_smear"), ph_smear)) 3964 ABI_CHECK(eph_fsewin == dtset%eph_fsewin, "netcdf eph_fsewin != input file") 3965 ABI_CHECK(eph_fsmear == dtset%eph_fsmear, "netcdf eph_fsmear != input file") 3966 ABI_CHECK(ph_wstep == dtset%ph_wstep, "netcdf ph_wstep != input file") 3967 ABI_CHECK(ph_smear == dtset%ph_smear, "netcdf ph_smear != input file") 3968 3969 if (present(extrael_fermie)) then 3970 extrael_fermie = [eph_extrael, eph_fermie] 3971 else 3972 ABI_CHECK_DEQ(eph_extrael, dtset%eph_extrael, "netcdf eph_extrael != input file") 3973 ABI_CHECK_DEQ(eph_fermie, dtset%eph_fermie, "netcdf eph_feremie != input file") 3974 end if 3975 3976 NCF_CHECK(nf90_get_var(ncid, vid("eph_task"), eph_task)) 3977 NCF_CHECK(nf90_get_var(ncid, vid("symdynmat"), symdynmat)) 3978 NCF_CHECK(nf90_get_var(ncid, vid("ph_intmeth"), ph_intmeth)) 3979 NCF_CHECK(nf90_get_var(ncid, vid("eph_intmeth"), eph_intmeth)) 3980 NCF_CHECK(nf90_get_var(ncid, vid("eph_transport"), eph_transport)) 3981 3982 if (dtset%eph_task==-4 .or. dtset%eph_task==4) then 3983 ABI_CHECK_IEQ(symdynmat, dtset%symdynmat, "netcdf symdynmat != input file") 3984 ABI_CHECK_IEQ(ph_intmeth, dtset%ph_intmeth, "netcdf ph_intmeth != input file") 3985 ABI_CHECK_IEQ(eph_intmeth, dtset%eph_intmeth, "netcdf eph_intmeth != input file") 3986 ABI_CHECK_IEQ(eph_transport, dtset%eph_transport, "netcdf eph_transport != input file") 3987 endif 3988 3989 !NCF_CHECK(nf90_get_var(ncid, vid("frohl_params"), frohl_params)) 3990 NCF_CHECK(nf90_get_var(ncid, vid("eph_ngqpt_fine"), eph_ngqpt_fine)) 3991 NCF_CHECK(nf90_get_var(ncid, vid("ddb_ngqpt"), ddb_ngqpt)) 3992 NCF_CHECK(nf90_get_var(ncid, vid("ph_ngqpt"), ph_ngqpt)) 3993 NCF_CHECK(nf90_get_var(ncid, vid("sigma_ngkpt"), my_sigma_ngkpt)) 3994 if (present(sigma_ngkpt)) then 3995 sigma_ngkpt = my_sigma_ngkpt 3996 else 3997 ABI_CHECK(all(dtset%sigma_ngkpt == my_sigma_ngkpt), "netcdf sigma_ngkpt != input file") 3998 end if 3999 4000 NCF_CHECK(nf90_get_var(ncid, vid("sigma_erange"), my_sigma_erange)) 4001 if (present(sigma_erange)) then 4002 sigma_erange = my_sigma_erange 4003 else 4004 ABI_CHECK(all(dtset%sigma_erange == my_sigma_erange), "netcdf sigma_erange != input file") 4005 end if 4006 4007 if (present(keep_open)) then 4008 new%ncid = ncid 4009 else 4010 NCF_CHECK(nf90_close(ncid)) 4011 ! so that the structure is properly freed 4012 new%ncid = nctk_noid 4013 end if 4014 4015 ABI_CHECK(all(dtset%eph_ngqpt_fine == eph_ngqpt_fine),"netcdf eph_ngqpt_fine != input file") 4016 ABI_CHECK(all(dtset%ddb_ngqpt == ddb_ngqpt), "netcdf ddb_ngqpt != input file") 4017 ABI_CHECK(all(dtset%ph_ngqpt == ph_ngqpt), "netcdf ph_ngqpt != input file") 4018 !ABI_CHECK(all(abs(dtset%frohl_params - frohl_params) < tol6), "netcdf frohl_params != input file") 4019 4020 call cwtime_report(" sigmaph_read", cpu, wall, gflops) 4021 4022 contains 4023 integer function vid(vname) 4024 character(len=*),intent(in) :: vname 4025 vid = nctk_idname(ncid, vname) 4026 end function vid 4027 4028 end function sigmaph_read
m_sigmaph/sigmaph_setup_kcalc [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_setup_kcalc
FUNCTION
Prepare calculations of self-energy matrix elements for ikcalc index.
INPUTS
dtset<dataset_type>=All input variables for this dataset. cryst<crystal_t> = Crystal structure. dvdb<dbdb_type>=Database with the DFPT SCF potentials. ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) ikcalc=Index of the k-point to compute. prtvol= Verbosity level comm= MPI communicator
SOURCE
4339 subroutine sigmaph_setup_kcalc(self, dtset, cryst, ebands, ikcalc, prtvol, comm) 4340 4341 !Arguments ------------------------------------ 4342 integer,intent(in) :: ikcalc, prtvol, comm 4343 type(dataset_type),intent(in) :: dtset 4344 type(crystal_t),intent(in) :: cryst 4345 class(sigmaph_t),target,intent(inout) :: self 4346 type(ebands_t),intent(in) :: ebands 4347 4348 !Local variables------------------------------- 4349 integer,parameter :: master = 0 4350 integer :: spin, my_rank, iq_ibz, nprocs, qtimrev, qptopt !, nbcalc_ks !, bstart_ks 4351 integer :: ikpt, ibz_k, isym_k, itim_k !isym_lgk, 4352 real(dp) :: cpu, wall, gflops 4353 character(len=5000) :: msg 4354 logical :: compute_lgk 4355 type(lgroup_t),target :: lgk 4356 type(lgroup_t),pointer :: lgk_ptr 4357 type(krank_t) :: krank, qrank 4358 !arrays 4359 integer :: qptrlatt(3,3) 4360 integer,allocatable :: iqk2dvdb(:,:) 4361 real(dp) :: kk(3) 4362 real(dp),allocatable :: kq_list(:,:) 4363 4364 ! ************************************************************************* 4365 4366 ABI_SFREE(self%qibz_k) 4367 ABI_SFREE(self%wtq_k) 4368 4369 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 4370 kk = self%kcalc(:, ikcalc) 4371 4372 call wrtout(std_out, sjoin(ch10, repeat("=", 92))) 4373 msg = sjoin("[", itoa(ikcalc), "/", itoa(self%nkcalc), "]") 4374 call wrtout(std_out, sjoin(" Computing self-energy matrix elements for k-point:", ktoa(kk), msg)) 4375 ! TODO Integrate with spin parallelism. 4376 spin = 1 4377 write(msg, "(3(a, i0))")" Treating ", self%nbcalc_ks(ikcalc, spin), " band(s) in Sigma_nk between: ", & 4378 self%bstart_ks(ikcalc, spin)," and: ", self%bstart_ks(ikcalc, spin) + self%nbcalc_ks(ikcalc, spin) - 1 4379 call wrtout(std_out, msg) 4380 write(msg, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, & 4381 " up to my_bsum_stop: ", self%my_bsum_stop 4382 call wrtout(std_out, msg) 4383 if (.not. self%imag_only .and. dtset%eph_stern /= 0) then 4384 if (dtset%eph_stern == 1) call wrtout(std_out, " Sternheimer method activated with cache for u1_nk") 4385 if (dtset%eph_stern == -1) call wrtout(std_out, " Sternheimer method activated WITHOUT cache for u1_nk!") 4386 end if 4387 4388 ! Prepare weights for BZ(k) integration 4389 if (self%qint_method > 0) then 4390 if (self%use_doublegrid) then 4391 call self%ephwg%double_grid_setup_kpoint(self%eph_doublegrid, kk, prtvol, comm) 4392 else 4393 call self%ephwg%setup_kpoint(kk, prtvol, comm, skip_mapping=.true.) 4394 end if 4395 call self%ephwg%report_stats() 4396 endif 4397 4398 call cwtime(cpu, wall, gflops, "start") 4399 4400 if (self%symsigma == 0) then 4401 ! Do not use symmetries in BZ sum_q --> nqibz_k == nqbz 4402 self%nqibz_k = self%nqbz 4403 ABI_MALLOC(self%qibz_k, (3, self%nqibz_k)) 4404 ABI_MALLOC(self%wtq_k, (self%nqibz_k)) 4405 self%qibz_k = self%qbz; self%wtq_k = one / self%nqbz 4406 call wrtout(std_out, sjoin(" symsigma = 0 --> Integration done over full BZ with nqbz:", itoa(self%nqibz_k))) 4407 4408 ! Store little group symmetries (well, just 1) 4409 self%lgk_nsym = 1 4410 ABI_REMALLOC(self%lgk_sym2glob, (2, self%lgk_nsym)) 4411 self%lgk_sym2glob(:, 1) = [1, 1] 4412 4413 else if (abs(self%symsigma) == 1) then 4414 ! Use the symmetries of the little group of the k-point 4415 ! Pack points in *shells* to minimise cache misses. 4416 compute_lgk = .not. (self%qint_method > 0 .and. .not. self%use_doublegrid) 4417 if (compute_lgk) then 4418 lgk = lgroup_new(cryst, kk, self%timrev, self%nqbz, self%qbz, self%nqibz, self%qibz, comm) 4419 lgk_ptr => lgk 4420 else 4421 ! Avoid this call to lgroup new. Use lgk already computed in self%ephwg 4422 lgk_ptr => self%ephwg%lgk 4423 end if 4424 4425 ! Store little group symmetries. 4426 self%lgk_nsym = lgk_ptr%nsym_lg 4427 ABI_REMALLOC(self%lgk_sym2glob, (2, self%lgk_nsym)) 4428 self%lgk_sym2glob = lgk_ptr%lgsym2glob 4429 4430 call wrtout(std_out, sjoin(" Number of operations in little group(k):", itoa(lgk_ptr%nsym_lg), & 4431 "(including time-reversal symmetry)")) 4432 call wrtout(std_out, sjoin(" Number of q-points in the IBZ(k):", itoa(lgk_ptr%nibz))) 4433 4434 if (dtset%prtvol > 0) call lgk_ptr%print(unit=std_out, prtvol=dtset%prtvol) 4435 4436 ! TODO: Pointers instead of copies to save space? 4437 self%nqibz_k = lgk_ptr%nibz 4438 ABI_MALLOC(self%qibz_k, (3, self%nqibz_k)) 4439 ABI_MALLOC(self%wtq_k, (self%nqibz_k)) 4440 self%qibz_k = lgk_ptr%ibz; self%wtq_k = lgk_ptr%weights 4441 !if (compute_lgk) call lgk%free() 4442 else 4443 ABI_ERROR(sjoin("Wrong symsigma:", itoa(self%symsigma))) 4444 end if 4445 4446 call cwtime_report(" lgroup_symsigma", cpu, wall, gflops) 4447 4448 ! TODO: Cleanup 4449 4450 if (self%symsigma == 0) then 4451 ! Find correspondence IBZ_k --> IBZ 4452 ABI_MALLOC(iqk2dvdb, (6, self%nqibz_k)) 4453 4454 ! Assume qptopt == kptopt unless value is specified in input 4455 qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt 4456 qtimrev = kpts_timrev_from_kptopt(qptopt) 4457 qptrlatt = 0; qptrlatt(1,1) = self%ngqpt(1); qptrlatt(2,2) = self%ngqpt(2); qptrlatt(3,3) = self%ngqpt(3) 4458 qrank = krank_from_kptrlatt(self%nqibz, self%qibz, qptrlatt, compute_invrank=.False.) 4459 4460 if (kpts_map("symrec", qtimrev, cryst, qrank, self%nqibz_k, self%qibz_k, iqk2dvdb) /= 0) then 4461 write(msg, '(3a)' )& 4462 "At least one of the q points in the IBZ_k could not be generated from one in the IBZ.", ch10,& 4463 "Action: check your DVDB file and use eph_task to interpolate the potentials on a denser q-mesh." 4464 ABI_ERROR(msg) 4465 end if 4466 call qrank%free() 4467 4468 ABI_REMALLOC(self%ind_ibzk2ibz, (6, self%nqibz_k)) 4469 do iq_ibz=1,self%nqibz_k 4470 self%ind_ibzk2ibz(:, iq_ibz) = iqk2dvdb(:, iq_ibz) 4471 end do 4472 ABI_FREE(iqk2dvdb) 4473 4474 else if (abs(self%symsigma) == 1) then 4475 4476 ! IBZ_k --> BZ --> IBZ 4477 ABI_REMALLOC(self%ind_ibzk2ibz, (6, self%nqibz_k)) 4478 self%ind_ibzk2ibz = 0 4479 do ikpt=1,self%nqbz 4480 ibz_k = lgk_ptr%bz2ibz_smap(1,ikpt) 4481 !isym_lgk = lgk_ptr%bz2ibz_smap(2,ikpt) 4482 !isym_k = lgk_ptr%lgsym2glob(1,isym_lgk) 4483 !itim_k = lgk_ptr%lgsym2glob(2,isym_lgk) 4484 isym_k = lgk_ptr%bz2ibz_smap(2,ikpt) 4485 itim_k = lgk_ptr%bz2ibz_smap(3,ikpt) 4486 ! I assume that isym=1 and itim_k=0 is identity but still verify the kpoint 4487 if (isym_k /= 1 .or. itim_k /= 1 .or. any(lgk_ptr%bz2ibz_smap(4:,ikpt) /= 0)) cycle 4488 ! check IBZ_k --> BZ 4489 ABI_CHECK(sum(abs(self%qbz(:,ikpt) - self%qibz_k(:,ibz_k))) < tol8, 'Wrong mapping') 4490 ! IBZ_k --> IBZ 4491 !self%ind_ibzk2ibz(:, ibz_k) = self%ind_qbz2ibz(:,ikpt) 4492 self%ind_ibzk2ibz(1, ibz_k) = self%ind_qbz2ibz(1, ikpt) 4493 self%ind_ibzk2ibz(2, ibz_k) = self%ind_qbz2ibz(2, ikpt) 4494 self%ind_ibzk2ibz(6, ibz_k) = self%ind_qbz2ibz(3, ikpt) 4495 self%ind_ibzk2ibz(3:5, ibz_k) = self%ind_qbz2ibz(4:6, ikpt) 4496 end do 4497 do ikpt=1,self%nqibz_k 4498 ABI_CHECK(self%ind_ibzk2ibz(1, ikpt) /= 0, 'Did not find mapping') 4499 end do 4500 if (compute_lgk) call lgk%free() 4501 else 4502 ABI_ERROR(sjoin("Wrong symsigma:", itoa(self%symsigma))) 4503 endif 4504 4505 call cwtime_report(" IBZ_k --> IBZ", cpu, wall, gflops) 4506 4507 if (.not. self%use_ftinterp) then 4508 ! Find correspondence IBZ_k --> set of q-points in DVDB. 4509 ! Need to handle q_bz = S q_ibz by symmetrizing the potentials already available in the DVDB. 4510 ! 4511 ! Note: 4512 ! q --> -q symmetry is always used for phonons. 4513 ! we use symrec instead of symrel (see also m_dvdb) 4514 ! IBZ_K -> BZ -> IBZ -> DVDB 4515 ABI_REMALLOC(self%ind_q2dvdb_k, (6, self%nqibz_k)) 4516 self%ind_q2dvdb_k = self%ind_ibzk2ibz 4517 do ikpt=1,self%nqibz_k 4518 self%ind_q2dvdb_k(1, ikpt) = self%qibz2dvdb(self%ind_ibzk2ibz(1, ikpt)) 4519 end do 4520 call cwtime_report(" IBZ_k --> DVDB", cpu, wall, gflops) 4521 end if 4522 4523 ! Find k+q in the extended zone and extract symmetry info. 4524 ! Be careful here because there are two umklapp vectors to be considered: 4525 ! 4526 ! k + q = k_bz + g0_bz = IS(k_ibz) + g0_ibz + g0_bz 4527 ! 4528 ! Note symrel and use_symrec=.False. in get_mapping. 4529 ! This means that this table can be used to symmetrize wavefunctions in cgtk_rotate. 4530 ! 4531 ABI_MALLOC(kq_list, (3, self%nqibz_k)) 4532 do iq_ibz=1,self%nqibz_k 4533 kq_list(:, iq_ibz) = kk + self%qibz_k(:,iq_ibz) 4534 end do 4535 4536 ! Use iqk2dvdb as workspace array. 4537 ABI_MALLOC(iqk2dvdb, (6, self%nqibz_k)) 4538 4539 krank = krank_from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.) 4540 4541 if (kpts_map("symrel", self%timrev, cryst, krank, self%nqibz_k, kq_list, iqk2dvdb) /= 0) then 4542 write(msg, '(11a)' )& 4543 "The WFK file cannot be used to compute self-energy corrections at k: ", trim(ktoa(kk)), ch10,& 4544 "At least one of the k+q points could not be generated from a symmetrical one.", ch10,& 4545 "Q-mesh: ",trim(ltoa(self%ngqpt)),", K-mesh (from kptrlatt) ",trim(ltoa(get_diag(dtset%kptrlatt))),ch10, & 4546 "Action: check your WFK file and the k/q point input variables." 4547 ABI_ERROR(msg) 4548 end if 4549 4550 call krank%free() 4551 4552 ABI_FREE(kq_list) 4553 4554 ABI_REMALLOC(self%indkk_kq, (6, self%nqibz_k)) 4555 do iq_ibz=1,self%nqibz_k 4556 self%indkk_kq(:, iq_ibz) = iqk2dvdb(:,iq_ibz) 4557 end do 4558 ABI_FREE(iqk2dvdb) 4559 4560 call cwtime_report(" k+q --> ebands", cpu, wall, gflops) 4561 4562 if (self%qint_method > 0 .and. .not. self%use_doublegrid) then 4563 ABI_REMALLOC(self%ephwg%lgk2ibz, (self%nqibz_k)) 4564 self%ephwg%lgk2ibz = self%ind_ibzk2ibz(1, :) 4565 ABI_REMALLOC(self%ephwg%kq2ibz, (self%nqibz_k)) 4566 self%ephwg%kq2ibz = self%indkk_kq(1, :) 4567 end if 4568 4569 end subroutine sigmaph_setup_kcalc
m_sigmaph/sigmaph_setup_qloop [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_setup_qloop
FUNCTION
Prepare integration of self-energy matrix in q-space for given (spin, ikcalc) Distribute q-points and precompute weights if tetrahedron method and imag_only
INPUTS
dtset<dataset_type>=All input variables for this dataset. cryst<crystal_t> = Crystal structure. ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) dvdb<dbdb_type>=Database with the DFPT SCF potentials. spin: spin index. ikcalc=Index of the k-point to compute. nfftf=Number of fft-points on the fine grid for interpolated potential ngfftf(18)=information on 3D FFT for interpolated potential comm= MPI communicator
SOURCE
4629 subroutine sigmaph_setup_qloop(self, dtset, cryst, ebands, dvdb, spin, ikcalc, nfftf, ngfftf, comm) 4630 4631 !Arguments ------------------------------------ 4632 integer,intent(in) :: spin, ikcalc, nfftf, comm 4633 type(dataset_type),intent(in) :: dtset 4634 type(crystal_t),intent(in) :: cryst 4635 class(sigmaph_t),intent(inout) :: self 4636 type(ebands_t),intent(in) :: ebands 4637 type(dvdb_t),intent(inout) :: dvdb 4638 !arrays 4639 integer,intent(in) :: ngfftf(18) 4640 4641 !Local variables------------------------------- 4642 integer,parameter :: master = 0 4643 integer :: my_rank, iq_ibz_k, iq_ibz, ierr, nprocs, imyq, iq_dvdb, ii, cnt, itreat, iq, nqeff, ndiv 4644 integer :: min_nqibz_k, max_nqibz_k 4645 real(dp) :: cpu, wall, gflops, efact_min, efact_max 4646 logical :: qfilter 4647 character(len=5000) :: msg 4648 !arrays 4649 integer,allocatable :: mask_qibz_k(:), imask(:), qtab(:), ineed_qibz(:), ineed_qdvdb(:) 4650 4651 ! ************************************************************************* 4652 4653 my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm) 4654 4655 msg = "Standard quadrature"; if (self%qint_method == 1) msg = "tetrahedron method" 4656 call wrtout(std_out, sjoin(" Preparing q-loop with integration method:", msg)) 4657 call cwtime(cpu, wall, gflops, "start") 4658 4659 select case (dtset%eph_task) 4660 case (4) 4661 ! Computation of re-im 4662 call distribute_nqibz_k_nofilter() 4663 if (self%qint_method == 1) call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm) 4664 4665 case (-4) 4666 ! Computation of imaginary part 4667 if (self%qint_method == 0) then 4668 call distribute_nqibz_k_nofilter() 4669 4670 else if (self%qint_method == 1) then 4671 ! Imag with tetra --> Precompute weights in IBZ_k. 4672 call distribute_nqibz_k_nofilter() 4673 call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm) 4674 4675 qfilter = any(dtset%eph_tols_idelta >= zero) 4676 4677 if (qfilter) then 4678 ! Two-pass algorithm: 4679 ! Select q-points with significant contribution, recompute my_nqibz_k and myq2ibz_k. 4680 ! Finally, recompute integration weights with new distribution. 4681 ! NB: the two-pass algorithm could be replaced by a decimation algo and a single call to the tetrahedron routines 4682 ! %deltaw_pm(2, nbcalc_ks, my_npert, bsum_start:bsum_stop, my_nqibz_k, ndiv) 4683 ndiv = 1; if (self%use_doublegrid) ndiv = self%eph_doublegrid%ndiv 4684 ABI_ICALLOC(mask_qibz_k, (self%nqibz_k)) 4685 do imyq=1,self%my_nqibz_k 4686 iq_ibz_k = self%myq2ibz_k(imyq) 4687 if (any(abs(self%deltaw_pm(1,:,:,:,imyq,:)) >= dtset%eph_tols_idelta(1) / ndiv)) mask_qibz_k(iq_ibz_k) = 1 4688 if (any(abs(self%deltaw_pm(2,:,:,:,imyq,:)) >= dtset%eph_tols_idelta(2) / ndiv)) mask_qibz_k(iq_ibz_k) = 1 4689 end do 4690 4691 ! Take max inside comm. 4692 call alloc_copy(mask_qibz_k, imask) 4693 call xmpi_max(imask, mask_qibz_k, comm, ierr) 4694 ABI_FREE(imask) 4695 4696 ! Find all qpts in the IBZ_k contributing to Im(Sigma). 4697 ABI_MALLOC(qtab, (self%nqibz_k)) 4698 nqeff = 0 4699 do iq_ibz_k=1,self%nqibz_k 4700 if (mask_qibz_k(iq_ibz_k) == 1) then 4701 nqeff = nqeff + 1; qtab(nqeff) = iq_ibz_k 4702 end if 4703 end do 4704 ABI_FREE(mask_qibz_k) 4705 4706 if (my_rank == master) then 4707 !write(std_out, "(a, 2(es16.6,1x))")" Removing q-points with integration weights < ", dtset%eph_tols_idelta / ndiv 4708 write(std_out, "(a,i0,a,f5.1,a)")" Total number of q-points contributing to Im(Sigma(eKS)): ", nqeff, & 4709 " (nqeff / nqibz_k): ", (100.0_dp * nqeff) / self%nqibz_k, " [%]" 4710 end if 4711 4712 ! Redistribute relevant q-points inside qpt_comm taking into account itreat_qibz 4713 ! I may need to update qcache after this operation --> build ineed_* table. 4714 ! Must handle two cases: potentials from DVDB or Fourier-interpolated. 4715 if (self%use_ftinterp) then 4716 ABI_ICALLOC(ineed_qibz, (self%nqibz)) 4717 else 4718 ABI_ICALLOC(ineed_qdvdb, (dvdb%nqpt)) 4719 end if 4720 4721 self%my_nqibz_k = 0 4722 do ii=1,2 4723 if (ii == 2) then 4724 ABI_REMALLOC(self%myq2ibz_k, (self%my_nqibz_k)) 4725 end if 4726 cnt = 0 4727 do iq=1,nqeff 4728 iq_ibz_k = qtab(iq) 4729 iq_ibz = self%ind_ibzk2ibz(1, iq_ibz_k) 4730 itreat = int(self%itreat_qibz(iq_ibz), kind=i4b) 4731 if (.not. self%use_ftinterp) iq_dvdb = self%ind_q2dvdb_k(1, iq_ibz_k) 4732 if (itreat /= 0) then 4733 if (ii == 1) self%my_nqibz_k = self%my_nqibz_k + 1 4734 if (ii == 2) then 4735 cnt = cnt + 1 4736 self%myq2ibz_k(cnt) = qtab(iq) 4737 if (self%use_ftinterp) then 4738 if (.not. allocated(dvdb%ft_qcache%key(iq_ibz)%v1scf)) ineed_qibz(iq_ibz) = 1 4739 else 4740 if (.not. allocated(dvdb%qcache%key(iq_dvdb)%v1scf)) ineed_qdvdb(iq_dvdb) = 1 4741 end if 4742 end if 4743 end if 4744 end do 4745 end do 4746 ABI_FREE(qtab) 4747 4748 ! Recompute weights with new q-point distribution. 4749 call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm) 4750 4751 call xmpi_min(self%my_nqibz_k, min_nqibz_k, self%qpt_comm%value, ierr) 4752 call xmpi_max(self%my_nqibz_k, max_nqibz_k, self%qpt_comm%value, ierr) 4753 !efact = (one * self%my_nqibz_k * self%qpt_comm%nproc) / nqeff 4754 efact_min = (one * min_nqibz_k * self%qpt_comm%nproc) / nqeff 4755 efact_max = (one * max_nqibz_k * self%qpt_comm%nproc) / nqeff 4756 write(msg, "(2(a,i0,a),a,2(f7.3,1x),a)") & 4757 " Number of q-points in the IBZ(k) treated by this MPI proc: ", self%my_nqibz_k, ch10, & 4758 " Number of MPI procs in qpt_comm: ", self%qpt_comm%nproc, ch10, & 4759 " Load balance inside qpt_comm ranges between: [", efact_min, efact_max, "] (should be ~1)" 4760 call wrtout(std_out, msg) 4761 ABI_WARNING_IF(self%my_nqibz_k == 0, "my_nqibz_k == 0") 4762 4763 ! Make sure each node has the q-points we need. Try not to break qcache_size_mb contract! 4764 if (self%use_ftinterp) then 4765 ! Update cache by Fourier interpolating W(r,R) 4766 call dvdb%ftqcache_update_from_ft(nfftf, ngfftf, self%nqibz, self%qibz, ineed_qibz, comm) 4767 else 4768 ! Update cache. Perform collective IO inside comm if needed. 4769 call dvdb%qcache_update_from_file(nfftf, ngfftf, ineed_qdvdb, comm) 4770 end if 4771 4772 ABI_SFREE(ineed_qibz) 4773 ABI_SFREE(ineed_qdvdb) 4774 end if ! qfilter 4775 4776 else 4777 ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(self%qint_method))) 4778 end if ! intmeth 4779 4780 if (dtset%ibte_prep > 0) then 4781 ! Allocate array with scattering rate for IBTE. 4782 ABI_RECALLOC(self%srate, (self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp, self%my_nqibz_k)) 4783 self%srate = zero 4784 end if 4785 4786 case default 4787 ABI_ERROR(sjoin("Invalid eph_task:", itoa(dtset%eph_task))) 4788 end select 4789 4790 call cwtime_report(" Setup qloop", cpu, wall, gflops) 4791 4792 contains 4793 4794 subroutine distribute_nqibz_k_nofilter() 4795 ! Find number of q-points in IBZ(k) treated by this MPI rank 4796 ! taking into account itreat_qibz and build redirection table myq2ibz_k. 4797 ! The distribution must be consistent with the WF distribution done with bks_mask 4798 4799 self%my_nqibz_k = 0 4800 do ii=1,2 4801 if (ii == 2) then 4802 ABI_REMALLOC(self%myq2ibz_k, (self%my_nqibz_k)) 4803 end if 4804 cnt = 0 4805 do iq_ibz_k=1,self%nqibz_k 4806 iq_ibz = self%ind_ibzk2ibz(1, iq_ibz_k) 4807 if (self%itreat_qibz(iq_ibz) == 0) cycle 4808 if (ii == 1) self%my_nqibz_k = self%my_nqibz_k + 1 4809 if (ii == 2) then 4810 cnt = cnt + 1 4811 self%myq2ibz_k(cnt) = iq_ibz_k 4812 end if 4813 end do 4814 end do 4815 4816 end subroutine distribute_nqibz_k_nofilter 4817 4818 end subroutine sigmaph_setup_qloop
m_sigmaph/sigmaph_skip_phmode [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_phskip_mode
FUNCTION
Ignore contribution of phonon mode depending on phonon frequency value or mode index.
INPUTS
SOURCE
4583 pure logical function sigmaph_skip_phmode(self, nu, wqnu, eph_phrange_w) result(skip) 4584 4585 !Arguments ------------------------------------ 4586 class(sigmaph_t),intent(in) :: self 4587 integer,intent(in) :: nu 4588 real(dp),intent(in) :: wqnu, eph_phrange_w(2) 4589 4590 ! ************************************************************************* 4591 4592 skip = wqnu < EPHTK_WTOL .or. self%phmodes_skip(nu) == 1 4593 4594 ! Check frequency range 4595 if (abs(eph_phrange_w(2)) > tol12) then 4596 if (eph_phrange_w(2) > zero) then 4597 ! wqnu must be inside range 4598 skip = skip .or. .not. (wqnu >= eph_phrange_w(1) .and. wqnu <= eph_phrange_w(2)) 4599 else 4600 ! wqnu must be outside range 4601 skip = skip .or. (wqnu >= eph_phrange_w(1) .and. wqnu <= eph_phrange_w(2)) 4602 end if 4603 end if 4604 4605 end function sigmaph_skip_phmode
m_sigmaph/sigmaph_t [ Types ]
[ Top ] [ m_sigmaph ] [ Types ]
NAME
sigmaph_t
FUNCTION
Container for the (diagonal) matrix elements of the electron-phonon self-energy in the KS representation i.e. Sigma_eph(omega, T, band, k, spin). Provides methods to compute QP corrections, spectral functions, QP linewidths and save the results to netcdf file.
SOURCE
124 type,public :: sigmaph_t 125 126 integer :: nkcalc 127 ! Number of k-points computed (inside energy window) 128 129 integer :: max_nbcalc 130 ! Maximum number of bands computed (max over nkcalc and spin). 131 132 integer :: nsppol 133 ! Number of independent spin polarizations. 134 135 integer :: nspinor 136 ! Number of spinor components. 137 138 integer :: nwr 139 ! Number of frequency points along the real axis for Sigma(w) and spectral function A(w) 140 ! Odd number so that the mesh is centered on the KS energy. 141 ! The spectral function is computed only if nwr > 0 (taken from dtset%nfreqsp) 142 143 integer :: ntemp 144 ! Number of temperatures. 145 146 integer :: symsigma 147 ! 1 if matrix elements should be symmetrized. 148 ! Required when the sum over q in the BZ is replaced by IBZ(k). 149 150 integer :: timrev 151 ! timrev = 1 if the use of time-reversal is allowed; 0 otherwise 152 153 integer :: nbsum 154 ! Total number of bands used in sum over states without taking into account MPI distribution. 155 156 integer :: bsum_start, bsum_stop 157 ! First and last band included in self-energy sum without taking into account MPI distribution inside bsum_comm 158 ! nbsum = bsum_stop - bsum_start + 1 159 160 integer :: my_bsum_start, my_bsum_stop 161 ! Initial and final band index included in self-energy sum 162 ! Processor-dependent if Re-Im calculation. 163 ! Processor-independent and computed at runtime on the basis of the nk states in Sigma_{nk} if imag_only 164 165 integer :: my_npert 166 ! Number of atomic perturbations or phonon modes treated by this MPI rank. 167 ! Note that natom3 are equally distributed. This allows us to use allgather instead of allgatherv 168 169 type(xcomm_t) :: pert_comm 170 ! MPI communicator for parallelism over atomic perturbations. 171 172 type(xcomm_t) :: qb_comm 173 ! MPI communicator used to distribute (band_sum, q-points) 174 175 type(xcomm_t) :: qpt_comm 176 ! MPI communicator for q-points 177 178 type(xcomm_t) :: bsum_comm 179 ! MPI communicator for bands in self-energy sum 180 181 type(xcomm_t) :: kcalc_comm 182 ! MPI communicator for parallelism over k-points (high-level) 183 184 type(xcomm_t) :: spin_comm 185 ! MPI communicator for parallelism over spins (high-level) 186 187 type(xcomm_t) :: pqb_comm 188 ! MPI communicator for the (perturbation, band_sum, qpoint_sum) 189 190 type(xcomm_t) :: ncwrite_comm 191 ! MPI communicator for parallel netcdf IO used to write results for the different k-points/spins 192 193 integer :: coords_pqbks(5) 194 ! Cartesian coordinates of this processor in the Cartesian grid. 195 196 integer :: nqbz 197 ! Number of q-points in the (dense) BZ for sigma integration 198 199 integer :: nqibz 200 ! Number of q-points in the (dense) IBZ for sigma integration 201 202 integer :: nqibz_k 203 ! Number of q-points in the IBZ(k). Depends on ikcalc. 204 205 integer :: my_nqibz_k 206 ! Number of q-points in the IBZ(k) treated by this MPI proc. Depends on ikcalc. 207 ! Differs from nqibz_k only if imag with tetra because in this case we can introduce a cutoff on the weights 208 209 integer :: lgk_nsym 210 ! Number of symmetries in the little group of k. Depends on ikcalc. 211 212 integer :: ncid = nctk_noid 213 ! Netcdf file handle used to save results. 214 215 integer :: mpw 216 ! Maximum number of PWs for all possible k+q 217 218 integer :: bcorr = 0 219 ! 1 to include Blochl correction in the tetrahedron method else 0. 220 221 integer :: zinv_opt = 1 222 ! Defines the algorithm used to compute the tetrahedron weights for 1/z if re-im computation 223 ! 1 for S. Kaprzyk routines, 224 ! 2 for Lambin-Vigneron. 225 226 integer :: ntheta = 0, nphi = 0 227 ! Number of division for spherical integration of Frohlich term. 228 229 integer :: angl_size = 0 230 ! Dimension of angular mesh for spherical integration of the Frohlich self-energy 231 ! angl_size = ntheta * nphi 232 233 complex(dpc) :: ieta 234 ! Used to shift the poles in the complex plane (Ha units) 235 ! Corresponds to `i eta` term in equations. 236 237 real(dp) :: elow, ehigh 238 ! min and Max KS energy treated in self-energy +- max phonon energy 239 ! Used to select bands in self-energy sum if imag_only and select q-points in qpoints_oracle 240 241 real(dp) :: phwinfact = four 242 ! phwinfact * wmax is used to define the energy window for filtering electronic states 243 ! in the computation of electron lifetimes. 244 245 real(dp) :: wr_step 246 ! Step of the linear mesh along the real axis (Ha units). 247 248 real(dp) :: wmax 249 ! Max phonon energy + buffer. Used to select the bands to sum for the imaginary part 250 ! and filter q-points on the basis of electron energy difference. 251 252 integer :: qint_method 253 ! Defines the method used for the q-space integration 254 ! 0 -> Standard quadrature (one point per micro zone). 255 ! 1 -> Use tetrahedron method. 256 257 integer :: frohl_model = 0 258 ! > 0 to treat the q --> 0 divergence and accelerate convergence in polar semiconductors. 259 ! 1: Use spherical integration inside the micro zone around the Gamma point 260 261 integer :: mrta = 0 262 ! 0 to disable MRTA. 263 ! > 0 if linewidths in the energy-momentum relaxation time approximation should be computed 264 265 real(dp),allocatable :: scratew(:,:,:,:) 266 ! (%phmesh_size, %ntemp, %max_nbcalc, 2) 267 268 logical :: use_doublegrid = .False. 269 ! whether to use double grid or not 270 271 logical :: use_ftinterp = .False. 272 ! whether DFPT potentials should be read from the DVDB or Fourier-interpolated on the fly. 273 274 type(eph_double_grid_t) :: eph_doublegrid 275 ! store the double grid related object 276 277 logical :: imag_only 278 ! True if only the imaginary part of the self-energy must be computed 279 280 integer :: gmax(3) 281 282 integer :: ngqpt(3) 283 ! Number of divisions in the Q mesh in the BZ. 284 285 integer,allocatable :: bstart_ks(:,:) 286 ! bstart_ks(nkcalc, nsppol) 287 ! Initial KS band index included in self-energy matrix elements for each k-point in kcalc. 288 ! Depends on spin because all degenerate states should be included when symmetries are used. 289 290 integer,allocatable :: bstop_ks(:,:) 291 ! bstop_ks(nkcalc, nsppol) 292 293 integer,allocatable :: nbcalc_ks(:,:) 294 ! nbcalc_ks(nkcalc, nsppol) 295 ! Number of bands included in self-energy matrix elements for each k-point in kcalc. 296 ! Depends on spin because all degenerate states should be included when symmetries are used. 297 298 integer,allocatable :: kcalc2ibz(:,:) 299 !kcalc2ibz(nkcalc, 6)) 300 ! Mapping ikcalc --> IBZ as reported by listkk. 301 302 integer :: my_nspins 303 ! Number of spins treated by this MPI rank 304 305 integer,allocatable :: my_spins(:) 306 ! my_spins(my_nspins) 307 ! Indirect table giving the spin indices treated by this MPI rank. 308 ! Used only in the collinear case with nsppol = 2 and nspinor == 1 309 310 integer :: my_nkcalc 311 ! Number of k-points treated by this MPI rank 312 313 integer,allocatable :: my_ikcalc(:) 314 ! my_ikcalc(my_nkcalc) 315 ! List of ikcalc indices treated by this pool if k-point parallelism is activated. 316 317 integer,allocatable :: myq2ibz_k(:) 318 ! myq2ibz_k(my_nqibz_k) 319 ! Mapping my q-point index --> index in nqibz_k arrays (IBZ_k) 320 ! Differs from nqibz_k only if imag with tetra because in this case we can introduce a cutoff. 321 322 integer(i1b),allocatable :: itreat_qibz(:) 323 ! itreat_qibz(nqibz) 324 ! Table used to distribute potentials over q-points in the IBZ. 325 ! The loop over qpts in the IBZ(k) is MPI distributed inside qpt_comm according to this table. 326 ! 0 if this IBZ point is not treated by this proc. 327 ! 1 if this IBZ is treated. 328 329 integer,allocatable :: my_pinfo(:,:) 330 ! my_pinfo(3, my_npert) 331 ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation. 332 ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation. 333 ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3 334 335 integer,allocatable :: pert_table(:,:) 336 ! pert_table(2, natom3) 337 ! pert_table(1, npert): rank of the processor treating this atomic perturbation. 338 ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert. 339 340 integer,allocatable :: phmodes_skip(:) 341 ! (natom3) 342 ! A mask to skip accumulating the contribution of certain phonon modes 343 344 integer,allocatable:: ind_qbz2ibz(:,:) 345 ! (6, %nqibz) 346 ! Mapping qBZ to IBZ 347 348 integer,allocatable:: indkk_kq(:, :) 349 ! (6, %nqibz_k)) 350 ! Mapping k+q --> initial IBZ. Depends on ikcalc. 351 ! These table used the conventions for the symmetrization of the wavefunctions expected by cgtk_rotate. 352 ! In this case listkk has been called with symrel and use_symrec=False 353 354 integer,allocatable :: ind_q2dvdb_k(:,:) 355 ! (6, %nqibz_k)) 356 ! Mapping qibz_k --> IBZ found in DVDB file. 357 ! Used when DFPT potentials are read from DVDB file so that we know how to access/symmetrize v1scf 358 ! Depends on ikcalc. 359 360 integer,allocatable :: ind_ibzk2ibz(:,:) 361 ! (6, %nqibz_k)) 362 ! Mapping qibz_k --> IBZ defined by eph_ngqpt_fine. 363 ! Depends on ikcalc. 364 365 integer,allocatable :: qibz2dvdb(:) 366 ! (%nqibz)) 367 ! Mapping dvdb%ibz --> %ibz 368 369 integer, allocatable :: lgk_sym2glob(:, :) 370 ! lgk_sym2glob(2, lgk_nsym) 371 ! Mapping isym_lg --> [isym, itime] 372 ! where isym is the index of the operation in the global array **crystal%symrec** 373 ! and itim is 2 if time-reversal T must be included else 1. Depends on ikcalc 374 375 integer,allocatable :: nbsum_rank(:,:) 376 ! (%bsum_comm%nproc, 2) 377 ! (rank+1, 1): Number of bands treated by rank in %bsum_comm. 378 ! (rank+1, 2): bsum_start of MPI rank 379 ! Available only if .not. imag_only 380 381 real(dp),allocatable :: kcalc(:,:) 382 ! kcalc(3, nkcalc) 383 ! List of k-points where the self-energy is computed. 384 385 real(dp),allocatable :: qbz(:,:) 386 ! qbz(3, nqbz) 387 ! Reduced coordinates of the q-points in the full BZ. 388 389 real(dp),allocatable :: qibz(:,:) 390 ! qibz(3, nqibz) 391 ! Reduced coordinates of the q-points in the IBZ (full simmetry of the system). 392 393 real(dp),allocatable :: wtq(:) 394 ! wtq(nqibz) 395 ! Weights of the q-points in the IBZ (normalized to one). 396 397 real(dp),allocatable :: qibz_k(:,:) 398 ! qibz(3, nqibz_k) 399 ! Reduced coordinates of the q-points in the IBZ(k). Depends on ikcalc. 400 401 real(dp),allocatable :: wtq_k(:) 402 ! wtq(nqibz_k) 403 ! Weights of the q-points in the IBZ(k) (normalized to one). Depends on ikcalc. 404 405 real(dp),allocatable :: srate(:,:,:,:) 406 ! (%bsum_start:%bsum_stop, %nbcalc_ks(ikcalc, spin), %ntemp, %my_nqibz_k)) 407 ! This array is initialized inside the (ikcalc, spin) loop 408 409 real(dp),allocatable :: kTmesh(:) 410 ! kTmesh(ntemp) 411 ! List of temperatures (kT units). 412 413 real(dp),allocatable :: mu_e(:) 414 ! mu_e(ntemp) 415 ! chemical potential of electrons for the different temperatures. 416 417 real(dp),allocatable :: e0vals(:) 418 ! (nbcalc_ks) 419 ! KS energies where QP corrections are wantend 420 ! This array is initialized inside the (ikcalc, spin) loop 421 422 real(dp),allocatable :: vcar_calc(:,:,:,:) 423 ! (3, max_nbcalc, nkcalc, nsppol)) 424 ! Diagonal elements of velocity operator in cartesian coordinates for all states in Sigma_nk. 425 426 real(dp),allocatable :: linewidth_mrta(:,:) 427 ! linewidth_mrta(ntemp, max_nbcalc) 428 ! Linewidths computed within the momentum relaxation time approximation 429 ! for given (ikcalc, spin). Only if imag_only 430 431 complex(dpc),allocatable :: cweights(:,:,:,:,:,:,:) 432 ! (nz, 2, nbcalc_ks, my_npert, my_bsum_start:my_bsum_stop, my_nqibz_k, ndiv)) 433 ! Weights for the q-integration of 1 / (e1 - e2 \pm w_{q, nu} + i.eta) 434 ! This array is initialized inside the (ikcalc, spin) loop 435 436 real(kind=DELTAW_KIND),allocatable :: deltaw_pm(:,:,:,:,:,:) 437 ! (2, nbcalc_ks, my_npert, bsum_start:bsum_stop, my_nqibz_k, ndiv)) 438 ! Weights for the q-integration of the two delta (abs/emission) if imag_only 439 ! This array is initialized inside the (ikcalc, spin) loop 440 441 real(dp),allocatable :: wrmesh_b(:,:) 442 ! wrmesh_b(nwr, max_nbcalc) 443 ! Frequency mesh along the real axis (Ha units) used for the different bands 444 ! Each mesh is **centered** on the corresponding KS energy. 445 ! This array depends on (ikcalc, spin) 446 447 real(dp), allocatable :: qvers_cart(:,:) 448 ! qvers_cart(3, angl_size) 449 ! For each point of the angular mesh, gives the Cartesian coordinates 450 ! of the corresponding point on an unitary sphere (Frohlich self-energy) 451 452 real(dp), allocatable :: angwgth(:) 453 ! angwgth(angl_size) 454 ! For each point of the angular mesh, gives the weight 455 ! of the corresponding point on an unitary sphere (Frohlich self-energy) 456 457 real(dp),allocatable :: frohl_deltas_sphcorr(:, :, :, :) 458 ! (2, ntemp, max_nbcalc, natom3)) 459 ! Integration of the imaginary part inside the small sphere around Gamma 460 ! computed numerically with the Frohlich model by Verdi and angular integration. 461 ! The first dimension stores the contributions due to +/- omega_qn 462 ! Used if frohl_model == 1 and imag_only. This array depend on (ikcalc, spin) 463 ! TODO: Finalize implementation 464 465 integer, allocatable :: qp_done(:,:) 466 ! qp_done(kcalc, spin) 467 ! Keep track of the QP states already computed for restart of the calculation 468 469 complex(dpc),allocatable :: vals_e0ks(:,:) 470 ! vals_e0ks(ntemp, max_nbcalc) 471 ! Sigma_eph(omega=eKS, kT, band) for given (ikcalc, spin). 472 ! Fan-Migdal + Debye-Waller 473 474 complex(dpc),allocatable :: fan_vals(:,:) 475 ! fan_vals(ntemp, max_nbcalc) 476 ! Fan-Migdal 477 478 complex(dpc),allocatable :: fan_stern_vals(:,:) 479 ! fan_stern_vals(ntemp, max_nbcalc) 480 ! Fan-Migdal adiabatic Sternheimer part 481 482 complex(dpc),allocatable :: dvals_de0ks(:,:) 483 ! dvals_de0ks(ntemp, max_nbcalc) for given (ikcalc, spin) 484 ! d Re Sigma_eph(omega, kT, band, kcalc, spin) / d omega (omega=eKS) 485 486 complex(dpc),allocatable :: frohl_dvals_de0ks(:,:) 487 ! frohl_dvals_de0ks(ntemp, max_nbcalc) for given (ikcalc, spin) 488 ! d Re Sigma_frohl(omega, kT, band, kcalc, spin) / d omega (omega=eKS) 489 490 real(dp),allocatable :: dw_vals(:,:) 491 ! dw_vals(ntemp, max_nbcalc) for given (ikcalc, spin) 492 ! Debye-Waller term (static). 493 494 real(dp),allocatable :: dw_stern_vals(:,:) 495 ! dw_stern_vals(ntemp, max_nbcalc) for given (ikcalc, spin) 496 ! Debye-Waller Sternheimer term (static) . 497 498 complex(dpc),allocatable :: vals_wr(:,:,:) 499 ! vals_wr(nwr, ntemp, max_nbcalc) 500 ! Sigma_eph(omega, kT, band) for given (ikcalc, spin). 501 ! enk_KS corresponds to nwr/2 + 1. 502 ! This array depends on (ikcalc, spin) 503 504 integer :: phmesh_size 505 ! Number of phonon frequencies in phonon mesh used for Eliashberg functions and 506 ! and other omega-resolved quantities. 507 508 real(dp),allocatable :: phmesh(:) 509 ! phmesh(phmesh_size) 510 ! phonon mesh in Ha. 511 512 real(dp),allocatable :: gf_nnuq(:,:,:,:) 513 ! (nbcalc_ks, natom3, %nqibz_k, 3) 514 ! Quantities needed to compute the generalized Eliashberg functions (gkq2/Fan-Migdal/DW terms) 515 ! This array depends on (ikcalc, spin) 516 ! NB: q-weights for integration are not included. 517 518 real(dp),allocatable :: gfw_vals(:,:,:) 519 ! gfw_vals(phmesh_size, 3, max_nbcalc) 520 ! Generalized Eliashberg function a2F_{n,k,spin}(w) 521 ! 1: |g(k,q)|^2 with delta(e_\nk - e_{m\kq}) 522 ! 2: Fan-Migdal in the adiabatic approximation 523 ! 3: DW contribution in the adiabatic approximation. 524 ! This array depends on (ikcalc, spin) 525 526 integer :: a2f_ne = 0 527 ! Number of points in a2f_emesh 528 529 real(dp),allocatable :: a2f_emesh(:) 530 ! a2f_emesh(a2f_ne) 531 ! Energy mesh for electrons 532 533 real(dp),allocatable :: a2few(:,:,:) 534 ! a2few(a2f_ne, phmesh_size, max_nbcalc) 535 ! FM Eliashberg function a2f_\nk(e, w) = \sum_{mq} |g(k,q)|^2 delta(e - e_{m\kq}) delta(w - w_\qnu} 536 ! This array depends on (ikcalc, spin) and is computed only if prteliash == 3 537 538 type(ephwg_t) :: ephwg 539 ! This object computes the weights for the BZ integration in q-space if qint_method > 0 540 541 type(degtab_t),allocatable :: degtab(:,:) 542 ! (nkcalc, nsppol) 543 ! Table used to average QP results in the degenerate subspace if symsigma == 1 544 545 contains 546 547 procedure :: write => sigmaph_write 548 ! Write main dimensions and header of sigmaph on a netcdf file. 549 550 procedure :: compare => sigmaph_compare 551 ! Compare two instances of sigmaph raise error if different 552 553 procedure :: setup_kcalc => sigmaph_setup_kcalc 554 ! Return tables used to perform the sum over q-points for given k-point. 555 556 procedure :: gather_and_write => sigmaph_gather_and_write 557 ! Compute the QP corrections. 558 559 procedure :: print => sigmaph_print 560 ! Print results to main output file. 561 562 procedure :: free => sigmaph_free 563 ! Free sigmaph object 564 565 procedure :: get_ebands => sigmaph_get_ebands 566 ! Fill in values in ebands from the sigmaph structure and netcdf file 567 568 procedure :: skip_phmode => sigmaph_skip_phmode 569 ! Ignore contribution of phonon mode depending on phonon frequency value or mode index. 570 571 end type sigmaph_t
m_sigmaph/sigmaph_write [ Functions ]
[ Top ] [ m_sigmaph ] [ Functions ]
NAME
sigmaph_write
FUNCTION
Define dimensions and netcdf arrays in SIGEPH file.
INPUTS
dtset<dataset_type>=All input variables for this dataset. cryst<crystal_t>=Crystalline structure ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...) wfk_hdr=Header of the WFK file. ifc<ifc_type>=interatomic force constants and corresponding real space grid info. dtfil<datafiles_type>=variables related to files. comm=MPI communicator
SOURCE
3604 subroutine sigmaph_write(self, dtset, cryst, ebands, wfk_hdr, dtfil, comm) 3605 3606 !Arguments ------------------------------------ 3607 integer,intent(in) :: comm 3608 class(sigmaph_t),intent(inout) :: self 3609 type(crystal_t),intent(in) :: cryst 3610 type(dataset_type),intent(in) :: dtset 3611 type(ebands_t),intent(in) :: ebands 3612 type(hdr_type),intent(in) :: wfk_hdr 3613 type(datafiles_type),intent(in) :: dtfil 3614 3615 !Local variables ------------------------------ 3616 !scalars 3617 integer,parameter :: master = 0 3618 integer :: my_rank, ii, edos_intmeth, spin, ikcalc 3619 integer :: ncid, ncerr, grp_ncid 3620 !character(len=5000) :: msg 3621 real(dp) :: edos_broad, edos_step, cpu_all, wall_all, gflops_all, cpu, wall, gflops 3622 character(len=fnlen) :: path 3623 type(edos_t) :: edos 3624 3625 ! ************************************************************************* 3626 3627 my_rank = xmpi_comm_rank(comm) 3628 3629 call cwtime(cpu_all, wall_all, gflops_all, "start") 3630 3631 if (dtset%prtdos /= 0) then 3632 call cwtime(cpu, wall, gflops, "start") 3633 ! Compute electron DOS. 3634 edos_intmeth = 2; if (self%bcorr == 1) edos_intmeth = -2 3635 if (dtset%prtdos == 1) edos_intmeth = 1 3636 edos_step = dtset%dosdeltae; edos_broad = dtset%tsmear 3637 call wrtout(std_out, " Computing electron dos. Use prtdos 0 to disable this part...", do_flush=.True.) 3638 edos = ebands_get_edos(ebands, cryst, edos_intmeth, edos_step, edos_broad, comm) 3639 if (my_rank == master) then 3640 path = strcat(dtfil%filnam_ds(4), "_EDOS") 3641 call wrtout(ab_out, sjoin("- Writing electron DOS to file:", path)) 3642 call edos%write(path) 3643 call edos%print(unit=std_out) 3644 !call edos%print(unit=ab_out) 3645 end if 3646 call cwtime_report(" sigmaph_new: ebands", cpu, wall, gflops) 3647 end if 3648 3649 ! Create netcdf file (only master works, HDF5 + MPI-IO is handled afterwards by reopening the file inside ncwrite_comm) 3650 path = strcat(dtfil%filnam_ds(4), "_SIGEPH.nc") 3651 if (my_rank == master) then 3652 ! Master creates the netcdf file used to store the results of the calculation. 3653 NCF_CHECK(nctk_open_create(self%ncid, path, xmpi_comm_self)) 3654 ncid = self%ncid 3655 3656 NCF_CHECK(wfk_hdr%ncwrite(ncid, fform_from_ext("SIGEPH.nc"), nc_define=.True.)) 3657 NCF_CHECK(cryst%ncwrite(ncid)) 3658 NCF_CHECK(ebands_ncwrite(ebands, ncid)) 3659 if (dtset%prtdos /= 0) then 3660 NCF_CHECK(edos%ncwrite(ncid)) 3661 end if 3662 3663 ! Add sigma_eph dimensions. 3664 ncerr = nctk_def_dims(ncid, [ & 3665 nctkdim_t("nkcalc", self%nkcalc), nctkdim_t("max_nbcalc", self%max_nbcalc), & 3666 nctkdim_t("nsppol", self%nsppol), nctkdim_t("ntemp", self%ntemp), nctkdim_t("natom3", 3 * cryst%natom), & 3667 nctkdim_t("phmesh_size", self%phmesh_size), & 3668 nctkdim_t("nqibz", self%nqibz), nctkdim_t("nqbz", self%nqbz)], & 3669 defmode=.True.) 3670 NCF_CHECK(ncerr) 3671 3672 if (self%nwr > 0) then 3673 NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nwr", self%nwr)])) 3674 end if 3675 if (dtset%prteliash == 3) then 3676 NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("a2f_ne", self%a2f_ne)])) 3677 end if 3678 3679 ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: & 3680 "eph_task", "symsigma", "nbsum", "bsum_start", "bsum_stop", "symdynmat", & 3681 "ph_intmeth", "eph_intmeth", "qint_method", "eph_transport", & 3682 "imag_only", "symv1scf", "dvdb_add_lr", "mrta", "ibte_prep", "eph_prtscratew", "eph_ahc_type"]) 3683 NCF_CHECK(ncerr) 3684 ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: & 3685 "eta", "wr_step", "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie", & 3686 "ph_wstep", "ph_smear", "eph_phwinfact"]) 3687 NCF_CHECK(ncerr) 3688 3689 ! Define arrays with results. 3690 ncerr = nctk_def_arrays(ncid, [ & 3691 nctkarr_t("ngqpt", "int", "three"), & 3692 nctkarr_t("eph_ngqpt_fine", "int", "three"), & 3693 nctkarr_t("eph_phrange", "int", "two"), & 3694 nctkarr_t("eph_phrange_w", "dp", "two"), & 3695 nctkarr_t("ddb_ngqpt", "int", "three"), & 3696 nctkarr_t("ph_ngqpt", "int", "three"), & 3697 nctkarr_t("sigma_ngkpt", "int", "three"), & 3698 nctkarr_t("sigma_erange", "dp", "two"), & 3699 !nctkarr_t("frohl_params", "dp", "four"), & 3700 nctkarr_t("bstart_ks", "int", "nkcalc, nsppol"), & 3701 !nctkarr_t("bstop_ks", "int", "nkcalc, nsppol"), & 3702 nctkarr_t("nbcalc_ks", "int", "nkcalc, nsppol"), & 3703 nctkarr_t("kcalc", "dp", "three, nkcalc"), & 3704 nctkarr_t("kcalc2ibz", "int", "nkcalc, six"), & 3705 nctkarr_t("kTmesh", "dp", "ntemp"), & 3706 nctkarr_t("mu_e", "dp", "ntemp"), & 3707 nctkarr_t("qp_done", "int", "nkcalc, nsppol"), & 3708 nctkarr_t("vals_e0ks", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3709 nctkarr_t("fan_vals", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3710 nctkarr_t("fan_stern_vals", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3711 nctkarr_t("dvals_de0ks", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3712 nctkarr_t("dw_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), & 3713 nctkarr_t("dw_stern_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), & 3714 nctkarr_t("qpoms_enes", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3715 nctkarr_t("qp_enes", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), & 3716 nctkarr_t("ze0_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), & 3717 nctkarr_t("ks_enes", "dp", "max_nbcalc, nkcalc, nsppol"), & 3718 nctkarr_t("ks_gaps", "dp", "nkcalc, nsppol"), & 3719 nctkarr_t("qpoms_gaps", "dp", "ntemp, nkcalc, nsppol"), & 3720 nctkarr_t("qp_gaps", "dp", "ntemp, nkcalc, nsppol"), & 3721 nctkarr_t("phmesh", "dp", "phmesh_size"), & 3722 nctkarr_t("vcar_calc", "dp", "three, max_nbcalc, nkcalc, nsppol") & 3723 ]) 3724 NCF_CHECK(ncerr) 3725 3726 if (self%mrta > 0) then 3727 ncerr = nctk_def_arrays(ncid, [ & 3728 nctkarr_t("linewidth_mrta", "dp", "ntemp, max_nbcalc, nkcalc, nsppol") & 3729 ]) 3730 NCF_CHECK(ncerr) 3731 end if 3732 3733 if (dtset%eph_prtscratew == 1) then 3734 ncerr = nctk_def_arrays(ncid, [ & 3735 nctkarr_t("scratew", "dp", "phmesh_size, ntemp, max_nbcalc, two, nkcalc, nsppol") & 3736 ]) 3737 NCF_CHECK(ncerr) 3738 end if 3739 3740 !if (self%frohl_model == 1) then 3741 ! if (self%imag_only) then 3742 ! ncerr = nctk_def_arrays(ncid, [ & 3743 ! nctkarr_t("frohl_deltas_sphcorr", "dp", "two, ntemp, max_nbcalc, natom3, nkcalc, nsppol") & 3744 ! ]) 3745 ! NCF_CHECK(ncerr) 3746 ! end if 3747 !end if 3748 3749 if (self%nwr > 0) then 3750 ! Make room for the spectral function. These arrays get two extra dimensions on file (nkcalc, nsppol). 3751 ncerr = nctk_def_arrays(ncid, [ & 3752 nctkarr_t("wrmesh_b", "dp", "nwr, max_nbcalc, nkcalc, nsppol"), & 3753 nctkarr_t("vals_wr", "dp", "two, nwr, ntemp, max_nbcalc, nkcalc, nsppol"), & 3754 nctkarr_t("spfunc_wr", "dp", "nwr, ntemp, max_nbcalc, nkcalc, nsppol") & 3755 ]) 3756 NCF_CHECK(ncerr) 3757 end if 3758 3759 if (dtset%prteliash /= 0) then 3760 ncerr = nctk_def_arrays(ncid, [ & 3761 nctkarr_t("gfw_vals", "dp", "phmesh_size, three, max_nbcalc, nkcalc, nsppol") & 3762 ]) 3763 NCF_CHECK(ncerr) 3764 if (dtset%prteliash == 3) then 3765 ncerr = nctk_def_arrays(ncid, [ & 3766 nctkarr_t("a2f_emesh", "dp", "a2f_ne"), & 3767 nctkarr_t("a2few", "dp", "a2f_ne, phmesh_size, max_nbcalc, nkcalc, nsppol") & 3768 ]) 3769 NCF_CHECK(ncerr) 3770 end if 3771 end if 3772 3773 if (dtset%ibte_prep > 0) then 3774 ! Create groups to store scattering rates (ragged array). 3775 do spin=1,self%nsppol 3776 do ikcalc=1,self%nkcalc 3777 NCF_CHECK(nf90_def_grp(ncid, strcat("srate_k", itoa(ikcalc), "_s", itoa(spin)), grp_ncid)) 3778 end do 3779 end do 3780 end if 3781 3782 ! ====================================================== 3783 ! Write data that do not depend on the (kpt, spin) loop. 3784 ! ====================================================== 3785 NCF_CHECK(nctk_set_datamode(ncid)) 3786 ii = 0; if (self%imag_only) ii = 1 3787 ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: & 3788 "eph_task", "symsigma", "nbsum", "bsum_start", "bsum_stop", & 3789 "symdynmat", "ph_intmeth", "eph_intmeth", "qint_method", & 3790 "eph_transport", "imag_only", "symv1scf", "dvdb_add_lr", "mrta", "ibte_prep", "eph_prtscratew", "eph_ahc_type"], & 3791 [dtset%eph_task, self%symsigma, self%nbsum, self%bsum_start, self%bsum_stop, & 3792 dtset%symdynmat, dtset%ph_intmeth, dtset%eph_intmeth, self%qint_method, dtset%eph_transport, ii, & 3793 dtset%symv1scf, dtset%dvdb_add_lr, self%mrta, dtset%ibte_prep, dtset%eph_prtscratew, dtset%eph_ahc_type]) 3794 NCF_CHECK(ncerr) 3795 ncerr = nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: & 3796 "eta", "wr_step", "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie", "ph_wstep", "ph_smear", "eph_phwinfact"], & 3797 [aimag(self%ieta), self%wr_step, dtset%eph_fsewin, dtset%eph_fsmear, dtset%eph_extrael, dtset%eph_fermie, & 3798 dtset%ph_wstep, dtset%ph_smear, dtset%eph_phwinfact]) 3799 NCF_CHECK(ncerr) 3800 3801 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), self%ngqpt)) 3802 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_ngqpt_fine"), dtset%eph_ngqpt_fine)) 3803 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ddb_ngqpt"), dtset%ddb_ngqpt)) 3804 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ph_ngqpt"), dtset%ph_ngqpt)) 3805 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "sigma_ngkpt"), dtset%sigma_ngkpt)) 3806 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "sigma_erange"), dtset%sigma_erange)) 3807 !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "frohl_params"), dtset%frohl_params)) 3808 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_phrange"), dtset%eph_phrange)) 3809 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_phrange_w"), dtset%eph_phrange_w)) 3810 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "bstart_ks"), self%bstart_ks)) 3811 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "nbcalc_ks"), self%nbcalc_ks)) 3812 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kcalc"), self%kcalc)) 3813 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kcalc2ibz"), self%kcalc2ibz)) 3814 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kTmesh"), self%kTmesh)) 3815 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "mu_e"), self%mu_e)) 3816 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eta"), aimag(self%ieta))) 3817 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phmesh"), self%phmesh)) 3818 if (dtset%prteliash == 3) then 3819 NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "a2f_emesh"), self%a2f_emesh)) 3820 end if 3821 NCF_CHECK(nf90_close(ncid)) 3822 end if ! master 3823 3824 call xmpi_barrier(comm) 3825 3826 ! Now reopen the file inside ncwrite_comm to perform parallel-IO (required for k-point parallelism). 3827 if (self%ncwrite_comm%value /= xmpi_comm_null) then 3828 NCF_CHECK(nctk_open_modify(self%ncid, path, self%ncwrite_comm%value)) 3829 NCF_CHECK(nctk_set_datamode(self%ncid)) 3830 end if 3831 3832 call edos%free() 3833 call cwtime_report(" sigmaph_new: netcdf", cpu_all, wall_all, gflops_all) 3834 3835 end subroutine sigmaph_write