Skip to content

GitLab

fleur
fleur
Commit e498c60c authored by Gregor Michalicek's avatar Gregor Michalicek
Browse files
Options

added Intraatomic magnetic dipole operator and multipole expansions 

Note: The output unit for <T> is hbar/2. ...this has to be changed in the future.
Note2: Switches have to be implemented to toggle the computation of these quantities.
parent f72dc951
Hide whitespace changes
Inline Side-by-side
Showing with 563 additions and 36 deletions
cdn/cdnval.F90
View file @ e498c60c
......@@ -134,7 +134,7 @@ SUBROUTINE cdnval(eig_id, mpi,kpts,jspin,noco,input,banddos,cell,atoms,enpara,st
CALL denCoeffs%init(atoms,sphhar,jsp_start,jsp_end)
! The last entry in denCoeffsOffdiag%init is l_fmpl. It is meant as a switch to a plot of the full magnet.
! density without the atomic sphere approximation for the magnet. density. It is not completely implemented (lo's missing).
CALL denCoeffsOffdiag%init(atoms,noco,sphhar,noco%l_mtnocopot)
CALL denCoeffsOffdiag%init(atoms,noco,sphhar,noco%l_mtnocopot.OR.noco%l_mperp)
CALL force%init1(input,atoms)
CALL orb%init(atoms,noco,jsp_start,jsp_end)
......
cdn_mt/CMakeLists.txt
View file @ e498c60c
......@@ -10,10 +10,13 @@ cdn_mt/abcof3.F90
cdn_mt/abcrot2.f90
cdn_mt/cdnmt.F90
cdn_mt/cdncore.F90
cdn_mt/denMultipoleExp.f90
cdn_mt/magMoms.f90
cdn_mt/magDiMom.f90
cdn_mt/orbMagMoms.f90
cdn_mt/orb_comp2.f90
cdn_mt/radfun.f90
cdn_mt/resMoms.f90
cdn_mt/rhomt.f90
cdn_mt/rhomt21.f90
cdn_mt/rhomtlo.f90
......
cdn_mt/cdnmt.F90
View file @ e498c60c
......@@ -38,7 +38,7 @@ CONTAINS
TYPE (t_denCoeffsOffdiag), INTENT(IN) :: denCoeffsOffdiag
! ..
! .. Local Scalars ..
INTEGER itype,na,nd,l,lp,llp ,lh,j,ispin,noded,nodeu
INTEGER itype,na,nd,l,lp,llp ,lh,j,ispin,noded,nodeu,llpb
INTEGER ilo,ilop,i
REAL s,wronk,sumlm,qmtt
COMPLEX cs
......@@ -63,11 +63,11 @@ CONTAINS
ENDIF
ENDIF
!$OMP PARALLEL DEFAULT(none) &
!$OMP SHARED(usdus,rho,moments,qmtl) &
!$OMP SHARED(atoms,jsp_start,jsp_end,enpara,vr,denCoeffs,sphhar)&
!$OMP SHARED(orb,noco,denCoeffsOffdiag,jspd)&
!$OMP PRIVATE(itype,na,ispin,l,rho21,f,g,nodeu,noded,wronk,i,j,s,qmtllo,qmtt,nd,lh,lp,llp,cs)
! !$OMP PARALLEL DEFAULT(none) &
! !$OMP SHARED(usdus,rho,moments,qmtl) &
! !$OMP SHARED(atoms,jsp_start,jsp_end,enpara,vr,denCoeffs,sphhar)&
! !$OMP SHARED(orb,noco,denCoeffsOffdiag,jspd)&
! !$OMP PRIVATE(itype,na,ispin,l,rho21,f,g,nodeu,noded,wronk,i,j,s,qmtllo,qmtt,nd,lh,lp,llp,llpb,cs)
IF (noco%l_mperp) THEN
ALLOCATE ( f(atoms%jmtd,2,0:atoms%lmaxd,jspd),g(atoms%jmtd,2,0:atoms%lmaxd,jspd) )
ELSE
......@@ -77,7 +77,7 @@ CONTAINS
qmtl = 0
!$OMP DO
! !$OMP DO
DO itype = 1,atoms%ntype
na = 1
DO i = 1, itype - 1
......@@ -88,11 +88,13 @@ CONTAINS
DO l = 0,atoms%lmax(itype)
CALL radfun(l,itype,ispin,enpara%el0(l,itype,ispin),vr(1,itype,ispin),atoms,&
f(1,1,l,ispin),g(1,1,l,ispin),usdus, nodeu,noded,wronk)
llp = (l* (l+1))/2 + l
DO j = 1,atoms%jri(itype)
s = denCoeffs%uu(l,itype,ispin)*( f(j,1,l,ispin)*f(j,1,l,ispin)+f(j,2,l,ispin)*f(j,2,l,ispin) )&
+ denCoeffs%dd(l,itype,ispin)*( g(j,1,l,ispin)*g(j,1,l,ispin)+g(j,2,l,ispin)*g(j,2,l,ispin) )&
+ 2*denCoeffs%du(l,itype,ispin)*( f(j,1,l,ispin)*g(j,1,l,ispin)+f(j,2,l,ispin)*g(j,2,l,ispin) )
rho(j,0,itype,ispin) = rho(j,0,itype,ispin)+ s/(atoms%neq(itype)*sfp_const)
moments%rhoLRes(j,0,llp,itype,ispin) = moments%rhoLRes(j,0,llp,itype,ispin)+ s/(atoms%neq(itype)*sfp_const)
ENDDO
ENDDO
......@@ -110,7 +112,7 @@ CONTAINS
denCoeffs%cclo(1,1,itype,ispin),denCoeffs%acnmt(0,1,1,itype,ispin),&
denCoeffs%bcnmt(0,1,1,itype,ispin),denCoeffs%ccnmt(1,1,1,itype,ispin),&
f(1,1,0,ispin),g(1,1,0,ispin),&
rho(:,0:,itype,ispin),qmtllo)
rho(:,0:,itype,ispin),qmtllo,moments%rhoLRes(:,0:,:,itype,ispin))
!---> l-decomposed density for each atom type
......@@ -146,6 +148,7 @@ CONTAINS
+ denCoeffs%dunmt(llp,lh,itype,ispin)*(g(j,1,l,ispin)*f(j,1,lp,ispin)&
+ g(j,2,l,ispin)*f(j,2,lp,ispin) )
rho(j,lh,itype,ispin) = rho(j,lh,itype,ispin)+ s/atoms%neq(itype)
moments%rhoLRes(j,lh,llp,itype,ispin) = moments%rhoLRes(j,lh,llp,itype,ispin)+ s/atoms%neq(itype)
ENDDO
ENDDO
ENDDO
......@@ -183,6 +186,7 @@ CONTAINS
!---> calculate off-diagonal part of the density matrix
!---> spherical component
DO l = 0,atoms%lmax(itype)
llp = (l* (l+1))/2 + l
DO j = 1,atoms%jri(itype)
cs = denCoeffsOffdiag%uu21(l,itype)*( f(j,1,l,2)*f(j,1,l,1) +f(j,2,l,2)*f(j,2,l,1) )&
+ denCoeffsOffdiag%ud21(l,itype)*( f(j,1,l,2)*g(j,1,l,1) +f(j,2,l,2)*g(j,2,l,1) )&
......@@ -192,6 +196,8 @@ CONTAINS
rho21=CONJG(cs)/(atoms%neq(itype)*sfp_const)
rho(j,0,itype,3)=rho(j,0,itype,3)+REAL(rho21)
rho(j,0,itype,4)=rho(j,0,itype,4)+imag(rho21)
moments%rhoLRes(j,0,llp,itype,3) = moments%rhoLRes(j,0,llp,itype,3)+ REAL(conjg(cs)/(atoms%neq(itype)*sfp_const))
moments%rhoLRes(j,0,llp,itype,4) = moments%rhoLRes(j,0,llp,itype,4)+ AIMAG(conjg(cs)/(atoms%neq(itype)*sfp_const))
ENDDO
ENDDO
......@@ -201,6 +207,7 @@ CONTAINS
DO l = 0,atoms%lmax(itype)
DO lp = 0,atoms%lmax(itype)
llp = lp*(atoms%lmax(itype)+1)+l+1
llpb = (MAX(l,lp)* (MAX(l,lp)+1))/2 + MIN(l,lp)
DO j = 1,atoms%jri(itype)
cs = denCoeffsOffdiag%uunmt21(llp,lh,itype)*(f(j,1,lp,2)*f(j,1,l,1)&
+ f(j,2,lp,2)*f(j,2,l,1) )+ denCoeffsOffdiag%udnmt21(llp,lh,itype)*(f(j,1,lp,2)*g(j,1,l,1)&
......@@ -211,6 +218,8 @@ CONTAINS
rho21=CONJG(cs)/atoms%neq(itype)
rho(j,lh,itype,3)=rho(j,lh,itype,3)+REAL(rho21)
rho(j,lh,itype,4)=rho(j,lh,itype,4)+imag(rho21)
moments%rhoLRes(j,lh,llpb,itype,3)= moments%rhoLRes(j,lh,llpb,itype,3) + REAL(conjg(cs)/atoms%neq(itype))
moments%rhoLRes(j,lh,llpb,itype,4)= moments%rhoLRes(j,lh,llpb,itype,4) + AIMAG(conjg(cs)/atoms%neq(itype))
ENDDO
ENDDO
ENDDO
......@@ -220,9 +229,9 @@ CONTAINS
ENDIF ! noco%l_mperp
ENDDO ! end of loop over atom types
!$OMP END DO
! !$OMP END DO
DEALLOCATE ( f,g)
!$OMP END PARALLEL
! !$OMP END PARALLEL
WRITE (6,FMT=8000)
8000 FORMAT (/,5x,'l-like charge',/,t6,'atom',t15,'s',t24,'p',&
......
cdn_mt/denMultipoleExp.f90 0 → 100644
View file @ e498c60c
MODULE m_denMultipoleExp
IMPLICIT NONE
CONTAINS
SUBROUTINE denMultipoleExp(input, mpi, atoms, sphhar, stars, sym, cell, oneD, den)
USE m_types
USE m_constants
USE m_mpmom
TYPE(t_input), INTENT(IN) :: input
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_stars), INTENT(IN) :: stars
TYPE(t_sym), INTENT(IN) :: sym
TYPE(t_cell), INTENT(IN) :: cell
TYPE(t_oneD), INTENT(IN) :: oneD
TYPE(t_potden), INTENT(IN) :: den
type(t_potden) :: workDen
COMPLEX :: qlm(-atoms%lmaxd:atoms%lmaxd,0:atoms%lmaxd,atoms%ntype)
IF(input%jspins == 2) THEN
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) 'Multipole expansion for spin-up density:'
WRITE(6,*) '======================================='
END IF
qlm = CMPLX(0.0,0.0)
workDen = den
CALL mpmom(input,mpi,atoms,sphhar,stars,sym,cell,oneD,workDen%pw(1:,1),workDen%mt(:,0:,1:,1),POTDEN_TYPE_DEN,qlm,.FALSE.)
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) '======================================='
END IF
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) 'Multipole expansion for spin-down density:'
WRITE(6,*) '======================================='
END IF
qlm = CMPLX(0.0,0.0)
CALL mpmom(input,mpi,atoms,sphhar,stars,sym,cell,oneD,workDen%pw(1:,2),workDen%mt(:,0:,1:,2),POTDEN_TYPE_DEN,qlm,.FALSE.)
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) '======================================='
END IF
END IF
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) 'Multipole expansion for charge density:'
WRITE(6,*) '======================================='
END IF
qlm = CMPLX(0.0,0.0)
workDen = den
IF(input%jspins == 2) CALL workDen%SpinsToChargeAndMagnetisation()
CALL mpmom(input,mpi,atoms,sphhar,stars,sym,cell,oneD,workDen%pw(1:,1),workDen%mt(:,0:,1:,1),POTDEN_TYPE_DEN,qlm,.FALSE.)
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) '======================================='
END IF
IF(input%jspins == 2) THEN
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) 'Multipole expansion for magnetization density:'
WRITE(6,*) '======================================='
END IF
qlm = CMPLX(0.0,0.0)
CALL mpmom(input,mpi,atoms,sphhar,stars,sym,cell,oneD,workDen%pw(1:,2),workDen%mt(:,0:,1:,2),POTDEN_TYPE_DEN,qlm,.FALSE.)
IF(mpi%irank.EQ.0) THEN
WRITE(6,*) '======================================='
END IF
END IF
END SUBROUTINE denMultipoleExp
END MODULE m_denMultipoleExp
cdn_mt/magDiMom.f90 0 → 100644
View file @ e498c60c
! Copyright (c) 2018 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_magDiMom
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This subroutine calculates intraatomic magnetic dipole moments.
!
! GM'2018
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE magDiMom(input,atoms,sphhar,noco,l_fmpl2,rho,magDipoles,elecDipoles)
USE m_constants
USE m_types
USE m_juDFT
USE m_rotdenmat
USE m_lattHarmsSphHarmsConv
USE m_gaunt
USE m_intgr
IMPLICIT NONE
TYPE(t_input), INTENT(IN) :: input
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_noco), INTENT(IN) :: noco
REAL, INTENT(IN) :: rho(:,0:,:,:) ! if l_fmpl last dimension is 4, otherwise 2.
LOGICAL, INTENT(IN) :: l_fmpl2
REAL, INTENT(INOUT) :: magDipoles(:,:)
REAL, INTENT(INOUT) :: elecDipoles(:,:)
REAL, ALLOCATABLE :: inRho(:,:,:,:)
COMPLEX, ALLOCATABLE :: rhoSphHarms(:,:,:,:), rhoTempSphHarms(:,:,:,:)
COMPLEX, ALLOCATABLE :: rhoSphHarmsR(:,:,:)
INTEGER :: iType, ilh, l, m, lm, lp, mp, lmp, i
REAL :: theta, phi, cdn11, cdn22
REAL :: magDipole(3), myCharge, elecDipole(3)
REAL :: constA
COMPLEX :: gauntA, gauntB, gauntC
COMPLEX :: cdn21
IF(input%jspins.EQ.1) RETURN
IF(.NOT.noco%l_noco) RETURN
!---> calculate the charge and magnetization density in the muffin tins
ALLOCATE(inRho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,4))
DO iType = 1,atoms%ntype
IF (.NOT.l_fmpl2) THEN
theta = noco%beta(iType)
phi = noco%alph(iType)
inRho(:,:,iType,1) = rho(:,:,iType,1) + rho(:,:,iType,2)
inRho(:,:,iType,2) = rho(:,:,iType,1) - rho(:,:,iType,2)
inRho(:,:,iType,3) = inRho(:,:,iType,2) * SIN(phi)*SIN(theta)
inRho(:,:,iType,4) = inRho(:,:,iType,2) * COS(theta)
inRho(:,:,iType,2) = inRho(:,:,iType,2) * COS(phi)*SIN(theta)
ELSE
DO ilh = 0,sphhar%nlh(atoms%ntypsy(iType))
DO i = 1,atoms%jri(iType)
cdn11 = rho(i,ilh,iType,1)
cdn22 = rho(i,ilh,iType,2)
cdn21 = CMPLX(rho(i,ilh,iType,3),rho(i,ilh,iType,4))
CALL rot_den_mat(noco%alph(iType),noco%beta(iType),cdn11,cdn22,cdn21)
inRho(i,ilh,iType,1) = cdn11 + cdn22
inRho(i,ilh,iType,2) = 2.0 * REAL(cdn21)
! Note: The minus sign in the following line is temporary to adjust for differences in the offdiagonal
! part of the density between this fleur version and ancient (v0.26) fleur.
inRho(i,ilh,iType,3) = -2.0 * AIMAG(cdn21)
inRho(i,ilh,iType,4) = cdn11 - cdn22
END DO
END DO
END IF
END DO
ALLOCATE (rhoSphHarms(atoms%jmtd,(atoms%lmaxd+1)**2,atoms%ntype,4))
ALLOCATE (rhoTempSphHarms(atoms%jmtd,(atoms%lmaxd+1)**2,atoms%ntype,4))
ALLOCATE (rhoSphHarmsR(atoms%jmtd,(atoms%lmaxd+1)**2,atoms%ntype))
rhoSphHarms = CMPLX(0.0,0.0)
DO i = 1, 4
DO iType = 1, atoms%ntype
CALL lattHarmsRepToSphHarms(atoms,sphhar,iType,inRho(:,0:,iType,i),rhoSphHarms(:,:,iType,i))
END DO
END DO
! electric dipole moment (start)
DO iType = 1, atoms%ntype
DO i = 1, atoms%jri(iType)
rhoSphHarmsR(i,:,iType) = rhoSphHarms(i,:,iType,1) * atoms%rmsh(i,iType)
END DO
END DO
constA = SQRT(2.0*pi_const/3.0)
rhoTempSphHarms = CMPLX(0.0,0.0)
DO iType = 1, atoms%ntype
DO lp = 0, MIN(2,atoms%lmax(iType))
DO mp = -lp, lp
DO l = 0, MIN(2,atoms%lmax(iType))
DO m = -l, l
!note 1: For refinement maybe I could make use of selection rules.
!note 2: ls for r^\hat is 1, ms is -1..1.
gauntA = gaunt1(lp,1,l,mp,-1,m,atoms%lmaxd)
gauntB = gaunt1(lp,1,l,mp,0,m,atoms%lmaxd)
gauntC = gaunt1(lp,1,l,mp,1,m,atoms%lmaxd)
lmp = lp*(lp+1) + mp + 1
lm = l*(l+1) + m + 1
DO i = 1, atoms%jri(iType)
rhoTempSphHarms(i,lmp,iType,2) = rhoTempSphHarms(i,lmp,iType,2) +&
constA*(gauntA-gauntC)*rhoSphHarmsR(i,lm,iType)
rhoTempSphHarms(i,lmp,iType,3) = rhoTempSphHarms(i,lmp,iType,3) +&
constA*CMPLX(0.0,1.0)*(gauntA+gauntC)*rhoSphHarmsR(i,lm,iType)
rhoTempSphHarms(i,lmp,iType,4) = rhoTempSphHarms(i,lmp,iType,4) +&
constA*SQRT(2.0)*gauntB*rhoSphHarmsR(i,lm,iType)
END DO
END DO
END DO
END DO
END DO
END DO
elecDipole = 0.0
DO iType = 1, atoms%ntype
CALL intgr3(REAL(rhoTempSphHarms(:,1,iType,2)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),elecDipole(1))
CALL intgr3(REAL(rhoTempSphHarms(:,1,iType,3)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),elecDipole(2))
CALL intgr3(REAL(rhoTempSphHarms(:,1,iType,4)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),elecDipole(3))
elecDipoles(:,iType) = elecDipole(:) * sfp_const
END DO
! electric dipole moment (end)
! WRITE(7534,*) '===================================================='
DO iType = 1, atoms%ntype
DO l = 0, 2
DO m = -l, l
magDipole(:) = 0.0
myCharge = 0.0
lm = l*(l+1) + m + 1
CALL intgr3(REAL(rhoSphHarms(:,lm,iType,1)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),myCharge)
CALL intgr3(REAL(rhoSphHarms(:,lm,iType,2)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(1))
CALL intgr3(REAL(rhoSphHarms(:,lm,iType,3)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(2))
CALL intgr3(REAL(rhoSphHarms(:,lm,iType,4)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(3))
! WRITE(7534,'(3i7,4e24.8)') iType, l, m, myCharge, magDipole(:)
END DO
END DO
rhoSphHarms(:,:,iType,1) = CMPLX(0.0,0.0)
END DO
constA = SQRT(2.0*pi_const/3.0)
DO iType = 1, atoms%ntype
DO lp = 0, MIN(2,atoms%lmax(iType))
DO mp = -lp, lp
DO l = 0, MIN(2,atoms%lmax(iType))
DO m = -l, l
!note 1: For refinement maybe I could make use of selection rules.
!note 2: ls for r^\hat is 1, ms is -1..1.
gauntA = gaunt1(lp,1,l,mp,-1,m,atoms%lmaxd)
gauntB = gaunt1(lp,1,l,mp,0,m,atoms%lmaxd)
gauntC = gaunt1(lp,1,l,mp,1,m,atoms%lmaxd)
lmp = lp*(lp+1) + mp + 1
lm = l*(l+1) + m + 1
DO i = 1, atoms%jri(iType)
rhoSphHarms(i,lmp,iType,1) = rhoSphHarms(i,lmp,iType,1) +&
constA*(gauntA-gauntC)*rhoSphHarms(i,lm,iType,2)
rhoSphHarms(i,lmp,iType,1) = rhoSphHarms(i,lmp,iType,1) +&
constA*CMPLX(0.0,1.0)*(gauntA+gauntC)*rhoSphHarms(i,lm,iType,3)
rhoSphHarms(i,lmp,iType,1) = rhoSphHarms(i,lmp,iType,1) +&
constA*SQRT(2.0)*gauntB*rhoSphHarms(i,lm,iType,4)
END DO
END DO
END DO
END DO
END DO
END DO
rhoTempSphHarms = CMPLX(0.0,0.0)
DO iType = 1, atoms%ntype
DO lp = 0, MIN(2,atoms%lmax(iType))
DO mp = -lp, lp
DO l = 0, MIN(2,atoms%lmax(iType))
DO m = -l, l
!note 1: For refinement maybe I could make use of selection rules.
!note 2: ls for r^\hat is 1, ms is -1..1.
gauntA = gaunt1(lp,1,l,mp,-1,m,atoms%lmaxd)
gauntB = gaunt1(lp,1,l,mp,0,m,atoms%lmaxd)
gauntC = gaunt1(lp,1,l,mp,1,m,atoms%lmaxd)
lmp = lp*(lp+1) + mp + 1
lm = l*(l+1) + m + 1
DO i = 1, atoms%jri(iType)
rhoTempSphHarms(i,lmp,iType,2) = rhoTempSphHarms(i,lmp,iType,2) +&
constA*(gauntA-gauntC)*rhoSphHarms(i,lm,iType,1)
rhoTempSphHarms(i,lmp,iType,3) = rhoTempSphHarms(i,lmp,iType,3) +&
constA*CMPLX(0.0,1.0)*(gauntA+gauntC)*rhoSphHarms(i,lm,iType,1)
rhoTempSphHarms(i,lmp,iType,4) = rhoTempSphHarms(i,lmp,iType,4) +&
constA*SQRT(2.0)*gauntB*rhoSphHarms(i,lm,iType,1)
END DO
END DO
END DO
END DO
END DO
END DO
DO iType = 1, atoms%ntype
DO l = 0, atoms%lmax(iType)
DO m = -l, l
lm = l*(l+1) + m + 1
DO i = 1, atoms%jri(iType)
rhoSphHarms(i,lm,iType,2) = rhoSphHarms(i,lm,iType,2) - 3.0 * rhoTempSphHarms(i,lm,iType,2)
rhoSphHarms(i,lm,iType,3) = rhoSphHarms(i,lm,iType,3) - 3.0 * rhoTempSphHarms(i,lm,iType,3)
rhoSphHarms(i,lm,iType,4) = rhoSphHarms(i,lm,iType,4) - 3.0 * rhoTempSphHarms(i,lm,iType,4)
END DO
END DO
END DO
END DO
DO iType = 1, atoms%ntype
DO i = 1, atoms%jri(iType)
IF (ANY(AIMAG(rhoSphHarms(i,1,iType,:)).GT.1.0e-11)) THEN
WRITE(6,*) 'imaginary part too large!'
END IF
END DO
END DO
magDipole = 0.0
DO iType = 1, atoms%ntype
CALL intgr3(REAL(rhoSphHarms(:,1,iType,2)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(1))
CALL intgr3(REAL(rhoSphHarms(:,1,iType,3)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(2))
CALL intgr3(REAL(rhoSphHarms(:,1,iType,4)),atoms%rmsh(:,iType),atoms%dx(iType),atoms%jri(iType),magDipole(3))
magDipoles(:,iType) = magDipole(:) * sfp_const
END DO
END SUBROUTINE magDiMom
END MODULE m_magDiMom
cdn_mt/resMoms.f90 0 → 100644
View file @ e498c60c
! Copyright (c) 2018 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_resMoms
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This subroutine calculates and writes out intraatomic electric and magnetic dipole
! moments resolved with respect to their orbital (angular momentum) origins.
!
! GM'2018
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE resMoms(input,atoms,sphhar,noco,den,rhoLRes)
USE m_constants
USE m_types
USE m_juDFT
USE m_magDiMom
IMPLICIT NONE
TYPE(t_input), INTENT(IN) :: input
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_noco), INTENT(IN) :: noco
TYPE(t_potden), INTENT(IN) :: den
REAL, INTENT(IN) :: rhoLRes(:,0:,0:,:,:)
REAL, ALLOCATABLE :: rhoTemp(:,:,:,:)
REAL :: t_op(3,atoms%ntype), elecDip(3,atoms%ntype)
REAL :: res_T_op(3,atoms%ntype,0:(atoms%lmaxd*(atoms%lmaxd+1))/2+atoms%lmaxd)
REAL :: resElecDip(3,atoms%ntype,0:(atoms%lmaxd*(atoms%lmaxd+1))/2+atoms%lmaxd)
INTEGER :: iType, l, lp, llp
IF(input%jspins.EQ.1) RETURN
IF(.NOT.noco%l_noco) RETURN
t_op = 0.0
res_T_op = 0.0
elecDip = 0.0
resElecDip = 0.0
ALLOCATE(rhoTemp(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,4))
rhoTemp = 0.0
rhoTemp(:,:,:,1) = den%mt(:,:,:,1)
rhoTemp(:,:,:,2) = den%mt(:,:,:,2)
IF (noco%l_mperp) THEN
rhoTemp(:,:,:,3) = den%mt(:,:,:,3)
rhoTemp(:,:,:,4) = den%mt(:,:,:,4)
! WRITE(5000,'(f15.8)') den%mt(:,:,:,3)
! WRITE(5000,'(f15.8)') den%mt(:,:,:,4)
END IF
CALL magDiMom(input,atoms,sphhar,noco,noco%l_mperp,rhoTemp,t_op,elecDip)
DO l = 0, atoms%lmaxd
DO lp = 0, l
llp = (l* (l+1))/2 + lp
rhoTemp = 0.0
rhoTemp(:,:,:,1) = rhoLRes(:,:,llp,:,1)
rhoTemp(:,:,:,2) = rhoLRes(:,:,llp,:,2)
rhoTemp(:,:,:,3) = rhoLRes(:,:,llp,:,3)
rhoTemp(:,:,:,4) = rhoLRes(:,:,llp,:,4)
CALL magDiMom(input,atoms,sphhar,noco,noco%l_mperp,rhoTemp,res_T_op(:,:,llp),resElecDip(:,:,llp))
END DO
END DO
DO iType = 1, atoms%ntype
WRITE(6,*) 'Intraatomic electric and magnetic dipole moments for atom type ', iType,':'
WRITE(6,'(a)') ' lowL largeL p_x p_y p_z t_x t_y t_z'
WRITE(6,'(a,6f15.8)') 'Overall: ', elecDip(:,iType), t_op(:,iType)
DO l = 0, atoms%lmax(iType)
DO lp = 0, l
llp = (l* (l+1))/2 + lp
IF(ALL(ABS(res_T_op(:,iType,llp)).LT.1.0e-8).AND.&
ALL(ABS(resElecDip(:,iType,llp)).LT.1.0e-8)) CYCLE
WRITE(6,'(a,2i6,6f15.8)') ' ', lp, l, resElecDip(:,iType,llp),res_T_op(:,iType,llp)
END DO
END DO
END DO
END SUBROUTINE resMoms
END MODULE m_resMoms
cdn_mt/rhosphnlo.f90
View file @ e498c60c
......@@ -13,7 +13,7 @@ MODULE m_rhosphnlo
!***********************************************************************
CONTAINS
SUBROUTINE rhosphnlo(itype,atoms,sphhar, uloulopn,dulon,uulon,&
ello,vr, aclo,bclo,cclo,acnmt,bcnmt,ccnmt,f,g, rho,qmtllo)
ello,vr, aclo,bclo,cclo,acnmt,bcnmt,ccnmt,f,g, rho,qmtllo,rhoLRes)
USE m_constants, ONLY : c_light,sfp_const
USE m_radsra
......@@ -36,11 +36,12 @@ CONTAINS
REAL, INTENT (IN) :: f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd)
REAL, INTENT (INOUT) :: qmtllo(0:atoms%lmaxd)
REAL, INTENT (INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd)
REAL, INTENT (INOUT) :: rhoLRes(atoms%jmtd,0:sphhar%nlhd,0:(atoms%lmaxd*(atoms%lmaxd+1))/2+atoms%lmaxd)