TABLE OF CONTENTS
- ABINIT/covar_cprj
- ABINIT/cpg_dij_cpb
- ABINIT/duq_she_qdu
- ABINIT/duqdu
- ABINIT/duqhqdu
- ABINIT/initorbmag
- ABINIT/make_eeig
- ABINIT/make_onsite_bm
- ABINIT/make_onsite_bm_k_n
- ABINIT/make_onsite_l
- ABINIT/make_onsite_l_k
- ABINIT/make_onsite_l_k_n
- ABINIT/make_rhorij1
- ABINIT/make_rhorij1_k_n
- ABINIT/make_S1trace
- ABINIT/make_S1trace_k_n
- ABINIT/mpicomm_helper
- ABINIT/orbmag_ddk
- ABINIT/orbmag_output
- ABINIT/orbmag_wf
- ABINIT/udsdsu
- ABINIT/udsqdu
- m_orbmag/destroy_orbmag
- m_orbmag/orbmag_type
ABINIT/covar_cprj [ Functions ]
NAME
covar_cprj
FUNCTION
Generate cprj multiplied by S^{-1}, similarly to the wavefunctions in smatrix
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
3876 subroutine covar_cprj(cprj_kb,cprj_kb_covar,dtset,nband_k,pawtab,smat_inv) 3877 3878 !Arguments ------------------------------------ 3879 !scalars 3880 integer,intent(in) :: nband_k 3881 type(dataset_type),intent(in) :: dtset 3882 type(pawcprj_type),intent(in) :: cprj_kb(dtset%natom,nband_k) 3883 type(pawcprj_type),intent(inout) :: cprj_kb_covar(dtset%natom,nband_k) 3884 3885 !arrays 3886 real(dp),intent(in) :: smat_inv(2,nband_k,nband_k) 3887 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 3888 3889 !Local variables ------------------------- 3890 !scalars 3891 integer :: iatom,iband,ilmn,itypat,jband 3892 complex(dpc) :: cpb,smi 3893 3894 !arrays 3895 3896 !---------------------------------------------------- 3897 3898 ! make covar cprj same as covar |unk> 3899 do iatom=1,dtset%natom 3900 itypat = dtset%typat(iatom) 3901 do ilmn=1,pawtab(itypat)%lmn_size 3902 do jband = 1, nband_k 3903 cprj_kb_covar(iatom,jband)%cp(:,ilmn) = zero 3904 do iband = 1, nband_k 3905 cpb=cmplx(cprj_kb(iatom,iband)%cp(1,ilmn),cprj_kb(iatom,iband)%cp(2,ilmn),KIND=dpc) 3906 smi=cmplx(smat_inv(1,iband,jband),smat_inv(2,iband,jband),KIND=dpc) 3907 cprj_kb_covar(iatom,jband)%cp(1,ilmn) = cprj_kb_covar(iatom,jband)%cp(1,ilmn) + & 3908 & real(cpb*smi) 3909 cprj_kb_covar(iatom,jband)%cp(2,ilmn) = cprj_kb_covar(iatom,jband)%cp(2,ilmn) + & 3910 & aimag(cpb*smi) 3911 end do ! end loop over iband 3912 end do ! end loop over jband 3913 end do ! end loop over ilmn 3914 end do ! end loop over iatom 3915 3916 end subroutine covar_cprj
ABINIT/cpg_dij_cpb [ Functions ]
NAME
cpg_dij_cpb
FUNCTION
Compute <u_kg|p_i>dij<p_j|u_kb> energy contribution
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
cgdijcb
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
4753 subroutine cpg_dij_cpb(cgdijcb,cprj_kb,cprj_kg,dtset,nb,ng,nspinor,paw_ij,pawtab) 4754 4755 !Arguments ------------------------------------ 4756 !scalars 4757 integer,intent(in) :: nb,ng,nspinor 4758 complex(dpc),intent(out) :: cgdijcb 4759 type(dataset_type),intent(in) :: dtset 4760 4761 !arrays 4762 type(pawcprj_type),intent(in) :: cprj_kb(dtset%natom,nspinor*dtset%mband) 4763 type(pawcprj_type),intent(in) :: cprj_kg(dtset%natom,nspinor*dtset%mband) 4764 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom) 4765 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 4766 4767 !Local variables ------------------------- 4768 !scalars 4769 integer :: iatom,ilmn,jlmn,klmn,itypat 4770 complex(dpc) :: cdij,cpg,cpb 4771 4772 !----------------------------------------------------------------------- 4773 4774 cgdijcb = czero 4775 do iatom = 1, dtset%natom 4776 itypat = dtset%typat(iatom) 4777 do ilmn = 1, pawtab(itypat)%lmn_size 4778 cpg=cmplx(cprj_kg(iatom,ng)%cp(1,ilmn),cprj_kg(iatom,ng)%cp(2,ilmn),KIND=dpc) 4779 do jlmn = 1, pawtab(itypat)%lmn_size 4780 cpb=cmplx(cprj_kb(iatom,nb)%cp(1,jlmn),cprj_kb(iatom,nb)%cp(2,jlmn),KIND=dpc) 4781 if (jlmn .LE. ilmn) then 4782 klmn = (ilmn-1)*ilmn/2 + jlmn 4783 else 4784 klmn = (jlmn-1)*jlmn/2 + ilmn 4785 end if 4786 if (paw_ij(iatom)%cplex_dij .EQ. 2) then 4787 cdij=cmplx(paw_ij(iatom)%dij(2*klmn-1,1),paw_ij(iatom)%dij(2*klmn,1),KIND=dpc) 4788 if (jlmn .GT. ilmn) cdij=conjg(cdij) 4789 else 4790 cdij=cmplx(paw_ij(iatom)%dij(klmn,1),zero,KIND=dpc) 4791 end if 4792 cgdijcb = cgdijcb + conjg(cpg)*cdij*cpb 4793 end do 4794 end do 4795 end do 4796 4797 end subroutine cpg_dij_cpb
ABINIT/duq_she_qdu [ Functions ]
NAME
duqdu
FUNCTION
Return i*epsabg\sum_n E_nk <\partial_b u_kn|Q{SHE}Q|\partial_g u_kn> where
Q projects onto the conduction space, and operator is S_k or E_nk or H_k
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
2573 subroutine duq_she_qdu(atindx1,cg,cprj,dtorbmag,dtset,energies,gmet,& 2574 & gprimd,mcg,mcprj,mpi_enreg,nband_k,nfftf,npwarr,out_e,out_h,out_s,pawang,& 2575 & pawfgr,paw_ij,pawrad,pawtab,psps,pwind,pwind_alloc,rmet,rprimd,& 2576 & vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2577 2578 !Arguments ------------------------------------ 2579 !scalars 2580 integer,intent(in) :: mcg,mcprj,nband_k,nfftf,pwind_alloc,with_vectornd 2581 type(dataset_type),intent(in) :: dtset 2582 type(MPI_type), intent(inout) :: mpi_enreg 2583 type(orbmag_type), intent(inout) :: dtorbmag 2584 type(pawang_type),intent(in) :: pawang 2585 type(pawfgr_type),intent(in) :: pawfgr 2586 type(pseudopotential_type),intent(in) :: psps 2587 2588 !arrays 2589 integer,intent(in) :: atindx1(dtset%natom) 2590 integer,intent(in) :: npwarr(dtset%nkpt),pwind(pwind_alloc,2,3) 2591 real(dp), intent(in) :: cg(2,mcg),gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3) 2592 real(dp),intent(in) :: energies(nband_k,dtset%nkpt) 2593 real(dp),intent(in) :: vhartr(nfftf),vpsp(nfftf),vxc(nfftf,dtset%nspden),xred(3,dtset%natom) 2594 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 2595 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 2596 real(dp), intent(out) :: out_e(2,nband_k,3),out_h(2,nband_k,3),out_s(2,nband_k,3) 2597 real(dp),intent(inout) :: vectornd(with_vectornd*nfftf,3) 2598 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 2599 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 2600 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 2601 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 2602 2603 !Local variables ------------------------- 2604 !scalars 2605 integer :: adir,bdir,bfor,bsigma,countb,countg,countk,dimffnl,epsabg,exchn2n3d,gdir 2606 integer :: getghc_cpopt,getghc_sij_opt,getghc_prtvol,getghc_tim,getghc_type_calc 2607 integer :: gfor,gsigma,iband,icg,icprji,ider,idir,ierr 2608 integer :: ikg,ikg1,ikpt,ikpt_loc,ikpti,ikptb,ikptbi,ikptg,ikptgi 2609 integer :: ilm,ish1,ish2,isppol,istwf_k,itrs 2610 integer :: me,mcg1_k,my_nspinor,n2dim,ncpgr,ndat,ngfft1,ngfft2,ngfft3 2611 integer :: ngfft4,ngfft5,ngfft6,nkpg,npw_k,npw_k_,npw_kb,npw_kg,nproc,ntotcp 2612 integer :: shiftbd,smatrix_ddkflag,smatrix_job,spaceComm 2613 real(dp) :: deltab,deltag,doti,dotr,ecut_eff,ENK,lambda 2614 complex(dpc) :: cprefac,out_e_term,out_h_term,out_s_term 2615 logical :: has_vectornd 2616 type(gs_hamiltonian_type) :: gs_hamk 2617 2618 !arrays 2619 integer :: nattyp_dum(dtset%ntypat) 2620 integer,allocatable :: dimlmn(:),kg_k(:,:),pwind_kb(:),pwind_kg(:),sflag_k(:) 2621 real(dp) :: dkb(3),dkbg(3),dkg(3),dtm_k(2),kpoint(3),lambda_ndat(1),rhodum(1) 2622 real(dp),allocatable :: bwave(:,:),cg_k(:,:),cg1_kb(:,:),cg1_kg(:,:),cgqb(:,:),cgqg(:,:),cgrvtrial(:,:) 2623 real(dp),allocatable :: ffnl_k(:,:,:,:) 2624 real(dp),allocatable :: ghc(:,:),gsc(:,:),gwave(:,:),gvnlc(:,:),kinpw(:),kk_paw(:,:,:),kpg_k(:,:),pwnsfac_k(:,:) 2625 real(dp),allocatable :: ph3d(:,:,:),smat_inv(:,:,:),smat_kk(:,:,:) 2626 real(dp),allocatable :: vectornd_pac(:,:,:,:,:),vlocal(:,:,:,:),vtrial(:,:) 2627 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 2628 type(pawcprj_type),allocatable :: cprj_buf(:,:),cprj_k(:,:),cprj_kb(:,:),cprj1_kb(:,:) 2629 type(pawcprj_type),allocatable :: cprj_kg(:,:),cprj1_kg(:,:),cwaveprj(:,:) 2630 2631 !---------------------------------------------------- 2632 2633 isppol = 1 2634 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 2635 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 2636 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 2637 exchn2n3d = 0; istwf_k = 1; ikg1 = 0 2638 has_vectornd = (with_vectornd .EQ. 1) 2639 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 2640 spaceComm=mpi_enreg%comm_cell 2641 nproc=xmpi_comm_size(spaceComm) 2642 me=mpi_enreg%me_kpt 2643 2644 ncpgr = cprj(1,1)%ncpgr 2645 ABI_MALLOC(dimlmn,(dtset%natom)) 2646 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 2647 ABI_MALLOC(cprj_k,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 2648 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 2649 ABI_MALLOC(cprj_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 2650 call pawcprj_alloc(cprj_kb,ncpgr,dimlmn) 2651 ABI_MALLOC(cprj1_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 2652 call pawcprj_alloc(cprj1_kb,ncpgr,dimlmn) 2653 ABI_MALLOC(cprj_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 2654 call pawcprj_alloc(cprj_kg,ncpgr,dimlmn) 2655 ABI_MALLOC(cprj1_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 2656 call pawcprj_alloc(cprj1_kg,ncpgr,dimlmn) 2657 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 2658 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 2659 n2dim = dtorbmag%nspinor*nband_k 2660 ntotcp = n2dim*SUM(dimlmn(:)) 2661 if (nproc>1) then 2662 ABI_MALLOC(cprj_buf,(dtset%natom,n2dim)) 2663 call pawcprj_alloc(cprj_buf,ncpgr,dimlmn) 2664 end if 2665 2666 ABI_MALLOC(kk_paw,(2,dtset%mband,dtset%mband)) 2667 ABI_MALLOC(sflag_k,(nband_k)) 2668 ABI_MALLOC(pwind_kb,(dtset%mpw)) 2669 ABI_MALLOC(pwind_kg,(dtset%mpw)) 2670 ABI_MALLOC(pwnsfac_k,(4,dtset%mpw)) 2671 pwnsfac_k(1,:) = one; pwnsfac_k(2,:) = zero 2672 pwnsfac_k(3,:) = one; pwnsfac_k(4,:) = zero 2673 2674 mcg1_k = dtset%mpw*dtset%nsppol*my_nspinor*nband_k 2675 ABI_MALLOC(cg_k,(2,mcg1_k)) 2676 ABI_MALLOC(cg1_kb,(2,mcg1_k)) 2677 ABI_MALLOC(cg1_kg,(2,mcg1_k)) 2678 ABI_MALLOC(smat_inv,(2,nband_k,nband_k)) 2679 ABI_MALLOC(smat_kk,(2,nband_k,nband_k)) 2680 2681 smatrix_ddkflag = 1 2682 itrs = 0 2683 smatrix_job = 1 2684 shiftbd = 1 2685 2686 ! input parameters for calls to getghc at ikpt 2687 getghc_cpopt = -1 ! cprj computed and not saved 2688 getghc_sij_opt = 0 ! compute H|C> only 2689 ndat = 1 ! number of fft's in parallel 2690 getghc_prtvol = 0 2691 getghc_type_calc = 3 ! 0: all; 1: local; 2: nonlocal+kinetic; 3: local+kinetic 2692 getghc_tim = 0 2693 lambda = zero 2694 lambda_ndat = zero 2695 2696 !==== Initialize most of the Hamiltonian ==== 2697 !Allocate all arrays and initialize quantities that do not depend on k and spin. 2698 !gs_hamk is the normal hamiltonian at k 2699 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 2700 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 2701 & paw_ij=paw_ij) 2702 2703 !---------construct local potential------------------ 2704 ABI_MALLOC(vtrial,(nfftf,dtset%nspden)) 2705 ! nspden=1 is essentially hard-coded in the following line 2706 vtrial(1:nfftf,1)=vhartr(1:nfftf)+vxc(1:nfftf,1)+vpsp(1:nfftf) 2707 2708 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 2709 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vtrial) 2710 2711 ABI_MALLOC(vlocal,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc)) 2712 call fftpac(isppol,mpi_enreg,dtset%nspden,ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,& 2713 & dtset%ngfft,cgrvtrial,vlocal,2) 2714 2715 ABI_FREE(cgrvtrial) 2716 ABI_FREE(vtrial) 2717 2718 ! if vectornd is present, set it up for addition to gs_hamk similarly to how it's done for 2719 ! vtrial. Note that it must be done for the three directions. Also, the following 2720 ! code assumes explicitly and implicitly that nvloc = 1. This should eventually be generalized. 2721 if(has_vectornd) then 2722 ABI_MALLOC(vectornd_pac,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc,3)) 2723 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 2724 do idir = 1, 3 2725 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vectornd(:,idir)) 2726 call fftpac(isppol,mpi_enreg,dtset%nspden,& 2727 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vectornd_pac(:,:,:,1,idir),2) 2728 end do 2729 ABI_FREE(cgrvtrial) 2730 end if 2731 2732 ! add vlocal 2733 call gs_hamk%load_spin(isppol,vlocal=vlocal,with_nonlocal=.true.) 2734 2735 ! add vectornd if available 2736 if(has_vectornd) then 2737 call gs_hamk%load_spin(isppol,vectornd=vectornd_pac) 2738 end if 2739 2740 out_s = zero 2741 out_e = zero 2742 out_h = zero 2743 2744 do ikpt_loc = 1,dtorbmag%fmkmem_max 2745 2746 ikpt=mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc,1) 2747 ! if this k and spin are for me do it 2748 ! if (ikpt1 > 0 .and. isppol > 0) then 2749 if (ikpt > 0) then 2750 2751 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 2752 icprji = dtorbmag%cprjindex(ikpti,isppol) 2753 ikg = dtorbmag%fkgindex(ikpt) 2754 npw_k = npwarr(ikpti) 2755 ABI_MALLOC(kg_k,(3,npw_k)) 2756 ABI_MALLOC(kinpw,(npw_k)) 2757 kpoint(:)=dtset%kptns(:,ikpt) 2758 kg_k(:,:) = 0 2759 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg_k,kpoint,1,mpi_enreg,dtset%mpw,npw_k_) 2760 kinpw(:) = zero 2761 call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg_k,kinpw,kpoint,npw_k,0,0) 2762 nkpg = 3 2763 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 2764 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 2765 2766 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 2767 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 2768 do ilm=1,psps%mpsang*psps%mpsang 2769 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 2770 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 2771 end do 2772 2773 ! Compute nonlocal form factors ffnl at all (k+G): 2774 ider=0 ! want ffnl and 1st derivative 2775 idir=4 ! d ffnl/ dk_red in all 3 directions 2776 dimffnl=1 ! 1 + number of derivatives 2777 ABI_MALLOC(ffnl_k,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 2778 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl_k,psps%ffspl,& 2779 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 2780 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 2781 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 2782 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 2783 2784 ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk)) 2785 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 2786 & kinpw_k=kinpw,kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,& 2787 & ph3d_k=ph3d,compute_ph3d=.TRUE.,compute_gbound=.TRUE.) 2788 2789 icg = dtorbmag%cgindex(ikpti,dtset%nsppol) 2790 ikg = dtorbmag%fkgindex(ikpt) 2791 countk = npw_k*my_nspinor*nband_k 2792 cg_k(1:2,1:countk) = cg(1:2,icg+1:icg+countk) 2793 2794 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprji,ikpti,0,isppol,dtset%mband,& 2795 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 2796 end if 2797 2798 do adir = 1, 3 2799 do epsabg = 1, -1, -2 2800 if (epsabg .EQ. 1) then 2801 bdir = modulo(adir,3)+1 2802 gdir = modulo(adir+1,3)+1 2803 else 2804 bdir = modulo(adir+1,3)+1 2805 gdir = modulo(adir,3)+1 2806 end if 2807 do bfor = 1, 2 2808 bsigma = 3-2*bfor 2809 dkb(1:3) = bsigma*dtorbmag%dkvecs(1:3,bdir) 2810 deltab = sqrt(DOT_PRODUCT(dkb,dkb)) 2811 2812 if (ikpt > 0) then 2813 ikptb = dtorbmag%ikpt_dk(ikpt,bfor,bdir) 2814 ikptbi = dtorbmag%indkk_f2ibz(ikptb,1) 2815 npw_kb = npwarr(ikptbi) 2816 pwind_kb(1:npw_k) = pwind(ikg+1:ikg+npw_k,bfor,bdir) 2817 end if 2818 2819 if (ikpt > 0 .AND. isppol > 0) then 2820 countb = npw_kb*my_nspinor*nband_k 2821 if(allocated(cgqb)) then 2822 ABI_FREE(cgqb) 2823 endif 2824 ABI_MALLOC(cgqb,(2,countb)) 2825 call mpicomm_helper(atindx1,bdir,bfor,cg,cgqb,cprj,cprj_kb,dimlmn,dtorbmag,dtset,& 2826 & ikpt,ikpt_loc,ikptbi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 2827 & nproc,npw_kb,npwarr,spaceComm) 2828 end if 2829 2830 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 2831 2832 ! get covariant |u_{n,k+b}> and associated cprj 2833 call overlap_k1k2_paw(cprj_k,cprj_kb,dkb,gprimd,kk_paw,dtorbmag%lmn2max,& 2834 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 2835 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 2836 sflag_k=0 2837 cg1_kb(:,:) = zero 2838 ! cg1_kb will hold |\tilde{u}_{n,k+b}> 2839 call smatrix(cg_k,cgqb,cg1_kb,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 2840 & mcg1_k,mcg1_k,mcg1_k,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kb,my_nspinor,& 2841 & pwind_kb,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 2842 ! cprj1_kb will hold cprj for cg1_kb 2843 call covar_cprj(cprj_kb,cprj1_kb,dtset,nband_k,pawtab,smat_inv) 2844 2845 if(allocated(cgqb)) then 2846 ABI_FREE(cgqb) 2847 end if 2848 2849 end if 2850 2851 do gfor = 1, 2 2852 gsigma=3-2*gfor 2853 dkg(1:3) = gsigma*dtorbmag%dkvecs(1:3,gdir) 2854 deltag = sqrt(DOT_PRODUCT(dkg,dkg)) 2855 2856 cprefac = j_dpc*epsabg*bsigma*gsigma/(two*deltab*two*deltag) 2857 2858 if (ikpt > 0) then 2859 ikptg = dtorbmag%ikpt_dk(ikpt,gfor,gdir) 2860 ikptgi = dtorbmag%indkk_f2ibz(ikptg,1) 2861 npw_kg = npwarr(ikptgi) 2862 pwind_kg(1:npw_k) = pwind(ikg+1:ikg+npw_k,gfor,gdir) 2863 2864 end if 2865 2866 2867 if (ikpt > 0 .AND. isppol > 0) then 2868 countg = npw_kg*my_nspinor*nband_k 2869 if(allocated(cgqg)) then 2870 ABI_FREE(cgqg) 2871 endif 2872 ABI_MALLOC(cgqg,(2,countg)) 2873 call mpicomm_helper(atindx1,gdir,gfor,cg,cgqg,cprj,cprj_kg,dimlmn,dtorbmag,dtset,& 2874 & ikpt,ikpt_loc,ikptgi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 2875 & nproc,npw_kg,npwarr,spaceComm) 2876 end if 2877 2878 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 2879 2880 ! get covariant |u_{n,k+g}> and associated cprj 2881 call overlap_k1k2_paw(cprj_k,cprj_kg,dkg,gprimd,kk_paw,dtorbmag%lmn2max,& 2882 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 2883 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 2884 sflag_k=0 2885 cg1_kg(:,:) = zero 2886 ! cg1_kg will hold |\tilde{u}_{n,k+g}> 2887 call smatrix(cg_k,cgqg,cg1_kg,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 2888 & mcg1_k,mcg1_k,mcg1_k,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kg,my_nspinor,& 2889 & pwind_kg,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 2890 ! cprj1_kg will hold cprj for cg1_kg 2891 call covar_cprj(cprj_kg,cprj1_kg,dtset,nband_k,pawtab,smat_inv) 2892 2893 dkbg = dkg - dkb 2894 ! overlap of covariant cprj at kb and kg 2895 call overlap_k1k2_paw(cprj1_kb,cprj1_kg,dkbg,gprimd,kk_paw,dtorbmag%lmn2max,& 2896 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 2897 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 2898 2899 ABI_MALLOC(bwave,(2,npw_k)) 2900 ABI_MALLOC(gwave,(2,npw_k)) 2901 ABI_MALLOC(ghc,(2,npw_k)) 2902 ABI_MALLOC(gsc,(2,npw_k)) 2903 ABI_MALLOC(gvnlc,(2,npw_k)) 2904 do iband = 1, nband_k 2905 2906 ish1 = (iband-1)*npw_k+1 2907 ish2 = iband*npw_k 2908 ENK = energies(iband,ikpt) 2909 2910 bwave(1:2,1:npw_k) = cg1_kb(1:2,ish1:ish2) 2911 gwave(1:2,1:npw_k) = cg1_kg(1:2,ish1:ish2) 2912 2913 dotr= DOT_PRODUCT(bwave(1,:),gwave(1,:))+DOT_PRODUCT(bwave(2,:),gwave(2,:)) 2914 doti=-DOT_PRODUCT(bwave(2,:),gwave(1,:))+DOT_PRODUCT(bwave(1,:),gwave(2,:)) 2915 2916 ! accumulate i*epsabg*\sum_occ [<d_bdir u|Q_SHE_Q|d_gdir u>] 2917 out_s_term = cprefac*cmplx((dotr+kk_paw(1,iband,iband)),(doti+kk_paw(2,iband,iband))) 2918 out_e_term = out_s_term*ENK 2919 2920 out_s(1,iband,adir) = out_s(1,iband,adir) + real(out_s_term) 2921 out_s(2,iband,adir) = out_s(2,iband,adir) + aimag(out_s_term) 2922 out_e(1,iband,adir) = out_e(1,iband,adir) + real(out_e_term) 2923 out_e(2,iband,adir) = out_e(2,iband,adir) + aimag(out_e_term) 2924 2925 call getghc(getghc_cpopt,bwave,cwaveprj,ghc,gsc,gs_hamk,gvnlc,& 2926 & lambda,mpi_enreg,ndat,getghc_prtvol,getghc_sij_opt,getghc_tim,& 2927 & getghc_type_calc) 2928 dotr= DOT_PRODUCT(gwave(1,:),ghc(1,:))+DOT_PRODUCT(gwave(2,:),ghc(2,:)) 2929 doti=-DOT_PRODUCT(gwave(2,:),ghc(1,:))+DOT_PRODUCT(gwave(1,:),ghc(2,:)) 2930 2931 !call cpg_dij_cpb(cgdijcb,cprj1_kb,cprj1_kg,dtset,iband,iband,my_nspinor,paw_ij,pawtab) 2932 !out_h_term = cprefac*(cmplx(dotr,doti) + cgdijcb) 2933 2934 ! the following includes only the kinetic and local contributions from H_k, the 2935 ! onsite contributions, which are much more complex than paw_ij, have not been coded 2936 out_h_term = cprefac*cmplx(dotr,doti) 2937 2938 out_h(1,iband,adir) = out_h(1,iband,adir) + real(out_h_term) 2939 out_h(2,iband,adir) = out_h(2,iband,adir) + aimag(out_h_term) 2940 2941 end do ! end loop over iband 2942 ABI_FREE(bwave) 2943 ABI_FREE(gwave) 2944 ABI_FREE(ghc) 2945 ABI_FREE(gsc) 2946 ABI_FREE(gvnlc) 2947 2948 if(allocated(cgqg)) then 2949 ABI_FREE(cgqg) 2950 end if 2951 2952 end if ! end check on ikpt > 0 2953 2954 end do ! end loop over gfor 2955 end do ! end loop over bfor 2956 end do ! end loop over epsabg 2957 end do ! end loop over adir 2958 ABI_FREE(kg_k) 2959 ABI_FREE(kinpw) 2960 ABI_FREE(kpg_k) 2961 ABI_FREE(ffnl_k) 2962 ABI_FREE(ylm_k) 2963 ABI_FREE(ylmgr_k) 2964 ABI_FREE(ph3d) 2965 end do ! end loop over ikpt_loc 2966 2967 ! ---- parallel communication 2968 if(nproc > 1) then 2969 call xmpi_sum(out_s,spaceComm,ierr) 2970 call xmpi_sum(out_e,spaceComm,ierr) 2971 call xmpi_sum(out_h,spaceComm,ierr) 2972 end if 2973 2974 ABI_FREE(dimlmn) 2975 call pawcprj_free(cprj_k) 2976 ABI_FREE(cprj_k) 2977 call pawcprj_free(cprj_kb) 2978 ABI_FREE(cprj_kb) 2979 call pawcprj_free(cprj1_kb) 2980 ABI_FREE(cprj1_kb) 2981 call pawcprj_free(cprj_kg) 2982 ABI_FREE(cprj_kg) 2983 call pawcprj_free(cprj1_kg) 2984 ABI_FREE(cprj1_kg) 2985 call pawcprj_free(cwaveprj) 2986 ABI_FREE(cwaveprj) 2987 if (nproc>1) then 2988 call pawcprj_free(cprj_buf) 2989 ABI_FREE(cprj_buf) 2990 end if 2991 2992 ABI_FREE(kk_paw) 2993 ABI_FREE(smat_kk) 2994 ABI_FREE(smat_inv) 2995 ABI_FREE(sflag_k) 2996 ABI_FREE(pwind_kb) 2997 ABI_FREE(pwind_kg) 2998 ABI_FREE(cg1_kb) 2999 ABI_FREE(cg1_kg) 3000 ABI_FREE(cg_k) 3001 ABI_FREE(pwnsfac_k) 3002 call gs_hamk%free() 3003 ABI_FREE(vlocal) 3004 if(has_vectornd) then 3005 ABI_FREE(vectornd_pac) 3006 end if 3007 3008 end subroutine duq_she_qdu
ABINIT/duqdu [ Functions ]
NAME
duqdu
FUNCTION
Return i*epsabg\sum_n E_nk <\partial_b u_kn|Q|\partial_g u_kn> where Q projects onto the conduction space.
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
CHILDREN
SOURCE
3044 subroutine duqdu(atindx1,cg,cprj,dtorbmag,dtset,duqduchern,duqdumag,energies,& 3045 & gprimd,mcg,mcprj,mpi_enreg,nband_k,npwarr,pawang,pawrad,pawtab,& 3046 & psps,pwind,pwind_alloc,xred) 3047 3048 !Arguments ------------------------------------ 3049 !scalars 3050 integer,intent(in) :: mcg,mcprj,nband_k,pwind_alloc 3051 type(dataset_type),intent(in) :: dtset 3052 type(MPI_type), intent(inout) :: mpi_enreg 3053 type(orbmag_type), intent(inout) :: dtorbmag 3054 type(pawang_type),intent(in) :: pawang 3055 type(pseudopotential_type),intent(in) :: psps 3056 3057 !arrays 3058 integer,intent(in) :: atindx1(dtset%natom) 3059 integer,intent(in) :: npwarr(dtset%nkpt),pwind(pwind_alloc,2,3) 3060 real(dp), intent(in) :: cg(2,mcg),gprimd(3,3),xred(3,dtset%natom) 3061 real(dp),intent(in) :: energies(nband_k,dtset%nkpt) 3062 real(dp), intent(out) :: duqduchern(2,nband_k,3),duqdumag(2,nband_k,3) 3063 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 3064 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 3065 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 3066 3067 !Local variables ------------------------- 3068 !scalars 3069 integer :: adir,bdir,bfor,bsigma,countb,countg,countk 3070 integer :: epsabg,gdir,gfor,gsigma,iband 3071 integer :: icg,icprji,ierr 3072 integer :: ikg,ikpt,ikpt_loc,ikpti,ikptb,ikptbi,ikptg,ikptgi,ish1,ish2,isppol,itrs 3073 integer :: me,mcg1_k,my_nspinor,n2dim,ncpgr,npw_k,npw_kb,npw_kg,nproc,ntotcp 3074 integer :: shiftbd,smatrix_ddkflag,smatrix_job,spaceComm 3075 real(dp) :: deltab,deltag,doti,dotr,ENK 3076 complex(dpc) :: cprefac,duqduchern_term,duqdumag_term 3077 3078 !arrays 3079 integer :: nattyp_dum(dtset%ntypat) 3080 integer,allocatable :: dimlmn(:),pwind_kb(:),pwind_kg(:),sflag_k(:) 3081 real(dp) :: dkb(3),dkbg(3),dkg(3),dtm_k(2) 3082 real(dp),allocatable :: cg_k(:,:),cg1_kb(:,:),cg1_kg(:,:),cgqb(:,:),cgqg(:,:) 3083 real(dp),allocatable :: kk_paw(:,:,:),pwnsfac_k(:,:) 3084 real(dp),allocatable :: smat_inv(:,:,:),smat_kk(:,:,:) 3085 type(pawcprj_type),allocatable :: cprj_buf(:,:),cprj_k(:,:),cprj_kb(:,:),cprj1_kb(:,:) 3086 type(pawcprj_type),allocatable :: cprj_kg(:,:),cprj1_kg(:,:) 3087 3088 !---------------------------------------------------- 3089 3090 isppol = 1 3091 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 3092 spaceComm=mpi_enreg%comm_cell 3093 nproc=xmpi_comm_size(spaceComm) 3094 me=mpi_enreg%me_kpt 3095 3096 ncpgr = cprj(1,1)%ncpgr 3097 ABI_MALLOC(dimlmn,(dtset%natom)) 3098 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 3099 ABI_MALLOC(cprj_k,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3100 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 3101 ABI_MALLOC(cprj_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3102 call pawcprj_alloc(cprj_kb,ncpgr,dimlmn) 3103 ABI_MALLOC(cprj1_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3104 call pawcprj_alloc(cprj1_kb,ncpgr,dimlmn) 3105 ABI_MALLOC(cprj_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3106 call pawcprj_alloc(cprj_kg,ncpgr,dimlmn) 3107 ABI_MALLOC(cprj1_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3108 call pawcprj_alloc(cprj1_kg,ncpgr,dimlmn) 3109 n2dim = dtorbmag%nspinor*nband_k 3110 ntotcp = n2dim*SUM(dimlmn(:)) 3111 if (nproc>1) then 3112 ABI_MALLOC(cprj_buf,(dtset%natom,n2dim)) 3113 call pawcprj_alloc(cprj_buf,ncpgr,dimlmn) 3114 end if 3115 3116 ABI_MALLOC(kk_paw,(2,dtset%mband,dtset%mband)) 3117 ABI_MALLOC(sflag_k,(nband_k)) 3118 ABI_MALLOC(pwind_kb,(dtset%mpw)) 3119 ABI_MALLOC(pwind_kg,(dtset%mpw)) 3120 ABI_MALLOC(pwnsfac_k,(4,dtset%mpw)) 3121 pwnsfac_k(1,:) = one; pwnsfac_k(2,:) = zero 3122 pwnsfac_k(3,:) = one; pwnsfac_k(4,:) = zero 3123 3124 mcg1_k = dtset%mpw*dtset%nsppol*my_nspinor*nband_k 3125 ABI_MALLOC(cg_k,(2,mcg1_k)) 3126 ABI_MALLOC(cg1_kb,(2,mcg1_k)) 3127 ABI_MALLOC(cg1_kg,(2,mcg1_k)) 3128 ABI_MALLOC(smat_inv,(2,nband_k,nband_k)) 3129 ABI_MALLOC(smat_kk,(2,nband_k,nband_k)) 3130 3131 smatrix_ddkflag = 1 3132 itrs = 0 3133 smatrix_job = 1 3134 shiftbd = 1 3135 3136 duqduchern(:,:,:) = zero 3137 duqdumag(:,:,:) = zero 3138 3139 do ikpt_loc = 1,dtorbmag%fmkmem_max 3140 3141 ikpt=mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc,1) 3142 ! if this k and spin are for me do it 3143 ! if (ikpt1 > 0 .and. isppol > 0) then 3144 if (ikpt > 0) then 3145 3146 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 3147 icprji = dtorbmag%cprjindex(ikpti,isppol) 3148 npw_k = npwarr(ikpti) 3149 icg = dtorbmag%cgindex(ikpti,dtset%nsppol) 3150 ikg = dtorbmag%fkgindex(ikpt) 3151 countk = npw_k*my_nspinor*nband_k 3152 cg_k(1:2,1:countk) = cg(1:2,icg+1:icg+countk) 3153 3154 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprji,ikpti,0,isppol,dtset%mband,& 3155 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 3156 end if 3157 3158 do adir = 1, 3 3159 do epsabg = 1, -1, -2 3160 if (epsabg .EQ. 1) then 3161 bdir = modulo(adir,3)+1 3162 gdir = modulo(adir+1,3)+1 3163 else 3164 bdir = modulo(adir+1,3)+1 3165 gdir = modulo(adir,3)+1 3166 end if 3167 do bfor = 1, 2 3168 bsigma = 3-2*bfor 3169 dkb(1:3) = bsigma*dtorbmag%dkvecs(1:3,bdir) 3170 deltab = sqrt(DOT_PRODUCT(dkb,dkb)) 3171 3172 if (ikpt > 0) then 3173 ikptb = dtorbmag%ikpt_dk(ikpt,bfor,bdir) 3174 ikptbi = dtorbmag%indkk_f2ibz(ikptb,1) 3175 npw_kb = npwarr(ikptbi) 3176 pwind_kb(1:npw_k) = pwind(ikg+1:ikg+npw_k,bfor,bdir) 3177 end if 3178 3179 if (ikpt > 0 .AND. isppol > 0) then 3180 countb = npw_kb*my_nspinor*nband_k 3181 if(allocated(cgqb)) then 3182 ABI_FREE(cgqb) 3183 endif 3184 ABI_MALLOC(cgqb,(2,countb)) 3185 call mpicomm_helper(atindx1,bdir,bfor,cg,cgqb,cprj,cprj_kb,dimlmn,dtorbmag,dtset,& 3186 & ikpt,ikpt_loc,ikptbi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 3187 & nproc,npw_kb,npwarr,spaceComm) 3188 end if 3189 3190 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 3191 3192 ! get covariant |u_{n,k+b}> and associated cprj 3193 call overlap_k1k2_paw(cprj_k,cprj_kb,dkb,gprimd,kk_paw,dtorbmag%lmn2max,& 3194 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 3195 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 3196 sflag_k=0 3197 cg1_kb(:,:) = zero 3198 ! cg1_kb will hold |\tilde{u}_{n,k+b}> 3199 call smatrix(cg_k,cgqb,cg1_kb,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 3200 & mcg1_k,mcg1_k,mcg1_k,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kb,my_nspinor,& 3201 & pwind_kb,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 3202 ! cprj1_kb will hold cprj for cg1_kb 3203 call covar_cprj(cprj_kb,cprj1_kb,dtset,nband_k,pawtab,smat_inv) 3204 3205 if(allocated(cgqb)) then 3206 ABI_FREE(cgqb) 3207 end if 3208 3209 end if 3210 3211 do gfor = 1, 2 3212 gsigma=3-2*gfor 3213 dkg(1:3) = gsigma*dtorbmag%dkvecs(1:3,gdir) 3214 deltag = sqrt(DOT_PRODUCT(dkg,dkg)) 3215 3216 cprefac = j_dpc*epsabg*bsigma*gsigma/(two*deltab*two*deltag) 3217 3218 if (ikpt > 0) then 3219 ikptg = dtorbmag%ikpt_dk(ikpt,gfor,gdir) 3220 ikptgi = dtorbmag%indkk_f2ibz(ikptg,1) 3221 npw_kg = npwarr(ikptgi) 3222 pwind_kg(1:npw_k) = pwind(ikg+1:ikg+npw_k,gfor,gdir) 3223 3224 end if 3225 3226 3227 if (ikpt > 0 .AND. isppol > 0) then 3228 countg = npw_kg*my_nspinor*nband_k 3229 if(allocated(cgqg)) then 3230 ABI_FREE(cgqg) 3231 endif 3232 ABI_MALLOC(cgqg,(2,countg)) 3233 call mpicomm_helper(atindx1,gdir,gfor,cg,cgqg,cprj,cprj_kg,dimlmn,dtorbmag,dtset,& 3234 & ikpt,ikpt_loc,ikptgi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 3235 & nproc,npw_kg,npwarr,spaceComm) 3236 end if 3237 3238 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 3239 3240 ! get covariant |u_{n,k+g}> and associated cprj 3241 call overlap_k1k2_paw(cprj_k,cprj_kg,dkg,gprimd,kk_paw,dtorbmag%lmn2max,& 3242 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 3243 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 3244 sflag_k=0 3245 cg1_kg(:,:) = zero 3246 ! cg1_kg will hold |\tilde{u}_{n,k+g}> 3247 call smatrix(cg_k,cgqg,cg1_kg,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 3248 & mcg1_k,mcg1_k,mcg1_k,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kg,my_nspinor,& 3249 & pwind_kg,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 3250 ! cprj1_kg will hold cprj for cg1_kg 3251 call covar_cprj(cprj_kg,cprj1_kg,dtset,nband_k,pawtab,smat_inv) 3252 3253 dkbg = dkg - dkb 3254 ! overlap of covariant cprj at kb and kg 3255 call overlap_k1k2_paw(cprj1_kb,cprj1_kg,dkbg,gprimd,kk_paw,dtorbmag%lmn2max,& 3256 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 3257 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 3258 do iband = 1, nband_k 3259 3260 ish1 = (iband-1)*npw_k+1 3261 ish2 = iband*npw_k 3262 ENK = energies(iband,ikpt) 3263 3264 dotr=DOT_PRODUCT(cg1_kb(1,ish1:ish2),cg1_kg(1,ish1:ish2)) + & 3265 & DOT_PRODUCT(cg1_kb(2,ish1:ish2),cg1_kg(2,ish1:ish2)) 3266 doti=DOT_PRODUCT(cg1_kb(1,ish1:ish2),cg1_kg(2,ish1:ish2)) - & 3267 & DOT_PRODUCT(cg1_kb(2,ish1:ish2),cg1_kg(1,ish1:ish2)) 3268 3269 ! accumulate i*epsabg*ENK*\sum_occ [<d_bdir u|Q|d_gdir u>] 3270 duqduchern_term = cprefac*cmplx((dotr+kk_paw(1,iband,iband)),(doti+kk_paw(2,iband,iband))) 3271 duqdumag_term = duqduchern_term*ENK 3272 3273 duqduchern(1,iband,adir) = duqduchern(1,iband,adir) + real(duqduchern_term) 3274 duqduchern(2,iband,adir) = duqduchern(2,iband,adir) + aimag(duqduchern_term) 3275 duqdumag(1,iband,adir) = duqdumag(1,iband,adir) + real(duqdumag_term) 3276 duqdumag(2,iband,adir) = duqdumag(2,iband,adir) + aimag(duqdumag_term) 3277 3278 end do ! end loop over iband 3279 if(allocated(cgqg)) then 3280 ABI_FREE(cgqg) 3281 end if 3282 end if ! end check on ikpt > 0 3283 3284 end do ! end loop over gfor 3285 end do ! end loop over bfor 3286 end do ! end loop over epsabg 3287 end do ! end loop over adir 3288 end do ! end loop over ikpt_loc 3289 3290 ! ---- parallel communication 3291 if(nproc > 1) then 3292 call xmpi_sum(duqduchern,spaceComm,ierr) 3293 call xmpi_sum(duqdumag,spaceComm,ierr) 3294 end if 3295 3296 ABI_FREE(dimlmn) 3297 call pawcprj_free(cprj_k) 3298 ABI_FREE(cprj_k) 3299 call pawcprj_free(cprj_kb) 3300 ABI_FREE(cprj_kb) 3301 call pawcprj_free(cprj1_kb) 3302 ABI_FREE(cprj1_kb) 3303 call pawcprj_free(cprj_kg) 3304 ABI_FREE(cprj_kg) 3305 call pawcprj_free(cprj1_kg) 3306 ABI_FREE(cprj1_kg) 3307 if (nproc>1) then 3308 call pawcprj_free(cprj_buf) 3309 ABI_FREE(cprj_buf) 3310 end if 3311 3312 ABI_FREE(kk_paw) 3313 ABI_FREE(smat_kk) 3314 ABI_FREE(smat_inv) 3315 ABI_FREE(sflag_k) 3316 ABI_FREE(pwind_kb) 3317 ABI_FREE(pwind_kg) 3318 ABI_FREE(cg1_kb) 3319 ABI_FREE(cg1_kg) 3320 ABI_FREE(cg_k) 3321 ABI_FREE(pwnsfac_k) 3322 3323 end subroutine duqdu
ABINIT/duqhqdu [ Functions ]
NAME
duqhqdu
FUNCTION
Return i*epsabg\sum_n <\partial_g u_kn|QH_kQ|\partial_b u_kn> where Q projects onto the conduction space.
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
3953 subroutine duqhqdu(atindx1,cg,cnum_duqhqdu,cprj,dtorbmag,dtset,gmet,gprimd,mcg,mcprj,mpi_enreg,& 3954 & nattyp,nband_k,nfftf,npwarr,paw_ij,pawang,pawfgr,pawrad,pawtab,psps,pwind,pwind_alloc,& 3955 & rmet,rprimd,ucvol,vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 3956 3957 !Arguments ------------------------------------ 3958 !scalars 3959 integer,intent(in) :: mcg,mcprj,nband_k,nfftf,pwind_alloc,with_vectornd 3960 real(dp),intent(in) :: ucvol 3961 type(dataset_type),intent(in) :: dtset 3962 type(MPI_type), intent(inout) :: mpi_enreg 3963 type(orbmag_type), intent(inout) :: dtorbmag 3964 type(pawang_type),intent(in) :: pawang 3965 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 3966 type(pseudopotential_type),intent(in) :: psps 3967 3968 !arrays 3969 integer, intent(in) :: atindx1(dtset%natom) 3970 integer, intent(in) :: nattyp(dtset%ntypat),npwarr(dtset%nkpt),pwind(pwind_alloc,2,3) 3971 real(dp), intent(in) :: cg(2,mcg),gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3) 3972 real(dp), intent(in) :: vhartr(nfftf),vpsp(nfftf),vxc(nfftf,dtset%nspden),xred(3,dtset%natom) 3973 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 3974 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 3975 real(dp), intent(inout) :: vectornd(with_vectornd*nfftf,3) 3976 real(dp), intent(out) :: cnum_duqhqdu(2,nband_k,3) 3977 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 3978 type(pawfgr_type),intent(in) :: pawfgr 3979 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 3980 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 3981 3982 !Local variables ------------------------- 3983 !scalars 3984 integer :: adir,bdir,bfor,bsigma,countb,countg,countk,cpopt,dimffnl 3985 integer :: getcprj_choice,getcprj_cpopt,getcprj_idir 3986 integer :: epsabg,exchn2n3d,gdir,gfor,gsigma,ia,iband,ibs1,ibs2 3987 integer :: icg,icprji,ider,idir,ierr 3988 integer :: ikg,ikg1,ikpt,ikpt_loc,ikpti,ikptb,ikptbi,ikptg,ikptgi 3989 integer :: ilm,isppol,istwf_k,itrs 3990 integer :: me,my_nspinor,ncpgr,ndat 3991 integer :: ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,nkpg,npw_k,npw_k_,npw_kb,npw_kg,nproc 3992 integer :: prtvol,shiftbd,sij_opt,smatrix_ddkflag,smatrix_job,spaceComm 3993 integer :: tim_getghc,type_calc 3994 real(dp) :: arg,deltab,deltag,doti,dotr,ecut_eff,lambda 3995 complex(dpc) :: cgdijcb,cprefac,duqhqdu_term 3996 logical :: has_vectornd 3997 type(gs_hamiltonian_type) :: gs_hamk 3998 3999 !arrays 4000 integer :: nattyp_dum(dtset%ntypat) 4001 integer,allocatable :: dimlmn(:),kg_k(:,:),pwind_kb(:),pwind_kg(:),sflag_k(:) 4002 real(dp) :: dkb(3),dkg(3),dtm_k(2),kpoint(3),lambdarr(1),rhodum(1) 4003 real(dp),allocatable :: cg_k(:,:),cg1_kb(:,:),cg1_kg(:,:),cgrvtrial(:,:) 4004 real(dp),allocatable :: cgqb(:,:),cgqg(:,:),cwavef(:,:),ffnl(:,:,:,:) 4005 real(dp),allocatable :: ghc(:,:),ghcall(:,:),gsc(:,:),gvnlc(:,:) 4006 real(dp),allocatable :: kinpw(:),kk_paw(:,:,:),kpg_k(:,:) 4007 real(dp),allocatable :: ph1d(:,:),ph3d(:,:,:),phkxred(:,:),pwnsfac_k(:,:) 4008 real(dp),allocatable :: smat_inv(:,:,:),smat_kk(:,:,:) 4009 real(dp),allocatable :: vectornd_pac(:,:,:,:,:),vlocal(:,:,:,:),vtrial(:,:) 4010 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 4011 type(pawcprj_type),allocatable :: cprj_k(:,:),cprj_kb(:,:),cprj1_kb(:,:) 4012 type(pawcprj_type),allocatable :: cprj_kg(:,:),cprj1_kg(:,:),cwaveprj(:,:) 4013 4014 !---------------------------------------------------- 4015 4016 isppol = 1 4017 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 4018 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 4019 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 4020 exchn2n3d = 0 ; istwf_k = 1 ; ikg1 = 0 4021 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 4022 spaceComm=mpi_enreg%comm_cell 4023 nproc=xmpi_comm_size(spaceComm) 4024 me=mpi_enreg%me_kpt 4025 4026 ! input parameters for calls to getghc at ikpt 4027 cpopt = -1 4028 ndat = 1 4029 prtvol = 0 4030 sij_opt = 0 4031 tim_getghc = 0 4032 ! getghc: type_calc 3 means kinetic, local only 4033 ! type_calc 1 means local only 4034 type_calc = 3 4035 lambda = zero; lambdarr(1) = zero 4036 4037 ! input parameters for calls to getcprj 4038 getcprj_choice = 1 ! just cprj no gradients 4039 getcprj_cpopt = 0 ! no cprj in memory already 4040 getcprj_idir = 0 ! gradient directions irrelevant here 4041 4042 !==== Initialize most of the Hamiltonian ==== 4043 !Allocate all arrays and initialize quantities that do not depend on k and spin. 4044 !gs_hamk is the normal hamiltonian at k 4045 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 4046 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 4047 & paw_ij=paw_ij) 4048 4049 !---------construct local potential------------------ 4050 ABI_MALLOC(vtrial,(nfftf,dtset%nspden)) 4051 ! nspden=1 is essentially hard-coded in the following line 4052 vtrial(1:nfftf,1)=vhartr(1:nfftf)+vxc(1:nfftf,1)+vpsp(1:nfftf) 4053 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 4054 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vtrial) 4055 ABI_MALLOC(vlocal,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc)) 4056 call fftpac(isppol,mpi_enreg,dtset%nspden,& 4057 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vlocal,2) 4058 ! add vlocal 4059 call gs_hamk%load_spin(isppol,vlocal=vlocal,with_nonlocal=.false.) 4060 ABI_FREE(cgrvtrial) 4061 ABI_FREE(vtrial) 4062 4063 ! if vectornd is present, set it up for addition to gs_hamk similarly to how it's done for 4064 ! vtrial. Note that it must be done for the three directions. Also, the following 4065 ! code assumes explicitly and implicitly that nvloc = 1. This should eventually be generalized. 4066 has_vectornd = (with_vectornd .EQ. 1) 4067 if(has_vectornd) then 4068 ABI_MALLOC(vectornd_pac,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc,3)) 4069 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 4070 do adir = 1, 3 4071 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vectornd(:,adir)) 4072 call fftpac(isppol,mpi_enreg,dtset%nspden,& 4073 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vectornd_pac(:,:,:,1,adir),2) 4074 end do 4075 call gs_hamk%load_spin(isppol,vectornd=vectornd_pac) 4076 ABI_FREE(cgrvtrial) 4077 end if 4078 4079 ABI_MALLOC(ph1d,(2,dtset%natom*(2*(ngfft1+ngfft2+ngfft3)+3))) 4080 call getph(atindx1,dtset%natom,ngfft1,ngfft2,ngfft3,ph1d,xred) 4081 4082 ncpgr = cprj(1,1)%ncpgr 4083 ABI_MALLOC(dimlmn,(dtset%natom)) 4084 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 4085 ABI_MALLOC(cprj_k,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4086 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 4087 ABI_MALLOC(cprj_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4088 call pawcprj_alloc(cprj_kb,ncpgr,dimlmn) 4089 ABI_MALLOC(cprj1_kb,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4090 call pawcprj_alloc(cprj1_kb,ncpgr,dimlmn) 4091 ABI_MALLOC(cprj_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4092 call pawcprj_alloc(cprj_kg,ncpgr,dimlmn) 4093 ABI_MALLOC(cprj1_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4094 call pawcprj_alloc(cprj1_kg,ncpgr,dimlmn) 4095 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 4096 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 4097 4098 smatrix_ddkflag = 1 4099 itrs = 0 4100 smatrix_job = 1 4101 shiftbd = 1 4102 4103 ABI_MALLOC(kk_paw,(2,dtset%mband,dtset%mband)) 4104 ABI_MALLOC(smat_kk,(2,dtset%mband,dtset%mband)) 4105 ABI_MALLOC(smat_inv,(2,dtset%mband,dtset%mband)) 4106 ABI_MALLOC(sflag_k,(nband_k)) 4107 ABI_MALLOC(pwind_kb,(dtset%mpw)) 4108 ABI_MALLOC(pwind_kg,(dtset%mpw)) 4109 ABI_MALLOC(pwnsfac_k,(4,dtset%mpw)) 4110 pwnsfac_k(1,:) = one; pwnsfac_k(2,:) = zero 4111 pwnsfac_k(3,:) = one; pwnsfac_k(4,:) = zero 4112 4113 cnum_duqhqdu(:,:,:) = zero 4114 4115 do ikpt_loc = 1,dtorbmag%fmkmem_max 4116 4117 ikpt=mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc,1) 4118 ! if this k and spin are for me do it 4119 ! if (ikpt1 > 0 .and. isppol > 0) then 4120 if (ikpt > 0) then 4121 4122 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 4123 kpoint(:)=dtorbmag%fkptns(:,ikpt) 4124 icprji = dtorbmag%cprjindex(ikpti,isppol) 4125 npw_k = npwarr(ikpti) 4126 icg = dtorbmag%cgindex(ikpti,dtset%nsppol) 4127 ikg = dtorbmag%fkgindex(ikpt) 4128 4129 ! wavefunction at k 4130 countk = npw_k*my_nspinor*nband_k 4131 ABI_MALLOC(cg_k,(2,countk)) 4132 cg_k(1:2,1:countk) = cg(1:2,icg+1:icg+countk) 4133 4134 ! cprj at k 4135 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprji,ikpti,0,isppol,dtset%mband,& 4136 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 4137 4138 ! kg_k and k+G_k at k 4139 ABI_MALLOC(kg_k,(3,npw_k)) 4140 kg_k = 0 4141 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg_k,kpoint,1,mpi_enreg,dtset%mpw,npw_k_) 4142 if (npw_k .NE. npw_k_) then 4143 write(std_out,'(a)')'JWZ debug duqhqdu npw_k inconsistency' 4144 end if 4145 nkpg = 3 4146 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 4147 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 4148 4149 ! Compute kinetic energy at k 4150 ABI_MALLOC(kinpw,(npw_k)) 4151 kinpw(:) = zero 4152 call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg_k,kinpw,kpoint,npw_k,0,0) 4153 4154 ! this is minimal Hamiltonian information, to apply vlocal and kinetic to |u_kn> 4155 ! Build basis sphere of plane waves for the k-point 4156 4157 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 4158 & kinpw_k=kinpw,kg_k=kg_k,kpg_k=kpg_k,compute_gbound=.TRUE.) 4159 4160 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 4161 do ilm=1,psps%mpsang*psps%mpsang 4162 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 4163 end do 4164 4165 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 4166 do ilm=1,psps%mpsang*psps%mpsang 4167 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 4168 end do 4169 4170 ABI_MALLOC(phkxred,(2,dtset%natom)) 4171 do ia=1, dtset%natom 4172 arg=two_pi*(kpoint(1)*xred(1,ia)+kpoint(2)*xred(2,ia)+kpoint(3)*xred(3,ia)) 4173 phkxred(1,ia)=cos(arg);phkxred(2,ia)=sin(arg) 4174 end do 4175 4176 ABI_MALLOC(ph3d,(2,npw_k,dtset%natom)) 4177 call ph1d3d(1,dtset%natom,kg_k,dtset%natom,dtset%natom,& 4178 & npw_k,ngfft1,ngfft2,ngfft3,phkxred,ph1d,ph3d) 4179 4180 ! Compute nonlocal form factors ffnl at k 4181 dimffnl=1 ! 1 + number of derivatives 4182 ABI_MALLOC(ffnl,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 4183 ider=0 ! no derivs 4184 idir=4 ! derivs in all directions of cart (not used if ider = 0) 4185 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl,psps%ffspl,& 4186 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 4187 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 4188 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 4189 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 4190 4191 ABI_FREE(ylm_k) 4192 ABI_FREE(ylmgr_k) 4193 4194 end if 4195 4196 do adir = 1, 3 4197 do epsabg = 1, -1, -2 4198 if (epsabg .EQ. 1) then 4199 bdir = modulo(adir,3)+1 4200 gdir = modulo(adir+1,3)+1 4201 else 4202 bdir = modulo(adir+1,3)+1 4203 gdir = modulo(adir,3)+1 4204 end if 4205 do bfor = 1, 2 4206 bsigma = 3-2*bfor 4207 dkb(1:3) = bsigma*dtorbmag%dkvecs(1:3,bdir) 4208 deltab = sqrt(DOT_PRODUCT(dkb,dkb)) 4209 4210 if(ikpt > 0) then 4211 ikptb = dtorbmag%ikpt_dk(ikpt,bfor,bdir) 4212 ikptbi = dtorbmag%indkk_f2ibz(ikptb,1) 4213 npw_kb = npwarr(ikptbi) 4214 pwind_kb(1:npw_k) = pwind(ikg+1:ikg+npw_k,bfor,bdir) 4215 4216 end if 4217 4218 if (ikpt > 0 .AND. isppol > 0) then 4219 countb = npw_kb*my_nspinor*nband_k 4220 ABI_MALLOC(cgqb,(2,countb)) 4221 call mpicomm_helper(atindx1,bdir,bfor,cg,cgqb,cprj,cprj_kb,dimlmn,dtorbmag,dtset,& 4222 & ikpt,ikpt_loc,ikptbi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 4223 & nproc,npw_kb,npwarr,spaceComm) 4224 end if 4225 4226 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 4227 ! get covariant |u_{n,k+b}> and associated cprj 4228 call overlap_k1k2_paw(cprj_k,cprj_kb,dkb,gprimd,kk_paw,dtorbmag%lmn2max,& 4229 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 4230 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 4231 sflag_k=0 4232 4233 ABI_MALLOC(cg1_kb,(2,countk)) 4234 cg1_kb(:,:) = zero 4235 ! cg1_kb will hold |\tilde{u}_{n,k+b}> 4236 call smatrix(cg_k,cgqb,cg1_kb,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 4237 & countk,countb,countk,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kb,my_nspinor,& 4238 & pwind_kb,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 4239 4240 ! cprj1_kb will hold cprj for cg1_kb that is <p|\tilde{u}_{n,k+b}> 4241 call covar_cprj(cprj_kb,cprj1_kb,dtset,nband_k,pawtab,smat_inv) 4242 4243 ABI_FREE(cgqb) 4244 4245 ABI_MALLOC(cwavef,(2,npw_k)) 4246 ABI_MALLOC(ghc,(2,npw_k)) 4247 ABI_MALLOC(gsc,(2,npw_k)) 4248 ABI_MALLOC(gvnlc,(2,npw_k)) 4249 ABI_MALLOC(ghcall,(2,npw_k*nband_k)) 4250 4251 do iband = 1, nband_k 4252 ibs1 = (iband-1)*npw_k+1 4253 ibs2 = iband*npw_k 4254 cwavef(1:2,1:npw_k) = cg1_kb(1:2,ibs1:ibs2) 4255 call pawcprj_get(atindx1,cwaveprj,cprj1_kb,dtset%natom,iband,0,ikptb,0,isppol,dtset%mband,& 4256 & dtset%mkmem,dtset%natom,1,nband_k,my_nspinor,dtset%nsppol,0) 4257 call getghc(cpopt,cwavef,cwaveprj,ghc,gsc,gs_hamk,gvnlc,lambda,mpi_enreg,ndat,& 4258 & prtvol,sij_opt,tim_getghc,type_calc) 4259 ghcall(1:2,ibs1:ibs2) = ghc(1:2,1:npw_k) 4260 end do 4261 ABI_FREE(ghc) 4262 ABI_FREE(gsc) 4263 ABI_FREE(gvnlc) 4264 4265 ! cprj generated here at k, rather than at k+b 4266 call pawcprj_set_zero(cprj1_kb) 4267 do iband = 1, nband_k 4268 ibs1 = (iband-1)*npw_k+1 4269 ibs2 = iband*npw_k 4270 cwavef(1:2,1:npw_k) = cg1_kb(1:2,ibs1:ibs2) 4271 call getcprj(getcprj_choice,getcprj_cpopt,cwavef,cwaveprj,ffnl,& 4272 & getcprj_idir,psps%indlmn,istwf_k,kg_k,kpg_k,kpoint,psps%lmnmax,& 4273 & dtset%mgfft,mpi_enreg,& 4274 & dtset%natom,nattyp,dtset%ngfft,dtset%nloalg,npw_k,dtset%nspinor,dtset%ntypat,& 4275 & phkxred,ph1d,ph3d,ucvol,psps%useylm) 4276 4277 call pawcprj_put(atindx1,cwaveprj,cprj1_kb,dtset%natom,& 4278 & iband,0,ikpt,0,isppol,nband_k,dtset%mkmem,& 4279 & dtset%natom,1,nband_k,dimlmn,dtset%nspinor,dtset%nsppol,0,& 4280 & mpicomm=mpi_enreg%comm_kpt,proc_distrb=mpi_enreg%proc_distrb) 4281 end do 4282 ABI_FREE(cg1_kb) 4283 ABI_FREE(cwavef) 4284 4285 end if 4286 4287 do gfor = 1, 2 4288 gsigma=3-2*gfor 4289 dkg(1:3) = gsigma*dtorbmag%dkvecs(1:3,gdir) 4290 deltag = sqrt(DOT_PRODUCT(dkg,dkg)) 4291 4292 cprefac = j_dpc*epsabg*bsigma*gsigma/(two*deltab*two*deltag) 4293 4294 if (ikpt > 0) then 4295 ikptg = dtorbmag%ikpt_dk(ikpt,gfor,gdir) 4296 ikptgi = dtorbmag%indkk_f2ibz(ikptg,1) 4297 npw_kg = npwarr(ikptgi) 4298 pwind_kg(1:npw_k) = pwind(ikg+1:ikg+npw_k,gfor,gdir) 4299 4300 end if 4301 4302 if (ikpt > 0 .AND. isppol > 0) then 4303 countg = npw_kg*my_nspinor*nband_k 4304 ABI_MALLOC(cgqg,(2,countg)) 4305 call mpicomm_helper(atindx1,gdir,gfor,cg,cgqg,cprj,cprj_kg,dimlmn,dtorbmag,dtset,& 4306 & ikpt,ikpt_loc,ikptgi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 4307 & nproc,npw_kg,npwarr,spaceComm) 4308 end if 4309 4310 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 4311 4312 ! get covariant |u_{n,k+g}> and associated cprj 4313 call overlap_k1k2_paw(cprj_k,cprj_kg,dkg,gprimd,kk_paw,dtorbmag%lmn2max,& 4314 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 4315 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 4316 sflag_k=0 4317 ABI_MALLOC(cg1_kg,(2,countk)) 4318 cg1_kg(:,:) = zero 4319 ! cg1_kg will hold |\tilde{u}_{n,k+g}> 4320 call smatrix(cg_k,cgqg,cg1_kg,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 4321 & countk,countg,countk,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kg,my_nspinor,& 4322 & pwind_kg,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 4323 ABI_FREE(cgqg) 4324 4325 ! ! cprj1_kg will hold cprj for cg1_kg that is <p|\tilde{u}_{n,k+g}> 4326 ! call covar_cprj(cprj_kg,cprj1_kg,dtset,nband_k,pawtab,smat_inv) 4327 4328 ABI_MALLOC(cwavef,(2,npw_k)) 4329 ! cprj generated here at k, rather than at k+g 4330 call pawcprj_set_zero(cprj1_kg) 4331 do iband = 1, nband_k 4332 ibs1 = (iband-1)*npw_k+1 4333 ibs2 = iband*npw_k 4334 cwavef(1:2,1:npw_k) = cg1_kg(1:2,ibs1:ibs2) 4335 call getcprj(getcprj_choice,getcprj_cpopt,cwavef,cwaveprj,ffnl,& 4336 & getcprj_idir,psps%indlmn,istwf_k,kg_k,kpg_k,kpoint,psps%lmnmax,& 4337 & dtset%mgfft,mpi_enreg,& 4338 & dtset%natom,nattyp,dtset%ngfft,dtset%nloalg,npw_k,dtset%nspinor,dtset%ntypat,& 4339 & phkxred,ph1d,ph3d,ucvol,psps%useylm) 4340 4341 call pawcprj_put(atindx1,cwaveprj,cprj1_kg,dtset%natom,& 4342 & iband,0,ikpt,0,isppol,nband_k,dtset%mkmem,& 4343 & dtset%natom,1,nband_k,dimlmn,dtset%nspinor,dtset%nsppol,0,& 4344 & mpicomm=mpi_enreg%comm_kpt,proc_distrb=mpi_enreg%proc_distrb) 4345 end do 4346 ABI_FREE(cwavef) 4347 4348 do iband = 1, nband_k 4349 ibs1=(iband-1)*npw_k+1 4350 ibs2=iband*npw_k 4351 dotr=DOT_PRODUCT(cg1_kg(1,ibs1:ibs2),ghcall(1,ibs1:ibs2)) + & 4352 & DOT_PRODUCT(cg1_kg(2,ibs1:ibs2),ghcall(2,ibs1:ibs2)) 4353 doti=DOT_PRODUCT(cg1_kg(1,ibs1:ibs2),ghcall(2,ibs1:ibs2)) - & 4354 & DOT_PRODUCT(cg1_kg(2,ibs1:ibs2),ghcall(1,ibs1:ibs2)) 4355 4356 ! compute onsite contribution due to paw_ij%dij 4357 call cpg_dij_cpb(cgdijcb,cprj1_kb,cprj1_kg,dtset,iband,iband,dtorbmag%nspinor,paw_ij,pawtab) 4358 4359 ! accumulate i*epsabg*\sum_occ [<d_gdir u|QHQ|d_bdir u>] 4360 ! duqhqdu_term = cprefac*(cmplx(dotr,doti)+cgdijcb) 4361 duqhqdu_term = cprefac*cmplx(dotr,doti) 4362 ! duqhqdu_term = cprefac*cgdijcb 4363 cnum_duqhqdu(1,iband,adir) = cnum_duqhqdu(1,iband,adir) + real(duqhqdu_term) 4364 cnum_duqhqdu(2,iband,adir) = cnum_duqhqdu(2,iband,adir) + aimag(duqhqdu_term) 4365 4366 end do ! end loop over iband 4367 ABI_FREE(cg1_kg) 4368 4369 end if ! end check on ikpt > 0 4370 4371 end do ! end loop over gfor 4372 4373 ABI_FREE(ghcall) 4374 4375 end do ! end loop over bfor 4376 end do ! end loop over epsabg 4377 end do ! end loop over adir 4378 4379 if (ikpt > 0) then 4380 ABI_FREE(cg_k) 4381 ABI_FREE(kg_k) 4382 ABI_FREE(kpg_k) 4383 ABI_FREE(kinpw) 4384 ABI_FREE(phkxred) 4385 ABI_FREE(ph3d) 4386 ABI_FREE(ffnl) 4387 end if 4388 4389 end do ! end loop over ikpt_loc 4390 4391 ! ---- parallel communication 4392 if(nproc > 1) then 4393 call xmpi_sum(cnum_duqhqdu,spaceComm,ierr) 4394 end if 4395 4396 call gs_hamk%free() 4397 ABI_FREE(vlocal) 4398 if(has_vectornd) then 4399 ABI_FREE(vectornd_pac) 4400 end if 4401 4402 ABI_FREE(ph1d) 4403 4404 ABI_FREE(dimlmn) 4405 call pawcprj_free(cprj_k) 4406 ABI_FREE(cprj_k) 4407 call pawcprj_free(cprj_kb) 4408 ABI_FREE(cprj_kb) 4409 call pawcprj_free(cprj_kg) 4410 ABI_FREE(cprj_kg) 4411 call pawcprj_free(cprj1_kb) 4412 ABI_FREE(cprj1_kb) 4413 call pawcprj_free(cprj1_kg) 4414 ABI_FREE(cprj1_kg) 4415 call pawcprj_free(cwaveprj) 4416 ABI_FREE(cwaveprj) 4417 4418 ABI_FREE(kk_paw) 4419 ABI_FREE(smat_kk) 4420 ABI_FREE(smat_inv) 4421 ABI_FREE(sflag_k) 4422 ABI_FREE(pwind_kb) 4423 ABI_FREE(pwind_kg) 4424 ABI_FREE(pwnsfac_k) 4425 4426 end subroutine duqhqdu
ABINIT/initorbmag [ Functions ]
NAME
initorbmag
FUNCTION
Initialization of orbital magnetization calculation; similar to initberry
COPYRIGHT
Copyright (C) 2004-2020 ABINIT group. This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
INPUTS
dtset <type(dataset_type)> = all input variables in this dataset gmet(3,3) = reciprocal space metric tensor in bohr**-2 gprimd(3,3) = primitive translations in recip space kg(3,mpw*mkmem) = reduced (integer) coordinates of G vecs in basis sphere npwarr(nkpt) = number of planewaves in basis and boundary at this k point occ(mband*nkpt*nsppol) = occup number for each band at each k point pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data psps <type(pseudopotential_type)>=variables related to pseudopotentials rprimd(3,3) = dimensional primitive vectors symrec(3,3,nsym) = symmetries in reciprocal space in terms of reciprocal space primitive translations xred(3,natom) = location of atoms in reduced units
OUTPUT
dtorbmag <type(orbmag_type)> = variables related to orbital magnetization
SIDE EFFECTS
mpi_enreg = information about MPI parallelization
PARENTS
m_gstate
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
310 subroutine initorbmag(dtorbmag,dtset,gmet,gprimd,kg,mpi_enreg,npwarr,occ,& 311 & pawtab,psps,pwind,pwind_alloc,pwnsfac,& 312 & rprimd,symrec,xred) 313 314 !Arguments ------------------------------------ 315 !scalars 316 integer,intent(out) :: pwind_alloc 317 type(MPI_type),intent(inout) :: mpi_enreg 318 type(dataset_type),intent(inout) :: dtset 319 type(orbmag_type),intent(out) :: dtorbmag 320 type(pseudopotential_type),intent(in) :: psps 321 !arrays 322 integer,intent(in) :: kg(3,dtset%mpw*dtset%mkmem),npwarr(dtset%nkpt) 323 integer,intent(in) :: symrec(3,3,dtset%nsym) 324 integer,pointer :: pwind(:,:,:) 325 real(dp),intent(in) :: gmet(3,3),gprimd(3,3),occ(dtset%mband*dtset%nkpt*dtset%nsppol) 326 real(dp),intent(in) :: rprimd(3,3),xred(3,dtset%natom) 327 real(dp),pointer :: pwnsfac(:,:) 328 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 329 330 !Local variables------------------------------- 331 !scalars 332 integer :: brav,exchn2n3d,fnkpt_computed 333 integer :: iband,icg,icprj,idir,idum,idum1,ierr,ifor,ikg,ikg1 334 integer :: ikpt,ikpt_loc,ikpti,ikpt1,ikpt1f,ikpt1i 335 integer :: index,ipw,ipwnsfac,isign,isppol,istwf_k,isym,isym1,itrs,itypat 336 integer :: jpw,lmax,lmn2_size_max 337 integer :: mband_occ_k,me,me_g0,mkmem_,mkpt,my_nspinor,nband_k,nkptlatt,nproc,npw_k,npw_k1 338 integer :: option,spaceComm 339 real(dp) :: diffk1,diffk2,diffk3,ecut_eff 340 real(dp) :: kpt_shifted1,kpt_shifted2,kpt_shifted3,rdum 341 character(len=500) :: message 342 !arrays 343 integer :: iadum(3),iadum1(3),dg(3) 344 integer,allocatable :: kg1_k(:,:) 345 real(dp) :: diffk(3),dk(3),dum33(3,3),kpt1(3),tsec(2) 346 real(dp),allocatable :: spkpt(:,:) 347 348 ! ************************************************************************* 349 350 DBG_ENTER("COLL") 351 352 call timab(1001,1,tsec) 353 call timab(1002,1,tsec) 354 355 !save the current value of nspinor 356 dtorbmag%nspinor = dtset%nspinor 357 358 !---------------------------------------------------------------------------- 359 !-------------------- Obtain k-point grid in the full BZ -------------------- 360 !---------------------------------------------------------------------------- 361 362 if(dtset%kptopt==1 .or. dtset%kptopt==2 .or. dtset%kptopt==4)then 363 ! Compute the number of k points in the G-space unit cell 364 nkptlatt=dtset%kptrlatt(1,1)*dtset%kptrlatt(2,2)*dtset%kptrlatt(3,3) & 365 & +dtset%kptrlatt(1,2)*dtset%kptrlatt(2,3)*dtset%kptrlatt(3,1) & 366 & +dtset%kptrlatt(1,3)*dtset%kptrlatt(2,1)*dtset%kptrlatt(3,2) & 367 & -dtset%kptrlatt(1,2)*dtset%kptrlatt(2,1)*dtset%kptrlatt(3,3) & 368 & -dtset%kptrlatt(1,3)*dtset%kptrlatt(2,2)*dtset%kptrlatt(3,1) & 369 & -dtset%kptrlatt(1,1)*dtset%kptrlatt(2,3)*dtset%kptrlatt(3,2) 370 371 ! Call smpbz to obtain the list of k-point in the full BZ - without symmetry reduction 372 option = 0 373 brav = 1 374 mkpt=nkptlatt*dtset%nshiftk 375 ABI_MALLOC(spkpt,(3,mkpt)) 376 call smpbz(1,ab_out,dtset%kptrlatt,mkpt,fnkpt_computed,dtset%nshiftk,option,dtset%shiftk,spkpt) 377 dtorbmag%fnkpt = fnkpt_computed 378 ABI_MALLOC(dtorbmag%fkptns,(3,dtorbmag%fnkpt)) 379 dtorbmag%fkptns(:,:)=spkpt(:,1:dtorbmag%fnkpt) 380 ABI_FREE(spkpt) 381 else if(dtset%kptopt==3.or.dtset%kptopt==0)then 382 dtorbmag%fnkpt=dtset%nkpt 383 ABI_MALLOC(dtorbmag%fkptns,(3,dtorbmag%fnkpt)) 384 dtorbmag%fkptns(1:3,1:dtorbmag%fnkpt)=dtset%kpt(1:3,1:dtorbmag%fnkpt) 385 if(dtset%kptopt==0)then 386 write(message,'(10a)') ch10,& 387 & ' initorbmag : WARNING -',ch10,& 388 & ' you have defined manually the k-point grid with kptopt = 0',ch10,& 389 & ' the orbital magnetization calculation works only with a regular k-points grid,',ch10,& 390 & ' abinit doesn''t check if your grid is regular...' 391 call wrtout(std_out,message,'PERS') 392 end if 393 end if 394 395 !call listkk to get mapping from FBZ to IBZ 396 rdum=1.0d-5 ! cutoff distance to decide when two k points match 397 ABI_MALLOC(dtorbmag%indkk_f2ibz,(dtorbmag%fnkpt,6)) 398 399 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 400 spaceComm=mpi_enreg%comm_cell 401 402 !JWZ: The following may need modification in the future 403 !**** no spin-polarization doubling ; do not allow use of time reversal symmetry **** 404 405 call timab(1002,2,tsec) 406 call timab(1003,1,tsec) 407 408 call listkk(rdum,gmet,dtorbmag%indkk_f2ibz,dtset%kptns,dtorbmag%fkptns,dtset%nkpt,& 409 & dtorbmag%fnkpt,dtset%nsym,1,dtset%symafm,symrec,0,spaceComm,use_symrec=.True.) 410 411 call timab(1003,2,tsec) 412 call timab(1004,1,tsec) 413 414 !Construct i2fbz and f2ibz 415 ABI_MALLOC(dtorbmag%i2fbz,(dtset%nkpt)) 416 idum=0 417 do ikpt=1,dtorbmag%fnkpt 418 if (dtorbmag%indkk_f2ibz(ikpt,2)==1 .and. & 419 & dtorbmag%indkk_f2ibz(ikpt,6) == 0 .and. & 420 & maxval(abs(dtorbmag%indkk_f2ibz(ikpt,3:5))) == 0 ) then 421 dtorbmag%i2fbz(dtorbmag%indkk_f2ibz(ikpt,1))=ikpt 422 idum=idum+1 423 end if 424 end do 425 if (idum/=dtset%nkpt)then 426 message = ' Found wrong number of k-points in IBZ' 427 ABI_ERROR(message) 428 end if 429 430 !---------------------------------------------------------------------------- 431 !------------- Allocate PAW space as necessary ------------------------------ 432 !---------------------------------------------------------------------------- 433 434 dtorbmag%usepaw = psps%usepaw 435 dtorbmag%natom = dtset%natom 436 dtorbmag%my_natom = mpi_enreg%my_natom 437 438 ABI_MALLOC(dtorbmag%lmn_size,(dtset%ntypat)) 439 ABI_MALLOC(dtorbmag%lmn2_size,(dtset%ntypat)) 440 do itypat = 1, dtset%ntypat 441 dtorbmag%lmn_size(itypat) = pawtab(itypat)%lmn_size 442 dtorbmag%lmn2_size(itypat) = pawtab(itypat)%lmn2_size 443 end do 444 445 lmn2_size_max = psps%lmnmax*(psps%lmnmax+1)/2 446 dtorbmag%lmn2max = lmn2_size_max 447 448 ABI_MALLOC(dtorbmag%cprjindex,(dtset%nkpt,dtset%nsppol)) 449 dtorbmag%cprjindex(:,:) = 0 450 451 if (dtset%kptopt /= 3) then 452 ABI_MALLOC(dtorbmag%atom_indsym,(4,dtset%nsym,dtorbmag%natom)) 453 call symatm(dtorbmag%atom_indsym,dtorbmag%natom,dtset%nsym,symrec,dtset%tnons,tol8,dtset%typat,xred) 454 lmax = psps%mpsang - 1 455 ABI_MALLOC(dtorbmag%zarot,(2*lmax+1,2*lmax+1,lmax+1,dtset%nsym)) 456 call setsym_ylm(gprimd,lmax,dtset%nsym,1,rprimd,symrec,dtorbmag%zarot) 457 dtorbmag%nsym = dtset%nsym 458 dtorbmag%lmax = lmax 459 dtorbmag%lmnmax = psps%lmnmax 460 end if 461 462 ! !------------------------------------------------------------------------------ 463 ! !------------------- Compute variables related to MPI // ---------------------- 464 ! !------------------------------------------------------------------------------ 465 spaceComm=mpi_enreg%comm_cell 466 nproc=xmpi_comm_size(spaceComm) 467 me=xmpi_comm_rank(spaceComm) 468 469 if (nproc==1) then 470 dtorbmag%fmkmem = dtorbmag%fnkpt 471 dtorbmag%fmkmem_max = dtorbmag%fnkpt 472 dtorbmag%mkmem_max = dtset%nkpt 473 else 474 dtorbmag%fmkmem = 0 475 do ikpt = 1, dtorbmag%fnkpt 476 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 477 nband_k = dtset%nband(ikpti) 478 if (.not.(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpti,1,nband_k,-1,me))) & 479 & dtorbmag%fmkmem = dtorbmag%fmkmem + 1 480 end do 481 ! Maximum value of mkmem and fmkmem 482 call xmpi_max(dtorbmag%fmkmem,dtorbmag%fmkmem_max,spaceComm,ierr) 483 ! I have to use the dummy variable mkmem_ because 484 ! mkmem is declared as intent(in) while the first 485 ! argument of xmpi_max must be intent(inout) 486 mkmem_ = dtset%mkmem 487 call xmpi_max(mkmem_,dtorbmag%mkmem_max,spaceComm,ierr) 488 end if 489 490 ABI_MALLOC(mpi_enreg%kpt_loc2fbz_sp,(0:nproc-1,1:dtorbmag%fmkmem_max*dtset%nsppol, 1:2)) 491 ABI_MALLOC(mpi_enreg%kpt_loc2ibz_sp,(0:nproc-1,1:dtorbmag%mkmem_max*dtset%nsppol, 1:2)) 492 ABI_MALLOC(mpi_enreg%kptdstrb,(nproc,6,dtorbmag%fmkmem_max*dtset%nsppol*2)) 493 ABI_MALLOC(mpi_enreg%mkmem,(0:nproc-1)) 494 mpi_enreg%kpt_loc2fbz_sp(:,:,:) = 0 495 mpi_enreg%kpt_loc2ibz_sp(:,:,:) = 0 496 mpi_enreg%kptdstrb(:,:,:) = 0 497 mpi_enreg%mkmem(:) = 0 498 499 pwind_alloc = dtset%mpw*dtorbmag%fmkmem_max 500 501 ABI_MALLOC(pwind,(pwind_alloc,2,3)) 502 ABI_MALLOC(pwnsfac,(2,pwind_alloc)) 503 504 ! !------------------------------------------------------------------------------ 505 ! !---------------------- Compute orbmag_type variables ------------------------- 506 ! !------------------------------------------------------------------------------ 507 508 !Initialization of orbmag_type variables 509 dtorbmag%dkvecs(:,:) = zero 510 ABI_MALLOC(dtorbmag%ikpt_dk,(dtorbmag%fnkpt,2,3)) 511 ABI_MALLOC(dtorbmag%cgindex,(dtset%nkpt,dtset%nsppol)) 512 ABI_MALLOC(dtorbmag%kgindex,(dtset%nkpt)) 513 ABI_MALLOC(dtorbmag%fkgindex,(dtorbmag%fnkpt)) 514 dtorbmag%ikpt_dk(:,:,:) = 0 515 dtorbmag%cgindex(:,:) = 0 516 dtorbmag%mband_occ = 0 517 ABI_MALLOC(dtorbmag%nband_occ,(dtset%nsppol)) 518 dtorbmag%kgindex(:) = 0 519 dtorbmag%fkgindex(:) = 0 520 ABI_MALLOC(dtorbmag%kg,(3,dtset%mpw*dtset%mkmem)) 521 dtorbmag%kg(:,:) = kg(:,:) 522 523 !Compute spin degeneracy 524 if (dtset%nsppol == 1 .and. dtset%nspinor == 1) then 525 dtorbmag%sdeg = two 526 else if (dtset%nsppol == 2 .or. my_nspinor == 2) then 527 dtorbmag%sdeg = one 528 end if 529 530 !Compute the number of occupied bands and check that 531 !it is the same for each k-point 532 533 index = 0 534 do isppol = 1, dtset%nsppol 535 dtorbmag%nband_occ(isppol) = 0 536 do ikpt = 1, dtset%nkpt 537 538 mband_occ_k = 0 539 nband_k = dtset%nband(ikpt + (isppol - 1)*dtset%nkpt) 540 541 do iband = 1, nband_k 542 index = index + 1 543 if (abs(occ(index) - dtorbmag%sdeg) < tol8) mband_occ_k = mband_occ_k + 1 544 end do 545 546 if (ikpt > 1) then 547 if (dtorbmag%nband_occ(isppol) /= mband_occ_k) then 548 message = "The number of valence bands is not the same for every k-point of present spin channel" 549 ABI_ERROR(message) 550 end if 551 else 552 dtorbmag%mband_occ = max(dtorbmag%mband_occ, mband_occ_k) 553 dtorbmag%nband_occ(isppol) = mband_occ_k 554 end if 555 556 end do ! close loop over ikpt 557 end do ! close loop over isppol 558 559 !Compute the location of each wavefunction 560 561 icg = 0 562 icprj = 0 563 !ikg = 0 564 do isppol = 1, dtset%nsppol 565 do ikpt = 1, dtset%nkpt 566 567 nband_k = dtset%nband(ikpt + (isppol-1)*dtset%nkpt) 568 569 if (proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) cycle 570 571 dtorbmag%cgindex(ikpt,isppol) = icg 572 npw_k = npwarr(ikpt) 573 icg = icg + npw_k*dtorbmag%nspinor*nband_k 574 575 if (psps%usepaw == 1) then 576 dtorbmag%cprjindex(ikpt,isppol) = icprj 577 icprj = icprj + dtorbmag%nspinor*nband_k 578 end if 579 580 end do 581 end do 582 583 ikg = 0 584 do ikpt = 1, dtset%nkpt 585 if ((proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,1,me)).and.& 586 & (proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,dtset%nsppol,me))) cycle 587 588 npw_k = npwarr(ikpt) 589 dtorbmag%kgindex(ikpt) = ikg 590 ikg = ikg + npw_k 591 end do 592 593 call timab(1004,2,tsec) 594 595 !------------------------------------------------------------------------------ 596 !---------------------- Compute dk -------------------------------------------- 597 !------------------------------------------------------------------------------ 598 599 call timab(1005,1,tsec) 600 601 do idir = 1, 3 602 603 ! Compute dk(:), the vector between a k-point and its nearest 604 ! neighbour along the direction idir 605 606 dk(:) = zero 607 dk(idir) = 1._dp ! 1 mean there is no other k-point un the direction idir 608 do ikpt = 2, dtorbmag%fnkpt 609 diffk(:) = abs(dtorbmag%fkptns(:,ikpt) - dtorbmag%fkptns(:,1)) 610 if ((diffk(1) < dk(1)+tol8).and.(diffk(2) < dk(2)+tol8).and.& 611 & (diffk(3) < dk(3)+tol8)) dk(:) = diffk(:) 612 end do 613 dtorbmag%dkvecs(:,idir) = dk(:) 614 ! DEBUG 615 ! write(std_out,*)' initorbmag : idir, dk', idir, dk 616 ! ENDDEBUG 617 618 ! For each k point, find k_prim such that k_prim= k + dk mod(G) 619 ! where G is a vector of the reciprocal lattice 620 621 do ikpt = 1, dtorbmag%fnkpt 622 623 ! First k+dk, then k-dk 624 do isign=-1,1,2 625 kpt_shifted1=dtorbmag%fkptns(1,ikpt)- isign*dk(1) 626 kpt_shifted2=dtorbmag%fkptns(2,ikpt)- isign*dk(2) 627 kpt_shifted3=dtorbmag%fkptns(3,ikpt)- isign*dk(3) 628 ! Note that this is still a order fnkpt**2 algorithm. 629 ! It is possible to implement a order fnkpt algorithm, see listkk.F90. 630 do ikpt1 = 1, dtorbmag%fnkpt 631 diffk1=dtorbmag%fkptns(1,ikpt1) - kpt_shifted1 632 if(abs(diffk1-nint(diffk1))>tol8)cycle 633 diffk2=dtorbmag%fkptns(2,ikpt1) - kpt_shifted2 634 if(abs(diffk2-nint(diffk2))>tol8)cycle 635 diffk3=dtorbmag%fkptns(3,ikpt1) - kpt_shifted3 636 if(abs(diffk3-nint(diffk3))>tol8)cycle 637 dtorbmag%ikpt_dk(ikpt,(isign+3)/2,idir) = ikpt1 638 exit 639 end do ! ikpt1 640 end do ! isign 641 642 end do ! ikpt 643 644 end do ! close loop over idir 645 646 call timab(1005,2,tsec) 647 call timab(1006,1,tsec) 648 649 !------------------------------------------------------------------------------ 650 !------------ Build the array pwind that is needed to compute the ------------- 651 !------------ overlap matrices at k +- dk ------------- 652 !------------------------------------------------------------------------------ 653 654 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 655 exchn2n3d = 0 ; istwf_k = 1 ; ikg1 = 0 656 pwind(:,:,:) = 0 657 pwnsfac(1,:) = 1.0_dp 658 pwnsfac(2,:) = 0.0_dp 659 ABI_MALLOC(kg1_k,(3,dtset%mpw)) 660 661 ipwnsfac = 0 662 663 do idir = 1, 3 664 665 dk(:) = dtorbmag%dkvecs(:,idir) 666 667 do ifor = 1, 2 668 669 if (ifor == 2) dk(:) = -1._dp*dk(:) 670 671 ! Build pwind and kgindex 672 ! NOTE: The array kgindex is important for parallel execution. 673 ! In case nsppol = 2, it may happen that a particular processor 674 ! treats k-points at different spin polarizations. 675 ! In this case, it is not possible to address the elements of 676 ! pwind correctly without making use of the kgindex array. 677 678 ikg = 0 ; ikpt_loc = 0 ; isppol = 1 679 do ikpt = 1, dtorbmag%fnkpt 680 681 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 682 nband_k = dtset%nband(ikpti) 683 ikpt1f = dtorbmag%ikpt_dk(ikpt,ifor,idir) 684 ikpt1i = dtorbmag%indkk_f2ibz(ikpt1f,1) 685 686 if ((proc_distrb_cycle(mpi_enreg%proc_distrb,ikpti,1,nband_k,1,me)).and.& 687 & (proc_distrb_cycle(mpi_enreg%proc_distrb,ikpti,1,nband_k,dtset%nsppol,me))) cycle 688 689 ikpt_loc = ikpt_loc + 1 690 691 ! Build basis sphere of plane waves for the nearest neighbour of 692 ! the k-point (important for MPI //) 693 694 kg1_k(:,:) = 0 695 kpt1(:) = dtset%kptns(:,ikpt1i) 696 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg1_k,kpt1,& 697 & 1,mpi_enreg,dtset%mpw,npw_k1) 698 me_g0=mpi_enreg%me_g0 699 700 701 ! ji: fkgindex is defined here ! 702 dtorbmag%fkgindex(ikpt) = ikg 703 704 ! 705 ! Deal with symmetry transformations 706 ! 707 708 ! bra k-point k(b) and IBZ k-point kIBZ(b) related by 709 ! k(b) = alpha(b) S(b)^t kIBZ(b) + G(b) 710 ! where alpha(b), S(b) and G(b) are given by indkk_f2ibz 711 ! 712 ! For the ket k-point: 713 ! k(k) = alpha(k) S(k)^t kIBZ(k) + G(k) - GBZ(k) 714 ! where GBZ(k) takes k(k) to the BZ 715 ! 716 717 isym = dtorbmag%indkk_f2ibz(ikpt,2) 718 isym1 = dtorbmag%indkk_f2ibz(ikpt1f,2) 719 720 ! Construct transformed G vector that enters the matching condition: 721 ! alpha(k) S(k)^{t,-1} ( -G(b) - GBZ(k) + G(k) ) 722 723 dg(:) = -dtorbmag%indkk_f2ibz(ikpt,3:5) & 724 & -nint(-dtorbmag%fkptns(:,ikpt) - dk(:) - tol10 & 725 & +dtorbmag%fkptns(:,ikpt1f)) & 726 & +dtorbmag%indkk_f2ibz(ikpt1f,3:5) 727 728 iadum(:) = MATMUL(TRANSPOSE(dtset%symrel(:,:,isym1)),dg(:)) 729 730 dg(:) = iadum(:) 731 732 if ( dtorbmag%indkk_f2ibz(ikpt1f,6) == 1 ) dg(:) = -dg(:) 733 734 ! Construct S(k)^{t,-1} S(b)^{t} 735 736 dum33(:,:) = MATMUL(TRANSPOSE(dtset%symrel(:,:,isym1)),symrec(:,:,isym)) 737 738 ! Construct alpha(k) alpha(b) 739 740 if (dtorbmag%indkk_f2ibz(ikpt,6) == dtorbmag%indkk_f2ibz(ikpt1f,6)) then 741 itrs=0 742 else 743 itrs=1 744 end if 745 746 747 npw_k = npwarr(ikpti) 748 ! npw_k1 = npwarr(ikpt1i) 749 750 ! loop over bra G vectors 751 do ipw = 1, npw_k 752 753 ! NOTE: the bra G vector is taken for the sym-related IBZ k point, 754 ! not for the FBZ k point 755 iadum(:) = kg(:,dtorbmag%kgindex(ikpti) + ipw) 756 757 ! Store non-symmorphic operation phase factor exp[i2\pi \alpha G \cdot t] 758 759 if ( ipwnsfac == 0 ) then 760 rdum=0.0_dp 761 do idum=1,3 762 rdum=rdum+dble(iadum(idum))*dtset%tnons(idum,isym) 763 end do 764 rdum=two_pi*rdum 765 if ( dtorbmag%indkk_f2ibz(ikpt,6) == 1 ) rdum=-rdum 766 pwnsfac(1,ikg+ipw) = cos(rdum) 767 pwnsfac(2,ikg+ipw) = sin(rdum) 768 end if 769 770 ! to determine r.l.v. matchings, we transformed the bra vector 771 ! Rotation 772 iadum1(:)=0 773 do idum1=1,3 774 iadum1(:)=iadum1(:)+dum33(:,idum1)*iadum(idum1) 775 end do 776 iadum(:)=iadum1(:) 777 ! Time reversal 778 if (itrs==1) iadum(:)=-iadum(:) 779 ! Translation 780 iadum(:) = iadum(:) + dg(:) 781 782 do jpw = 1, npw_k1 783 iadum1(1:3) = kg1_k(1:3,jpw) 784 if ( (iadum(1) == iadum1(1)).and. & 785 & (iadum(2) == iadum1(2)).and. & 786 & (iadum(3) == iadum1(3)) ) then 787 pwind(ikg + ipw,ifor,idir) = jpw 788 ! write(std_out,'(a,2x,3i4,2x,i4)') 'Found !:',iadum1(:),jpw 789 exit 790 end if 791 end do 792 end do 793 794 ikg = ikg + npw_k 795 796 end do ! close loop over ikpt 797 798 ipwnsfac = 1 799 800 end do ! close loop over ifor 801 802 end do ! close loop over idir 803 804 805 call timab(1008,2,tsec) 806 call timab(1009,1,tsec) 807 808 !Build mpi_enreg%kptdstrb 809 !array required to communicate the WFs between cpus 810 !(MPI // over k-points) 811 if (nproc>1) then 812 do idir = 1, 3 813 do ifor = 1, 2 814 815 ikpt_loc = 0 816 do isppol = 1, dtset%nsppol 817 818 do ikpt = 1, dtorbmag%fnkpt 819 820 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 821 nband_k = dtset%nband(ikpti) 822 ikpt1f = dtorbmag%ikpt_dk(ikpt,ifor,idir) 823 ikpt1i = dtorbmag%indkk_f2ibz(ikpt1f,1) 824 825 if (proc_distrb_cycle(mpi_enreg%proc_distrb,ikpti,1,nband_k,isppol,me)) cycle 826 827 ikpt_loc = ikpt_loc + 1 828 mpi_enreg%kptdstrb(me + 1,ifor+2*(idir-1),ikpt_loc) = & 829 & ikpt1i + (isppol - 1)*dtset%nkpt 830 831 mpi_enreg%kptdstrb(me+1,ifor+2*(idir-1),ikpt_loc+dtorbmag%fmkmem_max*dtset%nsppol) = & 832 & ikpt1f + (isppol - 1)*dtorbmag%fnkpt 833 834 end do ! ikpt 835 end do ! isppol 836 end do ! ifor 837 end do ! idir 838 end if ! nproc>1 839 840 !build mpi_enreg%kpt_loc2fbz_sp 841 ikpt_loc = 0 842 do isppol = 1, dtset%nsppol 843 do ikpt = 1, dtorbmag%fnkpt 844 845 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 846 nband_k = dtset%nband(ikpti) 847 848 if (proc_distrb_cycle(mpi_enreg%proc_distrb,ikpti,1,nband_k,isppol,me)) cycle 849 850 ikpt_loc = ikpt_loc + 1 851 852 mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc, 1) = ikpt 853 mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc, 2) = isppol 854 855 end do 856 end do 857 858 !should be temporary 859 !unassigned mpi_enreg%kpt_loc2fbz_sp are empty ; inform other cpu (there are better ways...) 860 mpi_enreg%mkmem(me) = dtset%mkmem 861 !do ii=ikpt_loc+1,dtefield%fmkmem_max 862 !mpi_enreg%kpt_loc2fbz_sp(me, ii, 1) = -1 863 !end do 864 865 call xmpi_sum(mpi_enreg%kptdstrb,spaceComm,ierr) 866 call xmpi_sum(mpi_enreg%kpt_loc2fbz_sp,spaceComm,ierr) 867 868 ABI_FREE(kg1_k) 869 870 871 call timab(1009,2,tsec) 872 call timab(1001,2,tsec) 873 874 DBG_EXIT("COLL") 875 876 end subroutine initorbmag
ABINIT/make_eeig [ Functions ]
NAME
make_eeig
FUNCTION
Compute the energy eigenvalues at each k point
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
eeig
TODO
NOTES
See Ceresoli et al, PRB 74, 024408 (2006) [[cite:Ceresoli2006]],
and Gonze and Zwanziger, PRB 84, 064445 (2011) [[cite:Gonze2011a]].
The derivative of the density operator is obtained from a discretized formula
$\partial_\beta \rho_k = \frac{1}{2\Delta}(\rho_{k+b} - \rho_{k-b})$ with
$\Delta = |b|$. When reduced to wavefunction overlaps the computation amounts to
multiple calls to smatrix.F90, exactly as in other Berry phase computations, with
the one additional complication of overlaps like $\langle u_{n,k+b}|u_{n',k+g}\rangle$.
At this stage mkpwind_k is invoked, which generalizes the code in initberry
and initorbmag necessary to index plane waves around different k points.
Direct questions and comments to J Zwanziger
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
2293 subroutine make_eeig(atindx1,cg,cprj,dtset,eeig,gmet,gprimd,mcg,mcprj,mpi_enreg,& 2294 & nattyp,nband_k,nfftf,npwarr,& 2295 & paw_ij,pawfgr,pawtab,psps,rmet,rprimd,& 2296 & vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2297 2298 !Arguments ------------------------------------ 2299 !scalars 2300 integer,intent(in) :: mcg,mcprj,nband_k,nfftf,with_vectornd 2301 type(dataset_type),intent(in) :: dtset 2302 type(MPI_type), intent(inout) :: mpi_enreg 2303 type(pawfgr_type),intent(in) :: pawfgr 2304 type(pseudopotential_type),intent(in) :: psps 2305 2306 !arrays 2307 integer,intent(in) :: atindx1(dtset%natom),nattyp(dtset%ntypat),npwarr(dtset%nkpt) 2308 real(dp),intent(in) :: cg(2,mcg),gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3) 2309 real(dp),intent(in) :: vhartr(nfftf),vpsp(nfftf),vxc(nfftf,dtset%nspden),xred(3,dtset%natom) 2310 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 2311 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 2312 real(dp),intent(inout) :: vectornd(with_vectornd*nfftf,3) 2313 real(dp),intent(out) :: eeig(nband_k,dtset%nkpt) 2314 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 2315 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 2316 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat*psps%usepaw) 2317 2318 !Local variables ------------------------- 2319 !scalars 2320 integer :: cpopt,dimffnl,eeig_size,exchn2n3d 2321 integer :: ierr,icg,icprj,ider,idir,ikg,ikg1,ikpt,ilm,isppol,istwf_k 2322 integer :: me,my_nspinor,ncpgr,ndat,ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,nkpg,nn 2323 integer :: nproc,npw_k,npw_k_,prtvol,sij_opt,spaceComm,tim_getghc,type_calc 2324 logical :: has_vectornd 2325 real(dp) :: ecut_eff,lambda 2326 type(gs_hamiltonian_type) :: gs_hamk 2327 2328 !arrays 2329 integer,allocatable :: dimlmn(:),kg_k(:,:) 2330 real(dp) :: kpoint(3),lambdarr(1),rhodum(1) 2331 real(dp),allocatable :: buffer1(:),buffer2(:),cgrvtrial(:,:),cwavef(:,:) 2332 real(dp),allocatable :: ffnl_k(:,:,:,:),ghc(:,:),gsc(:,:),gvnlc(:,:) 2333 real(dp),allocatable :: kinpw(:),kpg_k(:,:) 2334 real(dp),allocatable :: ph3d(:,:,:),vectornd_pac(:,:,:,:,:),vlocal(:,:,:,:),vtrial(:,:) 2335 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 2336 type(pawcprj_type),allocatable :: cprj_k(:,:),cwaveprj(:,:) 2337 2338 2339 !----------------------------------------------------------------------- 2340 2341 !Init MPI 2342 spaceComm=mpi_enreg%comm_cell 2343 nproc=xmpi_comm_size(spaceComm) 2344 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 2345 me = mpi_enreg%me_kpt 2346 2347 ! TODO: generalize to nsppol > 1 2348 isppol = 1 2349 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 2350 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 2351 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 2352 exchn2n3d = 0 ; istwf_k = 1 ; ikg1 = 0 2353 2354 has_vectornd = (with_vectornd .EQ. 1) 2355 2356 ! input parameters for calls to getghc at ikpt 2357 cpopt = 4 ! was 4 2358 ndat = 1 2359 prtvol = 0 2360 sij_opt = 0 2361 tim_getghc = 0 2362 ! getghc: type_calc 0 means kinetic, local, nonlocal 2363 type_calc = 0 2364 lambda = zero; lambdarr(1) = zero 2365 2366 !==== Initialize most of the Hamiltonian ==== 2367 !Allocate all arrays and initialize quantities that do not depend on k and spin. 2368 !gs_hamk is the normal hamiltonian at k, needed for computing E_nk 2369 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 2370 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 2371 & paw_ij=paw_ij) 2372 2373 !---------construct local potential------------------ 2374 ABI_MALLOC(vtrial,(nfftf,dtset%nspden)) 2375 ! nspden=1 is essentially hard-coded in the following line 2376 vtrial(1:nfftf,1)=vhartr(1:nfftf)+vxc(1:nfftf,1)+vpsp(1:nfftf) 2377 2378 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 2379 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vtrial) 2380 2381 ABI_MALLOC(vlocal,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc)) 2382 call fftpac(isppol,mpi_enreg,dtset%nspden,& 2383 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vlocal,2) 2384 2385 ABI_FREE(cgrvtrial) 2386 ABI_FREE(vtrial) 2387 2388 ! if vectornd is present, set it up for addition to gs_hamk similarly to how it's done for 2389 ! vtrial. Note that it must be done for the three directions. Also, the following 2390 ! code assumes explicitly and implicitly that nvloc = 1. This should eventually be generalized. 2391 if(has_vectornd) then 2392 ABI_MALLOC(vectornd_pac,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc,3)) 2393 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 2394 do idir = 1, 3 2395 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vectornd(:,idir)) 2396 call fftpac(isppol,mpi_enreg,dtset%nspden,& 2397 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vectornd_pac(:,:,:,1,idir),2) 2398 end do 2399 ABI_FREE(cgrvtrial) 2400 end if 2401 2402 ! add vlocal 2403 call gs_hamk%load_spin(isppol,vlocal=vlocal,with_nonlocal=.true.) 2404 2405 ! add vectornd if available 2406 if(has_vectornd) then 2407 call gs_hamk%load_spin(isppol,vectornd=vectornd_pac) 2408 end if 2409 2410 ncpgr = cprj(1,1)%ncpgr 2411 ABI_MALLOC(dimlmn,(dtset%natom)) 2412 call pawcprj_getdim(dimlmn,dtset%natom,nattyp,dtset%ntypat,dtset%typat,pawtab,'R') 2413 2414 ABI_MALLOC(cprj_k,(dtset%natom,nband_k)) 2415 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 2416 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 2417 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 2418 2419 ABI_MALLOC(kg_k,(3,dtset%mpw)) 2420 ABI_MALLOC(kinpw,(dtset%mpw)) 2421 2422 eeig(:,:) = zero 2423 icg = 0 2424 ikg = 0 2425 icprj = 0 2426 do ikpt = 1, dtset%nkpt 2427 2428 ! if the current kpt is not on the current processor, cycle 2429 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 2430 2431 kpoint(:)=dtset%kptns(:,ikpt) 2432 npw_k = npwarr(ikpt) 2433 2434 ! Build basis sphere of plane waves for the k-point 2435 kg_k(:,:) = 0 2436 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg_k,kpoint,1,mpi_enreg,dtset%mpw,npw_k_) 2437 if (npw_k .NE. npw_k_) then 2438 write(std_out,'(a)')'JWZ debug mpi_eeig npw_k inconsistency' 2439 end if 2440 2441 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 2442 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 2443 do ilm=1,psps%mpsang*psps%mpsang 2444 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 2445 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 2446 end do 2447 2448 ! Compute kinetic energy at kpt 2449 kinpw(:) = zero 2450 call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg_k,kinpw,kpoint,npw_k,0,0) 2451 2452 nkpg = 3 2453 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 2454 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 2455 2456 ! Compute nonlocal form factors ffnl at all (k+G): 2457 ider=0 ! want ffnl and 1st derivative 2458 idir=4 ! d ffnl/ dk_red in all 3 directions 2459 dimffnl=1 ! 1 + number of derivatives 2460 ABI_MALLOC(ffnl_k,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 2461 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl_k,psps%ffspl,& 2462 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 2463 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 2464 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 2465 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 2466 2467 ! - Compute 3D phase factors 2468 ! - Prepare various tabs in case of band-FFT parallelism 2469 ! - Load k-dependent quantities in the Hamiltonian 2470 ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk)) 2471 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 2472 & kinpw_k=kinpw,kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,ph3d_k=ph3d,& 2473 & compute_ph3d=.TRUE.,compute_gbound=.TRUE.) 2474 2475 2476 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt,0,isppol,dtset%mband,& 2477 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 2478 2479 ! apply gs_hamk to wavefunctions at k to compute E_nk eigenvalues 2480 ABI_MALLOC(cwavef,(2,npw_k)) 2481 ABI_MALLOC(ghc,(2,npw_k)) 2482 ABI_MALLOC(gsc,(2,npw_k)) 2483 ABI_MALLOC(gvnlc,(2,npw_k)) 2484 do nn = 1, nband_k 2485 cwavef(1:2,1:npw_k) = cg(1:2,icg+(nn-1)*npw_k+1:icg+nn*npw_k) 2486 call pawcprj_get(atindx1,cwaveprj,cprj_k,dtset%natom,nn,0,ikpt,0,isppol,dtset%mband,& 2487 & dtset%mkmem,dtset%natom,1,nband_k,my_nspinor,dtset%nsppol,0) 2488 call getghc(cpopt,cwavef,cwaveprj,ghc,gsc,gs_hamk,gvnlc,lambda,mpi_enreg,ndat,& 2489 & prtvol,sij_opt,tim_getghc,type_calc) 2490 eeig(nn,ikpt) = DOT_PRODUCT(cwavef(1,1:npw_k),ghc(1,1:npw_k)) & 2491 & + DOT_PRODUCT(cwavef(2,1:npw_k),ghc(2,1:npw_k)) 2492 end do 2493 2494 icg = icg + npw_k*nband_k 2495 ikg = ikg + npw_k 2496 icprj = icprj + nband_k 2497 2498 ABI_FREE(ylm_k) 2499 ABI_FREE(ylmgr_k) 2500 ABI_FREE(kpg_k) 2501 ABI_FREE(ffnl_k) 2502 ABI_FREE(ph3d) 2503 ABI_FREE(cwavef) 2504 ABI_FREE(ghc) 2505 ABI_FREE(gsc) 2506 ABI_FREE(gvnlc) 2507 2508 end do ! end loop over kpts on current processor 2509 2510 ! MPI communicate stuff between everyone 2511 if (nproc>1) then 2512 eeig_size = size(eeig) 2513 ABI_MALLOC(buffer1,(eeig_size)) 2514 ABI_MALLOC(buffer2,(eeig_size)) 2515 buffer1(1:eeig_size) = reshape(eeig,(/eeig_size/)) 2516 call xmpi_sum(buffer1,buffer2,eeig_size,spaceComm,ierr) 2517 eeig(1:nband_k,1:dtset%nkpt)=reshape(buffer2,(/nband_k,dtset%nkpt/)) 2518 ABI_FREE(buffer1) 2519 ABI_FREE(buffer2) 2520 end if 2521 2522 call gs_hamk%free() 2523 ABI_FREE(vlocal) 2524 if(has_vectornd) then 2525 ABI_FREE(vectornd_pac) 2526 end if 2527 2528 ABI_FREE(kg_k) 2529 ABI_FREE(kinpw) 2530 2531 ABI_FREE(dimlmn) 2532 call pawcprj_free(cprj_k) 2533 ABI_FREE(cprj_k) 2534 call pawcprj_free(cwaveprj) 2535 ABI_FREE(cwaveprj) 2536 2537 end subroutine make_eeig
ABINIT/make_onsite_bm [ Functions ]
NAME
make_onsite_bm
FUNCTION
Compute A_0.A_N onsite term for magnetic field + nuclear magnetic dipole moment
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
5157 subroutine make_onsite_bm(atindx1,cprj,dtset,idir,mcprj,mpi_enreg,nband_k,onsite_bm,& 5158 & pawang,pawrad,pawtab) 5159 5160 !Arguments ------------------------------------ 5161 !scalars 5162 integer,intent(in) :: idir,mcprj,nband_k 5163 type(MPI_type), intent(inout) :: mpi_enreg 5164 type(pawang_type),intent(in) :: pawang 5165 type(dataset_type),intent(in) :: dtset 5166 5167 !arrays 5168 integer,intent(in) :: atindx1(dtset%natom) 5169 complex(dpc),intent(out) :: onsite_bm(nband_k) 5170 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 5171 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 5172 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 5173 5174 !Local variables ------------------------- 5175 !scalars 5176 integer :: gint,iatom,icprj,ierr,ikpt,ikpt_loc,il,im,ilmn,isppol,itypat 5177 integer :: jl,jm,jlmn,klmn,klm,kln,lpmp,me,mesh_size,my_nspinor,ncpgr,nn,nproc,spaceComm 5178 real(dp) :: bm1,bm2,d00,d20,d22,dij,intg,scale_conversion 5179 complex(dpc) :: cpb,cpk 5180 5181 !arrays 5182 integer :: nattyp_dum(dtset%ntypat) 5183 integer,allocatable :: dimlmn(:) 5184 real(dp),allocatable :: ff(:) 5185 type(pawcprj_type),allocatable :: cprj_k(:,:) 5186 5187 ! *********************************************************************** 5188 5189 ! this term can only be non-zero if some nucdipmom is nonzero 5190 scale_conversion = half*FineStructureConstant2 5191 d00 = sqrt(4.0*pi)/3.0 5192 dij = sqrt(4.0*pi/15.0) 5193 d20 = sqrt(16.0*pi/5.0)/6.0 5194 d22 = sqrt(16.0*pi/15.0)/2.0 5195 onsite_bm = czero 5196 5197 ! TODO: generalize to nsppol > 1 5198 isppol = 1 5199 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 5200 5201 !Init MPI 5202 spaceComm=mpi_enreg%comm_cell 5203 nproc=xmpi_comm_size(spaceComm) 5204 me = mpi_enreg%me_kpt 5205 5206 ncpgr = cprj(1,1)%ncpgr 5207 ABI_MALLOC(dimlmn,(dtset%natom)) 5208 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 5209 ABI_MALLOC(cprj_k,(dtset%natom,nband_k)) 5210 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 5211 5212 ! loop over kpts on each processor 5213 5214 ikpt_loc = 0 5215 ! loop over all the kpts 5216 do ikpt = 1, dtset%nkpt 5217 5218 ! if the current kpt is not on the current processor, cycle 5219 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 5220 5221 ikpt_loc = ikpt_loc + 1 5222 icprj= (ikpt_loc - 1)*nband_k 5223 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt_loc,0,isppol,dtset%mband,& 5224 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 5225 5226 do iatom=1,dtset%natom 5227 itypat=dtset%typat(iatom) 5228 mesh_size=pawtab(itypat)%mesh_size 5229 ABI_MALLOC(ff,(mesh_size)) 5230 do jlmn=1,pawtab(itypat)%lmn_size 5231 jl=pawtab(itypat)%indlmn(1,jlmn) 5232 jm=pawtab(itypat)%indlmn(2,jlmn) 5233 do ilmn=1,pawtab(itypat)%lmn_size 5234 il=pawtab(itypat)%indlmn(1,ilmn) 5235 im=pawtab(itypat)%indlmn(2,ilmn) 5236 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 5237 kln = pawtab(itypat)%indklmn(2,klmn) ! need this for mesh selection below 5238 klm = pawtab(itypat)%indklmn(1,klmn) ! need this for bm2 gaunt integral selection 5239 ! compute integral of (phi_i*phi_j - tphi_i*tphi_j)/r 5240 ff(2:mesh_size)=(pawtab(itypat)%phiphj(2:mesh_size,kln) - & 5241 & pawtab(itypat)%tphitphj(2:mesh_size,kln)) / & 5242 & pawrad(itypat)%rad(2:mesh_size) 5243 call pawrad_deducer0(ff,mesh_size,pawrad(itypat)) 5244 call simp_gen(intg,ff,pawrad(itypat)) 5245 ! term B.m r^2/r^3 5246 bm1=zero 5247 if ( (jl .EQ. il) .AND. (jm .EQ. im) .AND. (abs(dtset%nucdipmom(idir,iatom)) .GT. tol8) ) then 5248 bm1 = scale_conversion*dtset%nucdipmom(idir,iatom)*intg 5249 end if 5250 bm2 = zero 5251 ! xx, yy, zz cases all have the same contribution from S00 5252 lpmp=1 5253 gint = pawang%gntselect(lpmp,klm) 5254 if (gint > 0) then 5255 bm2=bm2+scale_conversion*dtset%nucdipmom(idir,iatom)*d00*pawang%realgnt(gint)*intg 5256 end if 5257 ! all other contributions involve Gaunt integrals of S_{2m} 5258 do lpmp = 5, 9 5259 gint = pawang%gntselect(lpmp,klm) 5260 if (gint > 0) then 5261 select case (lpmp) 5262 case (5) ! S_{2,-2} contributes to xy term 5263 select case (idir) 5264 case (1) 5265 bm2=bm2+scale_conversion*dtset%nucdipmom(2,iatom)*dij*pawang%realgnt(gint)*intg 5266 case (2) 5267 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*dij*pawang%realgnt(gint)*intg 5268 end select 5269 case (6) ! S_{2,-1} contributes to yz term 5270 select case (idir) 5271 case (2) 5272 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*dij*pawang%realgnt(gint)*intg 5273 case (3) 5274 bm2=bm2+scale_conversion*dtset%nucdipmom(2,iatom)*dij*pawang%realgnt(gint)*intg 5275 end select 5276 case (7) ! S_{2,0} contributes to xx, yy, and zz terms 5277 select case (idir) 5278 case (1) 5279 bm2=bm2-scale_conversion*dtset%nucdipmom(1,iatom)*d20*pawang%realgnt(gint)*intg 5280 case (2) 5281 bm2=bm2-scale_conversion*dtset%nucdipmom(2,iatom)*d20*pawang%realgnt(gint)*intg 5282 case (3) 5283 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*2.0*d20*pawang%realgnt(gint)*intg 5284 end select 5285 case (8) ! S_{2,+1} contributes to xz term 5286 select case (idir) 5287 case (1) 5288 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*dij*pawang%realgnt(gint)*intg 5289 case (3) 5290 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*dij*pawang%realgnt(gint)*intg 5291 end select 5292 case (9) ! S_{2,2} contributes to xx, yy terms 5293 select case (idir) 5294 case (1) 5295 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*d22*pawang%realgnt(gint)*intg 5296 case (2) 5297 bm2=bm2-scale_conversion*dtset%nucdipmom(2,iatom)*d22*pawang%realgnt(gint)*intg 5298 end select 5299 end select 5300 end if ! end check on nonzero gaunt integral 5301 end do ! end loop over lp,mp 5302 do nn = 1, nband_k 5303 cpb=cmplx(cprj_k(iatom,nn)%cp(1,ilmn),cprj_k(iatom,nn)%cp(2,ilmn),KIND=dpc) 5304 cpk=cmplx(cprj_k(iatom,nn)%cp(1,jlmn),cprj_k(iatom,nn)%cp(2,jlmn),KIND=dpc) 5305 onsite_bm(nn)=onsite_bm(nn)+conjg(cpb)*(bm1-bm2)*cpk 5306 end do ! end loop over nn 5307 end do ! end loop over ilmn 5308 end do ! end loop over jlmn 5309 ABI_FREE(ff) 5310 end do ! end loop over atoms 5311 end do ! end loop over local k points 5312 5313 ! ---- parallel communication 5314 if(nproc > 1) then 5315 call xmpi_sum(onsite_bm,spaceComm,ierr) 5316 end if 5317 5318 !---------clean up memory------------------- 5319 5320 ABI_FREE(dimlmn) 5321 call pawcprj_free(cprj_k) 5322 ABI_FREE(cprj_k) 5323 5324 end subroutine make_onsite_bm
ABINIT/make_onsite_bm_k_n [ Functions ]
NAME
make_onsite_bm_k_n
FUNCTION
Compute A_0.A_N onsite term for magnetic field + nuclear magnetic dipole moment for k pt and 1 band
COPYRIGHT
Copyright (C) 2003-2021 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
1003 subroutine make_onsite_bm_k_n(cprj_k,dtset,iband,idir,nband_k,onsite_bm_k_n,& 1004 & pawang,pawrad,pawtab) 1005 1006 !Arguments ------------------------------------ 1007 !scalars 1008 integer,intent(in) :: idir,iband,nband_k 1009 complex(dpc),intent(out) :: onsite_bm_k_n 1010 type(pawang_type),intent(in) :: pawang 1011 type(dataset_type),intent(in) :: dtset 1012 1013 !arrays 1014 type(pawcprj_type),intent(in) :: cprj_k(dtset%natom,nband_k) 1015 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 1016 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 1017 1018 !Local variables ------------------------- 1019 !scalars 1020 integer :: gint,iatom,il,im,ilmn,itypat 1021 integer :: jl,jm,jlmn,klmn,klm,kln,lpmp,mesh_size 1022 real(dp) :: bm1,bm2,d00,d20,d22,dij,intg,scale_conversion 1023 complex(dpc) :: cpb,cpk 1024 1025 !arrays 1026 real(dp),allocatable :: ff(:) 1027 1028 ! *********************************************************************** 1029 1030 ! this term can only be non-zero if some nucdipmom is nonzero 1031 scale_conversion = half*FineStructureConstant2 1032 d00 = sqrt(4.0*pi)/3.0 1033 dij = sqrt(4.0*pi/15.0) 1034 d20 = sqrt(16.0*pi/5.0)/6.0 1035 d22 = sqrt(16.0*pi/15.0)/2.0 1036 onsite_bm_k_n = czero 1037 1038 do iatom=1,dtset%natom 1039 itypat=dtset%typat(iatom) 1040 mesh_size=pawtab(itypat)%mesh_size 1041 ABI_MALLOC(ff,(mesh_size)) 1042 do jlmn=1,pawtab(itypat)%lmn_size 1043 jl=pawtab(itypat)%indlmn(1,jlmn) 1044 jm=pawtab(itypat)%indlmn(2,jlmn) 1045 do ilmn=1,pawtab(itypat)%lmn_size 1046 il=pawtab(itypat)%indlmn(1,ilmn) 1047 im=pawtab(itypat)%indlmn(2,ilmn) 1048 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 1049 kln = pawtab(itypat)%indklmn(2,klmn) ! need this for mesh selection below 1050 klm = pawtab(itypat)%indklmn(1,klmn) ! need this for bm2 gaunt integral selection 1051 ! compute integral of (phi_i*phi_j - tphi_i*tphi_j)/r 1052 ff(2:mesh_size)=(pawtab(itypat)%phiphj(2:mesh_size,kln) - & 1053 & pawtab(itypat)%tphitphj(2:mesh_size,kln)) / & 1054 & pawrad(itypat)%rad(2:mesh_size) 1055 call pawrad_deducer0(ff,mesh_size,pawrad(itypat)) 1056 call simp_gen(intg,ff,pawrad(itypat)) 1057 ! term B.m r^2/r^3 1058 bm1=zero 1059 if ( (jl .EQ. il) .AND. (jm .EQ. im) .AND. (abs(dtset%nucdipmom(idir,iatom)) .GT. tol8) ) then 1060 bm1 = scale_conversion*dtset%nucdipmom(idir,iatom)*intg 1061 end if 1062 bm2 = zero 1063 ! xx, yy, zz cases all have the same contribution from S00 1064 lpmp=1 1065 gint = pawang%gntselect(lpmp,klm) 1066 if (gint > 0) then 1067 bm2=bm2+scale_conversion*dtset%nucdipmom(idir,iatom)*d00*pawang%realgnt(gint)*intg 1068 end if 1069 ! all other contributions involve Gaunt integrals of S_{2m} 1070 do lpmp = 5, 9 1071 gint = pawang%gntselect(lpmp,klm) 1072 if (gint > 0) then 1073 select case (lpmp) 1074 case (5) ! S_{2,-2} contributes to xy term 1075 select case (idir) 1076 case (1) 1077 bm2=bm2+scale_conversion*dtset%nucdipmom(2,iatom)*dij*pawang%realgnt(gint)*intg 1078 case (2) 1079 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*dij*pawang%realgnt(gint)*intg 1080 end select 1081 case (6) ! S_{2,-1} contributes to yz term 1082 select case (idir) 1083 case (2) 1084 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*dij*pawang%realgnt(gint)*intg 1085 case (3) 1086 bm2=bm2+scale_conversion*dtset%nucdipmom(2,iatom)*dij*pawang%realgnt(gint)*intg 1087 end select 1088 case (7) ! S_{2,0} contributes to xx, yy, and zz terms 1089 select case (idir) 1090 case (1) 1091 bm2=bm2-scale_conversion*dtset%nucdipmom(1,iatom)*d20*pawang%realgnt(gint)*intg 1092 case (2) 1093 bm2=bm2-scale_conversion*dtset%nucdipmom(2,iatom)*d20*pawang%realgnt(gint)*intg 1094 case (3) 1095 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*2.0*d20*pawang%realgnt(gint)*intg 1096 end select 1097 case (8) ! S_{2,+1} contributes to xz term 1098 select case (idir) 1099 case (1) 1100 bm2=bm2+scale_conversion*dtset%nucdipmom(3,iatom)*dij*pawang%realgnt(gint)*intg 1101 case (3) 1102 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*dij*pawang%realgnt(gint)*intg 1103 end select 1104 case (9) ! S_{2,2} contributes to xx, yy terms 1105 select case (idir) 1106 case (1) 1107 bm2=bm2+scale_conversion*dtset%nucdipmom(1,iatom)*d22*pawang%realgnt(gint)*intg 1108 case (2) 1109 bm2=bm2-scale_conversion*dtset%nucdipmom(2,iatom)*d22*pawang%realgnt(gint)*intg 1110 end select 1111 end select 1112 end if ! end check on nonzero gaunt integral 1113 end do ! end loop over lp,mp 1114 cpb=cmplx(cprj_k(iatom,iband)%cp(1,ilmn),cprj_k(iatom,iband)%cp(2,ilmn),KIND=dpc) 1115 cpk=cmplx(cprj_k(iatom,iband)%cp(1,jlmn),cprj_k(iatom,iband)%cp(2,jlmn),KIND=dpc) 1116 onsite_bm_k_n=onsite_bm_k_n+conjg(cpb)*(bm1-bm2)*cpk 1117 end do ! end loop over ilmn 1118 end do ! end loop over jlmn 1119 ABI_FREE(ff) 1120 end do ! end loop over atoms 1121 1122 end subroutine make_onsite_bm_k_n
ABINIT/make_onsite_l [ Functions ]
NAME
make_onsite_l
FUNCTION
Compute 1/2 <L_R> onsite contribution to orbital magnetization in direction idir
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
5048 subroutine make_onsite_l(atindx1,cprj,dtset,idir,mcprj,mpi_enreg,nband_k,onsite_l,pawrad,pawtab) 5049 5050 !Arguments ------------------------------------ 5051 !scalars 5052 integer,intent(in) :: idir,mcprj,nband_k 5053 type(MPI_type), intent(inout) :: mpi_enreg 5054 type(dataset_type),intent(in) :: dtset 5055 5056 !arrays 5057 integer,intent(in) :: atindx1(dtset%natom) 5058 complex(dpc),intent(out) :: onsite_l(nband_k) 5059 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 5060 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 5061 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 5062 5063 !Local variables ------------------------- 5064 !scalars 5065 integer :: icprj,ierr,ikpt,ikpt_loc,isppol,me,my_nspinor,ncpgr,nproc,spaceComm 5066 5067 !arrays 5068 integer :: nattyp_dum(dtset%ntypat) 5069 integer,allocatable :: dimlmn(:) 5070 complex(dpc),allocatable :: onsite_l_k(:) 5071 type(pawcprj_type),allocatable :: cprj_k(:,:) 5072 5073 ! *********************************************************************** 5074 5075 ! TODO: generalize to nsppol > 1 5076 isppol = 1 5077 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 5078 5079 !Init MPI 5080 spaceComm=mpi_enreg%comm_cell 5081 nproc=xmpi_comm_size(spaceComm) 5082 me = mpi_enreg%me_kpt 5083 5084 ncpgr = cprj(1,1)%ncpgr 5085 ABI_MALLOC(dimlmn,(dtset%natom)) 5086 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 5087 ABI_MALLOC(cprj_k,(dtset%natom,nband_k)) 5088 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 5089 5090 ! loop over kpts on each processor 5091 ABI_MALLOC(onsite_l_k,(nband_k)) 5092 onsite_l = czero 5093 ikpt_loc = 0 5094 ! loop over all the kpts 5095 do ikpt = 1, dtset%nkpt 5096 5097 ! if the current kpt is not on the current processor, cycle 5098 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 5099 5100 ikpt_loc = ikpt_loc + 1 5101 icprj= (ikpt_loc - 1)*nband_k 5102 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt_loc,0,isppol,dtset%mband,& 5103 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 5104 5105 call make_onsite_l_k(cprj_k,dtset,idir,nband_k,onsite_l_k,pawrad,pawtab) 5106 onsite_l(1:nband_k) = onsite_l(1:nband_k) + onsite_l_k(1:nband_k) 5107 5108 end do 5109 5110 ! ---- parallel communication 5111 if(nproc > 1) then 5112 call xmpi_sum(onsite_l,spaceComm,ierr) 5113 end if 5114 5115 !---------clean up memory------------------- 5116 5117 ABI_FREE(dimlmn) 5118 call pawcprj_free(cprj_k) 5119 ABI_FREE(cprj_k) 5120 ABI_FREE(onsite_l_k) 5121 5122 end subroutine make_onsite_l
ABINIT/make_onsite_l_k [ Functions ]
NAME
make_onsite_l_k
FUNCTION
Compute 1/2 <L_R> onsite contribution to orbital magnetization at given k point and idir
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
4958 subroutine make_onsite_l_k(cprj_k,dtset,idir,nband_k,onsite_l_k,pawrad,pawtab) 4959 4960 !Arguments ------------------------------------ 4961 !scalars 4962 integer,intent(in) :: idir,nband_k 4963 type(dataset_type),intent(in) :: dtset 4964 4965 !arrays 4966 complex(dpc),intent(out) :: onsite_l_k(nband_k) 4967 type(pawcprj_type),intent(in) :: cprj_k(dtset%natom,nband_k) 4968 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 4969 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 4970 4971 !Local variables ------------------------- 4972 !scalars 4973 integer :: iatom,ilmn,il,im,itypat,jlmn,jl,jm,klmn,kln,mesh_size,nn 4974 real(dp) :: intg 4975 complex(dpc) :: cpb,cpk,orbl_me 4976 4977 !arrays 4978 real(dp),allocatable :: ff(:) 4979 4980 !-------------------------------------------------------------------- 4981 4982 onsite_l_k = czero 4983 do iatom=1,dtset%natom 4984 itypat=dtset%typat(iatom) 4985 mesh_size=pawtab(itypat)%mesh_size 4986 ABI_MALLOC(ff,(mesh_size)) 4987 do jlmn=1,pawtab(itypat)%lmn_size 4988 jl=pawtab(itypat)%indlmn(1,jlmn) 4989 jm=pawtab(itypat)%indlmn(2,jlmn) 4990 do ilmn=1,pawtab(itypat)%lmn_size 4991 il=pawtab(itypat)%indlmn(1,ilmn) 4992 im=pawtab(itypat)%indlmn(2,ilmn) 4993 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 4994 kln = pawtab(itypat)%indklmn(2,klmn) ! need this for mesh selection below 4995 ! compute <L_dir> 4996 call slxyzs(il,im,idir,jl,jm,orbl_me) 4997 ! compute integral of phi_i*phi_j - tphi_i*tphi_j 4998 if (abs(orbl_me) > tol8) then 4999 ff(1:mesh_size)=pawtab(itypat)%phiphj(1:mesh_size,kln) - pawtab(itypat)%tphitphj(1:mesh_size,kln) 5000 call pawrad_deducer0(ff,mesh_size,pawrad(itypat)) 5001 call simp_gen(intg,ff,pawrad(itypat)) 5002 do nn = 1, nband_k 5003 cpb=cmplx(cprj_k(iatom,nn)%cp(1,ilmn),cprj_k(iatom,nn)%cp(2,ilmn),KIND=dpc) 5004 cpk=cmplx(cprj_k(iatom,nn)%cp(1,jlmn),cprj_k(iatom,nn)%cp(2,jlmn),KIND=dpc) 5005 onsite_l_k(nn)=onsite_l_k(nn)+conjg(cpb)*half*orbl_me*intg*cpk 5006 end do ! end loop over nn 5007 end if ! end check that |L_dir| > 0, otherwise ignore term 5008 end do ! end loop over ilmn 5009 end do ! end loop over jlmn 5010 ABI_FREE(ff) 5011 end do ! end loop over atoms 5012 5013 end subroutine make_onsite_l_k
ABINIT/make_onsite_l_k_n [ Functions ]
NAME
make_onsite_l_k_n
FUNCTION
Compute 1/2 <L_R> onsite contribution to orbital magnetization at given k point, band, and idir
COPYRIGHT
Copyright (C) 2003-2021 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
914 subroutine make_onsite_l_k_n(cprj_k,dtset,iband,idir,nband_k,onsite_l_k_n,pawrad,pawtab) 915 916 !Arguments ------------------------------------ 917 !scalars 918 integer,intent(in) :: iband,idir,nband_k 919 complex(dpc),intent(out) :: onsite_l_k_n 920 type(dataset_type),intent(in) :: dtset 921 922 !arrays 923 type(pawcprj_type),intent(in) :: cprj_k(dtset%natom,nband_k) 924 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 925 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 926 927 !Local variables ------------------------- 928 !scalars 929 integer :: iatom,ilmn,il,im,itypat,jlmn,jl,jm,klmn,kln,mesh_size 930 real(dp) :: intg 931 complex(dpc) :: cpb,cpk,orbl_me 932 933 !arrays 934 real(dp),allocatable :: ff(:) 935 936 !-------------------------------------------------------------------- 937 938 onsite_l_k_n = czero 939 do iatom=1,dtset%natom 940 itypat=dtset%typat(iatom) 941 mesh_size=pawtab(itypat)%mesh_size 942 ABI_MALLOC(ff,(mesh_size)) 943 do jlmn=1,pawtab(itypat)%lmn_size 944 jl=pawtab(itypat)%indlmn(1,jlmn) 945 jm=pawtab(itypat)%indlmn(2,jlmn) 946 do ilmn=1,pawtab(itypat)%lmn_size 947 il=pawtab(itypat)%indlmn(1,ilmn) 948 im=pawtab(itypat)%indlmn(2,ilmn) 949 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 950 kln = pawtab(itypat)%indklmn(2,klmn) ! need this for mesh selection below 951 ! compute <L_dir> 952 call slxyzs(il,im,idir,jl,jm,orbl_me) 953 ! compute integral of phi_i*phi_j - tphi_i*tphi_j 954 if (abs(orbl_me) > tol8) then 955 ff(1:mesh_size)=pawtab(itypat)%phiphj(1:mesh_size,kln) - pawtab(itypat)%tphitphj(1:mesh_size,kln) 956 call pawrad_deducer0(ff,mesh_size,pawrad(itypat)) 957 call simp_gen(intg,ff,pawrad(itypat)) 958 cpb=cmplx(cprj_k(iatom,iband)%cp(1,ilmn),cprj_k(iatom,iband)%cp(2,ilmn),KIND=dpc) 959 cpk=cmplx(cprj_k(iatom,iband)%cp(1,jlmn),cprj_k(iatom,iband)%cp(2,jlmn),KIND=dpc) 960 onsite_l_k_n=onsite_l_k_n+conjg(cpb)*half*orbl_me*intg*cpk 961 end if ! end check that |L_dir| > 0, otherwise ignore term 962 end do ! end loop over ilmn 963 end do ! end loop over jlmn 964 ABI_FREE(ff) 965 end do ! end loop over atoms 966 967 end subroutine make_onsite_l_k_n
ABINIT/make_rhorij1 [ Functions ]
NAME
make_rhorij1
FUNCTION
Compute Trace[\rho_0 \rho_Rij(1) ] in orbital magnetism context
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
5359 subroutine make_rhorij1(adir,atindx1,cprj,dtset,mcprj,mpi_enreg,& 5360 & nattyp,nband_k,paw_ij,pawtab,rhorij1) 5361 5362 !Arguments ------------------------------------ 5363 !scalars 5364 integer,intent(in) :: adir,mcprj,nband_k 5365 type(MPI_type), intent(inout) :: mpi_enreg 5366 type(dataset_type),intent(in) :: dtset 5367 5368 !arrays 5369 integer,intent(in) :: atindx1(dtset%natom),nattyp(dtset%ntypat) 5370 complex(dpc),intent(out) :: rhorij1(nband_k) 5371 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 5372 type(paw_ij_type),intent(in) :: paw_ij(dtset%natom) 5373 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 5374 5375 !Local variables ------------------------- 5376 !scalars 5377 integer :: bdir,icprj,epsabg,gdir,iatom,ierr,ikpt,ilmn,isppol,itypat 5378 integer :: jlmn,klmn,me,my_nspinor,ncpgr,nn,nproc,spaceComm 5379 complex(dpc) :: cpb,cdij,cpk 5380 5381 !arrays 5382 integer,allocatable :: dimlmn(:) 5383 type(pawcprj_type),allocatable :: cprj_k(:,:) 5384 5385 !---------------------------------------------------------------- 5386 5387 !Init MPI 5388 spaceComm=mpi_enreg%comm_cell 5389 nproc=xmpi_comm_size(spaceComm) 5390 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 5391 me = mpi_enreg%me_kpt 5392 5393 isppol = 1 5394 ncpgr = cprj(1,1)%ncpgr 5395 ABI_MALLOC(dimlmn,(dtset%natom)) 5396 call pawcprj_getdim(dimlmn,dtset%natom,nattyp,dtset%ntypat,dtset%typat,pawtab,'R') 5397 ABI_MALLOC(cprj_k,(dtset%natom,nband_k)) 5398 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 5399 5400 rhorij1 = czero 5401 icprj = 0 5402 do ikpt = 1, dtset%nkpt 5403 5404 ! if the current kpt is not on the current processor, cycle 5405 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 5406 5407 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt,0,isppol,dtset%mband,& 5408 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 5409 5410 do epsabg = 1, -1, -2 5411 5412 if (epsabg .EQ. 1) then 5413 bdir = modulo(adir,3)+1 5414 gdir = modulo(adir+1,3)+1 5415 else 5416 bdir = modulo(adir+1,3)+1 5417 gdir = modulo(adir,3)+1 5418 end if 5419 5420 do nn = 1, nband_k 5421 do iatom=1,dtset%natom 5422 itypat=dtset%typat(iatom) 5423 do ilmn=1,pawtab(itypat)%lmn_size 5424 do jlmn=1,pawtab(itypat)%lmn_size 5425 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 5426 cpb=cmplx(cprj_k(iatom,nn)%dcp(1,bdir,ilmn),cprj_k(iatom,nn)%dcp(2,bdir,ilmn),KIND=dpc) 5427 cpk=cmplx(cprj_k(iatom,nn)%dcp(1,gdir,jlmn),cprj_k(iatom,nn)%dcp(2,gdir,jlmn),KIND=dpc) 5428 if (paw_ij(iatom)%cplex_dij .EQ. 2) then 5429 cdij=cmplx(paw_ij(iatom)%dij(2*klmn-1,1),paw_ij(iatom)%dij(2*klmn,1),KIND=dpc) 5430 if (jlmn .GT. ilmn) cdij=conjg(cdij) 5431 else 5432 cdij=cmplx(paw_ij(iatom)%dij(klmn,1),zero,KIND=dpc) 5433 end if 5434 rhorij1(nn)=rhorij1(nn)-half*j_dpc*epsabg*conjg(cpb)*cdij*cpk 5435 end do ! end loop over jlmn 5436 end do ! end loop over ilmn 5437 end do ! end loop over atoms 5438 end do ! end loop over bands 5439 end do ! end loop over epsabg 5440 5441 icprj = icprj + nband_k 5442 5443 end do ! end loop over kpt 5444 5445 ! ---- parallel communication 5446 if(nproc > 1) then 5447 call xmpi_sum(rhorij1,spaceComm,ierr) 5448 end if 5449 5450 ABI_FREE(dimlmn) 5451 call pawcprj_free(cprj_k) 5452 ABI_FREE(cprj_k) 5453 5454 end subroutine make_rhorij1
ABINIT/make_rhorij1_k_n [ Functions ]
NAME
make_rhorij1_k_n
FUNCTION
Compute Trace[\rho^0_k \rho_Rij(1)_k ] in orbital magnetism context
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
1238 subroutine make_rhorij1_k_n(adir,cprj_k,dtset,iband,nband_occ,& 1239 & paw_ij,pawtab,rhorij1) 1240 1241 !Arguments ------------------------------------ 1242 !scalars 1243 integer,intent(in) :: adir,iband,nband_occ 1244 complex(dpc),intent(out) :: rhorij1 1245 type(dataset_type),intent(in) :: dtset 1246 1247 !arrays 1248 type(pawcprj_type),intent(in) :: cprj_k(dtset%natom,nband_occ) 1249 type(paw_ij_type),intent(in) :: paw_ij(dtset%natom) 1250 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 1251 1252 !Local variables ------------------------- 1253 !scalars 1254 integer :: bdir,epsabg,gdir,iatom,ilmn,itypat,jlmn,klmn 1255 complex(dpc) :: cpb,cdij,cpk 1256 1257 !---------------------------------------------------------------- 1258 1259 rhorij1 = czero 1260 1261 do epsabg = 1, -1, -2 1262 1263 if (epsabg .EQ. 1) then 1264 bdir = modulo(adir,3)+1 1265 gdir = modulo(adir+1,3)+1 1266 else 1267 bdir = modulo(adir+1,3)+1 1268 gdir = modulo(adir,3)+1 1269 end if 1270 1271 do iatom=1,dtset%natom 1272 itypat=dtset%typat(iatom) 1273 do ilmn=1,pawtab(itypat)%lmn_size 1274 do jlmn=1,pawtab(itypat)%lmn_size 1275 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 1276 cpb=cmplx(cprj_k(iatom,iband)%dcp(1,bdir,ilmn),cprj_k(iatom,iband)%dcp(2,bdir,ilmn),KIND=dpc) 1277 cpk=cmplx(cprj_k(iatom,iband)%dcp(1,gdir,jlmn),cprj_k(iatom,iband)%dcp(2,gdir,jlmn),KIND=dpc) 1278 if (paw_ij(iatom)%cplex_dij .EQ. 2) then 1279 cdij=cmplx(paw_ij(iatom)%dij(2*klmn-1,1),paw_ij(iatom)%dij(2*klmn,1),KIND=dpc) 1280 if (jlmn .GT. ilmn) cdij=conjg(cdij) 1281 else 1282 cdij=cmplx(paw_ij(iatom)%dij(klmn,1),zero,KIND=dpc) 1283 end if 1284 rhorij1=rhorij1-half*j_dpc*epsabg*conjg(cpb)*cdij*cpk 1285 end do ! end loop over jlmn 1286 end do ! end loop over ilmn 1287 end do ! end loop over atoms 1288 end do ! end loop over epsabg 1289 1290 end subroutine make_rhorij1_k_n
ABINIT/make_S1trace [ Functions ]
NAME
make_S1trace
FUNCTION
Compute Trace[\rho_0 S^{(1)} \rho_0] in orbital magnetism context
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
4832 subroutine make_S1trace(adir,atindx1,cprj,dtset,eeig,& 4833 & mcprj,mpi_enreg,nattyp,nband_k,pawtab,S1trace) 4834 4835 !Arguments ------------------------------------ 4836 !scalars 4837 integer,intent(in) :: adir,mcprj,nband_k 4838 type(MPI_type), intent(inout) :: mpi_enreg 4839 type(dataset_type),intent(in) :: dtset 4840 4841 !arrays 4842 integer,intent(in) :: atindx1(dtset%natom),nattyp(dtset%ntypat) 4843 real(dp),intent(in) :: eeig(nband_k,dtset%nkpt) 4844 complex(dpc),intent(out) :: S1trace(nband_k) 4845 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 4846 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 4847 4848 !Local variables ------------------------- 4849 !scalars 4850 integer :: bdir,icprj,epsabg,gdir,iatom,ierr,ikpt,ilmn,isppol,itypat 4851 integer :: jlmn,klmn,me,my_nspinor,ncpgr,nn,nproc,spaceComm 4852 real(dp) :: ENK 4853 complex(dpc) :: cpb,cpk 4854 4855 !arrays 4856 integer,allocatable :: dimlmn(:) 4857 type(pawcprj_type),allocatable :: cprj_k(:,:) 4858 4859 !---------------------------------------------------------------- 4860 4861 !Init MPI 4862 spaceComm=mpi_enreg%comm_cell 4863 nproc=xmpi_comm_size(spaceComm) 4864 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 4865 me = mpi_enreg%me_kpt 4866 4867 isppol = 1 4868 ncpgr = cprj(1,1)%ncpgr 4869 ABI_MALLOC(dimlmn,(dtset%natom)) 4870 call pawcprj_getdim(dimlmn,dtset%natom,nattyp,dtset%ntypat,dtset%typat,pawtab,'R') 4871 ABI_MALLOC(cprj_k,(dtset%natom,nband_k)) 4872 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 4873 4874 S1trace = czero 4875 icprj = 0 4876 do ikpt = 1, dtset%nkpt 4877 4878 ! if the current kpt is not on the current processor, cycle 4879 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 4880 4881 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt,0,isppol,dtset%mband,& 4882 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 4883 4884 do epsabg = 1, -1, -2 4885 4886 if (epsabg .EQ. 1) then 4887 bdir = modulo(adir,3)+1 4888 gdir = modulo(adir+1,3)+1 4889 else 4890 bdir = modulo(adir+1,3)+1 4891 gdir = modulo(adir,3)+1 4892 end if 4893 4894 do nn = 1, nband_k 4895 ENK = eeig(nn,ikpt) 4896 do iatom=1,dtset%natom 4897 itypat=dtset%typat(iatom) 4898 do ilmn=1,pawtab(itypat)%lmn_size 4899 do jlmn=1,pawtab(itypat)%lmn_size 4900 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 4901 cpb=cmplx(cprj_k(iatom,nn)%dcp(1,bdir,ilmn),cprj_k(iatom,nn)%dcp(2,bdir,ilmn),KIND=dpc) 4902 cpk=cmplx(cprj_k(iatom,nn)%dcp(1,gdir,jlmn),cprj_k(iatom,nn)%dcp(2,gdir,jlmn),KIND=dpc) 4903 S1trace(nn)=S1trace(nn)+half*j_dpc*epsabg*ENK*conjg(cpb)*pawtab(itypat)%sij(klmn)*cpk 4904 end do ! end loop over jlmn 4905 end do ! end loop over ilmn 4906 end do ! end loop over atoms 4907 end do ! end loop over bands 4908 end do ! end loop over epsabg 4909 4910 icprj = icprj + nband_k 4911 4912 end do ! end loop over kpt 4913 4914 ! ---- parallel communication 4915 if(nproc > 1) then 4916 call xmpi_sum(S1trace,spaceComm,ierr) 4917 end if 4918 4919 ABI_FREE(dimlmn) 4920 call pawcprj_free(cprj_k) 4921 ABI_FREE(cprj_k) 4922 4923 end subroutine make_S1trace
ABINIT/make_S1trace_k_n [ Functions ]
NAME
make_S1trace_k_n
FUNCTION
Compute single band contribution to Trace[\rho^0_k S_k^{(1)} ] in orbital magnetism context
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
1158 subroutine make_S1trace_k_n(adir,cprj_k,dtset,ENK,iband,nband_occ,pawtab,S1trace) 1159 1160 !Arguments ------------------------------------ 1161 !scalars 1162 integer,intent(in) :: adir,iband,nband_occ 1163 real(dp),intent(in) :: ENK 1164 complex(dpc),intent(out) :: S1trace 1165 type(dataset_type),intent(in) :: dtset 1166 1167 !arrays 1168 type(pawcprj_type),intent(in) :: cprj_k(dtset%natom,nband_occ) 1169 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 1170 1171 !Local variables ------------------------- 1172 !scalars 1173 integer :: bdir,epsabg,gdir,iatom,ilmn,itypat,jlmn,klmn 1174 complex(dpc) :: cpb,cpk 1175 1176 !---------------------------------------------------------------- 1177 1178 S1trace = czero 1179 1180 do epsabg = 1, -1, -2 1181 1182 if (epsabg .EQ. 1) then 1183 bdir = modulo(adir,3)+1 1184 gdir = modulo(adir+1,3)+1 1185 else 1186 bdir = modulo(adir+1,3)+1 1187 gdir = modulo(adir,3)+1 1188 end if 1189 1190 do iatom=1,dtset%natom 1191 itypat=dtset%typat(iatom) 1192 do ilmn=1,pawtab(itypat)%lmn_size 1193 do jlmn=1,pawtab(itypat)%lmn_size 1194 klmn=max(jlmn,ilmn)*(max(jlmn,ilmn)-1)/2 + min(jlmn,ilmn) 1195 cpb=cmplx(cprj_k(iatom,iband)%dcp(1,bdir,ilmn),cprj_k(iatom,iband)%dcp(2,bdir,ilmn),KIND=dpc) 1196 cpk=cmplx(cprj_k(iatom,iband)%dcp(1,gdir,jlmn),cprj_k(iatom,iband)%dcp(2,gdir,jlmn),KIND=dpc) 1197 S1trace=S1trace-half*j_dpc*epsabg*ENK*conjg(cpb)*pawtab(itypat)%sij(klmn)*cpk 1198 end do ! end loop over jlmn 1199 end do ! end loop over ilmn 1200 end do ! end loop over atoms 1201 end do ! end loop over epsabg 1202 1203 end subroutine make_S1trace_k_n
ABINIT/mpicomm_helper [ Functions ]
NAME
mpicomm_helper
FUNCTION
get wavefunction and cprj in mpi communication loop
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
3359 subroutine mpicomm_helper(atindx1,bdir,bfor,cg,cgqb,cprj,cprj_kb,dimlmn,dtorbmag,dtset,& 3360 & ikpt,ikpt_loc,ikptbi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 3361 & nproc,npw_kb,npwarr,spaceComm) 3362 3363 !Arguments ------------------------------------ 3364 !scalars 3365 integer,intent(in) :: bdir,bfor,ikpt,ikpt_loc,ikptbi,isppol,mcg,mcprj,me,my_nspinor 3366 integer,intent(in) :: nband_k,nproc,npw_kb,spaceComm 3367 type(dataset_type),intent(in) :: dtset 3368 type(MPI_type), intent(inout) :: mpi_enreg 3369 type(orbmag_type), intent(inout) :: dtorbmag 3370 3371 !arrays 3372 integer,intent(in) :: atindx1(dtset%natom),dimlmn(dtset%natom),npwarr(dtset%nkpt) 3373 real(dp),intent(in) :: cg(2,mcg) 3374 real(dp),intent(out) :: cgqb(2,npw_kb*my_nspinor*nband_k) 3375 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 3376 type(pawcprj_type),intent(inout) :: cprj_kb(dtset%natom,nband_k) 3377 3378 !Local variables ------------------------- 3379 !scalars 3380 integer :: countb,countjb,dest,icgb,icprjbi,ierr 3381 integer :: jcgb,jcprjbi,jkpt,jkptb,jkptbi,jsppol,n2dim,ncpgr,sourceb,tagb 3382 3383 !arrays 3384 real(dp),allocatable :: buffer(:,:) 3385 type(pawcprj_type),allocatable :: cprj_buf(:,:) 3386 3387 !---------------------------------------------------- 3388 3389 n2dim = dtorbmag%nspinor*nband_k 3390 ncpgr = cprj(1,1)%ncpgr 3391 if (nproc>1) then 3392 ABI_MALLOC(cprj_buf,(dtset%natom,n2dim)) 3393 call pawcprj_alloc(cprj_buf,ncpgr,dimlmn) 3394 end if 3395 3396 if (ikpt > 0 .and. isppol > 0) then ! I currently have a true kpt to use 3397 countb = npw_kb*my_nspinor*nband_k 3398 cgqb = zero 3399 sourceb = me 3400 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikptbi,1,nband_k,isppol,me)) then 3401 ! I need the data from someone else 3402 sourceb = mpi_enreg%proc_distrb(ikptbi,1,isppol) 3403 end if 3404 else 3405 sourceb = -1 ! I do not have a kpt to use 3406 end if 3407 3408 do dest=0,nproc-1 3409 if ((dest.EQ.me) .AND. (ikpt.GT.0) .AND. (isppol.GT.0)) then 3410 ! I am destination and I have something to do 3411 if(sourceb.EQ.me) then 3412 ! I am destination and source for kptb 3413 icprjbi = dtorbmag%cprjindex(ikptbi,isppol) 3414 icgb = dtorbmag%cgindex(ikptbi,dtset%nsppol) 3415 call pawcprj_get(atindx1,cprj_kb,cprj,dtset%natom,1,icprjbi,& 3416 & ikptbi,0,isppol,dtset%mband,dtset%mkmem,dtset%natom,nband_k,nband_k,& 3417 & my_nspinor,dtset%nsppol,0) 3418 cgqb(1:2,1:countb) = cg(1:2,icgb+1:icgb+countb) 3419 else ! sourceb .NE. me 3420 ! receive cgqb and cprj_kb 3421 tagb = ikptbi + (isppol - 1)*dtset%nkpt 3422 call xmpi_recv(cgqb,sourceb,tagb,spaceComm,ierr) 3423 call pawcprj_mpi_recv(dtset%natom,n2dim,dimlmn,ncpgr,cprj_kb,sourceb,spaceComm,ierr) 3424 end if 3425 else if (dest.NE.me) then 3426 ! jkpt is the kpt which is being treated by dest 3427 ! jsppol is his isppol 3428 jkpt = mpi_enreg%kpt_loc2fbz_sp(dest, ikpt_loc,1) 3429 jsppol = mpi_enreg%kpt_loc2fbz_sp(dest, ikpt_loc,2) 3430 if (jkpt > 0 .and. jsppol > 0) then ! dest is treating a true kpt 3431 3432 jkptb = dtorbmag%ikpt_dk(jkpt,bfor,bdir) 3433 jkptbi = dtorbmag%indkk_f2ibz(jkptb,1) 3434 3435 if((mpi_enreg%proc_distrb(jkptbi,1,jsppol) == me)) then 3436 jcgb = dtorbmag%cgindex(jkptbi,jsppol) 3437 jcprjbi=dtorbmag%cprjindex(jkptbi,jsppol) 3438 call pawcprj_get(atindx1,cprj_buf,cprj,dtset%natom,1,jcprjbi,jkptbi,0,jsppol,& 3439 & dtset%mband,dtset%mkmem,dtset%natom,dtorbmag%mband_occ,dtorbmag%mband_occ,& 3440 & my_nspinor,dtset%nsppol,0,mpicomm=mpi_enreg%comm_kpt,& 3441 & proc_distrb=mpi_enreg%proc_distrb) 3442 tagb = jkptbi + (jsppol - 1)*dtset%nkpt 3443 countjb = npwarr(jkptbi)*my_nspinor*nband_k 3444 ABI_MALLOC(buffer,(2,countjb)) 3445 buffer(:,1:countjb) = cg(:,jcgb+1:jcgb+countjb) 3446 call xmpi_send(buffer,dest,tagb,spaceComm,ierr) 3447 ABI_FREE(buffer) 3448 call pawcprj_mpi_send(dtset%natom,n2dim,dimlmn,ncpgr,cprj_buf,dest,spaceComm,ierr) 3449 end if ! end check that I am his source 3450 3451 end if ! end check that jkpt > 0 and jsppol > 0 3452 3453 end if ! test dest .EQ. me and ikpt .GT. 0 3454 3455 end do ! end loop over dest 3456 3457 if (nproc>1) then 3458 call pawcprj_free(cprj_buf) 3459 ABI_FREE(cprj_buf) 3460 end if 3461 3462 end subroutine mpicomm_helper
ABINIT/orbmag_ddk [ Functions ]
NAME
orbmag_ddk
FUNCTION
This routine computes the orbital magnetization and Berry curvature based on input wavefunctions and DDK wavefuntions. It is assumed that only completely filled bands are present.
COPYRIGHT
Copyright (C) 2003-2021 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
See Ceresoli et al, PRB 74, 024408 (2006) [[cite:Ceresoli2006]], and Gonze and Zwanziger, PRB 84, 064445 (2011) [[cite:Gonze2011a]]. DDK wavefunctions are used for the derivatives.
PARENTS
m_dfpt_looppert
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
1330 subroutine orbmag_ddk(atindx1,cg,cg1,dtset,gsqcut,kg,mcg,mcg1,mpi_enreg,& 1331 & nattyp,nfftf,ngfftf,npwarr,paw_ij,pawang,pawfgr,pawrad,pawtab,psps,rprimd,vtrial,& 1332 & xred,ylm,ylmgr) 1333 1334 !Arguments ------------------------------------ 1335 !scalars 1336 integer,intent(in) :: mcg,mcg1,nfftf 1337 real(dp),intent(in) :: gsqcut 1338 type(dataset_type),intent(in) :: dtset 1339 type(MPI_type), intent(inout) :: mpi_enreg 1340 type(pawang_type),intent(in) :: pawang 1341 type(pawfgr_type),intent(in) :: pawfgr 1342 type(pseudopotential_type), intent(inout) :: psps 1343 1344 !arrays 1345 integer,intent(in) :: atindx1(dtset%natom),kg(3,dtset%mpw*dtset%mkmem) 1346 integer,intent(in) :: nattyp(dtset%natom),ngfftf(18),npwarr(dtset%nkpt) 1347 real(dp),intent(in) :: cg(2,mcg),cg1(2,mcg1,3),rprimd(3,3),xred(3,dtset%natom) 1348 real(dp),intent(inout) :: vtrial(nfftf,dtset%nspden) 1349 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 1350 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 1351 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 1352 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat*psps%usepaw) 1353 type(pawtab_type),intent(inout) :: pawtab(psps%ntypat*psps%usepaw) 1354 1355 !Local 1356 !scalars 1357 integer :: adir,bdir,buff_size,dimffnl,exchn2n3d,getcprj_choice,getcprj_cpopt 1358 integer :: getghc_cpopt,getghc_prtvol,getghc_sij_opt,getghc_tim,getghc_type_calc 1359 integer :: gdir,iatom,icg,ider,idir,ierr,ikg,ikg1,ikpt,ilm,isppol,istwf_k 1360 integer :: me,mcgk,my_nspinor,nband_k,ncpgr,ndat,ngfft1,ngfft2,ngfft3,ngfft4 1361 integer :: ngfft5,ngfft6,nn,nnp,nkpg,npw_k 1362 integer :: nonlop_choice,nonlop_cpopt,nonlop_nnlout,nonlop_pawopt,nonlop_signs,nonlop_tim 1363 integer :: nproc,nterms,projbd_scprod_io,projbd_tim,projbd_useoverlap,spaceComm,with_vectornd 1364 integer,parameter :: cci=1,vvii=2,vvia=3,vvib=4,rho0h1=5,rho0s1=6,lrb=7,a0an=8,berrycurve=9 1365 real(dp) :: arg,dbi,dbr,dgi,dgr,doti,dub_dsg_i,dug_dsb_i 1366 real(dp) :: ecut_eff,Enk,lambda,local_fermie,trnrm,ucvol 1367 complex(dpc) :: dbc,dgc,onsite_bm_k_n,onsite_l_k_n,rhorij1,S1trace 1368 logical :: has_nucdip 1369 type(gs_hamiltonian_type) :: gs_hamk 1370 1371 !arrays 1372 integer,allocatable :: dimlmn(:),kg_k(:,:),nattyp_dum(:) 1373 real(dp) :: gmet(3,3),gprimd(3,3),kpoint(3),lambda_ndat(1),nonlop_enlout(1),rhodum(1),rmet(3,3) 1374 real(dp),allocatable :: buffer1(:),buffer2(:) 1375 real(dp),allocatable :: cg_k(:,:),cg1_k(:,:,:),cgrvtrial(:,:),cwaveb1(:,:),cwavef(:,:),cwavefp(:,:),cwaveg1(:,:) 1376 real(dp),allocatable :: cwavedsdb(:,:),cwavedsdg(:,:) 1377 real(dp),allocatable :: dscg_k(:,:,:),ffnl_k(:,:,:,:),ghc(:,:),gsc(:,:),gvnlc(:,:) 1378 real(dp),allocatable :: kinpw(:),kpg_k(:,:),orbmag_terms(:,:,:),orbmag_trace(:,:) 1379 real(dp),allocatable :: pcg1_k(:,:,:),ph1d(:,:),ph3d(:,:,:),phkxred(:,:),scg_k(:,:),scg1_k(:,:,:),scprod(:,:) 1380 real(dp),allocatable :: vectornd(:,:),vectornd_pac(:,:,:,:,:),vlocal(:,:,:,:) 1381 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 1382 type(pawcprj_type),allocatable :: cprj_k(:,:),cwaveprj(:,:) 1383 1384 !---------------------------------------------- 1385 1386 ! set up basic FFT parameters 1387 ! TODO: generalize to nsppol > 1 1388 isppol = 1 1389 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 1390 nband_k = dtset%mband 1391 istwf_k = 1 1392 spaceComm=mpi_enreg%comm_cell 1393 nproc=xmpi_comm_size(spaceComm) 1394 me = mpi_enreg%me_kpt 1395 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 1396 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 1397 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 1398 exchn2n3d = 0; ikg1 = 0 1399 1400 ! input parameters for calls to nonlop 1401 ! nonlop_choice will be changed from call to call 1402 nonlop_cpopt = -1 ! cprj computed and not saved 1403 nonlop_pawopt = 3 ! apply only S 1404 nonlop_signs = 2 ! get <G|Op|C> vector 1405 nonlop_nnlout = 1 1406 nonlop_tim = 0 1407 1408 ! input parameters to projbd 1409 projbd_scprod_io = 0 1410 projbd_useoverlap = 1 1411 projbd_tim = 0 1412 1413 ! input parameters for calls to getghc at ikpt 1414 getghc_cpopt = -1 ! cprj computed and not saved 1415 getghc_sij_opt = 1 ! compute both H|C> and S|C> 1416 ndat = 1 ! number of fft's in parallel 1417 getghc_prtvol = 0 1418 getghc_type_calc = 0 ! type_calc 0 means kinetic, local, nonlocal 1419 getghc_tim = 0 1420 lambda = zero 1421 lambda_ndat = zero 1422 1423 call metric(gmet,gprimd,-1,rmet,rprimd,ucvol) 1424 1425 ncpgr = 3 1426 ABI_MALLOC(dimlmn,(dtset%natom)) 1427 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 1428 ABI_MALLOC(cprj_k,(dtset%natom,dtset%mband)) 1429 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 1430 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 1431 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 1432 1433 !==== Initialize most of the Hamiltonian ==== 1434 !Allocate all arrays and initialize quantities that do not depend on k and spin. 1435 !gs_hamk is the normal hamiltonian at k 1436 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 1437 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 1438 & paw_ij=paw_ij) 1439 1440 !========= construct local potential ================== 1441 ! nspden=1 is essentially hard-coded in the following line 1442 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 1443 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vtrial) 1444 ABI_MALLOC(vlocal,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc)) 1445 call fftpac(isppol,mpi_enreg,dtset%nspden,& 1446 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vlocal,2) 1447 ABI_FREE(cgrvtrial) 1448 call gs_hamk%load_spin(isppol,vlocal=vlocal,with_nonlocal=.true.) 1449 1450 !======== compute nuclear dipole vector potential (may be zero) ========== 1451 with_vectornd=0 1452 has_nucdip = ANY( ABS(dtset%nucdipmom) .GT. tol8 ) 1453 if (has_nucdip) with_vectornd=1 1454 ABI_MALLOC(vectornd,(with_vectornd*nfftf,3)) 1455 vectornd = zero 1456 if(has_nucdip) then 1457 call make_vectornd(1,gsqcut,psps%usepaw,mpi_enreg,dtset%natom,nfftf,ngfftf,& 1458 & dtset%nucdipmom,rprimd,vectornd,xred) 1459 ABI_MALLOC(vectornd_pac,(ngfft4,ngfft5,ngfft6,gs_hamk%nvloc,3)) 1460 ABI_MALLOC(cgrvtrial,(dtset%nfft,dtset%nspden)) 1461 do idir = 1, 3 1462 call transgrid(1,mpi_enreg,dtset%nspden,-1,0,0,dtset%paral_kgb,pawfgr,rhodum,rhodum,cgrvtrial,vectornd(:,idir)) 1463 call fftpac(isppol,mpi_enreg,dtset%nspden,& 1464 & ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6,dtset%ngfft,cgrvtrial,vectornd_pac(:,:,:,1,idir),2) 1465 end do 1466 ABI_FREE(cgrvtrial) 1467 call gs_hamk%load_spin(isppol,vectornd=vectornd_pac) 1468 end if 1469 1470 ABI_MALLOC(kg_k,(3,dtset%mpw)) 1471 ABI_MALLOC(kinpw,(dtset%mpw)) 1472 1473 ABI_MALLOC(ph1d,(2,dtset%natom*(2*(ngfft1+ngfft2+ngfft3)+3))) 1474 call getph(atindx1,dtset%natom,ngfft1,ngfft2,ngfft3,ph1d,xred) 1475 1476 icg = 0 1477 ikg = 0 1478 nterms = 9 ! various contributing terms in orbmag and berrycurve 1479 ! 1 orbmag CC 1480 ! 2 orbmag VV II 1481 ! 3 orbmag VV I+III part a 1482 ! 4 orbmag VV I+III part b 1483 ! 5 orbmag Tr[\rho^0 H^1] with D^0_ij part 1484 ! 6 orbmag -Tr[\rho^0 S^1] part 1485 ! 7 orbmag onsite L_R/r^3 1486 ! 8 orbmag onsite A0.An 1487 ! 9 berrycurve 1488 ABI_MALLOC(orbmag_terms,(3,nterms,nband_k)) 1489 orbmag_terms = zero 1490 local_fermie = -1.0D10 1491 1492 !============= BIG FAT KPT LOOP :) =========================== 1493 do ikpt = 1, dtset%nkpt 1494 1495 ! if the current kpt is not on the current processor, cycle 1496 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 1497 1498 ! trace norm: assume occupation of two for each band and weight by kpts 1499 trnrm = two*dtset%wtk(ikpt) 1500 1501 kpoint(:)=dtset%kptns(:,ikpt) 1502 npw_k = npwarr(ikpt) 1503 1504 ! retrieve kg_k at this k point 1505 kg_k(1:3,1:npw_k) = kg(1:3,ikg+1:ikg+npw_k) 1506 1507 ! retrieve ylm at this k point 1508 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 1509 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 1510 do ilm=1,psps%mpsang*psps%mpsang 1511 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 1512 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 1513 end do 1514 1515 ! Compute kinetic energy at kpt 1516 kinpw(:) = zero 1517 call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg_k,kinpw,kpoint,npw_k,0,0) 1518 1519 ! Compute k+G at this k point 1520 nkpg = 3 1521 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 1522 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 1523 1524 ! Make 3d phase factors 1525 ABI_MALLOC(phkxred,(2,dtset%natom)) 1526 do iatom=1, dtset%natom 1527 arg=two_pi*DOT_PRODUCT(kpoint,xred(:,iatom)) 1528 phkxred(1,iatom)=cos(arg);phkxred(2,iatom)=sin(arg) 1529 end do 1530 ABI_MALLOC(ph3d,(2,npw_k,dtset%natom)) 1531 call ph1d3d(1,dtset%natom,kg_k,dtset%natom,dtset%natom,& 1532 & npw_k,ngfft1,ngfft2,ngfft3,phkxred,ph1d,ph3d) 1533 1534 ! Compute nonlocal form factors ffnl at all (k+G): 1535 ider=1 ! ffnl and 1st derivatives 1536 idir=4 ! ignored when ider = 0; idir=0 means d ffnl/ dk in reduced units referenced 1537 ! to reciprocal translations 1538 ! idir=4 meand d ffnl / dk in reduced units referenced to real space 1539 ! translations. rfddk = 1 wavefunctions are computed using this convention. 1540 dimffnl=4 ! 1 + number of derivatives 1541 ABI_MALLOC(ffnl_k,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 1542 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl_k,psps%ffspl,& 1543 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 1544 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 1545 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 1546 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 1547 1548 ! - Load k-dependent quantities in the Hamiltonian 1549 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 1550 & kinpw_k=kinpw,kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,ph3d_k=ph3d,& 1551 & compute_gbound=.TRUE.) 1552 1553 ! retrieve ground state wavefunctions at this k point 1554 mcgk = npw_k*nband_k 1555 ABI_MALLOC(cg_k,(2,mcgk)) 1556 cg_k = cg(1:2,icg+1:icg+mcgk) 1557 ABI_MALLOC(scg_k,(2,mcgk)) 1558 ABI_MALLOC(scg1_k,(2,mcgk,3)) 1559 1560 ! retrieve first order wavefunctions at this k point 1561 ABI_MALLOC(cg1_k,(2,mcgk,3)) 1562 cg1_k = cg1(1:2,icg+1:icg+mcgk,1:3) 1563 1564 ! compute cprj_k, S|u_nk>, and S|du/dk> 1565 ABI_MALLOC(cwavef,(2,npw_k)) 1566 ABI_MALLOC(gsc,(2,npw_k)) 1567 ABI_MALLOC(gvnlc,(2,npw_k)) 1568 ! input parameters for calls to nonlop 1569 nonlop_choice = 1! apply (I+S) 1570 ! input parameters for calls to getcprj 1571 getcprj_choice = 5 ! cprj and d cprj/dk 1572 getcprj_cpopt = 0 ! compute both cprj and d cprj/dk 1573 do nn = 1, nband_k 1574 cwavef = cg_k(:,(nn-1)*npw_k+1:nn*npw_k) 1575 call nonlop(nonlop_choice,nonlop_cpopt,cwaveprj,nonlop_enlout,gs_hamk,0,& 1576 & lambda_ndat,mpi_enreg,ndat,nonlop_nnlout,nonlop_pawopt,nonlop_signs,gsc,& 1577 & nonlop_tim,cwavef,gvnlc) 1578 scg_k(1:2,(nn-1)*npw_k+1:nn*npw_k) = gsc(1:2,1:npw_k) 1579 1580 do adir = 1, 3 1581 call getcprj(getcprj_choice,getcprj_cpopt,cwavef,cwaveprj,ffnl_k,& 1582 & adir,psps%indlmn,istwf_k,kg_k,kpg_k,kpoint,psps%lmnmax,& 1583 & dtset%mgfft,mpi_enreg,dtset%natom,nattyp,dtset%ngfft,& 1584 & dtset%nloalg,npw_k,dtset%nspinor,dtset%ntypat,& 1585 & phkxred,ph1d,ph3d,ucvol,psps%useylm) 1586 1587 call pawcprj_put(atindx1,cwaveprj,cprj_k,dtset%natom,& 1588 & nn,0,ikpt,0,isppol,nband_k,dtset%mkmem,& 1589 & dtset%natom,1,nband_k,dimlmn,dtset%nspinor,dtset%nsppol,0,& 1590 & mpicomm=mpi_enreg%comm_kpt,proc_distrb=mpi_enreg%proc_distrb) 1591 1592 end do 1593 1594 do adir = 1, 3 1595 cwavef = cg1_k(:,(nn-1)*npw_k+1:nn*npw_k,adir) 1596 call nonlop(nonlop_choice,nonlop_cpopt,cwaveprj,nonlop_enlout,gs_hamk,0,& 1597 & lambda_ndat,mpi_enreg,ndat,nonlop_nnlout,nonlop_pawopt,nonlop_signs,gsc,& 1598 & nonlop_tim,cwavef,gvnlc) 1599 scg1_k(1:2,(nn-1)*npw_k+1:nn*npw_k,adir) = gsc(1:2,1:npw_k) 1600 end do 1601 end do ! end loop over nn 1602 1603 ! compute \partial S/\partial k |u_nk> 1604 ABI_MALLOC(dscg_k,(2,mcgk,3)) 1605 ! input parameters for calls to nonlop 1606 nonlop_choice = 5! apply dS/dk 1607 do adir = 1, 3 1608 do nn = 1, nband_k 1609 cwavef = cg_k(:,(nn-1)*npw_k+1:nn*npw_k) 1610 call nonlop(nonlop_choice,nonlop_cpopt,cwaveprj,nonlop_enlout,gs_hamk,adir,& 1611 & lambda_ndat,mpi_enreg,ndat,nonlop_nnlout,nonlop_pawopt,nonlop_signs,gsc,& 1612 & nonlop_tim,cwavef,gvnlc) 1613 dscg_k(1:2,(nn-1)*npw_k+1:nn*npw_k,adir) = gsc(1:2,1:npw_k) 1614 end do ! end loop over nn 1615 end do 1616 1617 ! compute projection of cg1_k on conduction space 1618 ABI_MALLOC(pcg1_k,(2,nband_k*npw_k,3)) 1619 ABI_MALLOC(scprod,(2,nband_k)) 1620 do adir = 1, 3 1621 do nn = 1, nband_k 1622 1623 cwavef = cg1_k(1:2,(nn-1)*npw_k+1:nn*npw_k,adir) 1624 call projbd(cg_k,cwavef,-1,0,0,istwf_k,mcgk,mcgk,nband_k,npw_k,dtset%nspinor,& 1625 & scg_k,scprod,projbd_scprod_io,projbd_tim,projbd_useoverlap,& 1626 & mpi_enreg%me_g0,mpi_enreg%comm_fft) 1627 pcg1_k(1:2,(nn-1)*npw_k+1:nn*npw_k,adir) = cwavef 1628 1629 end do ! end loop over nn 1630 end do ! end loop over adir 1631 1632 ABI_MALLOC(ghc,(2,npw_k)) 1633 ABI_MALLOC(cwaveb1,(2,npw_k)) 1634 ABI_MALLOC(cwaveg1,(2,npw_k)) 1635 ABI_MALLOC(cwavedsdb,(2,npw_k)) 1636 ABI_MALLOC(cwavedsdg,(2,npw_k)) 1637 ABI_MALLOC(cwavefp,(2,npw_k)) 1638 do nn = 1, nband_k 1639 1640 ! compute H^0|u_nk> and <u_nk|H^0|u_nk> 1641 cwavef(1:2,1:npw_k) = cg_k(1:2,(nn-1)*npw_k+1:nn*npw_k) 1642 call getghc(getghc_cpopt,cwavef,cwaveprj,ghc,gsc,gs_hamk,gvnlc,lambda,mpi_enreg,ndat,& 1643 & getghc_prtvol,getghc_sij_opt,getghc_tim,getghc_type_calc) 1644 Enk = DOT_PRODUCT(cwavef(1,1:npw_k),ghc(1,1:npw_k)) & 1645 & + DOT_PRODUCT(cwavef(2,1:npw_k),ghc(2,1:npw_k)) 1646 1647 if (Enk .GT. local_fermie) local_fermie = Enk 1648 1649 do adir =1, 3 1650 bdir = modulo(adir,3)+1 1651 gdir = modulo(adir+1,3)+1 1652 1653 ! 1 orbmag CC 1654 ! -i/2 eps_abg <du/dg|P_c H0 P_c|du/db> = 1655 ! -i/2 (<du/dg|P_c H0 P_c|du/db> - <du/db|P_c H0 P_c|du/dg>) = 1656 ! -i/2 (2 i Im<du/dg|P_c H0 P_c|du/db>) = 1657 ! Im<du/dg|P_c H0 P_c|du/db> 1658 1659 cwaveb1(1:2,1:npw_k) = pcg1_k(1:2,(nn-1)*npw_k+1:nn*npw_k,bdir) 1660 1661 call getghc(getghc_cpopt,cwaveb1,cwaveprj,ghc,gsc,gs_hamk,gvnlc,lambda,mpi_enreg,ndat,& 1662 & getghc_prtvol,getghc_sij_opt,getghc_tim,getghc_type_calc) 1663 1664 cwaveg1(1:2,1:npw_k) = pcg1_k(1:2,(nn-1)*npw_k+1:nn*npw_k,gdir) 1665 doti=-DOT_PRODUCT(cwaveg1(2,:),ghc(1,:))+DOT_PRODUCT(cwaveg1(1,:),ghc(2,:)) 1666 1667 orbmag_terms(adir,cci,nn) = orbmag_terms(adir,cci,nn) + doti*trnrm 1668 1669 ! 2 orbmag VV II 1670 ! vv needs (+i/2)*eps_abg*<du/db|P_c S P_c|du/dg>Enk = 1671 ! +i/2 (<du/db|P_c S P_c|du/dg> - <du/dg|P_c S P_c|du/db>)Enk = 1672 ! -i/2 (<du/dg|P_c S P_c|du/db> - <du/db|P_c S P_c|du/dg>)Enk = 1673 ! Im<du/dg|P_c S P_c|du/db>Enk 1674 1675 doti=-DOT_PRODUCT(cwaveg1(2,:),gsc(1,:))+DOT_PRODUCT(cwaveg1(1,:),gsc(2,:)) 1676 orbmag_terms(adir,vvii,nn) = orbmag_terms(adir,vvii,nn) + doti*Enk*trnrm 1677 1678 !VV Ib term gives (i/2)eps_abg <du/db|P_c dS/dg|u>Enk 1679 !VV IIIb term gives (i/2)eps_abg <du|dS/db P_c|du/dg>Enk 1680 ! combined with eps_abg contraction they contribute 1681 ! -Im(VVI)*Enk 1682 ! 4 orbmag VV I+III part b 1683 cwavedsdb(1:2,1:npw_k) = dscg_k(1:2,(nn-1)*npw_k+1:nn*npw_k,bdir) 1684 cwavedsdg(1:2,1:npw_k) = dscg_k(1:2,(nn-1)*npw_k+1:nn*npw_k,gdir) 1685 1686 dug_dsb_i = -DOT_PRODUCT(cwaveg1(2,:),cwavedsdb(1,:)) + DOT_PRODUCT(cwaveg1(1,:),cwavedsdb(2,:)) 1687 dub_dsg_i = -DOT_PRODUCT(cwaveb1(2,:),cwavedsdg(1,:)) + DOT_PRODUCT(cwaveb1(1,:),cwavedsdg(2,:)) 1688 orbmag_terms(adir,vvib,nn)= orbmag_terms(adir,vvib,nn) - (dub_dsg_i-dug_dsb_i)*Enk*trnrm 1689 1690 ! VVIa term gives (i/2)eps_abg sum_n' (-)<u_n|dS/db|u_n'><u_n'|dS/dg|u_n>Enk 1691 ! = + sum_n' Im{<u_n|dS/db|u_n'><u_n'|dS/dg|u_n>Enk} 1692 ! VVIIIa is identical. VVIIa is the negative of VVIa. The total contribution of all 1693 ! three terms is thus the same as VVIa itself. 1694 ! term 3 1695 do nnp=1,nband_k 1696 cwavefp(1:2,1:npw_k) = cg_k(1:2,(nnp-1)*npw_k+1:nnp*npw_k) 1697 dbr= DOT_PRODUCT(cwavefp(1,:),cwavedsdb(1,:))+DOT_PRODUCT(cwavefp(2,:),cwavedsdb(2,:)) 1698 dbi=-DOT_PRODUCT(cwavefp(2,:),cwavedsdb(1,:))+DOT_PRODUCT(cwavefp(1,:),cwavedsdb(2,:)) 1699 dbc=cmplx(dbr,dbi,kind=dpc) 1700 dgr= DOT_PRODUCT(cwavefp(1,:),cwavedsdg(1,:))+DOT_PRODUCT(cwavefp(2,:),cwavedsdg(2,:)) 1701 dgi=-DOT_PRODUCT(cwavefp(2,:),cwavedsdg(1,:))+DOT_PRODUCT(cwavefp(1,:),cwavedsdg(2,:)) 1702 dgc=cmplx(dgr,dgi,kind=dpc) 1703 orbmag_terms(adir,vvia,nn) = orbmag_terms(adir,vvia,nn) + AIMAG(CONJG(dbc)*dgc*Enk)*trnrm 1704 end do 1705 1706 ! 5 Tr[-\rho^0 S^1 \rho^0 H^0] contribution 1707 call make_S1trace_k_n(adir,cprj_k,dtset,Enk,nn,nband_k,pawtab,S1trace) 1708 orbmag_terms(adir,rho0s1,nn) = orbmag_terms(adir,rho0s1,nn) - real(S1trace)*trnrm 1709 1710 ! 6 Tr[\rho^0 H^1] contribution: 1711 ! -i/2 eps_abg <u|dp/db>D_ij^0<dp/dg|u> 1712 call make_rhorij1_k_n(adir,cprj_k,dtset,nn,nband_k,paw_ij,pawtab,rhorij1) 1713 orbmag_terms(adir,rho0h1,nn) = orbmag_terms(adir,rho0h1,nn) + real(rhorij1)*trnrm 1714 1715 ! 7 onsite A_0.p = 1/2 L_R.B contribution 1716 call make_onsite_l_k_n(cprj_k,dtset,nn,adir,nband_k,onsite_l_k_n,pawrad,pawtab) 1717 orbmag_terms(adir,lrb,nn) = orbmag_terms(adir,lrb,nn) + real(onsite_l_k_n)*trnrm 1718 1719 ! 8 onsite A0.An contiribution 1720 call make_onsite_bm_k_n(cprj_k,dtset,nn,adir,nband_k,onsite_bm_k_n,& 1721 & pawang,pawrad,pawtab) 1722 orbmag_terms(adir,a0an,nn) = orbmag_terms(adir,a0an,nn) + real(onsite_bm_k_n)*trnrm 1723 1724 ! berrycurve needs i*eps_abg*<du/db|S|du/dg> 1725 ! N.B. the Berry curvature does not involve H0 so no projection onto conduction 1726 ! and valence bands, the "S" here is really I+S from PAW 1727 ! i eps_abg <du/db|S|du/dg> = -2*Im<du/db|S|du/dg> 1728 ! 9 berrycurve 1729 doti = -DOT_PRODUCT(cg1_k(2,(nn-1)*npw_k+1:nn*npw_k,bdir),scg1_k(1,(nn-1)*npw_k+1:nn*npw_k,gdir)) + & 1730 & DOT_PRODUCT(cg1_k(1,(nn-1)*npw_k+1:nn*npw_k,bdir),scg1_k(2,(nn-1)*npw_k+1:nn*npw_k,gdir)) 1731 orbmag_terms(adir,berrycurve,nn) = orbmag_terms(adir,berrycurve,nn) - two*doti*trnrm 1732 1733 end do 1734 1735 end do 1736 1737 ABI_FREE(cwavef) 1738 ABI_FREE(cwavefp) 1739 ABI_FREE(cwaveb1) 1740 ABI_FREE(cwaveg1) 1741 ABI_FREE(cwavedsdb) 1742 ABI_FREE(cwavedsdg) 1743 ABI_FREE(ghc) 1744 ABI_FREE(gsc) 1745 ABI_FREE(gvnlc) 1746 ABI_FREE(cg_k) 1747 ABI_FREE(scg_k) 1748 ABI_FREE(scg1_k) 1749 ABI_FREE(dscg_k) 1750 ABI_FREE(cg1_k) 1751 ABI_FREE(pcg1_k) 1752 ABI_FREE(scprod) 1753 1754 icg = icg + npw_k*nband_k 1755 ikg = ikg + npw_k 1756 1757 ABI_FREE(ylm_k) 1758 ABI_FREE(ylmgr_k) 1759 ABI_FREE(kpg_k) 1760 ABI_FREE(ffnl_k) 1761 ABI_FREE(ph3d) 1762 ABI_FREE(phkxred) 1763 1764 end do ! end loop over kpts 1765 1766 if (nproc > 1) then 1767 buff_size=size(orbmag_terms) 1768 ABI_MALLOC(buffer1,(buff_size)) 1769 ABI_MALLOC(buffer2,(buff_size)) 1770 buffer1(1:buff_size) = reshape(orbmag_terms,(/3*nterms*nband_k/)) 1771 call xmpi_sum(buffer1,buffer2,buff_size,spaceComm,ierr) 1772 orbmag_terms(1:3,1:nterms,1:nband_k)=reshape(buffer2,(/3,nterms,nband_k/)) 1773 ABI_FREE(buffer1) 1774 ABI_FREE(buffer2) 1775 end if 1776 1777 ! convert to cartesian frame, supply 1/(2\pi)^2 factor 1778 ! but not to lrb and a0an terms, they are already cartesian and don't require 1779 ! additional normalization 1780 do nn = 1, nband_k 1781 orbmag_terms(1:3,cci,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,cci,nn)) 1782 orbmag_terms(1:3,vvii,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvii,nn)) 1783 orbmag_terms(1:3,vvib,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvib,nn)) 1784 orbmag_terms(1:3,vvia,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvia,nn)) 1785 orbmag_terms(1:3,rho0h1,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,rho0h1,nn)) 1786 orbmag_terms(1:3,rho0s1,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,rho0s1,nn)) 1787 orbmag_terms(1:3,berrycurve,nn) = (ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,berrycurve,nn)) 1788 end do 1789 1790 ! compute trace of each term 1791 ABI_MALLOC(orbmag_trace,(3,nterms)) 1792 orbmag_trace = zero 1793 do nn = 1, nband_k 1794 orbmag_trace(1:3,1:nterms) = orbmag_trace(1:3,1:nterms) + orbmag_terms(1:3,1:nterms,nn) 1795 end do 1796 1797 call orbmag_output(dtset,local_fermie,nband_k,nterms,orbmag_terms,orbmag_trace) 1798 1799 !--------------------------------------------------- 1800 ! deallocate memory 1801 !--------------------------------------------------- 1802 call gs_hamk%free() 1803 1804 ABI_FREE(vlocal) 1805 ABI_FREE(vectornd) 1806 if(has_nucdip) then 1807 ABI_FREE(vectornd_pac) 1808 end if 1809 ABI_FREE(kg_k) 1810 ABI_FREE(kinpw) 1811 ABI_FREE(ph1d) 1812 ABI_FREE(orbmag_terms) 1813 ABI_FREE(orbmag_trace) 1814 1815 ABI_FREE(dimlmn) 1816 call pawcprj_free(cprj_k) 1817 ABI_FREE(cprj_k) 1818 call pawcprj_free(cwaveprj) 1819 ABI_FREE(cwaveprj) 1820 1821 end subroutine orbmag_ddk
ABINIT/orbmag_output [ Functions ]
NAME
orbmag_ddk_output
FUNCTION
This routine outputs orbmag terms tailored for ddk routine
COPYRIGHT
Copyright (C) 2003-2021 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,pawcprj_mpi_recv pawcprj_mpi_send,xmpi_sum
SOURCE
1857 subroutine orbmag_output(dtset,fermie,nband_k,nterms,orbmag_terms,orbmag_trace) 1858 1859 1860 !Arguments ------------------------------------ 1861 !scalars 1862 integer,intent(in) :: nband_k,nterms 1863 real(dp),intent(in) :: fermie 1864 type(dataset_type),intent(in) :: dtset 1865 1866 !arrays 1867 real(dp),intent(in) :: orbmag_terms(3,nterms,nband_k),orbmag_trace(3,nterms) 1868 1869 !Local variables ------------------------- 1870 !scalars 1871 integer :: adir,iband,iterms 1872 integer,parameter :: cci=1,vvii=2,vvia=3,vvib=4,rho0h1=5,rho0s1=6,lrb=7,a0an=8,berrycurve=9 1873 character(len=500) :: message 1874 1875 !arrays 1876 real(dp) :: orbmag_bb(3,2,nband_k),orbmag_total(3) 1877 1878 ! *********************************************************************** 1879 1880 orbmag_bb=zero;orbmag_total=zero 1881 do iterms = 1, nterms-1 1882 orbmag_total(1:3)=orbmag_total(1:3) + orbmag_trace(1:3,iterms) 1883 do iband=1, nband_k 1884 orbmag_bb(1:3,1,iband) = orbmag_bb(1:3,1,iband) + orbmag_terms(1:3,iterms,iband) 1885 end do 1886 end do 1887 1888 write(message,'(a,a,a)')ch10,'====================================================',ch10 1889 call wrtout(ab_out,message,'COLL') 1890 1891 if(dtset%orbmag .GT. 0) then 1892 write(message,'(a,a)')' Orbital magnetic moment computed with DFPT derivative wavefunctions ',ch10 1893 call wrtout(ab_out,message,'COLL') 1894 end if 1895 1896 if(dtset%orbmag .LT. 0) then 1897 write(message,'(a,a)')' Orbital magnetic moment computed with Finite Difference derivative wavefunctions ',ch10 1898 call wrtout(ab_out,message,'COLL') 1899 end if 1900 1901 write(message,'(a)')' Orbital magnetic moment, Cartesian directions : ' 1902 call wrtout(ab_out,message,'COLL') 1903 write(message,'(3es16.8)') (orbmag_total(adir),adir=1,3) 1904 call wrtout(ab_out,message,'COLL') 1905 write(message,'(a)')ch10 1906 call wrtout(ab_out,message,'COLL') 1907 write(message,'(a)')' Integral of Berry curvature, Cartesian directions : ' 1908 call wrtout(ab_out,message,'COLL') 1909 write(message,'(3es16.8)') (orbmag_trace(adir,berrycurve),adir=1,3) 1910 call wrtout(ab_out,message,'COLL') 1911 write(message,'(a,es16.8)')' Fermie energy : ',fermie 1912 call wrtout(ab_out,message,'COLL') 1913 1914 if(abs(dtset%orbmag) .GE. 2) then 1915 write(message,'(a)')ch10 1916 call wrtout(ab_out,message,'COLL') 1917 write(message,'(a)')' Orbital magnetic moment, Term-by-term breakdown : ' 1918 call wrtout(ab_out,message,'COLL') 1919 write(message,'(a,3es16.8)') ' Conduction space : ',(orbmag_trace(adir,cci),adir=1,3) 1920 call wrtout(ab_out,message,'COLL') 1921 write(message,'(a,3es16.8)') ' Valence space IIb : ',(orbmag_trace(adir,vvii),adir=1,3) 1922 call wrtout(ab_out,message,'COLL') 1923 write(message,'(a,3es16.8)') ' Valence space Ia+IIa+IIIa : ',(orbmag_trace(adir,vvia),adir=1,3) 1924 call wrtout(ab_out,message,'COLL') 1925 write(message,'(a,3es16.8)') ' Valence space Ib : ',(orbmag_trace(adir,vvib),adir=1,3) 1926 call wrtout(ab_out,message,'COLL') 1927 write(message,'(a,3es16.8)') ' S(1) PAW overlap : ',(orbmag_trace(adir,rho0s1),adir=1,3) 1928 call wrtout(ab_out,message,'COLL') 1929 write(message,'(a,3es16.8)') ' H(1) cprj : ',(orbmag_trace(adir,rho0h1),adir=1,3) 1930 call wrtout(ab_out,message,'COLL') 1931 write(message,'(a,3es16.8)') ' H(1) on-site 1/2 L_R.B : ',(orbmag_trace(adir,lrb),adir=1,3) 1932 call wrtout(ab_out,message,'COLL') 1933 write(message,'(a,3es16.8)') ' H(1) on-site A0.An : ',(orbmag_trace(adir,a0an),adir=1,3) 1934 call wrtout(ab_out,message,'COLL') 1935 write(message,'(a,3es16.8)') ' Berry curvature : ',(orbmag_trace(adir,berrycurve),adir=1,3) 1936 call wrtout(ab_out,message,'COLL') 1937 end if 1938 1939 if(abs(dtset%orbmag) .EQ. 3) then 1940 write(message,'(a)')ch10 1941 call wrtout(ab_out,message,'COLL') 1942 write(message,'(a)')' Orbital magnetic moment, Term-by-term breakdown for each band : ' 1943 call wrtout(ab_out,message,'COLL') 1944 do iband = 1, nband_k 1945 write(message,'(a)')ch10 1946 call wrtout(ab_out,message,'COLL') 1947 write(message,'(a,i2,a,i2)') ' band ',iband,' of ',nband_k 1948 call wrtout(ab_out,message,'COLL') 1949 write(message,'(a,3es16.8)') ' Total orbital moment : ',(orbmag_bb(adir,1,iband),adir=1,3) 1950 call wrtout(ab_out,message,'COLL') 1951 write(message,'(a,3es16.8)') ' Conduction space : ',(orbmag_terms(adir,cci,iband),adir=1,3) 1952 call wrtout(ab_out,message,'COLL') 1953 write(message,'(a,3es16.8)') ' Valence space IIb : ',(orbmag_terms(adir,vvii,iband),adir=1,3) 1954 call wrtout(ab_out,message,'COLL') 1955 write(message,'(a,3es16.8)') ' Valence space Ia+IIa+IIIa : ',(orbmag_terms(adir,vvia,iband),adir=1,3) 1956 call wrtout(ab_out,message,'COLL') 1957 write(message,'(a,3es16.8)') ' Valence space Ib : ',(orbmag_terms(adir,vvib,iband),adir=1,3) 1958 call wrtout(ab_out,message,'COLL') 1959 write(message,'(a,3es16.8)') ' S(1) PAW overlap : ',(orbmag_terms(adir,rho0s1,iband),adir=1,3) 1960 call wrtout(ab_out,message,'COLL') 1961 write(message,'(a,3es16.8)') ' H(1) cprj : ',(orbmag_terms(adir,rho0h1,iband),adir=1,3) 1962 call wrtout(ab_out,message,'COLL') 1963 write(message,'(a,3es16.8)') ' H(1) on-site 1/2 L_R.B : ',(orbmag_terms(adir,lrb,iband),adir=1,3) 1964 call wrtout(ab_out,message,'COLL') 1965 write(message,'(a,3es16.8)') ' H(1) on-site A0.An : ',(orbmag_terms(adir,a0an,iband),adir=1,3) 1966 call wrtout(ab_out,message,'COLL') 1967 write(message,'(a,3es16.8)') ' Berry curvature : ',(orbmag_terms(adir,berrycurve,iband),adir=1,3) 1968 call wrtout(ab_out,message,'COLL') 1969 end do 1970 end if 1971 1972 write(message,'(a,a,a)')ch10,'====================================================',ch10 1973 call wrtout(ab_out,message,'COLL') 1974 1975 end subroutine orbmag_output
ABINIT/orbmag_wf [ Functions ]
NAME
orbmag_wf
FUNCTION
This routine computes the orbital magnetization based on input wavefunctions. It is assumed that only completely filled bands are present.
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
atindx1(natom)=index table for atoms, inverse of atindx (see gstate.f) cg(2,mcg)=planewave coefficients of wavefunctions cprj(natom,mcprj*usecrpj)=<p_lmn|Cnk> coefficients for each WF |Cnk> and each |p_lmn> non-local projector dtset <type(dataset_type)>=all input variables in this dataset kg(3,mpw*mkmem) = reduced (integer) coordinates of G vecs in basis sphere mcg=size of wave-functions array (cg) =mpw*nspinor*mband*mkmem*nsppol mcprj=size of projected wave-functions array (cprj) =nspinor*mband*mkmem*nsppol mpi_enreg=information about MPI parallelization nfftf= - PAW only - number of FFT grid points for the "fine" grid (see NOTES at beginning of scfcv) npwarr(nkpt)=number of planewaves in basis at this k point paw_ij(my_natom*usepaw) <type(paw_ij_type)>=paw arrays given on (i,j) channels pawang <type(pawang_type)>=paw angular mesh and related data pawfgr <type(pawfgr_type)>=fine grid parameters and related data pawrad(ntypat*psps%usepaw) <type(pawrad_type)>=paw radial mesh and related data pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data psps <type(pseudopotential_type)>=variables related to pseudopotentials pwind(pwind_alloc,2,3) = array used to compute the overlap matrix smat between k-points (see initberry.f) pwind_alloc = first dimension of pwind rprimd(3,3)=dimensional primitive translations in real space (bohr) symrec(3,3,nsym) = symmetries in reciprocal space in terms of reciprocal space primitive translations usecprj=1 if cprj datastructure has been allocated vhartr(nfftf)=Hartree potential vpsp(nfftf)=array for holding local psp vxc(nfftf,nspden)=exchange-correlation potential (hartree) in real space xred(3,natom) = location of atoms in unit cell ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point ylmgr(mpw*mkmem,3,mpsang*mpsang*useylm)= gradients of real spherical harmonics
OUTPUT
SIDE EFFECTS
dtorbmag <type(orbmag_type)> = variables related to orbital magnetization
TODO
NOTES
See Ceresoli et al, PRB 74, 024408 (2006) [[cite:Ceresoli2006]], and Gonze and Zwanziger, PRB 84, 064445 (2011) [[cite:Gonze2011a]]. Chern number and magnetization computed using discretized wavefunction derivatives as in [[cite:Ceresoli2006]].
PARENTS
m_afterscfloop
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
2045 subroutine orbmag_wf(atindx1,cg,cprj,dtset,dtorbmag,& 2046 & mcg,mcprj,mpi_enreg,nattyp,nfftf,npwarr,paw_ij,pawang,pawfgr,pawrad,pawtab,psps,& 2047 & pwind,pwind_alloc,rprimd,usecprj,vectornd,& 2048 & vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2049 2050 !Arguments ------------------------------------ 2051 !scalars 2052 integer,intent(in) :: mcg,mcprj,nfftf,pwind_alloc,usecprj,with_vectornd 2053 type(dataset_type),intent(in) :: dtset 2054 type(MPI_type), intent(inout) :: mpi_enreg 2055 type(orbmag_type), intent(inout) :: dtorbmag 2056 type(pawang_type),intent(in) :: pawang 2057 type(pawfgr_type),intent(in) :: pawfgr 2058 type(pseudopotential_type),intent(in) :: psps 2059 2060 !arrays 2061 integer,intent(in) :: atindx1(dtset%natom),nattyp(dtset%ntypat) 2062 integer,intent(in) :: npwarr(dtset%nkpt),pwind(pwind_alloc,2,3) 2063 real(dp),intent(in) :: cg(2,mcg),rprimd(3,3) 2064 real(dp),intent(in) :: vhartr(nfftf),vpsp(nfftf),vxc(nfftf,dtset%nspden),xred(3,dtset%natom) 2065 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 2066 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 2067 real(dp),intent(inout) :: vectornd(with_vectornd*nfftf,3) 2068 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 2069 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat*psps%usepaw) 2070 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj*usecprj) 2071 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat*psps%usepaw) 2072 2073 !Local variables ------------------------- 2074 !scalars 2075 integer :: adir,isppol,istwf_k,my_nspinor,nband_k,nn,ncpgr,nterms 2076 real(dp) :: trnrm,ucvol 2077 2078 !arrays 2079 integer,parameter :: cci=1,vvii=2,vvia=3,vvib=4,rho0h1=5,rho0s1=6,lrb=7,a0an=8,berrycurve=9 2080 real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3) 2081 real(dp),allocatable :: CCIterms(:,:,:),eeig(:,:),onsite_bm(:,:,:),onsite_l(:,:,:) 2082 real(dp),allocatable :: out_e(:,:,:),out_h(:,:,:),out_s(:,:,:) 2083 real(dp),allocatable :: orbmag_terms(:,:,:),orbmag_trace(:,:) 2084 real(dp),allocatable :: rhorij1(:,:,:),s1trace(:,:,:),udsqduchern(:,:,:),udsqdumag(:,:,:),VVIaterms(:,:,:) 2085 complex(dpc),allocatable :: onsite_bm_dir(:),onsite_l_dir(:),rhorij1_dir(:),s1trace_dir(:) 2086 2087 ! *********************************************************************** 2088 ! my_nspinor=max(1,dtorbmag%nspinor/mpi_enreg%nproc_spinor) 2089 2090 ncpgr = cprj(1,1)%ncpgr 2091 2092 ! TODO: generalize to nsppol > 1 2093 isppol = 1 2094 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 2095 nband_k = dtorbmag%mband_occ 2096 istwf_k = 1 2097 2098 ABI_MALLOC(onsite_l_dir,(nband_k)) 2099 ABI_MALLOC(onsite_l,(2,nband_k,3)) 2100 ABI_MALLOC(s1trace_dir,(nband_k)) 2101 ABI_MALLOC(s1trace,(2,nband_k,3)) 2102 ABI_MALLOC(rhorij1_dir,(nband_k)) 2103 ABI_MALLOC(rhorij1,(2,nband_k,3)) 2104 ABI_MALLOC(onsite_bm_dir,(nband_k)) 2105 ABI_MALLOC(onsite_bm,(2,nband_k,3)) 2106 ABI_MALLOC(VVIaterms,(2,nband_k,3)) 2107 ABI_MALLOC(out_s,(2,nband_k,3)) 2108 ABI_MALLOC(out_e,(2,nband_k,3)) 2109 ABI_MALLOC(out_h,(2,nband_k,3)) 2110 ABI_MALLOC(udsqduchern,(2,nband_k,3)) 2111 ABI_MALLOC(udsqdumag,(2,nband_k,3)) 2112 ABI_MALLOC(CCIterms,(2,nband_k,3)) 2113 2114 nterms = 9 ! various contributing terms in orbmag and berrycurve 2115 ! 1 orbmag CC 2116 ! 2 orbmag VV II 2117 ! 3 orbmag VV I+III part a 2118 ! 4 orbmag VV I+III part b 2119 ! 5 orbmag Tr[\rho^0 H^1] with D^0_ij part 2120 ! 6 orbmag -Tr[\rho^0 S^1] part 2121 ! 7 orbmag onsite L_R/r^3 2122 ! 8 orbmag onsite A0.An 2123 ! 9 berrycurve 2124 ABI_MALLOC(orbmag_terms,(3,nterms,nband_k)) 2125 orbmag_terms = zero 2126 2127 call metric(gmet,gprimd,-1,rmet,rprimd,ucvol) 2128 2129 ! call covar_test(atindx1,cg,cprj,dtorbmag,dtset,gprimd,mcg,mcprj,mpi_enreg,& 2130 ! & nband_k,npwarr,pawang,pawrad,pawtab,psps,pwind,pwind_alloc,xred) 2131 2132 ABI_MALLOC(eeig,(nband_k,dtset%nkpt)) 2133 eeig(:,:) = zero 2134 call make_eeig(atindx1,cg,cprj,dtset,eeig,gmet,gprimd,mcg,mcprj,mpi_enreg,nattyp,nband_k,nfftf,npwarr,& 2135 & paw_ij,pawfgr,pawtab,psps,rmet,rprimd,& 2136 & vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2137 2138 ! compute i*\epsilon_{abg}\sum_n <du|Q_SHE_Q|du> 2139 call duq_she_qdu(atindx1,cg,cprj,dtorbmag,dtset,eeig,gmet,gprimd,mcg,mcprj,mpi_enreg,& 2140 & nband_k,nfftf,npwarr,out_e,out_h,out_s,pawang,pawfgr,paw_ij,pawrad,pawtab,psps,pwind,pwind_alloc,& 2141 & rmet,rprimd,vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2142 2143 ! compute i*\epsilon_{abg}\sum_n <u|dS Q|du> with and without E_nk weights (needed respectively 2144 ! by Chern number and by magnetization) 2145 call udsqdu(atindx1,cg,cprj,dtorbmag,dtset,eeig,gmet,gprimd,& 2146 & mcg,mcprj,mpi_enreg,nband_k,npwarr,paw_ij,pawang,pawrad,pawtab,psps,& 2147 pwind,pwind_alloc,rmet,rprimd,udsqduchern,udsqdumag,xred,ylm,ylmgr) 2148 2149 do adir=1, 3 2150 ! this needs careful checking 2151 orbmag_terms(adir,berrycurve,1:nband_k) = out_s(1,1:nband_k,adir)-half*udsqduchern(1,1:nband_k,adir) 2152 end do 2153 2154 do adir = 1, 3 2155 2156 call make_onsite_l(atindx1,cprj,dtset,adir,mcprj,mpi_enreg,nband_k,onsite_l_dir,pawrad,pawtab) 2157 onsite_l(1,1:nband_k,adir) = real(onsite_l_dir(1:nband_k)) 2158 onsite_l(2,1:nband_k,adir) = aimag(onsite_l_dir(1:nband_k)) 2159 2160 call make_S1trace(adir,atindx1,cprj,dtset,eeig,mcprj,mpi_enreg,nattyp,nband_k,pawtab,s1trace_dir) 2161 s1trace(1,1:nband_k,adir) = real(s1trace_dir(1:nband_k)) 2162 s1trace(2,1:nband_k,adir) = aimag(s1trace_dir(1:nband_k)) 2163 2164 call make_rhorij1(adir,atindx1,cprj,dtset,mcprj,mpi_enreg,nattyp,nband_k,paw_ij,pawtab,rhorij1_dir) 2165 rhorij1(1,1:nband_k,adir) = real(rhorij1_dir(1:nband_k)) 2166 rhorij1(2,1:nband_k,adir) = aimag(rhorij1_dir(1:nband_k)) 2167 2168 if (any(abs(dtset%nucdipmom)>tol8)) then 2169 call make_onsite_bm(atindx1,cprj,dtset,adir,mcprj,mpi_enreg,nband_k,onsite_bm_dir,& 2170 & pawang,pawrad,pawtab) 2171 onsite_bm(1,1:nband_k,adir) = real(onsite_bm_dir(1:nband_k)) 2172 onsite_bm(2,1:nband_k,adir) = aimag(onsite_bm_dir(1:nband_k)) 2173 else 2174 onsite_bm(:,:,adir) = zero 2175 end if 2176 2177 orbmag_terms(adir,rho0h1,1:nband_k) = rhorij1(1,1:nband_k,adir) 2178 orbmag_terms(adir,rho0s1,1:nband_k) = s1trace(1,1:nband_k,adir) 2179 orbmag_terms(adir,lrb,1:nband_k) = onsite_l(1,1:nband_k,adir) 2180 orbmag_terms(adir,a0an,1:nband_k) = onsite_bm(1,1:nband_k,adir) 2181 2182 end do ! end loop over adir 2183 2184 !CCIterms=zero 2185 !call duqhqdu(atindx1,cg,CCIterms,cprj,dtorbmag,dtset,gmet,gprimd,mcg,mcprj,mpi_enreg,& 2186 ! & nattyp,nband_k,nfftf,npwarr,paw_ij,pawang,pawfgr,pawrad,pawtab,psps,pwind,pwind_alloc,& 2187 ! & rmet,rprimd,ucvol,vectornd,vhartr,vpsp,vxc,with_vectornd,xred,ylm,ylmgr) 2188 2189 call udsdsu(atindx1,cg,VVIaterms,cprj,dtorbmag,dtset,eeig,gmet,gprimd,mcg,mcprj,mpi_enreg,& 2190 & nband_k,npwarr,paw_ij,pawtab,psps,rmet,rprimd,xred,ylm,ylmgr) 2191 2192 do adir=1,3 2193 ! duqhqdu returns i*epsabg*\sum_occ [<d_gdir u|QHQ|d_bdir u>] 2194 ! CCI is (-i/2) times this 2195 orbmag_terms(adir,cci,1:nband_k)=half*out_h(1,1:nband_k,adir) 2196 !orbmag_terms(adir,cci,1:nband_k)=half*CCIterms(1,1:nband_k,adir) 2197 orbmag_terms(adir,vvii,1:nband_k)=half*out_e(1,1:nband_k,adir) 2198 orbmag_terms(adir,vvib,1:nband_k)=udsqdumag(1,1:nband_k,adir) 2199 orbmag_terms(adir,vvia,1:nband_k)=VVIaterms(1,1:nband_k,adir) 2200 end do 2201 2202 trnrm = two/(dtorbmag%fnkpt) 2203 2204 orbmag_terms(:,lrb,:) = trnrm*orbmag_terms(:,lrb,:) 2205 orbmag_terms(:,a0an,:) = trnrm*orbmag_terms(:,a0an,:) 2206 do nn = 1, nband_k 2207 orbmag_terms(1:3,cci,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,cci,nn)) 2208 orbmag_terms(1:3,vvii,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvii,nn)) 2209 orbmag_terms(1:3,vvib,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvib,nn)) 2210 orbmag_terms(1:3,vvia,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,vvia,nn)) 2211 orbmag_terms(1:3,rho0h1,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,rho0h1,nn)) 2212 orbmag_terms(1:3,rho0s1,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,rho0s1,nn)) 2213 orbmag_terms(1:3,berrycurve,nn) = (trnrm*ucvol/(two_pi*two_pi))*MATMUL(gprimd,orbmag_terms(1:3,berrycurve,nn)) 2214 end do 2215 2216 ! compute trace of each term 2217 ABI_MALLOC(orbmag_trace,(3,nterms)) 2218 orbmag_trace = zero 2219 do nn = 1, nband_k 2220 orbmag_trace(1:3,1:nterms) = orbmag_trace(1:3,1:nterms) + orbmag_terms(1:3,1:nterms,nn) 2221 end do 2222 2223 call orbmag_output(dtset,MAXVAL(eeig),nband_k,nterms,orbmag_terms,orbmag_trace) 2224 2225 if(allocated(eeig)) then 2226 ABI_FREE(eeig) 2227 end if 2228 2229 ABI_FREE(onsite_l_dir) 2230 ABI_FREE(onsite_l) 2231 ABI_FREE(s1trace_dir) 2232 ABI_FREE(s1trace) 2233 ABI_FREE(onsite_bm_dir) 2234 ABI_FREE(onsite_bm) 2235 ABI_FREE(rhorij1_dir) 2236 ABI_FREE(rhorij1) 2237 ABI_FREE(VVIaterms) 2238 ABI_FREE(out_e) 2239 ABI_FREE(out_h) 2240 ABI_FREE(out_s) 2241 ABI_FREE(udsqduchern) 2242 ABI_FREE(udsqdumag) 2243 ABI_FREE(CCIterms) 2244 ABI_FREE(orbmag_terms) 2245 ABI_FREE(orbmag_trace) 2246 2247 end subroutine orbmag_wf
ABINIT/udsdsu [ Functions ]
NAME
udsdsu
FUNCTION
Return (-i/2)*epsabg\sum_{n,n}<u_kn|\partial_b S|u_kn'><u_kn|\partial_g S|u_kn>E_nk
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
4462 subroutine udsdsu(atindx1,cg,cnum_udsdsu,cprj,dtorbmag,dtset,energies,gmet,gprimd,mcg,mcprj,mpi_enreg,& 4463 & nband_k,npwarr,paw_ij,pawtab,psps,rmet,rprimd,xred,ylm,ylmgr) 4464 4465 !Arguments ------------------------------------ 4466 !scalars 4467 integer,intent(in) :: mcg,mcprj,nband_k 4468 type(dataset_type),intent(in) :: dtset 4469 type(MPI_type), intent(inout) :: mpi_enreg 4470 type(orbmag_type), intent(inout) :: dtorbmag 4471 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 4472 type(pseudopotential_type),intent(in) :: psps 4473 4474 !arrays 4475 integer,intent(in) :: atindx1(dtset%natom),npwarr(dtset%nkpt) 4476 real(dp), intent(in) :: cg(2,mcg),energies(nband_k,dtset%nkpt),gmet(3,3),gprimd(3,3) 4477 real(dp), intent(in) :: rmet(3,3),rprimd(3,3),xred(3,dtset%natom) 4478 real(dp), intent(out) :: cnum_udsdsu(2,nband_k,3) 4479 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 4480 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 4481 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 4482 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 4483 4484 !Local variables ------------------------- 4485 !scalars 4486 integer :: adir,bdir,dimph1d,dimffnl,exchn2n3d,epsabg 4487 integer :: gdir,ia,iband,ibs1,ibs2 4488 integer :: icg,icprj,ider,idir,ierr 4489 integer :: ikg,ikg1,ikpt,ilm,isppol,istwf_k,jband 4490 integer :: me,my_nspinor,ncpgr,ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6 4491 integer :: nkpg,npw_k,npw_k_ 4492 integer :: nonlop_choice,nonlop_cpopt,nonlop_nnlout,nonlop_ndat,nonlop_paw_opt,nonlop_signs 4493 integer :: nproc,spaceComm,tim_nonlop 4494 real(dp) :: arg,doti,dotr,ecut_eff,ENK 4495 complex(dpc) :: udsdsu_term,ujdsbu,ujdsgu 4496 type(gs_hamiltonian_type) :: gs_hamk 4497 4498 !arrays 4499 integer :: nattyp_dum(dtset%ntypat) 4500 integer,allocatable :: dimlmn(:),kg_k(:,:) 4501 real(dp) :: kpoint(3),nonlop_lambda(1) 4502 real(dp),allocatable :: cwavef(:,:),cwavefp(:,:),ffnl_k(:,:,:,:) 4503 real(dp),allocatable :: kpg_k(:,:),nonlop_enlout(:) 4504 real(dp),allocatable :: phkxred(:,:),ph1d(:,:),ph3d(:,:,:) 4505 real(dp),allocatable :: svect(:,:,:),svectout(:,:),svectoutp(:,:),vectout(:,:) 4506 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 4507 type(pawcprj_type),allocatable :: cprj_k(:,:),cwaveprj(:,:) 4508 4509 !---------------------------------------------------- 4510 4511 isppol = 1 4512 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 4513 spaceComm=mpi_enreg%comm_cell 4514 nproc=xmpi_comm_size(spaceComm) 4515 me = mpi_enreg%me_kpt 4516 4517 ncpgr = cprj(1,1)%ncpgr 4518 ABI_MALLOC(dimlmn,(dtset%natom)) 4519 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 4520 ABI_MALLOC(cprj_k,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 4521 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 4522 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 4523 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 4524 4525 !==== Initialize most of the Hamiltonian ==== 4526 !Allocate all arrays and initialize quantities that do not depend on k and spin. 4527 !gs_hamk is the normal hamiltonian at k 4528 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 4529 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 4530 istwf_k = 1 4531 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 4532 exchn2n3d = 0 ; ikg1 = 0 4533 4534 ABI_MALLOC(phkxred,(2,dtset%natom)) 4535 dimph1d=dtset%natom*(2*(ngfft1+ngfft2+ngfft3)+3) 4536 ABI_MALLOC(ph1d,(2,dimph1d)) 4537 call getph(atindx1,dtset%natom,ngfft1,ngfft2,ngfft3,ph1d,xred) 4538 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 4539 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 4540 & paw_ij=paw_ij) 4541 call gs_hamk%load_spin(isppol,with_nonlocal=.true.) 4542 4543 ABI_MALLOC(kg_k,(3,dtset%mpw)) 4544 4545 ! nonlop parameters 4546 nonlop_choice = 5 ! first derivative wrt k 4547 nonlop_cpopt = -1 4548 nonlop_nnlout = 1 ! size of enlout, not used in call 4549 ABI_MALLOC(nonlop_enlout,(nonlop_nnlout)) 4550 nonlop_lambda(1) = 0.0 ! shift for eigenvalues, not used 4551 nonlop_ndat = 1 ! number of wavefunctions to apply nonlop 4552 nonlop_paw_opt = 3 ! use Sij matrix 4553 nonlop_signs = 2 ! apply to function in recip space 4554 tim_nonlop = 0 ! timing not used 4555 4556 cnum_udsdsu(:,:,:) = zero 4557 icg = 0 4558 ikg = 0 4559 icprj = 0 4560 do ikpt = 1, dtset%nkpt 4561 4562 ! if the current kpt is not on the current processor, cycle 4563 if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,-1,me)) cycle 4564 4565 kpoint(:)=dtset%kptns(:,ikpt) 4566 npw_k = npwarr(ikpt) 4567 4568 ! Build basis sphere of plane waves for the k-point 4569 kg_k(:,:) = 0 4570 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg_k,kpoint,1,mpi_enreg,dtset%mpw,npw_k_) 4571 if (npw_k .NE. npw_k_) then 4572 write(std_out,'(a)')'JWZ debug udsdsu npw_k inconsistency' 4573 end if 4574 4575 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 4576 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 4577 do ilm=1,psps%mpsang*psps%mpsang 4578 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 4579 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 4580 end do 4581 4582 nkpg = 3 4583 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 4584 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 4585 4586 ! Compute nonlocal form factors ffnl at all (k+G): 4587 ider=1 ! want ffnl and 1st derivative 4588 idir=4 ! d ffnl/ dk 4589 dimffnl=4 ! 1 + number of derivatives 4590 ABI_MALLOC(ffnl_k,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 4591 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl_k,psps%ffspl,& 4592 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 4593 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 4594 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 4595 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 4596 4597 ! Load k-dependent part in the Hamiltonian datastructure 4598 ! - Compute 3D phase factors 4599 ! - Prepare various tabs in case of band-FFT parallelism 4600 ! - Load k-dependent quantities in the Hamiltonian 4601 ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk)) 4602 do ia=1, dtset%natom 4603 arg=two_pi*(kpoint(1)*xred(1,ia)+kpoint(2)*xred(2,ia)+kpoint(3)*xred(3,ia)) 4604 phkxred(1,ia)=cos(arg);phkxred(2,ia)=sin(arg) 4605 end do 4606 4607 call ph1d3d(1,dtset%natom,kg_k,dtset%natom,dtset%natom,npw_k,ngfft1,ngfft2,ngfft3,phkxred,ph1d,ph3d) 4608 4609 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 4610 & kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,ph3d_k=ph3d,compute_gbound=.TRUE.) 4611 4612 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprj,ikpt,0,isppol,dtset%mband,& 4613 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 4614 4615 4616 ABI_MALLOC(cwavef,(2,npw_k)) 4617 ABI_MALLOC(svectout,(2,npw_k)) 4618 ABI_MALLOC(vectout,(2,npw_k)) 4619 ABI_MALLOC(svect,(2,3,npw_k*nband_k)) 4620 do adir = 1, 3 4621 do iband = 1, nband_k 4622 ibs1=(iband-1)*npw_k+1 4623 ibs2=iband*npw_k 4624 cwavef(1:2,1:npw_k) = cg(1:2,icg+ibs1:icg+ibs2) 4625 call pawcprj_get(atindx1,cwaveprj,cprj_k,dtset%natom,iband,0,ikpt,0,isppol,dtset%mband,& 4626 & dtset%mkmem,dtset%natom,1,nband_k,my_nspinor,dtset%nsppol,0) 4627 ! compute dS/dk_adir|u_nk>, store in svectout 4628 call nonlop(nonlop_choice,nonlop_cpopt,cwaveprj,nonlop_enlout,gs_hamk,adir,nonlop_lambda,& 4629 & mpi_enreg,nonlop_ndat,nonlop_nnlout,nonlop_paw_opt,nonlop_signs,svectout,& 4630 & tim_nonlop,cwavef,vectout) 4631 svect(1:2,adir,ibs1:ibs2) = svectout(1:2,1:npw_k) 4632 end do 4633 end do 4634 ABI_FREE(cwavef) 4635 ABI_FREE(svectout) 4636 ABI_FREE(vectout) 4637 ABI_FREE(ylm_k) 4638 ABI_FREE(ylmgr_k) 4639 ABI_FREE(kpg_k) 4640 ABI_FREE(ffnl_k) 4641 ABI_FREE(ph3d) 4642 4643 do adir = 1, 3 4644 4645 do epsabg = 1, -1, -2 4646 if (epsabg .EQ. 1) then 4647 bdir = modulo(adir,3)+1 4648 gdir = modulo(adir+1,3)+1 4649 else 4650 bdir = modulo(adir+1,3)+1 4651 gdir = modulo(adir,3)+1 4652 end if 4653 4654 ABI_MALLOC(svectout,(2,npw_k)) 4655 ABI_MALLOC(svectoutp,(2,npw_k)) 4656 ABI_MALLOC(cwavefp,(2,npw_k)) 4657 do iband = 1, nband_k 4658 4659 ENK = energies(iband,ikpt) 4660 svectout(1:2,1:npw_k) = svect(1:2,gdir,(iband-1)*npw_k+1:iband*npw_k) 4661 svectoutp(1:2,1:npw_k) = svect(1:2,bdir,(iband-1)*npw_k+1:iband*npw_k) 4662 4663 do jband = 1, nband_k 4664 4665 cwavefp(1:2,1:npw_k) = cg(1:2,icg+(jband-1)*npw_k+1:icg+jband*npw_k) 4666 4667 dotr=DOT_PRODUCT(cwavefp(1,:),svectout(1,:))+DOT_PRODUCT(cwavefp(2,:),svectout(2,:)) 4668 doti=DOT_PRODUCT(cwavefp(1,:),svectout(2,:))-DOT_PRODUCT(cwavefp(2,:),svectout(1,:)) 4669 4670 ujdsgu = cmplx(dotr,doti,KIND=dpc) 4671 4672 dotr=DOT_PRODUCT(cwavefp(1,:),svectoutp(1,:))+DOT_PRODUCT(cwavefp(2,:),svectoutp(2,:)) 4673 doti=DOT_PRODUCT(cwavefp(1,:),svectoutp(2,:))-DOT_PRODUCT(cwavefp(2,:),svectoutp(1,:)) 4674 4675 ujdsbu = cmplx(dotr,doti,KIND=dpc) 4676 4677 ! accumulate (-i/2)*epsabg*ENK\sum_occ [<u_nk|dS_bdir|u_n'k><u_n'k|dS_gdir|u_nk>] 4678 udsdsu_term = -half*j_dpc*epsabg*ENK*CONJG(ujdsbu)*ujdsgu 4679 cnum_udsdsu(1,iband,adir) = cnum_udsdsu(1,iband,adir) + real(udsdsu_term) 4680 cnum_udsdsu(2,iband,adir) = cnum_udsdsu(2,iband,adir) + aimag(udsdsu_term) 4681 4682 end do !end loop over jband 4683 end do ! end loop over iband 4684 ABI_FREE(svectout) 4685 ABI_FREE(svectoutp) 4686 ABI_FREE(cwavefp) 4687 4688 end do ! end loop over epsabg 4689 end do ! end loop over adir 4690 4691 icg = icg + npw_k*nband_k 4692 ikg = ikg + npw_k 4693 icprj = icprj + nband_k 4694 4695 ABI_FREE(svect) 4696 4697 end do ! end loop over ikpt 4698 4699 ! ---- parallel communication 4700 if(nproc > 1) then 4701 call xmpi_sum(cnum_udsdsu,spaceComm,ierr) 4702 end if 4703 4704 call gs_hamk%free() 4705 4706 ABI_FREE(dimlmn) 4707 call pawcprj_free(cprj_k) 4708 ABI_FREE(cprj_k) 4709 call pawcprj_free(cwaveprj) 4710 ABI_FREE(cwaveprj) 4711 4712 ABI_FREE(phkxred) 4713 ABI_FREE(ph1d) 4714 ABI_FREE(kg_k) 4715 ABI_FREE(nonlop_enlout) 4716 4717 end subroutine udsdsu
ABINIT/udsqdu [ Functions ]
NAME
udsqdu
FUNCTION
Return i*epsabg\sum_n<u_kn|\partial_b S Q |\partial_g u_kn> where Q projects onto the conduction space. This term contributes to the Chern number (integral over Berry curvature).
COPYRIGHT
Copyright (C) 2003-2020 ABINIT group (JWZ) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt . For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
INPUTS
OUTPUT
only printing
SIDE EFFECTS
TODO
NOTES
PARENTS
m_orbmag
CHILDREN
pawcprj_alloc,pawcprj_free,pawcprj_get,pawcprj_getdim,xmpi_sum
SOURCE
3501 subroutine udsqdu(atindx1,cg,cprj,dtorbmag,dtset,energies,gmet,gprimd,& 3502 & mcg,mcprj,mpi_enreg,nband_k,npwarr,paw_ij,pawang,pawrad,pawtab,psps,& 3503 pwind,pwind_alloc,rmet,rprimd,udsqduchern,udsqdumag,xred,ylm,ylmgr) 3504 3505 !Arguments ------------------------------------ 3506 !scalars 3507 integer,intent(in) :: mcg,mcprj,nband_k,pwind_alloc 3508 type(dataset_type),intent(in) :: dtset 3509 type(MPI_type), intent(inout) :: mpi_enreg 3510 type(orbmag_type), intent(inout) :: dtorbmag 3511 type(pawang_type),intent(in) :: pawang 3512 type(pawcprj_type),intent(in) :: cprj(dtset%natom,mcprj) 3513 type(pseudopotential_type),intent(in) :: psps 3514 3515 !arrays 3516 integer,intent(in) :: atindx1(dtset%natom) 3517 integer,intent(in) :: npwarr(dtset%nkpt),pwind(pwind_alloc,2,3) 3518 real(dp), intent(in) :: cg(2,mcg),gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3),xred(3,dtset%natom) 3519 real(dp), intent(out) :: udsqduchern(2,nband_k,3),udsqdumag(2,nband_k,3) 3520 real(dp),intent(in) :: ylm(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm) 3521 real(dp),intent(in) :: ylmgr(dtset%mpw*dtset%mkmem,3,psps%mpsang*psps%mpsang*psps%useylm) 3522 real(dp),intent(in) :: energies(nband_k,dtset%nkpt) 3523 type(paw_ij_type),intent(inout) :: paw_ij(dtset%natom*psps%usepaw) 3524 type(pawrad_type),intent(in) :: pawrad(dtset%ntypat) 3525 type(pawtab_type),intent(in) :: pawtab(dtset%ntypat) 3526 3527 !Local variables ------------------------- 3528 !scalars 3529 integer :: adir,bdir,countg,countk,dimph1d,dimffnl,exchn2n3d,epsabg 3530 integer :: gdir,gfor,gsigma,ia,iband,ibs1,ibs2 3531 integer :: icg,icprji,ider,idir,ierr 3532 integer :: ikg,ikg1,ikpt,ikpt_loc,ikpti,ikptg,ikptgi,ilm,isppol,istwf_k,itrs 3533 integer :: mcg1_k,me,my_nspinor,n2dim,ncpgr,ngfft1,ngfft2,ngfft3,ngfft4,ngfft5,ngfft6 3534 integer :: nkpg,nproc,npw_k,npw_k_,npw_kg 3535 integer :: nonlop_choice,nonlop_cpopt,nonlop_nnlout,nonlop_ndat 3536 integer :: nonlop_paw_opt,nonlop_signs,ntotcp 3537 integer :: shiftbd,smatrix_ddkflag,smatrix_job,spaceComm,tim_nonlop 3538 real(dp) :: arg,deltag,doti,dotr,ecut_eff,ENK 3539 complex(dpc) :: cprefac,udsqduchern_term,udsqdumag_term 3540 type(gs_hamiltonian_type) :: gs_hamk 3541 3542 !arrays 3543 integer :: nattyp_dum(dtset%ntypat) 3544 integer,allocatable :: dimlmn(:),kg_k(:,:),pwind_kg(:),sflag_k(:) 3545 real(dp) :: dkg(3),dtm_k(2),kpoint(3),nonlop_lambda(1) 3546 real(dp),allocatable :: cg_k(:,:),cg1_kg(:,:),cgqg(:,:),cwavef(:,:),ffnl_k(:,:,:,:) 3547 real(dp),allocatable :: kk_paw(:,:,:),kpg_k(:,:),nonlop_enlout(:) 3548 real(dp),allocatable :: phkxred(:,:),ph1d(:,:),ph3d(:,:,:),pwnsfac_k(:,:) 3549 real(dp),allocatable :: smat_inv(:,:,:),smat_kk(:,:,:),svect(:,:,:),svectout(:,:),vectout(:,:) 3550 real(dp),allocatable :: ylm_k(:,:),ylmgr_k(:,:,:) 3551 type(pawcprj_type),allocatable :: cprj_buf(:,:),cprj_k(:,:),cprj_kg(:,:),cwaveprj(:,:) 3552 3553 !---------------------------------------------------- 3554 3555 isppol = 1 3556 my_nspinor=max(1,dtset%nspinor/mpi_enreg%nproc_spinor) 3557 spaceComm=mpi_enreg%comm_cell 3558 nproc=xmpi_comm_size(spaceComm) 3559 me = mpi_enreg%me_kpt 3560 3561 ncpgr = cprj(1,1)%ncpgr 3562 ABI_MALLOC(dimlmn,(dtset%natom)) 3563 call pawcprj_getdim(dimlmn,dtset%natom,nattyp_dum,dtset%ntypat,dtset%typat,pawtab,'R') 3564 ABI_MALLOC(cprj_k,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3565 call pawcprj_alloc(cprj_k,ncpgr,dimlmn) 3566 ABI_MALLOC(cprj_kg,(dtset%natom,dtorbmag%nspinor*dtset%mband)) 3567 call pawcprj_alloc(cprj_kg,ncpgr,dimlmn) 3568 ABI_MALLOC(cwaveprj,(dtset%natom,1)) 3569 call pawcprj_alloc(cwaveprj,ncpgr,dimlmn) 3570 n2dim = dtorbmag%nspinor*nband_k 3571 ntotcp = n2dim*SUM(dimlmn(:)) 3572 if (nproc>1) then 3573 ABI_MALLOC(cprj_buf,(dtset%natom,n2dim)) 3574 call pawcprj_alloc(cprj_buf,ncpgr,dimlmn) 3575 end if 3576 3577 ABI_MALLOC(kk_paw,(2,dtset%mband,dtset%mband)) 3578 ABI_MALLOC(sflag_k,(nband_k)) 3579 ABI_MALLOC(pwind_kg,(dtset%mpw)) 3580 ABI_MALLOC(pwnsfac_k,(4,dtset%mpw)) 3581 pwnsfac_k(1,:) = one; pwnsfac_k(2,:) = zero 3582 pwnsfac_k(3,:) = one; pwnsfac_k(4,:) = zero 3583 3584 ABI_MALLOC(kg_k,(3,dtset%mpw)) 3585 3586 mcg1_k = dtset%mpw*dtset%nsppol*my_nspinor*nband_k 3587 ABI_MALLOC(cg1_kg,(2,mcg1_k)) 3588 ABI_MALLOC(cg_k,(2,mcg1_k)) 3589 ABI_MALLOC(smat_inv,(2,nband_k,nband_k)) 3590 ABI_MALLOC(smat_kk,(2,nband_k,nband_k)) 3591 3592 smatrix_ddkflag = 1 3593 itrs = 0 3594 smatrix_job = 1 3595 shiftbd = 1 3596 3597 !==== Initialize most of the Hamiltonian ==== 3598 !Allocate all arrays and initialize quantities that do not depend on k and spin. 3599 !gs_hamk is the normal hamiltonian at k 3600 ngfft1=dtset%ngfft(1) ; ngfft2=dtset%ngfft(2) ; ngfft3=dtset%ngfft(3) 3601 ngfft4=dtset%ngfft(4) ; ngfft5=dtset%ngfft(5) ; ngfft6=dtset%ngfft(6) 3602 istwf_k = 1 3603 ecut_eff = dtset%ecut*(dtset%dilatmx)**2 3604 exchn2n3d = 0 ; ikg1 = 0 3605 3606 ABI_MALLOC(phkxred,(2,dtset%natom)) 3607 dimph1d=dtset%natom*(2*(ngfft1+ngfft2+ngfft3)+3) 3608 ABI_MALLOC(ph1d,(2,dimph1d)) 3609 call getph(atindx1,dtset%natom,ngfft1,ngfft2,ngfft3,ph1d,xred) 3610 call init_hamiltonian(gs_hamk,psps,pawtab,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%natom,& 3611 & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,nucdipmom=dtset%nucdipmom,& 3612 & paw_ij=paw_ij) 3613 call gs_hamk%load_spin(isppol,with_nonlocal=.true.) 3614 3615 ! nonlop parameters 3616 nonlop_choice = 5 ! first derivative wrt k 3617 nonlop_cpopt = -1 3618 nonlop_nnlout = 1 ! size of enlout, not used in call 3619 ABI_MALLOC(nonlop_enlout,(nonlop_nnlout)) 3620 nonlop_lambda(1) = 0.0 ! shift for eigenvalues, not used 3621 nonlop_ndat = 1 ! number of wavefunctions to apply nonlop 3622 nonlop_paw_opt = 3 ! use Sij matrix 3623 nonlop_signs = 2 ! apply to function in recip space 3624 tim_nonlop = 0 ! timing not used 3625 3626 udsqduchern(:,:,:) = zero 3627 udsqdumag(:,:,:) = zero 3628 3629 do ikpt_loc = 1,dtorbmag%fmkmem_max 3630 3631 ikpt=mpi_enreg%kpt_loc2fbz_sp(me, ikpt_loc,1) 3632 ! if this k and spin are for me do it 3633 if (ikpt > 0) then 3634 3635 ikpti = dtorbmag%indkk_f2ibz(ikpt,1) 3636 icprji = dtorbmag%cprjindex(ikpti,isppol) 3637 npw_k = npwarr(ikpti) 3638 icg = dtorbmag%cgindex(ikpti,dtset%nsppol) 3639 ikg = dtorbmag%fkgindex(ikpt) 3640 3641 countk = npw_k*my_nspinor*nband_k 3642 cg_k(1:2,1:countk) = cg(1:2,icg+1:icg+countk) 3643 3644 call pawcprj_get(atindx1,cprj_k,cprj,dtset%natom,1,icprji,ikpti,0,isppol,dtset%mband,& 3645 & dtset%mkmem,dtset%natom,nband_k,nband_k,my_nspinor,dtset%nsppol,0) 3646 3647 kpoint(:)=dtset%kptns(:,ikpt) 3648 ! Build basis sphere of plane waves for the k-point 3649 kg_k(:,:) = 0 3650 call kpgsph(ecut_eff,exchn2n3d,gmet,ikg1,ikpt,istwf_k,kg_k,kpoint,1,mpi_enreg,dtset%mpw,npw_k_) 3651 if (npw_k .NE. npw_k_) then 3652 write(std_out,'(a)')'JWZ debug udsqdu npw_k inconsistency' 3653 end if 3654 3655 ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang)) 3656 ABI_MALLOC(ylmgr_k,(npw_k,3,psps%mpsang*psps%mpsang*psps%useylm)) 3657 do ilm=1,psps%mpsang*psps%mpsang 3658 ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm) 3659 ylmgr_k(1:npw_k,1:3,ilm)=ylmgr(1+ikg:npw_k+ikg,1:3,ilm) 3660 end do 3661 3662 nkpg = 3 3663 ABI_MALLOC(kpg_k,(npw_k,nkpg)) 3664 call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k) 3665 3666 ! Compute nonlocal form factors ffnl at all (k+G): 3667 ider=1 ! want ffnl and 1st derivative 3668 idir=4 ! d ffnl/ dk 3669 dimffnl=4 ! 1 + number of derivatives 3670 ABI_MALLOC(ffnl_k,(npw_k,dimffnl,psps%lmnmax,dtset%ntypat)) 3671 call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl_k,psps%ffspl,& 3672 & gmet,gprimd,ider,idir,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,& 3673 & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,& 3674 & npw_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,& 3675 & psps%usepaw,psps%useylm,ylm_k,ylmgr_k) 3676 3677 ! Load k-dependent part in the Hamiltonian datastructure 3678 ! - Compute 3D phase factors 3679 ! - Prepare various tabs in case of band-FFT parallelism 3680 ! - Load k-dependent quantities in the Hamiltonian 3681 ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk)) 3682 do ia=1, dtset%natom 3683 arg=two_pi*(kpoint(1)*xred(1,ia)+kpoint(2)*xred(2,ia)+kpoint(3)*xred(3,ia)) 3684 phkxred(1,ia)=cos(arg);phkxred(2,ia)=sin(arg) 3685 end do 3686 3687 call ph1d3d(1,dtset%natom,kg_k,dtset%natom,dtset%natom,npw_k,ngfft1,ngfft2,ngfft3,phkxred,ph1d,ph3d) 3688 3689 call gs_hamk%load_k(kpt_k=kpoint(:),istwf_k=istwf_k,npw_k=npw_k,& 3690 & kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,ph3d_k=ph3d,compute_gbound=.TRUE.) 3691 3692 ABI_MALLOC(cwavef,(2,npw_k)) 3693 ABI_MALLOC(svectout,(2,npw_k)) 3694 ABI_MALLOC(vectout,(2,npw_k)) 3695 ABI_MALLOC(svect,(2,3,npw_k*nband_k)) 3696 3697 do bdir = 1, 3 3698 do iband = 1, nband_k 3699 3700 ibs1=(iband-1)*npw_k+1 3701 ibs2=iband*npw_k 3702 3703 cwavef(1:2,1:npw_k) = cg_k(1:2,ibs1:ibs2) 3704 call pawcprj_get(atindx1,cwaveprj,cprj_k,dtset%natom,iband,0,ikpt,0,isppol,dtset%mband,& 3705 & dtset%mkmem,dtset%natom,1,nband_k,my_nspinor,dtset%nsppol,0) 3706 3707 ! compute dS/dk_bdir|u_nk> 3708 call nonlop(nonlop_choice,nonlop_cpopt,cwaveprj,nonlop_enlout,gs_hamk,bdir,nonlop_lambda,& 3709 & mpi_enreg,nonlop_ndat,nonlop_nnlout,nonlop_paw_opt,nonlop_signs,svectout,& 3710 & tim_nonlop,cwavef,vectout) 3711 3712 svect(1:2,bdir,ibs1:ibs2) = svectout(1:2,1:npw_k) 3713 3714 end do ! end loop over iband 3715 end do ! end loop over bdir 3716 ABI_FREE(cwavef) 3717 ABI_FREE(svectout) 3718 ABI_FREE(vectout) 3719 3720 end if ! end check that ikpt > 0 3721 3722 do adir = 1, 3 3723 do epsabg = 1, -1, -2 3724 if (epsabg .EQ. 1) then 3725 bdir = modulo(adir,3)+1 3726 gdir = modulo(adir+1,3)+1 3727 else 3728 bdir = modulo(adir+1,3)+1 3729 gdir = modulo(adir,3)+1 3730 end if 3731 3732 do gfor = 1, 2 3733 gsigma = 3-2*gfor 3734 dkg(1:3) = gsigma*dtorbmag%dkvecs(1:3,gdir) 3735 deltag = sqrt(DOT_PRODUCT(dkg,dkg)) 3736 3737 ikptg = dtorbmag%ikpt_dk(ikpt,gfor,gdir) 3738 ikptgi = dtorbmag%indkk_f2ibz(ikptg,1) 3739 npw_kg = npwarr(ikptgi) 3740 pwind_kg(1:npw_k) = pwind(ikg+1:ikg+npw_k,gfor,gdir) 3741 3742 cprefac = j_dpc*epsabg*gsigma/(two*deltag) 3743 3744 if (ikpt > 0 .AND. isppol > 0) then 3745 countg = npw_kg*my_nspinor*nband_k 3746 if(allocated(cgqg)) then 3747 ABI_FREE(cgqg) 3748 endif 3749 ABI_MALLOC(cgqg,(2,countg)) 3750 call mpicomm_helper(atindx1,gdir,gfor,cg,cgqg,cprj,cprj_kg,dimlmn,dtorbmag,dtset,& 3751 & ikpt,ikpt_loc,ikptgi,isppol,mcg,mcprj,me,mpi_enreg,my_nspinor,nband_k,& 3752 & nproc,npw_kg,npwarr,spaceComm) 3753 end if 3754 3755 if (ikpt > 0 .and. isppol > 0) then ! if I am treating a kpt, compute the overlaps 3756 3757 ! get covariant |u_{n,k+g}> and associated cprj 3758 call overlap_k1k2_paw(cprj_k,cprj_kg,dkg,gprimd,kk_paw,dtorbmag%lmn2max,& 3759 & dtorbmag%lmn_size,dtset%natom,dtset%mband,dtset%mband,& 3760 & my_nspinor,dtset%ntypat,pawang,pawrad,pawtab,dtset%typat,xred) 3761 sflag_k=0 3762 cg1_kg(:,:) = zero 3763 ! cg1_kg will hold |\tilde{u}_{n,k+g}> 3764 call smatrix(cg_k,cgqg,cg1_kg,smatrix_ddkflag,dtm_k,0,0,itrs,smatrix_job,nband_k,& 3765 & mcg1_k,mcg1_k,mcg1_k,1,dtset%mpw,nband_k,nband_k,npw_k,npw_kg,my_nspinor,& 3766 & pwind_kg,pwnsfac_k,sflag_k,shiftbd,smat_inv,smat_kk,kk_paw,psps%usepaw) 3767 3768 do iband = 1, nband_k 3769 3770 ibs1=(iband-1)*npw_k+1 3771 ibs2=iband*npw_k 3772 3773 dotr=DOT_PRODUCT(svect(1,bdir,ibs1:ibs2),cg1_kg(1,ibs1:ibs2))+& 3774 & DOT_PRODUCT(svect(2,bdir,ibs1:ibs2),cg1_kg(2,ibs1:ibs2)) 3775 doti=DOT_PRODUCT(svect(1,bdir,ibs1:ibs2),cg1_kg(2,ibs1:ibs2))-& 3776 & DOT_PRODUCT(svect(2,bdir,ibs1:ibs2),cg1_kg(1,ibs1:ibs2)) 3777 3778 ! accumulate i*epsabg*ENK\sum_occ [<u|dS_bdir Q|d_gdir u>] 3779 ENK = energies(iband,ikpt) 3780 udsqduchern_term = cprefac*cmplx(dotr,doti) 3781 udsqdumag_term = udsqduchern_term*ENK 3782 3783 udsqduchern(1,iband,adir) = udsqduchern(1,iband,adir) + real(udsqduchern_term) 3784 udsqduchern(2,iband,adir) = udsqduchern(2,iband,adir) + aimag(udsqduchern_term) 3785 udsqdumag(1,iband,adir) = udsqdumag(1,iband,adir) + real(udsqdumag_term) 3786 udsqdumag(2,iband,adir) = udsqdumag(2,iband,adir) + aimag(udsqdumag_term) 3787 3788 end do ! end loop over iband 3789 3790 if(allocated(cgqg)) then 3791 ABI_FREE(cgqg) 3792 end if 3793 3794 end if ! end check that ikpt > 0 3795 end do ! end loop for gfor 3796 end do ! end loop over epsabg 3797 end do ! end loop over adir 3798 ABI_FREE(ylm_k) 3799 ABI_FREE(ylmgr_k) 3800 ABI_FREE(kpg_k) 3801 ABI_FREE(ffnl_k) 3802 ABI_FREE(ph3d) 3803 ABI_FREE(svect) 3804 end do ! end loop over ikpt_loc 3805 3806 ! accumulate result from all processes 3807 if(nproc > 1) then 3808 call xmpi_sum(udsqduchern,spaceComm,ierr) 3809 call xmpi_sum(udsqdumag,spaceComm,ierr) 3810 end if 3811 3812 call gs_hamk%free() 3813 3814 ABI_FREE(dimlmn) 3815 call pawcprj_free(cprj_k) 3816 ABI_FREE(cprj_k) 3817 call pawcprj_free(cprj_kg) 3818 ABI_FREE(cprj_kg) 3819 call pawcprj_free(cwaveprj) 3820 ABI_FREE(cwaveprj) 3821 if (nproc>1) then 3822 call pawcprj_free(cprj_buf) 3823 ABI_FREE(cprj_buf) 3824 end if 3825 3826 ABI_FREE(kk_paw) 3827 ABI_FREE(sflag_k) 3828 ABI_FREE(pwind_kg) 3829 ABI_FREE(pwnsfac_k) 3830 ABI_FREE(kg_k) 3831 ABI_FREE(cg1_kg) 3832 ABI_FREE(cg_k) 3833 ABI_FREE(smat_inv) 3834 ABI_FREE(smat_kk) 3835 ABI_FREE(phkxred) 3836 ABI_FREE(ph1d) 3837 ABI_FREE(nonlop_enlout) 3838 3839 end subroutine udsqdu
m_orbmag/destroy_orbmag [ Functions ]
NAME
FUNCTION
deallocate fields in orbmag structure
INPUTS
OUTPUT
SOURCE
211 subroutine destroy_orbmag(dtorbmag) 212 213 !Arguments ------------------------------------ 214 !array 215 type(orbmag_type),intent(inout) :: dtorbmag 216 217 ! ************************************************************************ 218 219 ! Integer pointers 220 if(allocated(dtorbmag%atom_indsym)) then 221 ABI_FREE(dtorbmag%atom_indsym) 222 end if 223 if(allocated(dtorbmag%cgindex)) then 224 ABI_FREE(dtorbmag%cgindex) 225 end if 226 if(allocated(dtorbmag%cprjindex)) then 227 ABI_FREE(dtorbmag%cprjindex) 228 end if 229 if(allocated(dtorbmag%fkgindex)) then 230 ABI_FREE(dtorbmag%fkgindex) 231 end if 232 if(allocated(dtorbmag%ikpt_dk)) then 233 ABI_FREE(dtorbmag%ikpt_dk) 234 end if 235 if(allocated(dtorbmag%indkk_f2ibz)) then 236 ABI_FREE(dtorbmag%indkk_f2ibz) 237 end if 238 if(allocated(dtorbmag%i2fbz)) then 239 ABI_FREE(dtorbmag%i2fbz) 240 end if 241 if(allocated(dtorbmag%kg)) then 242 ABI_FREE(dtorbmag%kg) 243 end if 244 if(allocated(dtorbmag%kgindex)) then 245 ABI_FREE(dtorbmag%kgindex) 246 end if 247 if(allocated(dtorbmag%lmn_size)) then 248 ABI_FREE(dtorbmag%lmn_size) 249 end if 250 if(allocated(dtorbmag%lmn2_size)) then 251 ABI_FREE(dtorbmag%lmn2_size) 252 end if 253 if(allocated(dtorbmag%nband_occ)) then 254 ABI_FREE(dtorbmag%nband_occ) 255 end if 256 ! Real(dp) pointers 257 258 if(allocated(dtorbmag%fkptns)) then 259 ABI_FREE(dtorbmag%fkptns) 260 end if 261 if(allocated(dtorbmag%zarot)) then 262 ABI_FREE(dtorbmag%zarot) 263 end if 264 265 end subroutine destroy_orbmag
m_orbmag/orbmag_type [ Types ]
NAME
orbmag_type
FUNCTION
variables used in orbital magnetism calculation
SOURCE
85 type, public :: orbmag_type 86 87 ! WARNING : if you modify this datatype, please check whether there might be creation/destruction/copy routines, 88 ! declared in another part of ABINIT, that might need to take into account your modification. 89 90 ! Integer variables 91 integer :: orbmag ! value of orbmag input variable in use 92 integer :: fmkmem ! number of k-points in the FBZ per cpu 93 integer :: fmkmem_max ! max of fmkmem 94 integer :: fnkpt ! number of k-points in the FBZ 95 integer :: lmax 96 integer :: lmnmax 97 integer :: lmn2max 98 integer :: mkmem_max ! max of mkmem 99 integer :: natom ! number of atoms in unit cell 100 integer :: my_natom ! number of atoms treated by current proc 101 integer :: mband_occ ! max number of occupied bands (over spin) 102 ! this number must be the same for every k 103 integer :: nspinor ! nspinor input from data set 104 integer :: nsym 105 integer :: usepaw ! 1 if a PAW calculation, 0 else 106 107 ! Real(dp) scalars 108 real(dp) :: sdeg ! spin degeneracy: sdeg = 2 if nsppol = 1 109 110 ! Real(dp) arrays 111 real(dp) :: chern(2,3) ! result of chern number calculation 112 113 real(dp) :: dkvecs(3,3) ! dkvec(:,idir) = vector between a k-point and its nearest neighbour along idir 114 115 real(dp) :: orbmagvec(2,3) ! result of orbital magnetization calculation 116 117 ! Integer pointers 118 integer, allocatable :: atom_indsym(:,:,:) ! atom_indsym(4,nsym,natom) 119 ! this is data on how the symmetries map the atoms in the cell 120 ! see symatm.F90 for full description 121 integer, allocatable :: cgindex(:,:) ! cgindex(nkpt,nsppol) 122 ! for each k-point, stores the location 123 ! of the WF in the cg array 124 integer, allocatable :: cprjindex(:,:) ! cprjindex(nkpt,nsppol) 125 ! for each k-point, stores the location 126 ! of the cprj in the cprj array (used only 127 ! for PAW calculations) 128 integer, allocatable :: fkgindex(:) ! same as kgindex, but defined 129 ! for the FBZ and intended to use 130 ! with pwindf 131 integer, allocatable :: ikpt_dk(:,:,:) ! ikpt_dk(nkpt,2,3) 132 ! ikpt_dp(ikpt,ii,idir) = index of the 133 ! k-point at k+dk (ii=1) and k-dk (ii=2) 134 integer, allocatable :: indkk_f2ibz(:,:) ! indkk_f2ibz(1:dtorbmag%fnkpt,1:6) 135 ! information needed to fold a 136 ! k-point in the FBZ into the IBZ; 137 ! the second index (1:6) 138 ! is as described in listkk 139 integer, allocatable :: i2fbz(:) ! i2fbz(1:nkpt) gives index of IBZ 140 ! k-points in the FBZ k-point list 141 142 integer, allocatable :: kg(:,:) ! reduced (integer) coordinates of G vecs in basis sphere 143 144 integer, allocatable :: kgindex(:) ! kgind(nkpt) on current processor 145 ! kgindex(ikpt) = ikg 146 147 integer, allocatable :: lmn_size(:) ! lmn_size(ntypat) 148 integer, allocatable :: lmn2_size(:) ! lmn2_size(ntypat) 149 150 integer, allocatable :: nband_occ(:) ! nband_occ(nsppol) = actual number of occupied bands 151 ! can be different for spin up and down!!! 152 ! Real(dp) allocatables 153 154 real(dp), allocatable :: fkptns(:,:) ! fkptns(3,1:dtorbmag%fnkpt) k-points in FBZ 155 156 real(dp), allocatable :: zarot(:,:,:,:) 157 ! zarot(l_size_max,l_size_max,l_max,nsym) 158 ! Coeffs of the transformation of real spherical 159 ! harmonics under the symmetry operations. These are needed when the 160 ! cprj's need to be computed in the full BZ, that is, 161 ! in the PAW case with kptopt /= 3. 162 163 ! complex(dpc) allocatable 164 165 end type orbmag_type 166 167 168 ! Bound methods: 169 public :: destroy_orbmag 170 public :: initorbmag 171 public :: orbmag_ddk 172 public :: orbmag_wf 173 174 private :: make_onsite_l_k_n 175 private :: make_onsite_bm_k_n 176 private :: make_rhorij1_k_n 177 private :: make_S1trace_k_n 178 private :: orbmag_output 179 private :: make_eeig 180 private :: duqdu 181 private :: duq_she_qdu 182 private :: mpicomm_helper 183 private :: udsqdu 184 private :: covar_cprj 185 private :: duqhqdu 186 private :: udsdsu 187 private :: cpg_dij_cpb 188 private :: make_S1trace 189 private :: make_onsite_l 190 private :: make_onsite_l_k 191 private :: make_onsite_bm 192 private :: make_rhorij1 193 194 CONTAINS !========================================================================================