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 source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -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) /) )
......
......@@ -16,762 +16,753 @@
! It is done directly without employing the mixed basis set.
MODULE m_exchange_core
CONTAINS
SUBROUTINE exchange_vccv(&
& nk,atoms,&
& hybrid,hybdat,&
& dimension,jsp,lapw,&
& maxbands,mnobd,mpi,irank2,&
& degenerat,symequivalent,results,&
& ex_vv)
USE m_constants
USE m_util
USE m_wrapper
USE m_types
USE m_io_hybrid
IMPLICIT NONE
TYPE(t_hybdat),INTENT(IN) :: hybdat
TYPE(t_results),INTENT(INOUT) :: results
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_dimension),INTENT(IN) :: dimension
TYPE(t_hybrid),INTENT(IN) :: hybrid
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
! -scalars -
INTEGER,INTENT(IN) :: jsp
INTEGER,INTENT(IN) ::nk ,maxbands, mnobd
INTEGER,INTENT(IN) :: irank2
! - arays -
INTEGER,INTENT(IN) :: degenerat(hybdat%ne_eig(nk))
#ifdef CPP_INVERSION
REAL ,INTENT(INOUT) :: ex_vv(:,:,:)!(maxbands,mnobd,nkpti)
#else
COMPLEX ,INTENT(INOUT) :: ex_vv(:,:,:)!(maxbands,mnobd,nkpti)
#endif
LOGICAL :: symequivalent(count(degenerat .ge. 1),&
& count(degenerat .ge. 1))
! - local scalars -
INTEGER :: iatom,ieq,itype,ic,l,l1,l2,&
& ll,lm ,m1,m2,p1,p2,n,n1,n2,i,j
INTEGER :: iband1,iband2,ndb1,ndb2,ic1,ic2
INTEGER :: m
REAL :: time1,time2
REAL :: rdum
REAL :: sum_offdia
COMPLEX :: cdum
! - local arrays -
INTEGER,ALLOCATABLE :: larr(:),larr2(:)
INTEGER,ALLOCATABLE :: parr(:),parr2(:)
REAL :: integrand(atoms%jmtd)
REAL :: primf1(atoms%jmtd),primf2(atoms%jmtd)
REAL,ALLOCATABLE :: fprod(:,:),fprod2(:,:)
REAL,ALLOCATABLE :: integral(:,:)
COMPLEX :: cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat)
COMPLEX :: exchange(hybdat%nbands(nk),hybdat%nbands(nk))
COMPLEX,ALLOCATABLE :: carr(:,:),carr2(:,:),carr3(:,:)
LOGICAL :: ldum(hybdat%nbands(nk),hybdat%nbands(nk))
IF ( irank2 == 0 ) THEN
WRITE(6,'(A)') new_line('n') // new_line('n') // '### valence-core-core-valence exchange ###'
WRITE(6,'(A)') new_line('n') // ' k-point band exchange (core contribution)'
END IF
! read in mt wavefunction coefficients from file cmt
call read_cmt(cmt,nk)
ALLOCATE ( fprod(atoms%jmtd,5),larr(5),parr(5) )
! generate ldum(nbands(nk),nbands(nk)), which is true if the corresponding matrix entry is non-zero
ic1 = 0
ldum = .false.
DO iband1 = 1,hybdat%nbands(nk)
ndb1 = degenerat(iband1)
IF( ndb1 .ge. 1 ) THEN
MODULE m_exchange_core
CONTAINS
SUBROUTINE exchange_vccv(nk,atoms, hybrid,hybdat, DIMENSION,jsp,lapw,&
maxbands,mnobd,mpi,irank2, degenerat,symequivalent,results,&
ex_vv_r,ex_vv_c,l_real)
USE m_constants
USE m_util
USE m_wrapper
USE m_types
USE m_io_hybrid
IMPLICIT NONE
TYPE(t_hybdat),INTENT(IN) :: hybdat
TYPE(t_results),INTENT(INOUT) :: results
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_dimension),INTENT(IN) :: DIMENSION
TYPE(t_hybrid),INTENT(IN) :: hybrid
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
! -scalars -
INTEGER,INTENT(IN) :: jsp
INTEGER,INTENT(IN) ::nk ,maxbands, mnobd
INTEGER,INTENT(IN) :: irank2
! - arays -
INTEGER,INTENT(IN) :: degenerat(hybdat%ne_eig(nk))
LOGICAL,INTENT(IN) :: l_real
REAL ,INTENT(INOUT) :: ex_vv_r(:,:,:)!(maxbands,mnobd,nkpti)
COMPLEX ,INTENT(INOUT) :: ex_vv_c(:,:,:)!(maxbands,mnobd,nkpti)
LOGICAL :: symequivalent(COUNT(degenerat .GE. 1), COUNT(degenerat .GE. 1))
! - local scalars -
INTEGER :: iatom,ieq,itype,ic,l,l1,l2, ll,lm ,m1,m2,p1,p2,n,n1,n2,i,j
INTEGER :: iband1,iband2,ndb1,ndb2,ic1,ic2
INTEGER :: m
REAL :: time1,time2
REAL :: rdum
REAL :: sum_offdia
COMPLEX :: cdum
! - local arrays -
INTEGER,ALLOCATABLE :: larr(:),larr2(:)
INTEGER,ALLOCATABLE :: parr(:),parr2(:)
REAL :: integrand(atoms%jmtd)
REAL :: primf1(atoms%jmtd),primf2(atoms%jmtd)
REAL,ALLOCATABLE :: fprod(:,:),fprod2(:,:)
REAL,ALLOCATABLE :: integral(:,:)
COMPLEX :: cmt(DIMENSION%neigd,hybrid%maxlmindx,atoms%nat)
COMPLEX :: exchange(hybdat%nbands(nk),hybdat%nbands(nk))
COMPLEX,ALLOCATABLE :: carr(:,:),carr2(:,:),carr3(:,:)
LOGICAL :: ldum(hybdat%nbands(nk),hybdat%nbands(nk))
IF ( irank2 == 0 ) THEN
WRITE(6,'(A)') new_LINE('n') // new_LINE('n') // '### valence-core-core-valence exchange ###'
WRITE(6,'(A)') new_LINE('n') // ' k-point band exchange (core contribution)'
END IF
! read in mt wavefunction coefficients from file cmt
CALL read_cmt(cmt,nk)
ALLOCATE ( fprod(atoms%jmtd,5),larr(5),parr(5) )
! generate ldum(nbands(nk),nbands(nk)), which is true if the corresponding matrix entry is non-zero
ic1 = 0
ldum = .FALSE.
DO iband1 = 1,hybdat%nbands(nk)
ndb1 = degenerat(iband1)
IF( ndb1 .GE. 1 ) THEN
ic1 = ic1 + 1
ic2 = 0
DO iband2 = 1,hybdat%nbands(nk)
ndb2 = degenerat(iband2)
IF( ndb2 .ge. 1 ) THEN
ic2 = ic2 + 1
IF( symequivalent(ic2,ic1) ) THEN
IF( ndb1 .ne. ndb2 ) STOP 'exchange: failure symequivalent'
DO i = 0,ndb1-1
DO j = 0,ndb2 - 1
ldum(iband1+i,iband2+j) = .true.
END DO
END DO
ndb2 = degenerat(iband2)
IF( ndb2 .GE. 1 ) THEN
ic2 = ic2 + 1
IF( symequivalent(ic2,ic1) ) THEN
IF( ndb1 .NE. ndb2 ) STOP 'exchange: failure symequivalent'
DO i = 0,ndb1-1
DO j = 0,ndb2 - 1
ldum(iband1+i,iband2+j) = .TRUE.
END DO
END DO
END IF
END IF
END IF
END IF
END DO
END IF
END DO
exchange = 0
iatom = 0
rdum = 0
DO itype = 1,atoms%ntype
DO ieq = 1,atoms%neq(itype)
END IF
END DO
exchange = 0
iatom = 0
rdum = 0
DO itype = 1,atoms%ntype
DO ieq = 1,atoms%neq(itype)
iatom = iatom + 1
DO l1 = 0,hybdat%lmaxc(itype)
DO p1 = 1,hybdat%nindxc(l1,itype)
DO l = 0,hybrid%lcutm1(itype)
! Define core-valence product functions
n = 0
DO l2 = 0,atoms%lmax(itype)
IF(l.lt.abs(l1-l2).or.l.gt.l1+l2) CYCLE
DO p2 = 1,hybrid%nindx(l2,itype)
n = n + 1
M = size(fprod,2)
IF(n.gt.M) THEN
ALLOCATE ( fprod2(atoms%jmtd,M),larr2(M),parr2(M) )
fprod2 = fprod ; larr2 = larr ; parr2 = parr
DEALLOCATE ( fprod,larr,parr )
ALLOCATE ( fprod(atoms%jmtd,M+5),larr(M+5),parr(M+5) )
fprod(:,:M) = fprod2
larr(:M) = larr2
parr(:M) = parr2
DEALLOCATE ( fprod2,larr2,parr2 )
END IF
fprod(:,n) = ( hybdat%core1(:,p1,l1,itype) *hybdat%bas1 (:,p2,l2,itype)&
& +hybdat%core2(:,p1,l1,itype) *hybdat%bas2 (:,p2,l2,itype) )/ atoms%rmsh(:,itype)
larr(n) = l2
parr(n) = p2
END DO
END DO
DO p1 = 1,hybdat%nindxc(l1,itype)
DO l = 0,hybrid%lcutm1(itype)
! Define core-valence product functions
n = 0
DO l2 = 0,atoms%lmax(itype)
IF(l.LT.ABS(l1-l2).OR.l.GT.l1+l2) CYCLE
DO p2 = 1,hybrid%nindx(l2,itype)
n = n + 1
M = SIZE(fprod,2)
IF(n.GT.M) THEN
ALLOCATE ( fprod2(atoms%jmtd,M),larr2(M),parr2(M) )
fprod2 = fprod ; larr2 = larr ; parr2 = parr
DEALLOCATE ( fprod,larr,parr )
ALLOCATE ( fprod(atoms%jmtd,M+5),larr(M+5),parr(M+5) )
fprod(:,:M) = fprod2
larr(:M) = larr2
parr(:M) = parr2
DEALLOCATE ( fprod2,larr2,parr2 )
END IF
fprod(:,n) = ( hybdat%core1(:,p1,l1,itype) *hybdat%bas1 (:,p2,l2,itype)&
+hybdat%core2(:,p1,l1,itype) *hybdat%bas2 (:,p2,l2,itype) )/ atoms%rmsh(:,itype)
larr(n) = l2
parr(n) = p2
END DO
END DO
! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT)
! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT)
ALLOCATE ( integral(n,n),carr(n,hybdat%nbands(nk)), carr2(n,lapw%nv(jsp)),carr3(n,lapw%nv(jsp)) )
ALLOCATE ( integral(n,n),carr(n,hybdat%nbands(nk)), carr2(n,lapw%nv(jsp)),carr3(n,lapw%nv(jsp)) )
DO i = 1,n
CALL primitivef(</