Commit 73087055 authored by Daniel Wortmann's avatar Daniel Wortmann

More bugfixes

Removed most of CPP_INVERSION
parent 2d811c6b
......@@ -76,7 +76,7 @@ CONTAINS
CALL setabc1locdn1(jspin, atoms,lapw, sym,usdus,kveclo,enough,nkvec,kvec,&
nbasf0,alo1,blo1,clo1)
nvmax=lapw%nv(jspin)
!---> loop over lapws
DO k = 1,nvmax
!calculate k+G
......
......@@ -53,7 +53,7 @@ CONTAINS
ALLOCATE ( lapw%k1(DIMENSION%nvd,DIMENSION%jspd),lapw%k2(DIMENSION%nvd,DIMENSION%jspd),&
lapw%k3(DIMENSION%nvd,DIMENSION%jspd),lapw%rk(DIMENSION%nvd,DIMENSION%jspd) )
ENDIF
lapw%rk = 0 ; lapw%k1 = 0 ; lapw%k2 = 0 ; lapw%k3 = 0
lapw%rk = 0 ; lapw%k1 = 0 ; lapw%k2 = 0 ; lapw%k3 = 0 ;lapw%nv=0
! ..
! ..
!---> in a spin-spiral calculation different basis sets are used for
......
......@@ -9,7 +9,7 @@ MODULE m_eigen
CONTAINS
SUBROUTINE eigen(mpi,stars,sphhar,atoms,obsolete,xcpot,&
sym,kpts,DIMENSION, vacuum, input, cell, enpara_in,banddos, noco,jij, oneD,hybrid,&
it,eig_id,results,v)
it,eig_id,results,v,vx)
!*********************************************************************
! sets up and solves the eigenvalue problem for a basis of lapws.
!
......@@ -65,7 +65,7 @@ CONTAINS
TYPE(t_kpts),INTENT(IN) :: kpts
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_atoms),INTENT(INOUT) :: atoms!in u_setup n_u might be modified
TYPE(t_potden),INTENT(INOUT) :: v
TYPE(t_potden),INTENT(INOUT) :: v,vx
#ifdef CPP_MPI
INCLUDE 'mpif.h'
#endif
......@@ -291,6 +291,7 @@ CONTAINS
WRITE (*,*) 'the tlmplm%tuu, tlmplm%tdd etc.: ',err,' size: ',mlotot
CALL juDFT_error("eigen: Error during allocation of tlmplm, tdd etc.",calledby ="eigen")
ENDIF
lh0=1
CALL tlmplm(sphhar,atoms,DIMENSION,enpara, jsp,1,mpi, v%mt(1,0,1,jsp),lh0,input, td,ud)
IF (input%l_f) CALL write_tlmplm(td,vs_mmp,atoms%n_u>0,1,jsp,input%jspins)
CALL timestop("tlmplm")
......@@ -358,7 +359,7 @@ CONTAINS
IF( hybrid%l_hybrid ) THEN
!write overlap matrix b to direct access file olap
print *,"Wrong overlap matrix used, fix this later"
call olap%from_packed(dimension%nbasfcn,l_real,hamovlp%b_r,hamovlp%b_c)
call olap%from_packed(l_real,dimension%nbasfcn,hamovlp%b_r,hamovlp%b_c)
call write_olap(olap,nrec)
......@@ -371,7 +372,7 @@ CONTAINS
IF( hybrid%l_subvxc ) THEN
CALL subvxc(lapw,kpts%bk(:,nk),DIMENSION,input,jsp,vr0,atoms,ud,hybrid,enpara%el0,enpara%ello0,&
sym, atoms%nlotot,kveclo, cell,sphhar, stars, xcpot,mpi,&
oneD, hamovlp)
oneD, hamovlp,vx)
END IF
END IF ! hybrid%l_hybrid
......@@ -419,13 +420,13 @@ CONTAINS
zmat%nbands=ne_found
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,lapw%nv(jsp),lapw%nmat,&
lapw%k1(:lapw%nv(jsp),jsp),lapw%k2 (:lapw%nv(jsp),jsp),lapw%k3(:lapw%nv(jsp),jsp),&
bkpt, kpts%wtkpt(nk),eig(:ne_found),enpara%el0(0:,:,jsp), enpara%ello0(:,:,jsp),enpara%evac0(:,jsp),&
atoms%nlotot,kveclo,mpi%n_size,mpi%n_rank,zMat)
bkpt, kpts%wtkpt(nk),eig(:ne_found),el=enpara%el0(0:,:,jsp),ello=enpara%ello0(:,:,jsp),evac=enpara%evac0(:,jsp),&
nlotot=atoms%nlotot,kveclo=kveclo,n_start=mpi%n_size,n_end=mpi%n_rank,zmat=zMat)
IF (noco%l_noco) THEN
CALL write_eig(eig_id, nk,2,ne_found,ne_all,lapw%nv(2),lapw%nmat,&
lapw%k1(:lapw%nv(2),2),lapw%k2 (:lapw%nv(2),2),lapw%k3(:lapw%nv(2),2),&
bkpt, kpts%wtkpt(nk),eig(:ne_found),enpara%el0(0:,:,2), enpara%ello0(:,:,2),enpara%evac0(:,2),&
atoms%nlotot,kveclo)
bkpt, kpts%wtkpt(nk),eig(:ne_found),el=enpara%el0(0:,:,2),ello= enpara%ello0(:,:,2),evac=enpara%evac0(:,2),&
nlotot=atoms%nlotot,kveclo=kveclo)
ENDIF
#if defined(CPP_MPI)
!RMA synchronization
......
......@@ -28,7 +28,7 @@ CONTAINS
!-----------------------------------------------------------------------
USE m_eig66_io, ONLY : read_eig
USE m_eig66_io, ONLY : read_eig,write_eig
#if defined(CPP_MPI)&&defined(CPP_NEVER)
USE m_mpi_col_eigJ
#endif
......@@ -235,6 +235,13 @@ CONTAINS
WRITE(attributes(2),'(a)') 'Htr'
IF (mpi%irank.EQ.0) CALL writeXMLElement('FermiEnergy',(/'value','units'/),attributes(1:2))
!Put w_iks into eig-file
DO jsp = 1,nspins
DO k = 1,kpts%nkpt
CALL write_eig(eig_id,k,jsp,w_iks=results%w_iks(:,k,jsp))
ENDDO
ENDDO
RETURN
8020 FORMAT (/,'FERMIE:',/,&
& 10x,'first approx. to ef (T=0) :',f10.6,' htr',&
......
......@@ -401,6 +401,7 @@ MODULE m_types
INTEGER :: lexp
INTEGER :: bands1 !Only read in
INTEGER :: bands2 !Only read in
INTEGER :: nbasp
INTEGER :: maxlcutm1
INTEGER :: maxindxm1
INTEGER :: maxbasm1
......@@ -452,7 +453,6 @@ MODULE m_types
INTEGER :: l1,l2,n1,n2
END TYPE prodtype
TYPE t_hybdat
INTEGER :: nbasp
INTEGER :: lmaxcd,maxindxc
REAL, ALLOCATABLE :: gridf(:,:) !alloc in util.F
INTEGER , ALLOCATABLE:: nindxc(:,:) !alloc in eigen_HF_init
......
......@@ -12,6 +12,8 @@ module m_types_rcmat
PROCEDURE :: multiply=>t_mat_multiply
PROCEDURE :: transpose=>t_mat_transpose
PROCEDURE :: from_packed=>t_mat_from_packed
PROCEDURE :: inverse =>t_mat_inverse
PROCEDURE :: to_packed=>t_mat_to_packed
END type t_mat
CONTAINS
......@@ -33,7 +35,9 @@ module m_types_rcmat
IF (mat%l_real) THEN
ALLOCATE(mat%data_r(mat%matsize1,mat%matsize2),STAT=err)
ALLOCATE(mat%data_c(0,0))
ELSE
ALLOCATE(mat%data_r(0,0))
ALLOCATE(mat%data_c(mat%matsize1,mat%matsize2),STAT=err)
ENDIF
......@@ -86,7 +90,7 @@ module m_types_rcmat
end IF
end SUBROUTINE t_mat_transpose
SUBROUTINE t_mat_from_packed(mat1,matsize,l_real,packed_r,packed_c)
SUBROUTINE t_mat_from_packed(mat1,l_real,matsize,packed_r,packed_c)
CLASS(t_mat),INTENT(INOUT) :: mat1
INTEGER,INTENT(IN) :: matsize
LOGICAL,INTENT(IN) :: l_real
......@@ -94,17 +98,68 @@ module m_types_rcmat
COMPLEX,INTENT(IN) :: packed_c(:)
INTEGER:: n,nn,i
call mat1%alloc(l_real,matsize)
call mat1%alloc(l_real,matsize,matsize)
i=1
DO n=1,matsize
DO nn=1,n
if (l_real) THEN
mat1%data_r(n,nn)=packed_r(i)
mat1%data_r(nn,n)=packed_r(i)
else
mat1%data_c(n,nn)=packed_c(i)
mat1%data_c(n,nn)=conjg(packed_c(i))
mat1%data_c(nn,n)=packed_c(i)
end if
i=i+1
end DO
end DO
end SUBROUTINE t_mat_from_packed
function t_mat_to_packed(mat)result(packed)
CLASS(t_mat),INTENT(IN) :: mat
COMPLEX :: packed(mat%matsize1*(mat%matsize1+1)/2)
integer :: n,nn,i
real,parameter :: tol=1e-5
if (mat%matsize1.ne.mat%matsize2) call judft_error("Could not pack no-square matrix",hint='This is a BUG, please report')
i=1
DO n=1,mat%matsize1
DO nn=1,n
if (mat%l_real) THEN
packed(i)=(mat%data_r(n,nn)+mat%data_r(nn,n))/2.
if (abs(mat%data_r(n,nn)-mat%data_r(nn,n))>tol) call judft_warn("Large unsymmetry in matrix packing")
else
packed(i)=(conjg(mat%data_c(n,nn))+mat%data_c(nn,n))/2.
if (abs(conjg(mat%data_c(n,nn))-mat%data_c(nn,n))>tol) call judft_warn("Large unsymmetry in matrix packing")
endif
i=i+1
end DO
end DO
end function t_mat_to_packed
subroutine t_mat_inverse(mat)
implicit none
CLASS(t_mat),INTENT(INOUT) :: mat
integer :: info
real, allocatable :: work_r(:)
integer, allocatable :: ipiv(:)
complex,allocatable :: work_c(:)
if (mat%matsize1.ne.mat%matsize2) call judft_error("Can only invert square matrices",hint="This is a BUG in FLEUR, please report")
ALLOCATE(ipiv(mat%matsize1))
if (mat%l_real) THEN
ALLOCATE(work_r(mat%matsize1))
call dgetrf(mat%matsize1,mat%matsize1,mat%data_r,size(mat%data_r,1),ipiv,info)
if(info.ne.0) call judft_error("Failed to invert matrix: dpotrf failed.")
call dgetri(mat%matsize1,mat%data_r,size(mat%data_r,1),ipiv,work_r,size(work_r),info)
if(info.ne.0) call judft_error("Failed to invert matrix: dpotrf failed.")
else
ALLOCATE(work_c(mat%matsize1))
call zgetrf(mat%matsize1,mat%matsize1,mat%data_c,size(mat%data_c,1),ipiv,info)
if(info.ne.0) call judft_error("Failed to invert matrix: dpotrf failed.")
call zgetri(mat%matsize1,mat%data_c,size(mat%data_c,1),ipiv,work_c,size(work_c),info)
if(info.ne.0) call judft_error("Failed to invert matrix: dpotrf failed.")
end if
end subroutine t_mat_inverse
end module m_types_rcmat
......@@ -41,7 +41,7 @@
! - local scalars -
INTEGER :: i,itype,iatom,ikpt,ineq,igpt,iband
INTEGER :: irecl_cmt,irecl_z
INTEGER :: irecl_cmt
INTEGER :: j,m
INTEGER :: l
INTEGER :: lm,lm1
......@@ -66,13 +66,7 @@
REAL :: rtaual(3)
REAL , ALLOCATABLE :: olapcb(:)
REAL , ALLOCATABLE :: olapcv_avg(:,:,:,:),olapcv_max(:,:,:,:)
#ifdef CPP_INVERSION
REAL , ALLOCATABLE :: olappp(:,:)
REAL :: z(dimension%nbasfcn,dimension%neigd,nkpti)
#else
COMPLEX , ALLOCATABLE :: olappp(:,:)
COMPLEX :: z(dimension%nbasfcn,dimension%neigd,nkpti)
#endif
TYPE(t_mat),ALLOCATABLE :: z(:)
COMPLEX :: cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat,nkpti)
COMPLEX :: y((atoms%lmaxd+1)**2)
......@@ -85,7 +79,11 @@
& 'x','x','x','x','x','x','x','x','x','x','x','x','x' /)
LOGICAL :: l_mism = .true.
ALLOCATE(z(nkpti))
DO ikpt=1,nkpti
call z(ikpt)%alloc(sym%invs,dimension%nbasfcn,dimension%neigd)
ENDDO
IF ( mpi%irank == 0 ) WRITE(6,'(//A)') '### checkolap ###'
cmt = 0
......@@ -238,18 +236,9 @@
ALLOCATE (carr1(maxval(hybdat%nbands),(atoms%lmaxd+1)**2))
ALLOCATE (carr2(maxval(hybdat%nbands),(atoms%lmaxd+1)**2))
ALLOCATE (carr3(maxval(hybdat%nbands),(atoms%lmaxd+1)**2))
#ifdef CPP_INVERSION
irecl_z = dimension%nbasfcn*dimension%neigd*8
#else
irecl_z = dimension%nbasfcn*dimension%neigd*16
#endif
OPEN(unit=778,file='z',form='unformatted',access='direct',&
& recl=irecl_z)
DO ikpt = 1,nkpti
READ(778,rec=ikpt) z(:,:,ikpt)
call read_z(z(ikpt),ikpt)
END DO
CLOSE(778)
iatom = 0
DO itype = 1,atoms%ntype
......@@ -292,8 +281,12 @@
DO m = -l,l
lm = lm + 1
DO iband = 1,hybdat%nbands(ikpt)
carr2(iband,lm) = carr2(iband,lm) + cdum * z(igpt,iband,ikpt) * y(lm)
END DO
if (z(1)%l_real) THEN
carr2(iband,lm) = carr2(iband,lm) + cdum * z(ikpt)%data_r(igpt,iband) * y(lm)
Else
carr2(iband,lm) = carr2(iband,lm) + cdum * z(ikpt)%data_c(igpt,iband) * y(lm)
END if
end DO
END DO
END DO
END DO
......
This diff is collapsed.
......@@ -43,8 +43,6 @@ contains
END IF
IF( hybrid%l_calhf ) THEN
hybrid%maxlmindx = MAXVAL((/ ( SUM( (/ (hybrid%nindx(l,itype)*(2*l+1), l=0,atoms%lmax(itype)) /) ),itype=1,atoms%ntype) /) )
call open_hybrid_io(hybrid,dimension,atoms,l_real)
!initialize hybdat%gridf for radial integration
CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf)
......@@ -72,25 +70,11 @@ contains
IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation hybdat%eig_c'
hybdat%nindxc = 0 ; hybdat%core1 = 0 ; hybdat%core2 = 0 ; hybdat%eig_c = 0
! determine the size of the mixed basis at each k-point
! ( can be done in mixedbasis only once)
hybdat%nbasp = 0
DO itype=1,atoms%ntype
DO ieq=1,atoms%neq(itype)
DO l=0,hybrid%lcutm1(itype)
DO m=-l,l
DO i=1,hybrid%nindxm1(l,itype)
hybdat%nbasp = hybdat%nbasp + 1
END DO
END DO
END DO
END DO
END DO
ALLOCATE( hybdat%nbasm(kpts%nkptf) ,stat=ok)
IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation hybdat%nbasm'
DO nk = 1,kpts%nkptf
hybdat%nbasm(nk) = hybdat%nbasp + hybrid%ngptm(nk)
hybdat%nbasm(nk) = hybrid%nbasp + hybrid%ngptm(nk)
END DO
! pre-calculate gaunt coefficients
......
......@@ -21,7 +21,7 @@ CONTAINS
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_input),INTENT(IN) :: input
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_results),INTENT(IN) :: results
TYPE(t_results),INTENT(INOUT):: results
INTEGER,INTENT(IN) :: irank2(:),it
INTEGER,INTENT(IN) :: jsp,eig_id_hf
......@@ -40,7 +40,7 @@ CONTAINS
INTEGER :: degenerat(DIMENSION%neigd2+1,kpts%nkpt)
INTEGER :: matind(DIMENSION%nbasfcn,2),nred
TYPE(t_lapw) :: lapw
LOGICAL:: skip_kpt(kpts%nkpt)
REAL :: g(3)
skip_kpt=.FALSE.
......@@ -72,12 +72,14 @@ CONTAINS
zmat(nk)%nbands=dimension%neigd2
if (l_real) THEN
ALLOCATE(zmat(nk)%z_r(dimension%nbasfcn,dimension%neigd2))
ALLOCATE(zmat(nk)%z_c(0,0))
else
ALLOCATE(zmat(nk)%z_c(dimension%nbasfcn,dimension%neigd2))
ALLOCATE(zmat(nk)%z_r(0,0))
endif
print *,"eigen_HF_Setup: read_eig:",nk
print *,zmat(nk)%nbasfcn,zmat(nk)%nbands,hybdat%ne_eig(nk)
CALL read_eig(eig_id_hf,nk,jsp,el=el_eig,ello=ello_eig, neig=hybdat%ne_eig(nk),eig=eig_irr(:,nk), kveclo=hybdat%kveclo_eig(:,nk),zmat=zmat(nk)) !TODO introduce zmat!!,z=z_irr(:,:,nk))
CALL read_eig(eig_id_hf,nk,jsp,el=el_eig,ello=ello_eig, neig=hybdat%ne_eig(nk),eig=eig_irr(:,nk), w_iks=results%w_iks(:,nk,jsp),kveclo=hybdat%kveclo_eig(:,nk),zmat=zmat(nk))
print *,"Done"
END DO
......@@ -144,7 +146,7 @@ CONTAINS
END DO
DO i = 1,hybdat%ne_eig(nk)
IF( results%w_iks(i,nk,jsp) .GT. 0d0 ) hybdat%nobd(nk) = hybdat%nobd(nk) + 1
IF(results%w_iks(i,nk,jsp) .GT. 0d0 ) hybdat%nobd(nk) = hybdat%nobd(nk) + 1
END DO
......@@ -294,8 +296,8 @@ CONTAINS
! Reading the eig file
!DO nk = n_start,kpts%nkpt,n_stride
DO nk = 1,kpts%nkpt,1
CALL read_eig(eig_id_hf,nk,jsp,el=el_eig, ello=ello_eig,neig=hybdat%ne_eig(nk))
hybdat%nobd(nk) = COUNT( results%w_iks(:hybdat%ne_eig(nk),nk,jsp) > 0.0 )
CALL read_eig(eig_id_hf,nk,jsp,el=el_eig, ello=ello_eig,neig=hybdat%ne_eig(nk),w_iks=results%w_iks(:,nk,jsp))
hybdat%nobd(nk) = COUNT(results%w_iks(:hybdat%ne_eig(nk),nk,jsp) > 0.0 )
END DO
hybrid%maxlmindx = MAXVAL((/ ( SUM( (/ (hybrid%nindx(l,itype)*(2*l+1), l=0,atoms%lmax(itype)) /) ),itype=1,atoms%ntype) /) )
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -319,12 +319,13 @@ MODULE m_hsfock
! in the case of a spin-unpolarized calculation the factor 2 is added in eigen_hf.F
if (.not.v_x%l_real) v_x%data_c=conjg(v_x%data_c)
exch = 0
print *,"sizes:",shape(z%data_r),shape(v_x%data_r)
call v_x%multiply(z,tmp)
DO iband = 1,hybdat%nbands(nk)
if (z%l_real) THEN
exch(iband,iband) = dot_product(z%data_r(:,iband),tmp%data_r(:,iband))
exch(iband,iband) = dot_product(z%data_r(:z%matsize1,iband),tmp%data_r(:,iband))
else
exch(iband,iband) = dot_product(z%data_r(:,iband),tmp%data_r(:,iband))
exch(iband,iband) = dot_product(z%data_r(:z%matsize1,iband),tmp%data_r(:,iband))
endif
IF( iband .le. hybdat%nobd(nk) ) THEN
results%te_hfex%valence = results%te_hfex%valence -a_ex*results%w_iks(iband,nk,jsp)*exch(iband,iband)
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -164,6 +164,7 @@ c --------
enddo
end function packmatcoul_d
function unpackmat_d(mat)
implicit none
real, intent(in) :: mat(:)
......
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