...
 
Commits (25)
......@@ -110,10 +110,10 @@
! ..
! .. Array Arguments ..
COMPLEX,INTENT (INOUT) :: qpw(stars%ng3,input%jspins)
COMPLEX,INTENT (INOUT) :: rhtxy(vacuum%nmzxyd,oneD%odi%n2d-1,2,input%jspins)
COMPLEX,INTENT (INOUT) :: rhtxy(vacuum%nmzxy,oneD%odi%n2d-1,2,input%jspins)
REAL, INTENT (INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
REAL, INTENT (INOUT) :: rht(vacuum%nmzd,2,input%jspins)
REAL, INTENT (INOUT) :: rh(DIMENSION%msh,atoms%ntype)
REAL, INTENT (INOUT) :: rht(vacuum%nmz,2,input%jspins)
REAL, INTENT (INOUT) :: rh(atoms%mshd,atoms%ntype)
! ..
! .. Local Scalars ..
COMPLEX czero,carg,VALUE,slope,c_ph
......@@ -127,7 +127,7 @@
! .. Local Arrays ..
COMPLEX, ALLOCATABLE :: qpwc(:)
REAL acoff(atoms%ntype),alpha(atoms%ntype),rho_out(2)
REAL rat(DIMENSION%msh,atoms%ntype)
REAL rat(atoms%mshd,atoms%ntype)
INTEGER mshc(atoms%ntype)
REAL fJ(-oneD%odi%M:oneD%odi%M),dfJ(-oneD%odi%M:oneD%odi%M)
! ..
......@@ -174,7 +174,7 @@
! (2) cut_off core tails from noise
!
#ifdef CPP_MPI
CALL MPI_BCAST(rh,DIMENSION%msh*atoms%ntype,CPP_MPI_REAL,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(rh,atoms%mshd*atoms%ntype,CPP_MPI_REAL,0,mpi%mpi_comm,ierr)
#endif
nloop: DO n = 1 , atoms%ntype
IF ((atoms%ncst(n).GT.0).OR.l_st) THEN
......@@ -182,13 +182,13 @@
rat(j,n) = atoms%rmsh(j,n)
ENDDO
dxx = EXP(atoms%dx(n))
DO j = atoms%jri(n) + 1 , DIMENSION%msh
DO j = atoms%jri(n) + 1 , atoms%mshd
rat(j,n) = rat(j-1,n)*dxx
ENDDO
DO j = atoms%jri(n) - 1 , DIMENSION%msh
DO j = atoms%jri(n) - 1 , atoms%mshd
rh(j,n) = rh(j,n)/ (fpi_const*rat(j,n)*rat(j,n))
ENDDO
DO j = DIMENSION%msh , atoms%jri(n) , -1
DO j = atoms%mshd , atoms%jri(n) , -1
IF ( rh(j,n) .GT. tol_14 ) THEN
mshc(n) = j
CYCLE nloop
......@@ -492,11 +492,11 @@
type(t_atoms) ,intent(in) :: atoms
integer ,intent(in) :: mshc(atoms%ntype)
real ,intent(in) :: alpha(atoms%ntype), tol_14
real ,intent(in) :: rh(DIMENSION%msh,atoms%ntype)
real ,intent(in) :: rh(atoms%mshd,atoms%ntype)
real ,intent(in) :: acoff(atoms%ntype)
type(t_stars) ,intent(in) :: stars
integer ,intent(in) :: method2
real ,intent(in) :: rat(DIMENSION%msh,atoms%ntype)
real ,intent(in) :: rat(atoms%mshd,atoms%ntype)
type(t_cell) ,intent(in) :: cell
type(t_oneD) ,intent(in) :: oneD
type(t_sym) ,intent(in) :: sym
......@@ -682,8 +682,8 @@
integer ,intent(in) :: jri
real ,intent(in) :: dx
integer ,intent(in) :: mshc
real ,intent(in) :: rat(DIMENSION%msh)
real ,intent(in) :: rh(DIMENSION%msh)
real ,intent(in) :: rat(atoms%mshd)
real ,intent(in) :: rh(atoms%mshd)
real ,intent(in) :: alpha
type(t_stars) ,intent(in) :: stars
type(t_cell) ,intent(in) :: cell
......@@ -697,7 +697,7 @@
logical tail
! ..Local arrays
real rhohelp(DIMENSION%msh)
real rhohelp(atoms%mshd)
zero = 0.0
DO k = 1,stars%ng3
......
......@@ -35,7 +35,7 @@ CONTAINS
INTEGER i,ivac,j,jspin,n,nz
! ..
! .. Local Arrays ..
REAL qmt(atoms%ntype),qvac(2),q2(vacuum%nmz),rht1(vacuum%nmzd,2,input%jspins)
REAL qmt(atoms%ntype),qvac(2),q2(vacuum%nmz),rht1(vacuum%nmz,2,input%jspins)
INTEGER, ALLOCATABLE :: lengths(:,:)
CHARACTER(LEN=20) :: attributes(6), names(6)
! ..
......
......@@ -165,8 +165,8 @@ SUBROUTINE cdnval(eig_id, mpi,kpts,jspin,noco,input,banddos,cell,atoms,enpara,st
END DO
IF (noco%l_mperp) CALL denCoeffsOffdiag%addRadFunScalarProducts(atoms,f,g,flo,iType)
IF (banddos%l_mcd) CALL mcd_init(atoms,input,dimension,vTot%mt(:,0,:,:),g,f,mcd,iType,jspin)
IF (l_coreSpec) CALL corespec_rme(atoms,input,iType,dimension%nstd,input%jspins,jspin,results%ef,&
dimension%msh,vTot%mt(:,0,:,:),f,g)
IF (l_coreSpec) CALL corespec_rme(atoms,input,iType,nstd_dim,input%jspins,jspin,results%ef,&
atoms%mshd,vTot%mt(:,0,:,:),f,g)
END DO
DEALLOCATE (f,g,flo)
......@@ -256,7 +256,7 @@ SUBROUTINE cdnval(eig_id, mpi,kpts,jspin,noco,input,banddos,cell,atoms,enpara,st
IF (noco%l_soc) CALL orbmom(atoms,noccbd,we,ispin,eigVecCoeffs,orb)
IF (input%l_f) CALL force%addContribsA21A12(input,atoms,dimension,sym,cell,oneD,enpara,&
usdus,eigVecCoeffs,noccbd,ispin,eig,we,results)
IF(l_coreSpec) CALL corespec_dos(atoms,usdus,ispin,dimension%lmd,kpts%nkpt,ikpt,dimension%neigd,&
IF(l_coreSpec) CALL corespec_dos(atoms,usdus,ispin,kpts%nkpt,ikpt,dimension%neigd,&
noccbd,results%ef,banddos%sig_dos,eig,we,eigVecCoeffs)
END DO ! end loop over ispin
IF (noco%l_mperp) CALL denCoeffsOffdiag%calcCoefficients(atoms,sphhar,sym,eigVecCoeffs,we,noccbd)
......
......@@ -38,13 +38,13 @@ CONTAINS
INTEGER, INTENT (in) :: kvac3(DIMENSION%nv2d)
REAL, INTENT (in) :: bkpt(3),qssbti
REAL, INTENT (in) :: vz(vacuum%nmzd)
REAL, INTENT (in) :: vz(vacuum%nmz)
REAL, INTENT (out):: udz(DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: uz(DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: dudz(DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: duz(DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: u(vacuum%nmzd,DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: ud(vacuum%nmzd,DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: u(vacuum%nmz,DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: ud(vacuum%nmz,DIMENSION%nv2d,-vM:vM)
REAL, INTENT (out):: ddnv(DIMENSION%nv2d,-vM:vM)
! ..local scalars..
REAL ev,scale,xv,yv,vzero,v1
......@@ -53,9 +53,9 @@ CONTAINS
! .. local arrays..
REAL wdz(DIMENSION%nv2d,-vM:vM),wz(DIMENSION%nv2d,-vM:vM)
REAL dwdz(DIMENSION%nv2d,-vM:vM),dwz(DIMENSION%nv2d,-vM:vM)
REAL v(3),x(vacuum%nmzd)
REAL vr0(vacuum%nmzd)
REAL w(vacuum%nmzd,DIMENSION%nv2d,-vM:vM),wd(vacuum%nmzd,DIMENSION%nv2d,-vM:vM)
REAL v(3),x(vacuum%nmz)
REAL vr0(vacuum%nmz)
REAL w(vacuum%nmz,DIMENSION%nv2d,-vM:vM),wd(vacuum%nmz,DIMENSION%nv2d,-vM:vM)
! wronksian for the schrodinger equation given by an identity
......
......@@ -7,7 +7,7 @@
MODULE m_prpqfftmap
use m_juDFT
CONTAINS
SUBROUTINE prp_qfft_map(stars,sym,input, igq2_fft,igq_fft)
SUBROUTINE prp_qfft_map(stars,sym,input)
!*********************************************************************
! This subroutine prepares the pointer which identifies a
! threedimensional g-vector in the positive domain of the
......@@ -25,11 +25,9 @@ CONTAINS
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_stars),INTENT(INOUT):: stars
!
!
INTEGER igq2_fft(0:stars%kq1_fft*stars%kq2_fft-1),igq_fft(0:stars%kq1_fft*stars%kq2_fft*stars%kq3_fft-1)
!
!---> local variables
!
LOGICAL new
......@@ -87,11 +85,11 @@ CONTAINS
if(im.lt.0) im=im+stars%kq2_fft
if(in.lt.0) in=in+stars%kq3_fft
iv1d = in*ifftq2 + im*ifftq1 + il
igq_fft(kidx)=iv1d
stars%igq_fft(kidx)=iv1d
kidx=kidx+1
IF (input%film.AND.(stars%kv3(3,istr).EQ.0)) THEN
iv1d = im*ifftq1 + il
igq2_fft(kid2x)=iv1d
stars%igq2_fft(kid2x)=iv1d
kid2x=kid2x+1
ENDIF
ENDIF
......
......@@ -72,7 +72,7 @@ CONTAINS
! .. Array Arguments ..
REAL, INTENT(IN) :: evac(2,input%jspins)
REAL, INTENT(IN) :: we(DIMENSION%neigd)
REAL :: vz(vacuum%nmzd,2) ! Note this breaks the INTENT(IN) from cdnval. It may be read from a file in this subroutine.
REAL :: vz(vacuum%nmz,2) ! Note this breaks the INTENT(IN) from cdnval. It may be read from a file in this subroutine.
! STM-Arguments
REAL, INTENT (IN) :: eig(DIMENSION%neigd)
! local STM variables
......@@ -139,24 +139,24 @@ CONTAINS
CALL timestart("vacden")
ALLOCATE ( ac(DIMENSION%nv2d,DIMENSION%neigd,input%jspins),bc(DIMENSION%nv2d,DIMENSION%neigd,input%jspins),dt(DIMENSION%nv2d),&
& dte(DIMENSION%nv2d),du(vacuum%nmzd),ddu(vacuum%nmzd,DIMENSION%nv2d),due(vacuum%nmzd),&
& ddue(vacuum%nmzd,DIMENSION%nv2d),t(DIMENSION%nv2d),te(DIMENSION%nv2d),&
& tei(DIMENSION%nv2d,input%jspins),u(vacuum%nmzd,DIMENSION%nv2d,input%jspins),ue(vacuum%nmzd,DIMENSION%nv2d,input%jspins),&
& v(3),yy(vacuum%nmzd))
& dte(DIMENSION%nv2d),du(vacuum%nmz),ddu(vacuum%nmz,DIMENSION%nv2d),due(vacuum%nmz),&
& ddue(vacuum%nmz,DIMENSION%nv2d),t(DIMENSION%nv2d),te(DIMENSION%nv2d),&
& tei(DIMENSION%nv2d,input%jspins),u(vacuum%nmz,DIMENSION%nv2d,input%jspins),ue(vacuum%nmz,DIMENSION%nv2d,input%jspins),&
& v(3),yy(vacuum%nmz))
IF (oneD%odi%d1) THEN
ALLOCATE ( ac_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,DIMENSION%neigd,input%jspins),&
& bc_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,DIMENSION%neigd,input%jspins),&
& dt_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& dte_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& du_1(vacuum%nmzd,-oneD%odi%mb:oneD%odi%mb),&
& ddu_1(vacuum%nmzd,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& due_1(vacuum%nmzd,-oneD%odi%mb:oneD%odi%mb),&
& ddue_1(vacuum%nmzd,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& du_1(vacuum%nmz,-oneD%odi%mb:oneD%odi%mb),&
& ddu_1(vacuum%nmz,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& due_1(vacuum%nmz,-oneD%odi%mb:oneD%odi%mb),&
& ddue_1(vacuum%nmz,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& t_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& te_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb),&
& tei_1(DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,input%jspins),&
& u_1(vacuum%nmzd,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,input%jspins),&
& ue_1(vacuum%nmzd,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,input%jspins) )
& u_1(vacuum%nmz,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,input%jspins),&
& ue_1(vacuum%nmz,DIMENSION%nv2d,-oneD%odi%mb:oneD%odi%mb,input%jspins) )
END IF ! oneD%odi%d1
!
......@@ -683,7 +683,7 @@ CONTAINS
!
! ----> either integrated LDOS(z1,z2) or LDOS(z1)
!
IF (input%integ) THEN
IF (vacuum%integ) THEN
ll = 1
DO ii = vacuum%izlay(jj,1),vacuum%izlay(jj,2)
ui = u(ii,l,jspin)
......@@ -738,7 +738,7 @@ CONTAINS
!
! ---> either integrated (z1,z2) or slice (z1)
!
IF (input%integ) THEN
IF (vacuum%integ) THEN
ll = 1
DO ii = vacuum%izlay(jj,1),vacuum%izlay(jj,2)
ui = u(ii,l,ispin)
......@@ -796,7 +796,7 @@ CONTAINS
!
! ---> either integrated (z1,z2) or slice (z1)
!
IF (input%integ) THEN
IF (vacuum%integ) THEN
ll = 1
DO ii = vacuum%izlay(jj,1), vacuum%izlay(jj,2)
ui = u(ii,l,jspin)
......
......@@ -47,10 +47,10 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
REAL :: seig, rhoint, momint
LOGICAL, PARAMETER :: l_st=.FALSE.
REAL :: rh(dimension%msh,atoms%ntype,input%jspins)
REAL :: rh(atoms%mshd,atoms%ntype,input%jspins)
REAL :: qint(atoms%ntype,input%jspins)
REAL :: tec(atoms%ntype,input%jspins)
REAL :: rhTemp(dimension%msh,atoms%ntype,input%jspins)
REAL :: rhTemp(atoms%mshd,atoms%ntype,input%jspins)
results%seigc = 0.0
IF (mpi%irank.EQ.0) THEN
......@@ -62,12 +62,7 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
END IF
IF (input%kcrel.EQ.0) THEN
! Generate input file ecore for subsequent GW calculation
! 11.2.2004 Arno Schindlmayr
IF ((input%gw.eq.1 .or. input%gw.eq.3).AND.(mpi%irank.EQ.0)) THEN
OPEN (15,file='ecore',status='unknown', action='write',form='unformatted')
END IF
rh = 0.0
tec = 0.0
qint = 0.0
......@@ -138,7 +133,6 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
IF (mpi%irank.EQ.0) THEN
CALL writeCoreDensity(input,atoms,dimension,rhTemp,tec,qint)
END IF
IF ((input%gw.eq.1 .or. input%gw.eq.3).AND.(mpi%irank.EQ.0)) CLOSE(15)
END IF
END SUBROUTINE cdncore
......
......@@ -36,6 +36,7 @@ include(mpi/CMakeLists.txt)
include(hybrid/CMakeLists.txt)
include(eels/CMakeLists.txt)
include(types/CMakeLists.txt)
include(types/setup_types/CMakeLists.txt)
include(wannier/CMakeLists.txt)
include(wannier/uhu/CMakeLists.txt)
include(forcetheorem/CMakeLists.txt)
......
......@@ -23,7 +23,7 @@ CONTAINS
REAL, INTENT (IN) :: sume
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: rhochr(:),rhospn(:)!(dimension%msh)
REAL, INTENT (IN) :: rhochr(:),rhospn(:)!(atoms%mshd)
REAL, INTENT (IN) :: vrs(:,:,:)!(atoms%jmtd,atoms%ntype,input%jspins)
REAL, INTENT (OUT) :: tecs(:,:)!(atoms%ntype,input%jspins)
REAL, INTENT (OUT) :: qints(:,:)!(atoms%ntype,input%jspins)
......
......@@ -13,7 +13,7 @@ CONTAINS
! *******************************************************
USE m_juDFT
USE m_intgr, ONLY : intgr3,intgr0,intgr1
USE m_constants, ONLY : c_light,sfp_const
USE m_constants, ONLY : c_light,sfp_const,nstd_dim
USE m_setcor
USE m_differ
USE m_types
......@@ -31,7 +31,7 @@ CONTAINS
! .. Array Arguments ..
REAL, INTENT(IN) :: vr(atoms%jmtd,atoms%ntype)
REAL, INTENT(INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
REAL, INTENT(INOUT) :: rhc(DIMENSION%msh,atoms%ntype,input%jspins)
REAL, INTENT(INOUT) :: rhc(atoms%mshd,atoms%ntype,input%jspins)
REAL, INTENT(INOUT) :: qint(atoms%ntype,input%jspins)
REAL, INTENT(INOUT) :: tec(atoms%ntype,input%jspins)
! ..
......@@ -42,10 +42,10 @@ CONTAINS
! ..
! .. Local Arrays ..
REAL rhcs(DIMENSION%msh),rhoc(DIMENSION%msh),rhoss(DIMENSION%msh),vrd(DIMENSION%msh),f(0:3)
REAL occ(DIMENSION%nstd),a(DIMENSION%msh),b(DIMENSION%msh),ain(DIMENSION%msh),ahelp(DIMENSION%msh)
REAL occ_h(DIMENSION%nstd,2)
INTEGER kappa(DIMENSION%nstd),nprnc(DIMENSION%nstd)
REAL rhcs(atoms%mshd),rhoc(atoms%mshd),rhoss(atoms%mshd),vrd(atoms%mshd),f(0:3)
REAL occ(nstd_dim),a(atoms%mshd),b(atoms%mshd),ain(atoms%mshd),ahelp(atoms%mshd)
REAL occ_h(nstd_dim,2)
INTEGER kappa(nstd_dim),nprnc(nstd_dim)
CHARACTER(LEN=20) :: attributes(6)
REAL stateEnergies(29)
! ..
......@@ -56,7 +56,7 @@ CONTAINS
DO n = 1,atoms%ntype
rnot = atoms%rmsh(1,n) ; dxx = atoms%dx(n)
ncmsh = NINT( LOG( (atoms%rmt(n)+10.0)/rnot ) / dxx + 1 )
ncmsh = MIN( ncmsh, DIMENSION%msh )
ncmsh = MIN( ncmsh, atoms%mshd )
! ---> update spherical charge density
DO i = 1,atoms%jri(n)
rhoc(i) = rhc(i,n,jspin)
......@@ -94,7 +94,7 @@ CONTAINS
rnot = atoms%rmsh(1,jatom)
d = EXP(atoms%dx(jatom))
ncmsh = NINT( LOG( (atoms%rmt(jatom)+10.0)/rnot ) / dxx + 1 )
ncmsh = MIN( ncmsh, DIMENSION%msh )
ncmsh = MIN( ncmsh, atoms%mshd )
rn = rnot* (d** (ncmsh-1))
WRITE (6,FMT=8000) z,rnot,dxx,atoms%jri(jatom)
WRITE (16,FMT=8000) z,rnot,dxx,atoms%jri(jatom)
......@@ -129,9 +129,7 @@ CONTAINS
nst = atoms%ncst(jatom) ! for lda+U
IF (input%gw==1 .OR. input%gw==3)&
& WRITE(15) nst,atoms%rmsh(1:atoms%jri(jatom),jatom)
stateEnergies = 0.0
DO korb = 1,nst
IF (occ(korb) /= 0.0) THEN
......@@ -146,9 +144,7 @@ CONTAINS
WRITE (6,FMT=8010) fn,fl,fj,e,weight
WRITE (16,FMT=8010) fn,fl,fj,e,weight
IF (ierr/=0) CALL juDFT_error("error in core-level routine" ,calledby ="cored")
IF (input%gw==1 .OR. input%gw==3) WRITE (15) NINT(fl),weight,e,&
a(1:atoms%jri(jatom)),b(1:atoms%jri(jatom))
sume = sume + weight*e/input%jspins
DO j = 1,ncmsh
rhcs(j) = weight* (a(j)**2+b(j)**2)
......@@ -166,7 +162,7 @@ CONTAINS
ENDDO
rhc(1:ncmsh,jatom,jspin) = rhoss(1:ncmsh) / input%jspins
rhc(ncmsh+1:DIMENSION%msh,jatom,jspin) = 0.0
rhc(ncmsh+1:atoms%mshd,jatom,jspin) = 0.0
seig = seig + atoms%neq(jatom)*sume
DO i = 1,nm
......
......@@ -23,7 +23,7 @@ CONTAINS
! .. Array Arguments ..
REAL , INTENT (IN) :: vrs(atoms%jmtd,atoms%ntype,input%jspins)
REAL, INTENT (INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype,input%jspins)
REAL, INTENT (OUT) :: rhc(DIMENSION%msh,atoms%ntype,input%jspins),qints(atoms%ntype,input%jspins)
REAL, INTENT (OUT) :: rhc(atoms%mshd,atoms%ntype,input%jspins),qints(atoms%ntype,input%jspins)
! ..
! .. Local Scalars ..
REAL dxx,rnot,sume,t2,t2b,z,t1,rr,d,v1,v2
......@@ -31,9 +31,9 @@ CONTAINS
LOGICAL exetab
! ..
! .. Local Arrays ..
REAL br(atoms%jmtd,atoms%ntype),brd(DIMENSION%msh),etab(100,atoms%ntype),&
rhcs(atoms%jmtd,atoms%ntype,input%jspins),rhochr(DIMENSION%msh),rhospn(DIMENSION%msh),&
tecs(atoms%ntype,input%jspins),vr(atoms%jmtd,atoms%ntype),vrd(DIMENSION%msh)
REAL br(atoms%jmtd,atoms%ntype),brd(atoms%mshd),etab(100,atoms%ntype),&
rhcs(atoms%jmtd,atoms%ntype,input%jspins),rhochr(atoms%mshd),rhospn(atoms%mshd),&
tecs(atoms%ntype,input%jspins),vr(atoms%jmtd,atoms%ntype),vrd(atoms%mshd)
INTEGER nkmust(atoms%ntype),ntab(100,atoms%ntype),ltab(100,atoms%ntype)
! ..
......@@ -76,7 +76,7 @@ CONTAINS
CALL etabinit(atoms,DIMENSION,input, vr, etab,ntab,ltab,nkmust)
END IF
!
ncmsh = DIMENSION%msh
ncmsh = atoms%mshd
seig = 0.
! ---> set up densities
DO jatom = 1,atoms%ntype
......@@ -125,7 +125,7 @@ CONTAINS
z = atoms%zatom(jatom)
dxx = atoms%dx(jatom)
CALL spratm(DIMENSION%msh,vrd,brd,z,rnot,dxx,ncmsh,&
CALL spratm(atoms%mshd,vrd,brd,z,rnot,dxx,ncmsh,&
etab(1,jatom),ntab(1,jatom),ltab(1,jatom), sume,rhochr,rhospn)
seig = seig + atoms%neq(jatom)*sume
......@@ -144,12 +144,12 @@ CONTAINS
END DO
END IF
IF (input%jspins.EQ.2) THEN
DO j = 1,DIMENSION%msh
DO j = 1,atoms%mshd
rhc(j,jatom,input%jspins) = (rhochr(j)+rhospn(j))*0.5
rhc(j,jatom,1) = (rhochr(j)-rhospn(j))*0.5
ENDDO
ELSE
DO j = 1,DIMENSION%msh
DO j = 1,atoms%mshd
rhc(j,jatom,1) = rhochr(j)
END DO
END IF
......
......@@ -16,7 +16,7 @@ CONTAINS
SUBROUTINE etabinit(atoms,DIMENSION,input, vr,&
etab,ntab,ltab,nkmust)
USE m_constants, ONLY : c_light
USE m_constants, ONLY : c_light,nstd_dim
USE m_setcor
USE m_differ
USE m_types
......@@ -39,15 +39,15 @@ CONTAINS
INTEGER i,ic,iksh,ilshell,j,jatom,korb,l, nst,ncmsh ,nshell,ipos,ierr
! ..
! .. Local Arrays ..
INTEGER kappa(DIMENSION%nstd),nprnc(DIMENSION%nstd)
REAL eig(DIMENSION%nstd),occ(DIMENSION%nstd,1),vrd(DIMENSION%msh),a(DIMENSION%msh),b(DIMENSION%msh)
INTEGER kappa(nstd_dim),nprnc(nstd_dim)
REAL eig(nstd_dim),occ(nstd_dim,1),vrd(atoms%mshd),a(atoms%mshd),b(atoms%mshd)
! ..
!
c = c_light(1.0)
!
WRITE (6,FMT=8020)
!
ncmsh = DIMENSION%msh
ncmsh = atoms%mshd
! ---> set up densities
DO jatom = 1,atoms%ntype
z = atoms%zatom(jatom)
......@@ -70,10 +70,10 @@ CONTAINS
rr = atoms%rmt(jatom)
d = EXP(atoms%dx(jatom))
ELSE
t2 = vrd(atoms%jri(jatom))/ (atoms%jri(jatom)-DIMENSION%msh)
t2 = vrd(atoms%jri(jatom))/ (atoms%jri(jatom)-atoms%mshd)
ENDIF
IF (atoms%jri(jatom).LT.DIMENSION%msh) THEN
DO i = atoms%jri(jatom) + 1,DIMENSION%msh
IF (atoms%jri(jatom).LT.atoms%mshd) THEN
DO i = atoms%jri(jatom) + 1,atoms%mshd
if (input%l_core_confpot) THEN
rr = d*rr
vrd(i) = rr*( t2 + rr*t1 )
......@@ -91,7 +91,7 @@ CONTAINS
weight = 2*fj + 1.e0
fl = fj + (.5e0)*isign(1,kappa(korb))
e = -2* (z/ (fn+fl))**2
CALL differ(fn,fl,fj,c,z,dxx,rnot,rn,d,DIMENSION%msh,vrd,&
CALL differ(fn,fl,fj,c,z,dxx,rnot,rn,d,atoms%mshd,vrd,&
e, a,b,ierr)
IF (ierr/=0) CALL juDFT_error("error in core-levels",calledby="etabinit")
WRITE (6,FMT=8010) fn,fl,fj,e,weight
......
......@@ -47,10 +47,10 @@ CONTAINS
INTEGER,INTENT(IN):: ikpt,jspin ,nbands
!
! STM Arguments
COMPLEX, INTENT (IN) ::qstars(:,:,:,:) !(vacuum%nstars,DIMENSION%neigd,vacuum%layerd,2)
COMPLEX, INTENT (IN) ::qstars(:,:,:,:) !(vacuum%nstars,DIMENSION%neigd,vacuum%layers,2)
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: qvlay(:,:,:) !DIMENSION%neigd,vacuum%layerd,2)
REAL, INTENT (IN) :: qvlay(:,:,:) !DIMENSION%neigd,vacuum%layers,2)
REAL, INTENT (IN) :: qis(:,:,:)!(DIMENSION%neigd,kpts%nkpt,DIMENSION%jspd)
REAL, INTENT (IN) :: qvac(:,:,:,:) !(DIMENSION%neigd,2,kpts%nkpt,DIMENSION%jspd)
REAL, INTENT (IN) :: bkpt(3)
......
......@@ -83,7 +83,7 @@
ENDIF
ALLOCATE( qal(qdim,dimension%neigd,kpts%nkpt),&
& qval(vacuum%nstars*vacuum%layers*vacuum%nvac,dimension%neigd,kpts%nkpt),&
& qlay(dimension%neigd,vacuum%layerd,2))
& qlay(dimension%neigd,vacuum%layers,2))
IF (l_mcd) THEN
ALLOCATE(mcd_local(3*atoms%ntype*ncored,dimension%neigd,kpts%nkpt) )
ELSE
......
......@@ -33,7 +33,7 @@ CONTAINS
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: evac(2)
REAL, INTENT (IN) :: vz(:,:)!(vacuum%nmzd,2)
REAL, INTENT (IN) :: vz(:,:)!(vacuum%nmz,2)
INTEGER, INTENT (OUT) :: gvac1d(:),gvac2d(:) !(dimension%nv2d)
! ..
! .. Local Scalars
......
......@@ -363,7 +363,7 @@ MODULE m_corespec_eval
!
!-------------------------------------------------------------------------------
!
subroutine corespec_dos(atoms,usdus,ispin,lmd,nkpt,ikpt,&
subroutine corespec_dos(atoms,usdus,ispin,nkpt,ikpt,&
neigd,noccbd,efermi,sig_dos,eig,we,eigVecCoeffs)
IMPLICIT NONE
......@@ -373,7 +373,7 @@ MODULE m_corespec_eval
TYPE(t_eigVecCoeffs),INTENT(IN) :: eigVecCoeffs
! .. Scalar Arguments ..
integer, intent(in) :: ispin,lmd,nkpt,ikpt
integer, intent(in) :: ispin,nkpt,ikpt
integer, intent(in) :: neigd,noccbd
real, intent(in) :: efermi,sig_dos
! .. Array Arguments ..
......@@ -444,7 +444,7 @@ MODULE m_corespec_eval
enddo
write(36,*) ""
write(*,'(10i8)') atoms%llod,noccbd,atoms%nlod,atoms%nat,neigd,atoms%ntype,atoms%lmaxd
write(*,'(10i8)') lmd,atoms%ntype
WRITE(*,'(10i8)') atoms%lmaxd*(atoms%lmaxd+2),atoms%ntype
if(csi%verb.eq.1) write(*,*) ""
endif
......
......@@ -35,7 +35,7 @@ CONTAINS
END IF
CALL timestart("tlmplm")
CALL td%init(DIMENSION%lmplmd,DIMENSION%lmd,atoms%ntype,atoms%lmaxd,atoms%llod,SUM(atoms%nlo),&
CALL td%init(atoms%ntype,atoms%lmaxd,atoms%llod,SUM(atoms%nlo),&
DOT_PRODUCT(atoms%nlo,atoms%nlo+1)/2,input%jspins,&
(noco%l_noco.AND.noco%l_soc.AND..NOT.noco%l_ss).OR.noco%l_constr)!l_offdiag
......
......@@ -39,9 +39,9 @@ CONTAINS
INTEGER, INTENT (IN) :: m_cyl
! ..
! .. Array Arguments ..
COMPLEX, INTENT (INOUT) :: vxy(vacuum%nmzxyd,n2d_1-1,2)
COMPLEX, INTENT (INOUT) :: vxy(vacuum%nmzxy,n2d_1-1,2)
INTEGER, INTENT (OUT):: nv2(input%jspins)
REAL, INTENT (INOUT) :: vz(vacuum%nmzd,2,4)
REAL, INTENT (INOUT) :: vz(vacuum%nmz,2,4)
REAL, INTENT (IN) :: evac(2,input%jspins)
REAL, INTENT (IN) :: bkpt(3)
......@@ -127,7 +127,7 @@ CONTAINS
IF (noco%l_noco) THEN
!---> load the non-warping part of the potential
READ (25)((vz(imz,ivac,ipot),imz=1,vacuum%nmzd),ipot=1,4)
READ (25)((vz(imz,ivac,ipot),imz=1,vacuum%nmz),ipot=1,4)
npot = 3
ENDIF
......
......@@ -38,12 +38,12 @@ CONTAINS
! .. Array Arguments ..
INTEGER, INTENT (IN) :: nv2(input%jspins)
INTEGER, INTENT (IN) :: kvac3(DIMENSION%nv2d,input%jspins)
COMPLEX, INTENT (IN) :: vxy(vacuum%nmzxyd,n2d_1-1)
COMPLEX, INTENT (IN) :: vxy(vacuum%nmzxy,n2d_1-1)
COMPLEX, INTENT (OUT):: tddv(-vM:vM,-vM:vM,DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX, INTENT (OUT):: tduv(-vM:vM,-vM:vM,DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX, INTENT (OUT):: tudv(-vM:vM,-vM:vM,DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX, INTENT (OUT):: tuuv(-vM:vM,-vM:vM,DIMENSION%nv2d,DIMENSION%nv2d)
REAL, INTENT (IN) :: vz(vacuum%nmzd,2,4) ,evac(2,input%jspins)
REAL, INTENT (IN) :: vz(vacuum%nmz,2,4) ,evac(2,input%jspins)
REAL, INTENT (IN) :: bkpt(3)
REAL, INTENT (OUT):: udz(-vM:vM,DIMENSION%nv2d,input%jspins),uz(-vM:vM,DIMENSION%nv2d,input%jspins)
REAL, INTENT (OUT):: dudz(-vM:vM,DIMENSION%nv2d,input%jspins)
......@@ -59,10 +59,10 @@ CONTAINS
! .. Local Arrays ..
REAL wdz(-vM:vM,DIMENSION%nv2d,input%jspins),wz(-vM:vM,DIMENSION%nv2d,input%jspins)
REAL dwdz(-vM:vM,DIMENSION%nv2d,input%jspins),dwz(-vM:vM,DIMENSION%nv2d,input%jspins)
REAL u(vacuum%nmzd,-vM:vM,DIMENSION%nv2d,input%jspins),ud(vacuum%nmzd,-vM:vM,DIMENSION%nv2d,input%jspins)
REAL v(3),x(vacuum%nmzd)
REAL vr0(vacuum%nmzd,2,4)
REAL w(vacuum%nmzd,-vM:vM,DIMENSION%nv2d,input%jspins),wd(vacuum%nmzd,-vM:vM,DIMENSION%nv2d,input%jspins)
REAL u(vacuum%nmz,-vM:vM,DIMENSION%nv2d,input%jspins),ud(vacuum%nmz,-vM:vM,DIMENSION%nv2d,input%jspins)
REAL v(3),x(vacuum%nmz)
REAL vr0(vacuum%nmz,2,4)
REAL w(vacuum%nmz,-vM:vM,DIMENSION%nv2d,input%jspins),wd(vacuum%nmz,-vM:vM,DIMENSION%nv2d,input%jspins)
REAL qssbti(2)
! ..
......@@ -92,12 +92,12 @@ CONTAINS
v(3) = bkpt(3) + kvac3(ik,jspin) + qssbti(jspin)
ev = evac(ivac,jspin) - 0.5*DOT_PRODUCT(v,MATMUL(v,cell%bbmat))
! constructing of the 'pseudopotential'
DO i=1,vacuum%nmzd
DO i=1,vacuum%nmz
v1 = 1./(8.*((cell%z1+(i-1)*vacuum%delz)**2))&
-(m*m)/(2.*((cell%z1+(i-1)*vacuum%delz)**2))
vr0(i,ivac,jspin) = vz(i,ivac,jspin)-v1
ENDDO
vzero = vr0(vacuum%nmzd,ivac,jspin)
vzero = vr0(vacuum%nmz,ivac,jspin)
! obtaining solutions with the 'pseudopotential'
CALL vacuz(ev,vr0(:,ivac,jspin),vzero,vacuum%nmz,vacuum%delz,&
......
MODULE m_apws
use m_juDFT
!*********************************************************************
! determines the lapw list such that |k+G|<rkmax.
! bk(i) is the nk k-point given in internal (i.e. b1,b2,b3) units.
! m. weinert 1986
! unit 29 removed gb 2004
!*********************************************************************
! modified for explicit use of z-reflection symmetry in seclr4.f
! g. bihlmayer '96
! subroutine boxdim added to treat non-orthogonal lattice vectors
! s.bluegel, IFF, 18.Nov.97
!*********************************************************************
CONTAINS
!REMOVED and REPLACED by types_lapw
END MODULE m_apws
!--------------------------------------------------------------------------------
! Copyright (c) 2016 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_hsint
CONTAINS
SUBROUTINE hsint(input,noco,jij,stars, vpw,lapw,jspin,&
n_size,n_rank,bkpt,cell,atoms,l_real,hamOvlp)
!*********************************************************************
! initializes and sets up the hamiltonian and overlap matrices
! for the interstitial. only the lower triangle of the hermitian
! matrices are stored in compact real mode such that if h(i,j),
! i.ge.j, is hermitian and a is real, then
! a(i,j)=real( h(i,j) ) and a(j,i)=aimag( h(i,j) )
! m. weinert 1986
!
! For the eigenvector parallelization each pe calculates an equal share
! of columns labeled nc. Then the starting element of a columns nc is
!
! ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2
!
! and, if a non-collinear matrix has to be set up, the starting column
! for the second spin-direction is
!
! nc = int( 1. + (nv - n_rank - 1)/n_size ) + 1 .
!
! For this direction, the outer loop starts at
!
! istart = n_rank + (nc - 1)*n_size - nv . gb99
!
! for a lo-calculation nv has to be replaced by nv+nlotot gb01
!
!*********************************************************************
USE m_types
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_jij),INTENT(IN) :: jij
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(INOUT) :: lapw
TYPE(t_hamOvlp),INTENT(INOUT) :: hamOvlp
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: n_size,n_rank,jspin
! ..
! .. Array Arguments ..
COMPLEX, INTENT (INOUT) :: vpw(stars%ng3)
REAL, INTENT (IN) :: bkpt(3)
LOGICAL,INTENT(IN) :: l_real
! ..
! .. Local Scalars ..
COMPLEX th,ts,phase
REAL b1(3),b2(3),r2
INTEGER i,i1,i2,i3,ii,in,j,ig3,ispin,l,iloc
INTEGER istart,nc
COMPLEX ust1,vp1
COMPLEX, ALLOCATABLE :: vpw1(:) ! for J constants
! ..
! ..
!$OMP PARALLEL
if (l_real) THEN
!$OMP DO
do i = 1, size(hamOvlp%a_r)
hamOvlp%a_r(i)=0.0
end do
!OMP END DO
!$OMP DO
do i = 1, size(hamOvlp%b_r)
hamOvlp%b_r(i)=0.0
end do
!OMP END DO
ELSE
!$OMP DO
do i = 1, size(hamOvlp%a_c)
hamOvlp%a_c(i)=0.0
end do
!$OMP END DO
!$OMP DO
do i = 1, size(hamOvlp%b_c)
hamOvlp%b_c(i)=0.0
end do
!$OMP END DO
ENDIF
!$OMP END PARALLEL
ust1 = stars%ustep(1)
ispin = jspin
lapw%nmat = lapw%nv(ispin)
!---> pk non-collinear
IF (noco%l_noco) THEN
!---> determine spin-up spin-up part of Hamiltonian- and overlapp-matrix
!---> reload V_11
READ (25) (vpw(ig3),ig3=1,stars%ng3)
!--- J const
IF( jij%l_J) THEN
ALLOCATE ( vpw1(stars%ng3) )
READ (25) (vpw1(ig3),ig3=1,stars%ng3)
ENDIF
!--- J const
lapw%nmat = lapw%nv(1) + lapw%nv(2)
ispin = 1
!--- J const
IF (jij%l_J) THEN
DO i = 1,stars%ng3
vpw(i) = (vpw(i) + vpw1(i))/2.
END DO
ENDIF
!--- J const
vp1 = REAL(vpw(1))
ENDIF
!---> pk non-collinear
vp1 = vpw(1)
!---> loop over (k+g')
ii = 0
!$OMP PARALLEL DO SCHEDULE(dynamic) DEFAULT(none) &
!$OMP SHARED(n_rank,n_size,lapw,ispin,stars,input,bkpt,cell,vpw,ust1,vp1) &
!$OMP SHARED(l_real,hamOvlp)&
!$OMP PRIVATE(i,j,iloc,i1,i2,i3,in,phase,b1,b2,r2,th,ts)&
!$OMP FIRSTPRIVATE(ii)
DO i = n_rank+1, lapw%nv(ispin), n_size
!---> loop over (k+g)
DO j = 1,i - 1
ii = 0
DO iloc = n_rank+1,i-n_size,n_size
ii = ii + iloc
ENDDO
ii = ii + j
!--> determine index and phase factor
i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin)
i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin)
i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) CYCLE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
IF (input%l_useapw) THEN
b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin)
b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin)
b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin)
r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1)
th = phase*(0.5*r2*stars%ustep(in)+vpw(in))
ELSE
th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in))
ENDIF
!-APW_LO
!---> determine matrix element and store
ts = phase*stars%ustep(in)
if (l_real) THEN
hamOvlp%a_r(ii) = REAL(th)
hamOvlp%b_r(ii) = REAL(ts)
else
hamOvlp%a_c(ii) = th
hamOvlp%b_c(ii) = ts
endif
ENDDO
!---> diagonal term (g-g'=0 always first star)
ii = ii + 1
if (l_real) THEN
hamOvlp%a_r(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*REAL(ust1) + REAL(vp1)
hamOvlp%b_r(ii) = REAL(ust1)
else
hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1
hamOvlp%b_c(ii) = ust1
endif
ENDDO
!$OMP END PARALLEL DO
!---> pk non-collinear
IF (noco%l_noco) THEN
!+gb99
nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size )
istart = n_rank + nc*n_size - (lapw%nv(1)+atoms%nlotot)
! ii = (nv(1)+nlotot+1)*(nv(1)+nlotot+2)/2 - 1
ii = nc*(n_rank-n_size+1) + n_size*(nc+1)*nc/2 + lapw%nv(1)+atoms%nlotot
!-gb99
ispin = 2
!---> determine spin-down spin-down part of Hamiltonian- and ovlp-matrix
!---> reload V_22
!--- J constants
IF(.NOT.jij%l_J) THEN
READ (25) (vpw(ig3),ig3=1,stars%ng3)
vp1 = REAL(vpw(1))
ENDIF
!--- J constants
!---> loop over (k+g')
DO i = istart+1, lapw%nv(ispin), n_size
nc = nc + 1
!---> loop over (k+g)
DO j = 1,i - 1
!-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + nv(1) + j
ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + lapw%nv(1)+atoms%nlotot + j
!---> determine index and phase factor
i1 = lapw%k1(i,ispin) - lapw%k1(j,ispin)
i2 = lapw%k2(i,ispin) - lapw%k2(j,ispin)
i3 = lapw%k3(i,ispin) - lapw%k3(j,ispin)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) THEN
WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j
ELSE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
IF (input%l_useapw) THEN
b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin)
b1(2) = bkpt(2)+lapw%k2(i,ispin) ; b2(2) = bkpt(2)+lapw%k2(j,ispin)
b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin)
r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1)
th = phase*( 0.5*r2*stars%ustep(in) + vpw(in) )
ELSE
th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in))
ENDIF
!-APW_LO
ts = phase*stars%ustep(in)
hamOvlp%a_c(ii) = th
hamOvlp%b_c(ii) = ts
ENDIF
ENDDO
!---> diagonal term (g-g'=0 always first star)
!-gb99 ii = (nv(1)+i)*(nv(1)+i+1)/2
ii = ii + 1
hamOvlp%a_c(ii) = 0.5*lapw%rk(i,ispin)*lapw%rk(i,ispin)*ust1 + vp1
hamOvlp%b_c(ii) = ust1
ENDDO
!---> determine spin-down spin-up part of Hamiltonian- and ovlp-matrix
!---> reload real part of V_21
READ (25) (vpw(ig3),ig3=1,stars%ng3)
nc = INT( 1. + (lapw%nv(1)+atoms%nlotot - n_rank - 1)/n_size )
!
!---> loop over (k+g')
!
DO i = istart+1, lapw%nv(2), n_size
nc = nc + 1
!---> loop over (k+g)
DO j = 1,lapw%nv(1)
!-gb99 ii = (nv(1)+i-1)*(nv(1)+i)/2 + j
ii = (nc-1)*( n_rank - n_size + 1 ) + n_size*(nc-1)*nc/2 + j
!---> determine index and phase factor
i1 = lapw%k1(i,2) - lapw%k1(j,1)
i2 = lapw%k2(i,2) - lapw%k2(j,1)
i3 = lapw%k3(i,2) - lapw%k3(j,1)
in = stars%ig(i1,i2,i3)
IF (in.EQ.0) THEN
WRITE (*,*) 'HSINT: G-G'' not in star i,j= ',i,j
ELSE
hamOvlp%a_c(ii) = stars%rgphs(i1,i2,i3)*vpw(in)
!--- J constants
IF(jij%l_J) THEN
hamOvlp%a_c(ii) = 0
ENDIF
!--- J constants
ENDIF
ENDDO
ENDDO
!---> pk non-collinear
ENDIF
IF (jij%l_J) DEALLOCATE (vpw1)
RETURN
END SUBROUTINE hsint
END MODULE m_hsint
!--------------------------------------------------------------------------------
! Copyright (c) 2016 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_hsmt_blas
use m_juDFT
implicit none
CONTAINS
SUBROUTINE hsmt_blas(sym,atoms,isp,noco,cell,lapw,td,ud,gk,vk,fj,gj,smat,hmat)
!Calculate overlap matrix
USE m_hsmt_ab
USE m_constants, ONLY : fpi_const,tpi_const
USE m_types
USE m_ylm
IMPLICIT NONE
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_tlmplm),INTENT(IN) :: td
TYPE(t_usdus),INTENT(IN) :: ud
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: isp
! ..
! .. Array Arguments ..
REAL,INTENT(IN) :: gk(:,:,:),vk(:,:,:)
REAL,INTENT(IN) :: fj(:,0:,:,:),gj(:,0:,:,:)
TYPE(t_lapwmat),INTENT(INOUT)::smat,hmat
INTEGER:: n,nn,na,aboffset,l,ll,m
COMPLEX,ALLOCATABLE:: ab(:,:),tmpdata(:,:),tmp_s(:,:),tmp_h(:,:),ab1(:,:)
ALLOCATE(ab(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2),ab1(lapw%nv(isp),2*atoms%lmaxd*(atoms%lmaxd+2)+2))
ALLOCATE(tmp_s(smat%matsize1,smat%matsize2),tmp_h(smat%matsize1,smat%matsize2))
tmp_s=0.0;tmp_h=0.0;ab=0.0;ab1=0.0
ntyploop: DO n=1,atoms%ntype
DO nn = 1,atoms%neq(n)
na = SUM(atoms%neq(:n-1))+nn
IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN
!---> Calculate Overlapp matrix
CALL timestart("ab-coefficients")
CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset)
CALL timestop("ab-coefficients")
CALL timestart("Overlapp")
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
DO l=0,atoms%lmax(n)
ll=l*(l+1)
DO m=-l,l
ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m)
ENDDO
ENDDO
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
CALL timestop("Overlapp")
CALL timestart("Hamiltonian")
!Calculate Hamiltonian
CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1))
! CALL zgemm("N","C",lapw%nv(isp),lapw%nv(isp),2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),ab1,SIZE(ab,1),CMPLX(1.0,0),tmp_h,SIZE(tmp_h,1))
CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1))
CALL timestop("Hamiltonian")
ENDIF
END DO
END DO ntyploop
!Copy tmp array back
IF (smat%l_real) THEN
smat%data_r=smat%data_r+tmp_s
hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s
ELSE
smat%data_c=smat%data_c+tmp_s
hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s
ENDIF
END SUBROUTINE hsmt_blas
#if 1==2
!this version uses zherk for Hamiltonian
ntyploop: DO n=1,atoms%ntype
DO nn = 1,atoms%neq(n)
na = SUM(atoms%neq(:n-1))+nn
IF ((atoms%invsat(na)==0) .OR. (atoms%invsat(na)==1)) THEN
!---> Calculate Overlapp matrix
CALL timestart("ab-coefficients")
CALL hsmt_ab(sym,atoms,isp,n,na,cell,lapw,gk,vk,fj,gj,ab,aboffset)
CALL timestop("ab-coefficients")
CALL timestart("Overlapp")
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
DO l=0,atoms%lmax(n)
ll=l*(l+1)
DO m=-l,l
ab1(:,1+ll+m)=SQRT(ud%ddn(l,n,isp))*ab(:,aboffset+1+ll+m)
ENDDO
ENDDO
CALL ZHERK("U","N",lapw%nv(isp),aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_s,SIZE(tmp_s,1))
CALL timestop("Overlapp")
CALL timestart("Hamiltonian")
!Calculate Hamiltonian
CALL zgemm("N","N",SIZE(ab,1),2*aboffset,2*aboffset,CMPLX(1.0,0.0),ab,SIZE(ab,1),td%h_loc(:,:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab,1))
CALL ZHERK("U","N",lapw%nv(isp),2*aboffset,1.,ab1,SIZE(ab,1),1.0,tmp_h,SIZE(tmp_h,1))
CALL timestop("Hamiltonian")
ENDIF
END DO
END DO ntyploop
!Copy tmp array back
IF (smat%l_real) THEN
smat%data_r=smat%data_r+tmp_s
hmat%data_r=hmat%data_r+tmp_h-td%e_shift*tmp_s
ELSE
smat%data_c=smat%data_c+tmp_s
hmat%data_c=hmat%data_c+tmp_h-td%e_shift*tmp_s
ENDIF
#endif
END MODULE m_hsmt_blas
This diff is collapsed.
module m_hsmt_hlptomat
#include "juDFT_env.h"
implicit none
contains
subroutine hsmt_hlptomat(nlotot,nv,sub_comm,chi11,chi21,chi22,aahlp,aa,bbhlp,bb)
!hsmt_hlptomat: aa/bbhlp - to -aa/bb matrix
!Rotate the aahlp&bbhlp arrays from the local spin-frame into the global frame
!and add the data to the aa&bb arrays, call mingeselle in distributed case