Skip to content

GitLab

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

More cleanup in cdn/cdnval.F90

parent b7cf3c84
Show whitespace changes
Inline Side-by-side
Showing with 66 additions and 91 deletions
cdn/cdnval.F90
View file @ 401d204f
......@@ -73,7 +73,7 @@ CONTAINS
USE m_Ekwritesl ! and write to file.
USE m_abcrot2
USE m_doswrite
USE m_cdnread, ONLY : cdn_read0, cdn_read
USE m_eig66_io, ONLY : read_eig
USE m_corespec, only : l_cs ! calculation of core spectra (EELS)
USE m_corespec_io, only : corespec_init
USE m_corespec_eval, only : corespec_gaunt,corespec_rme,corespec_dos,corespec_ddscs
......@@ -112,23 +112,20 @@ CONTAINS
#ifdef CPP_MPI
INCLUDE 'mpif.h'
LOGICAL :: mpi_flag, mpi_status
#endif
! .. Local Scalars ..
INTEGER :: llpd,ikpt,jsp_start,jsp_end,ispin,jsp
INTEGER :: i,ie,iv,ivac,j,k,l,n,ilo,isp,nbands,noccbd
INTEGER :: ikpt,jsp_start,jsp_end,ispin,jsp
INTEGER :: i,ie,ivac,j,k,l,n,ilo,nbands,noccbd
INTEGER :: skip_t,skip_tt
INTEGER :: nStart,nEnd,nbasfcn
LOGICAL :: l_fmpl,l_evp,l_orbcomprot,l_real, l_write
! ...Local Arrays ..
INTEGER :: noccbd_in(kpts%nkpt)
INTEGER :: nStart_in(kpts%nkpt)
INTEGER :: nEnd_in(kpts%nkpt)
REAL :: eig(dimension%neigd)
! ...Local Arrays ..
INTEGER, ALLOCATABLE :: gvac1d(:),gvac2d(:)
INTEGER, ALLOCATABLE :: jsym(:),ksym(:)
REAL, ALLOCATABLE :: we(:)
REAL, ALLOCATABLE :: eig(:)
REAL, ALLOCATABLE :: f(:,:,:,:),g(:,:,:,:),flo(:,:,:,:) ! radial functions
TYPE (t_lapw) :: lapw
......@@ -145,7 +142,6 @@ CONTAINS
l_real = sym%invs.AND.(.NOT.noco%l_soc).AND.(.NOT.noco%l_noco)
llpd=(atoms%lmaxd*(atoms%lmaxd+3))/2
!---> l_fmpl is meant as a switch to 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).
......@@ -223,18 +219,18 @@ CONTAINS
skip_tt = dot_product(enpara%skiplo(:atoms%ntype,jspin),atoms%neq(:atoms%ntype))
IF (noco%l_soc.OR.noco%l_noco) skip_tt = 2 * skip_tt
ALLOCATE (we(MAXVAL(cdnvalKLoop%noccbd(:))))
ALLOCATE (eig(MAXVAL(cdnvalKLoop%noccbd(:))))
jsp = MERGE(1,jspin,noco%l_noco)
DO ikpt = cdnvalKLoop%ikptStart, cdnvalKLoop%nkptExtended, cdnvalKLoop%ikptIncrement
IF (ikpt.GT.kpts%nkpt) THEN
#ifdef CPP_MPI
! Synchronizes the RMA operations
CALL MPI_BARRIER(mpi%mpi_comm,ie)
CALL MPI_BARRIER(mpi%mpi_comm,ie) ! Synchronizes the RMA operations
#endif
EXIT
END IF
! -> Gu test: distribute ev's among the processors...
CALL lapw%init(input,noco, kpts,atoms,sym,ikpt,cell,.false., mpi)
skip_t = skip_tt
noccbd = cdnvalKLoop%noccbd(ikpt)
......@@ -242,12 +238,8 @@ CONTAINS
nEnd = cdnvalKLoop%nEnd(ikpt)
we=0.0
IF(noccbd.GT.0) THEN
we(1:noccbd) = results%w_iks(nStart:nEnd,ikpt,jsp)
END IF
IF ((sliceplot%slice).AND.(input%pallst)) THEN
we(:) = kpts%wtkpt(ikpt)
END IF
IF(noccbd.GT.0) we(1:noccbd) = results%w_iks(nStart:nEnd,ikpt,jsp)
IF ((sliceplot%slice).AND.(input%pallst)) we(:) = kpts%wtkpt(ikpt)
IF (cdnvalKLoop%l_evp) THEN
IF (nStart > skip_tt) skip_t = 0
......@@ -257,20 +249,16 @@ CONTAINS
nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco)
CALL zMat%init(l_real,nbasfcn,noccbd)
CALL cdn_read(eig_id,dimension%nvd,dimension%jspd,mpi%irank,mpi%isize,&
ikpt,jspin,zmat%nbasfcn,noco%l_ss,noco%l_noco,&
noccbd,nStart,nEnd,nbands,eig,zMat)
CALL read_eig(eig_id,ikpt,jsp,n_start=nStart,n_end=nEnd,neig=nbands,zmat=zMat)
#ifdef CPP_MPI
! Synchronizes the RMA operations
CALL MPI_BARRIER(mpi%mpi_comm,ie)
CALL MPI_BARRIER(mpi%mpi_comm,ie) ! Synchronizes the RMA operations
#endif
eig(1:noccbd) = results%eig(nStart:nEnd,ikpt,jsp)
IF (vacuum%nstm.EQ.3.AND.input%film) THEN
CALL nstm3(sym,atoms,vacuum,stars,ikpt,lapw%nv(jspin),input,jspin,kpts,&
cell,kpts%wtkpt(ikpt),lapw%k1(:,jspin),lapw%k2(:,jspin),&
enpara%evac0(1,jspin),vTot%vacz(:,:,jspin),gvac1d,gvac2d)
CALL nstm3(sym,atoms,vacuum,stars,lapw,ikpt,input,jspin,kpts,&
cell,enpara%evac0(1,jspin),vTot%vacz(:,:,jspin),gvac1d,gvac2d)
END IF
IF (noccbd.EQ.0) GO TO 199
......@@ -386,14 +374,8 @@ CONTAINS
!---> and write the information to the files dosinp and vacdos
!---> for dos and bandstructure plots
!--dw parallel writing of vacdos,dosinp....
! write data to direct access file first, write to formated file later by PE 0 only!
!--dw since z is no longer an argument of cdninf sympsi has to be called here!
IF (banddos%ndir.GT.0) THEN
CALL sympsi(lapw%bkpt,lapw%nv(jspin),lapw%k1(:,jspin),lapw%k2(:,jspin),&
lapw%k3(:,jspin),sym,dimension,nbands,cell,eig,noco, ksym,jsym,zMat)
END IF
IF (banddos%ndir.GT.0) CALL sympsi(lapw,jspin,sym,dimension,nbands,cell,eig,noco,ksym,jsym,zMat)
CALL write_dos(eig_id,ikpt,jspin,regCharges,slab,orbcomp,ksym,jsym,mcd%mcd)
......@@ -404,7 +386,7 @@ CONTAINS
#ifdef CPP_MPI
CALL timestart("cdnval: mpi_col_den")
DO ispin = jsp_start,jsp_end
CALL mpi_col_den(mpi,sphhar,atoms,oneD,stars,vacuum,input,noco,l_fmpl,ispin,llpd,regCharges,&
CALL mpi_col_den(mpi,sphhar,atoms,oneD,stars,vacuum,input,noco,l_fmpl,ispin,regCharges,&
results,denCoeffs,orb,denCoeffsOffdiag,den,den%mmpMat(:,:,:,jspin))
END DO
CALL timestop("cdnval: mpi_col_den")
......@@ -412,8 +394,7 @@ CONTAINS
IF (mpi%irank==0) THEN
CALL cdnmt(dimension%jspd,atoms,sphhar,noco,l_fmpl,jsp_start,jsp_end,&
enpara%el0,enpara%ello0,vTot%mt(:,0,:,:),denCoeffs,&
usdus,orb,denCoeffsOffdiag,moments,den%mt)
enpara,vTot%mt(:,0,:,:),denCoeffs,usdus,orb,denCoeffsOffdiag,moments,den%mt)
IF(l_cs) CALL corespec_ddscs(jspin,input%jspins)
......@@ -459,7 +440,7 @@ CONTAINS
END IF ! end of (mpi%irank==0)
#ifdef CPP_MPI
CALL MPI_BARRIER(mpi%mpi_comm,ie)
CALL MPI_BARRIER(mpi%mpi_comm,ie) ! Synchronizes the RMA operations
#endif
IF ((jsp_end.EQ.input%jspins)) THEN
......
cdn_mt/cdnmt.f90
View file @ 401d204f
......@@ -10,8 +10,8 @@ MODULE m_cdnmt
! Philipp Kurz 2000-02-03
!***********************************************************************
CONTAINS
SUBROUTINE cdnmt(jspd,atoms,sphhar,noco,l_fmpl,jsp_start,jsp_end, epar,&
ello,vr,denCoeffs,usdus,orb,denCoeffsOffdiag,moments,rho)
SUBROUTINE cdnmt(jspd,atoms,sphhar,noco,l_fmpl,jsp_start,jsp_end,enpara,&
vr,denCoeffs,usdus,orb,denCoeffsOffdiag,moments,rho)
use m_constants,only: sfp_const
USE m_rhosphnlo
USE m_radfun
......@@ -23,6 +23,7 @@ CONTAINS
TYPE(t_noco), INTENT(IN) :: noco
TYPE(t_sphhar), INTENT(IN) :: sphhar
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_enpara), INTENT(IN) :: enpara
TYPE(t_moments), INTENT(INOUT) :: moments
! .. Scalar Arguments ..
......@@ -30,9 +31,7 @@ CONTAINS
LOGICAL, INTENT (IN) :: l_fmpl
! ..
! .. Array Arguments ..
REAL, INTENT (IN) :: epar(0:atoms%lmaxd,atoms%ntype,jspd)
REAL, INTENT (IN) :: vr(atoms%jmtd,atoms%ntype,jspd)
REAL, INTENT (IN) :: ello(atoms%nlod,atoms%ntype,jspd)
REAL, INTENT (INOUT) :: rho(:,0:,:,:)!(toms%jmtd,0:sphhar%nlhd,atoms%ntype,jspd)
TYPE (t_orb), INTENT(IN) :: orb
TYPE (t_denCoeffs), INTENT(IN) :: denCoeffs
......@@ -66,7 +65,7 @@ CONTAINS
!$OMP PARALLEL DEFAULT(none) &
!$OMP SHARED(usdus,rho,moments,rho21,qmtl) &
!$OMP SHARED(atoms,jsp_start,jsp_end,epar,vr,denCoeffs,sphhar,ello)&
!$OMP SHARED(atoms,jsp_start,jsp_end,enpara,vr,denCoeffs,sphhar)&
!$OMP SHARED(orb,noco,l_fmpl,denCoeffsOffdiag,jspd)&
!$OMP PRIVATE(itype,na,ispin,l,f,g,nodeu,noded,wronk,i,j,s,qmtllo,qmtt,nd,lh,lp,llp,cs)
IF (noco%l_mperp) THEN
......@@ -87,7 +86,7 @@ CONTAINS
!---> spherical component
DO ispin = jsp_start,jsp_end
DO l = 0,atoms%lmax(itype)
CALL radfun(l,itype,ispin,epar(l,itype,ispin),vr(1,itype,ispin),atoms,&
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)
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) )&
......@@ -106,7 +105,7 @@ CONTAINS
CALL rhosphnlo(itype,atoms,sphhar,&
usdus%uloulopn(1,1,itype,ispin),usdus%dulon(1,itype,ispin),&
usdus%uulon(1,itype,ispin),ello(1,itype,ispin),&
usdus%uulon(1,itype,ispin),enpara%ello0(1,itype,ispin),&
vr(1,itype,ispin),denCoeffs%aclo(1,itype,ispin),denCoeffs%bclo(1,itype,ispin),&
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),&
......
dos/nstm3.f90
View file @ 401d204f
......@@ -9,13 +9,9 @@ MODULE m_nstm3
!
!***********************************************************************
CONTAINS
SUBROUTINE nstm3(&
& sym,atoms,vacuum,stars,ikpt,nv,&
& input,jspin,kpts,&
& cell,wk,k1,k2,&
& evac,vz,&
& gvac1d,gvac2d)
!
SUBROUTINE nstm3(sym,atoms,vacuum,stars,lapw,ikpt,input,jspin,kpts,&
cell,evac,vz,gvac1d,gvac2d)
USE m_sort
USE m_types
IMPLICIT NONE
......@@ -24,17 +20,16 @@ CONTAINS
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_kpts),INTENT(IN) :: kpts
TYPE(t_atoms),INTENT(IN) :: atoms
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: ikpt,nv
INTEGER, INTENT (IN) :: ikpt
INTEGER, INTENT (IN) :: jspin
REAL, INTENT (IN) :: wk
! ..
! .. Array Arguments ..
INTEGER, INTENT (IN) :: k1(:),k2(:)
REAL, INTENT (IN) :: evac(2)
REAL, INTENT (IN) :: vz(:,:)!(vacuum%nmzd,2)
INTEGER, INTENT (OUT) :: gvac1d(:),gvac2d(:) !(dimension%nv2d)
......@@ -50,17 +45,17 @@ CONTAINS
!
IF (ikpt.EQ.1) THEN
n2 = 0
k_loop: DO k = 1,nv
k_loop: DO k = 1,lapw%nv(jspin)
DO j = 1,n2
IF (k1(k).EQ.gvac1(j).AND.k2(k).EQ.gvac2(j)) THEN
IF (lapw%k1(k,jspin).EQ.gvac1(j).AND.lapw%k2(k,jspin).EQ.gvac2(j)) THEN
CYCLE k_loop
END IF
ENDDO
n2 = n2 + 1
gvac1(n2) = k1(k)
gvac2(n2) = k2(k)
gvac1(n2) = lapw%k1(k,jspin)
gvac2(n2) = lapw%k2(k,jspin)
DO i=1,2
gvac(i)=k1(k)*cell%bmat(1,i)+k2(k)*cell%bmat(2,i)
gvac(i)=lapw%k1(k,jspin)*cell%bmat(1,i)+lapw%k2(k,jspin)*cell%bmat(2,i)
END DO
gvacl(n2) = SQRT(REAL(gvac(1)**2+gvac(2)**2))
ENDDO k_loop
......@@ -120,7 +115,7 @@ CONTAINS
! only write here if not on T3E
WRITE (87,'(i3,1x,f12.6)') ikpt,wk
WRITE (87,'(i3,1x,f12.6)') ikpt,kpts%wtkpt(ikpt)
END SUBROUTINE nstm3
END MODULE m_nstm3
dos/sympsi.F90
View file @ 401d204f
......@@ -18,13 +18,14 @@ MODULE m_sympsi
! Jussi Enkovaara, Juelich 2004
CONTAINS
SUBROUTINE sympsi(bkpt,nv,kx,ky,kz,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat)
SUBROUTINE sympsi(lapw,jspin,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat)
USE m_grp_k
USE m_inv3
USE m_types
IMPLICIT NONE
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_dimension),INTENT(IN) :: DIMENSION
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_sym),INTENT(IN) :: sym
......@@ -32,11 +33,10 @@ CONTAINS
TYPE(t_zMat),INTENT(IN) :: zMat
!
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: nv,ne
INTEGER, INTENT (IN) :: ne,jspin
! ..
! .. Array Arguments ..
INTEGER, INTENT (IN) :: kx(:),ky(:),kz(:)!(nvd)
REAL, INTENT (IN) :: bkpt(3),eig(DIMENSION%neigd)
REAL, INTENT (IN) :: eig(DIMENSION%neigd)
INTEGER, INTENT (OUT):: jsym(DIMENSION%neigd),ksym(DIMENSION%neigd)
! ..
......@@ -72,9 +72,9 @@ CONTAINS
IF (soc) THEN
ALLOCATE(su(2,2,2*sym%nop))
CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table, grpname,irrname,su)
CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname,su)
ELSE
CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table, grpname,irrname)
CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname)
ENDIF
ALLOCATE(csum(ne,ne,nclass))
ALLOCATE(chars(ne,nclass))
......@@ -97,25 +97,25 @@ CONTAINS
gmap=0
DO c=1,nclass
CALL inv3(mrot_k(:,:,c),mtmpinv,d)
kloop: DO k=1,nv
kv(1)=kx(k)
kv(2)=ky(k)
kv(3)=kz(k)
kv=kv+bkpt
kloop: DO k=1,lapw%nv(jspin)
kv(1)=lapw%k1(k,jspin)
kv(2)=lapw%k2(k,jspin)
kv(3)=lapw%k3(k,jspin)
kv=kv+lapw%bkpt
kvtest=MATMUL(kv,mtmpinv)
! kvtest=MATMUL(kv,mrot_k(:,:,c))
DO i = 1,nv
kv(1)=kx(i)
kv(2)=ky(i)
kv(3)=kz(i)
kv=kv+bkpt
DO i = 1,lapw%nv(jspin)
kv(1)=lapw%k1(i,jspin)
kv(2)=lapw%k2(i,jspin)
kv(3)=lapw%k3(i,jspin)
kv=kv+lapw%bkpt
IF (ABS(kvtest(1)-kv(1)).LT.small.AND.&
ABS(kvtest(2)-kv(2)).LT.small.AND. ABS(kvtest(3)-kv(3)).LT.small) THEN
gmap(k,c)=i
CYCLE kloop
ENDIF
ENDDO
WRITE(6,*) 'Problem in symcheck, cannot find rotated kv for', k,kx(k),ky(k),kz(k)
WRITE(6,*) 'Problem in symcheck, cannot find rotated kv for', k,lapw%k1(k,jspin),lapw%k2(k,jspin),lapw%k3(k,jspin)
RETURN
ENDDO kloop
ENDDO
......@@ -124,16 +124,16 @@ CONTAINS
DO i=1,ne
norm(i)=0.0
IF (soc) THEN
DO k=1,nv*2
DO k=1,lapw%nv(jspin)*2
norm(i)=norm(i)+ABS(zMat%z_c(k,i))**2
ENDDO
ELSE
IF (zmat%l_real) THEN
DO k=1,nv
DO k=1,lapw%nv(jspin)
norm(i)=norm(i)+ABS(zMat%z_r(k,i))**2
ENDDO
ELSE
DO k=1,nv
DO k=1,lapw%nv(jspin)
norm(i)=norm(i)+ABS(zMat%z_c(k,i))**2
ENDDO
ENDIF
......@@ -161,21 +161,21 @@ CONTAINS
DO n1=1,ndeg
DO n2=1,ndeg
IF (zmat%l_real) THEN
DO k=1,nv
DO k=1,lapw%nv(jspin)
csum(n1,n2,c)=csum(n1,n2,c)+zMat%z_r(k,deg(n1))*&
zMat%z_r(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
END DO
ELSE
IF (soc) THEN
DO k=1,nv
DO k=1,lapw%nv(jspin)
csum(n1,n2,c)=csum(n1,n2,c)+(CONJG(zMat%z_c(k,deg(n1)))*&
(su(1,1,c)*zMat%z_c(gmap(k,c),deg(n2))+ su(1,2,c)*zMat%z_c(gmap(k,c)+nv,deg(n2)))+&
CONJG(zMat%z_c(k+nv,deg(n1)))* (su(2,1,c)*zMat%z_c(gmap(k,c),deg(n2))+&
su(2,2,c)*zMat%z_c(gmap(k,c)+nv,deg(n2))))/ (norm(deg(n1))*norm(deg(n2)))
(su(1,1,c)*zMat%z_c(gmap(k,c),deg(n2))+ su(1,2,c)*zMat%z_c(gmap(k,c)+lapw%nv(jspin),deg(n2)))+&
CONJG(zMat%z_c(k+lapw%nv(jspin),deg(n1)))* (su(2,1,c)*zMat%z_c(gmap(k,c),deg(n2))+&
su(2,2,c)*zMat%z_c(gmap(k,c)+lapw%nv(jspin),deg(n2))))/ (norm(deg(n1))*norm(deg(n2)))
END DO
ELSE
DO k=1,nv
DO k=1,lapw%nv(jspin)
csum(n1,n2,c)=csum(n1,n2,c)+CONJG(zMat%z_c(k,deg(n1)))*&
zMat%z_c(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
END DO
......@@ -217,7 +217,7 @@ CONTAINS
!>
IF (.NOT.char_written) THEN
WRITE(444,124) bkpt
WRITE(444,124) lapw%bkpt
WRITE(444,*) 'Group is ' ,grpname
DO c=1,nirr
IF (zmat%l_real)THEN
......
mpi/mpi_col_den.F90
View file @ 401d204f
......@@ -10,7 +10,7 @@ MODULE m_mpi_col_den
!
CONTAINS
SUBROUTINE mpi_col_den(mpi,sphhar,atoms,oneD,stars,vacuum,&
input, noco,l_fmpl,jspin,llpd,regCharges,&
input, noco,l_fmpl,jspin,regCharges,&
results,denCoeffs,orb,denCoeffsOffdiag,den,n_mmp)
#include"cpp_double.h"
......@@ -31,7 +31,7 @@ CONTAINS
INCLUDE 'mpif.h'
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: jspin,llpd
INTEGER, INTENT (IN) :: jspin
LOGICAL, INTENT (IN) :: l_fmpl
! ..
! .. Array Arguments ..
......@@ -104,7 +104,7 @@ CONTAINS
!
!--> Collect uunmt,udnmt,dunmt,ddnmt
!
n = (llpd+1)*sphhar%nlhd*atoms%ntype
n = (((atoms%lmaxd*(atoms%lmaxd+3))/2)+1)*sphhar%nlhd*atoms%ntype
ALLOCATE(r_b(n))
CALL MPI_REDUCE(denCoeffs%uunmt(0:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi%irank.EQ.0) THEN
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment