Commit d16d3702 authored by Matthias Redies's avatar Matthias Redies

merge fix

parents 4b65d160 3615dabb
......@@ -4,7 +4,7 @@ MODULE m_cdntot
! vacuum, and mt regions c.l.fu
! ********************************************************
CONTAINS
SUBROUTINE cdntot(stars,atoms,sym,vacuum,input,cell,oneD,&
SUBROUTINE cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,&
den,l_printData,qtot,qistot)
USE m_intgr, ONLY : intgr3
......@@ -18,6 +18,7 @@ CONTAINS
IMPLICIT NONE
! .. Scalar Arguments ..
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sym),INTENT(IN) :: sym
......@@ -88,7 +89,7 @@ CONTAINS
ELSE
qis = 0.
CALL pwint_all(stars,atoms,sym,oneD,cell,x)
CALL pwint_all(stars,atoms,sym,oneD,cell,1,stars%ng3,x)
DO j = 1,stars%ng3
qis = qis + den%pw(j,jspin)*x(j)*stars%nstr(j)
ENDDO
......
......@@ -122,7 +122,7 @@
END SUBROUTINE pwint
SUBROUTINE pwint_all(&
& stars,atoms,sym,oneD,&
& cell,&
& cell,x_start,x_end,&
& x)
USE m_spgrot
......@@ -138,6 +138,7 @@
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_cell),INTENT(IN) :: cell
INTEGER, INTENT (IN) :: x_start,x_end
COMPLEX, INTENT (OUT):: x(:)
! ..
!-odim
......@@ -159,7 +160,7 @@
!$OMP PARALLEL DO default(shared) &
!$OMP PRIVATE(ng,ig3d,g,gr,fj,ig2d,s,na,kr,ph,n)&
!$OMP PRIVATE(srmt,nn,sfs,arg,s1,ii)
starloop:DO ng=1,size(x)
starloop:DO ng=x_start,x_end
ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
IF (ig3d.EQ.0) THEN
x(ng) = (0.,0.)
......
......@@ -9,7 +9,7 @@ if (XXD_PROG)
else()
ADD_CUSTOM_COMMAND(
OUTPUT ${CMAKE_SOURCE_DIR}/io/xml/inputSchema.h
COMMAND mv ${CMAKE_SOURCE_DIR}/io/xml/inputSchema.h.backup ${CMAKE_SOURCE_DIR}/io/xml/inputSchema.h
COMMAND cp ${CMAKE_SOURCE_DIR}/io/xml/inputSchema.h.backup ${CMAKE_SOURCE_DIR}/io/xml/inputSchema.h
COMMENT "No xxd found using backup")
message("No xxd command found! Using backup of inputSchema.h")
endif()
......@@ -26,8 +26,8 @@ CONTAINS
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_noco),INTENT(IN) :: noco
! ..
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: na,ntyp
......@@ -48,20 +48,20 @@ CONTAINS
INTEGER locol,lorow,ii,ij,n,k,ab_size
! ..
! .. Local Arrays ..
COMPLEX, ALLOCATABLE :: ab(:,:),ax(:),bx(:),cx(:)
COMPLEX, ALLOCATABLE :: ab(:,:,:),ax(:),bx(:),cx(:)
COMPLEX,ALLOCATABLE :: abclo(:,:,:,:,:)
! ..
!--> synthesize the complex conjugates of a and b
ALLOCATE(ab(MAXVAL(lapw%nv),0:2*atoms%lmaxd*(atoms%lmaxd+2)+1))
ALLOCATE(ab(MAXVAL(lapw%nv),0:2*atoms%lmaxd*(atoms%lmaxd+2)+1,MIN(jintsp,iintsp):MAX(jintsp,iintsp)))
ALLOCATE(ax(MAXVAL(lapw%nv)),bx(MAXVAL(lapw%nv)),cx(MAXVAL(lapw%nv)))
ALLOCATE(abclo(3,-atoms%llod:atoms%llod,2*(2*atoms%llod+1),atoms%nlod,2))
DO i=MIN(jintsp,iintsp),MAX(jintsp,iintsp)
CALL hsmt_ab(sym,atoms,noco,isp,i,ntyp,na,cell,lapw,fj,gj,ab(:,:),ab_size,.TRUE.,abclo(:,:,:,:,i),alo1,blo1,clo1)
CALL hsmt_ab(sym,atoms,noco,isp,i,ntyp,na,cell,lapw,fj,gj,ab(:,:,i),ab_size,.TRUE.,abclo(:,:,:,:,i),alo1,blo1,clo1)
ENDDO
mlo=0;mlolo=0
DO m=1,ntyp-1
mlo=mlo+atoms%nlo(m)
......@@ -80,7 +80,7 @@ CONTAINS
IF (atoms%invsat(na) == 0) invsfct = 1
IF (atoms%invsat(na) == 1) invsfct = 2
!
DO lo = 1,atoms%nlo(ntyp)
l = atoms%llo(lo,ntyp)
!---> calculate the hamiltonian matrix elements with the regular
......@@ -117,19 +117,18 @@ CONTAINS
!---> and that a,b,alo... are the complex
!---> conjugates of the a,b...-coefficients
DO kp = 1,lapw%nv(iintsp)
ax(kp) = ax(kp) + ab(kp,lmp)*utu + ab(kp,ab_size/2+lmp)*dtu
bx(kp) = bx(kp) + ab(kp,lmp)*utd + ab(kp,ab_size/2+lmp)*dtd
cx(kp) = cx(kp) + ab(kp,lmp)*utulo + ab(kp,ab_size/2+lmp)*dtulo
ax(kp) = ax(kp) + ab(kp,lmp,iintsp)*utu + ab(kp,ab_size/2+lmp,iintsp)*dtu
bx(kp) = bx(kp) + ab(kp,lmp,iintsp)*utd + ab(kp,ab_size/2+lmp,iintsp)*dtd
cx(kp) = cx(kp) + ab(kp,lmp,iintsp)*utulo + ab(kp,ab_size/2+lmp,iintsp)*dtulo
END DO
END IF
END DO
END DO
!+t3e
DO nkvec = 1,invsfct* (2*l+1)
locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN !only this MPI rank calculates this column
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
IF (hmat%l_real) THEN
DO kp = 1,lapw%nv(iintsp)
hmat%data_r(kp,locol) = hmat%data_r(kp,locol) + chi*invsfct * (&
......@@ -142,8 +141,8 @@ CONTAINS
IF (input%l_useapw) THEN
!---> APWlo
hmat%data_r(kp,locol) = hmat%data_r(kp,locol) + 0.25 * atoms%rmt(ntyp)**2 * chi*invsfct * (&
(CONJG(ab(kp,lm))* ud%us(l,ntyp,isp)+&
CONJG(ab(kp,ab_size/2+lm))*ud%uds(l,ntyp,isp))*&
(CONJG(ab(kp,lm,iintsp))* ud%us(l,ntyp,isp)+&
CONJG(ab(kp,ab_size/2+lm,iintsp))*ud%uds(l,ntyp,isp))*&
(abclo(1,m,nkvec,lo,jintsp)* ud%dus(l,ntyp,isp)&
+abclo(2,m,nkvec,lo,jintsp)* ud%duds(l,ntyp,isp)&
+abclo(3,m,nkvec,lo,jintsp)*ud%dulos(lo,ntyp,isp) ))
......@@ -151,19 +150,19 @@ CONTAINS
ENDDO
ELSE
DO kp = 1,lapw%nv(iintsp)
hmat%data_c(kp,locol) = hmat%data_c(kp,locol) + chi*invsfct * (&
abclo(1,m,nkvec,lo,jintsp) * CONJG( ax(kp) ) +&
abclo(2,m,nkvec,lo,jintsp) * CONJG( bx(kp) ) +&
abclo(3,m,nkvec,lo,jintsp) * CONJG( cx(kp) ) )
IF (input%l_useapw) THEN
!---> APWlo
hmat%data_c(kp,locol)=hmat%data_c(kp,locol) + 0.25 * atoms%rmt(ntyp)**2 * chi*invsfct*(&
(CONJG(ab(kp,lm))* ud%us(l,ntyp,isp)+&
CONJG(ab(kp,ab_size/2+lm))*ud%uds(l,ntyp,isp))*&
(abclo(1,m,nkvec,lo,jintsp)* ud%dus(l,ntyp,isp)&
+abclo(2,m,nkvec,lo,jintsp)* ud%duds(l,ntyp,isp)&
+abclo(3,m,nkvec,lo,jintsp)*ud%dulos(lo,ntyp,isp) ))
ENDIF
hmat%data_c(kp,locol) = hmat%data_c(kp,locol) + chi*invsfct * (&
abclo(1,m,nkvec,lo,jintsp) * CONJG( ax(kp) ) +&
abclo(2,m,nkvec,lo,jintsp) * CONJG( bx(kp) ) +&
abclo(3,m,nkvec,lo,jintsp) * CONJG( cx(kp) ) )
IF (input%l_useapw) THEN
!---> APWlo
hmat%data_c(kp,locol)=hmat%data_c(kp,locol) + 0.25 * atoms%rmt(ntyp)**2 * chi*invsfct*(&
(CONJG(ab(kp,lm,iintsp))* ud%us(l,ntyp,isp)+&
CONJG(ab(kp,ab_size/2+lm,iintsp))*ud%uds(l,ntyp,isp))*&
(abclo(1,m,nkvec,lo,jintsp)* ud%dus(l,ntyp,isp)&
+abclo(2,m,nkvec,lo,jintsp)* ud%duds(l,ntyp,isp)&
+abclo(3,m,nkvec,lo,jintsp)*ud%dulos(lo,ntyp,isp) ))
ENDIF
ENDDO
ENDIF
!---> jump to the last matrixelement of the current row
......@@ -173,13 +172,13 @@ CONTAINS
!---> calculate the hamiltonian matrix elements with other
!---> local orbitals at the same atom and with itself
DO nkvec = 1,invsfct* (2*l+1)
locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN !only this MPI rank calculates this column
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
!---> calculate the hamiltonian matrix elements with other
!---> local orbitals at the same atom, if they have the same l
DO lop = 1, (lo-1)
DO lop = 1, MERGE(lo-1,atoms%nlo(ntyp),iintsp==jintsp)
IF (lop==lo) CYCLE
lp = atoms%llo(lop,ntyp)
DO nkvecp = 1,invsfct* (2*lp+1)
lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
......@@ -207,8 +206,13 @@ CONTAINS
ulotu=CONJG(tlmplm%tuulo(lm,mp,lop+mlo,isp))
ulotd=CONJG(tlmplm%tdulo(lm,mp,lop+mlo,isp))
!---> note that lo > lop
lolop = ((lo-1)*lo)/2 + lop
ulotulo = CONJG(tlmplm%tuloulo (m,mp,lolop+mlolo,isp))
IF (lo>lop) THEN
lolop = ((lo-1)*lo)/2 + lop
ulotulo = CONJG(tlmplm%tuloulo (m,mp,lolop+mlolo,isp))
ELSE
lolop = ((lop-1)*lop)/2 + lo
ulotulo = CONJG(tlmplm%tuloulo (mp,m,lolop+mlolo,isp))
ENDIF
axx=CONJG(abclo(1,m,nkvec,lo,jintsp))*utu +&
CONJG(abclo(2,m,nkvec,lo,jintsp))*utd +&
CONJG(abclo(3,m,nkvec,lo,jintsp))*utulo
......@@ -240,7 +244,8 @@ CONTAINS
END DO
!---> calculate the hamiltonian matrix elements of one local
!---> orbital with itself
DO nkvecp = 1,nkvec
lop=lo
DO nkvecp = 1,MERGE(nkvec,invsfct* (2*l+1),iintsp==jintsp)
lorow=lapw%nv(iintsp)+lapw%index_lo(lop,na)+nkvecp
DO m = -l,l
lm = l* (l+1) + m
......@@ -294,13 +299,12 @@ CONTAINS
END DO
END DO
END DO
ENDIF
!-t3e
ENDIF !If this lo to be calculated by mpi rank
END DO
END DO ! end of lo = 1,atoms%nlo loop
END IF
!$OMP END MASTER
!$OMP barrier
END SUBROUTINE hlomat
END MODULE m_hlomat
END MODULE m_hlomat
......@@ -43,7 +43,7 @@ CONTAINS
REAL, INTENT (IN) :: fj(:,0:,:),gj(:,0:,:)
TYPE(t_usdus),INTENT(IN) :: ud
CLASS(t_mat),INTENT(INOUT) :: smat
! ..
! .. Local Scalars ..
REAL con,dotp,fact1,fact2,fact3,fl2p1
......@@ -67,10 +67,11 @@ CONTAINS
!---> (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
IF (atoms%invsat(na) == 0) invsfct = 1
IF (atoms%invsat(na) == 1) invsfct = 2
con = fpi_const/SQRT(cell%omtil)* ((atoms%rmt(ntyp))**2)/2.0
DO lo = 1,atoms%nlo(ntyp) !loop over all LOs for this atom
l = atoms%llo(lo,ntyp)
fl2p1 = (2*l+1)/fpi_const
fact1 = (con**2)* fl2p1 * (&
......@@ -80,11 +81,9 @@ CONTAINS
2*clo1(lo) * ud%dulon(lo,ntyp,isp) ) +&
clo1(lo)* clo1(lo) )
DO nkvec = 1,invsfct* (2*l+1) !Each LO can have several functions
!+t3e
locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage!
k = lapw%kvec(nkvec,lo,na)
!---> calculate the overlap matrix elements with the regular
!---> flapw basis-functions
......@@ -105,7 +104,8 @@ CONTAINS
END DO
!---> calculate the overlap matrix elements with other local
!---> orbitals at the same atom, if they have the same l
DO lop = 1, (lo-1)
DO lop = 1, MERGE(lo-1,atoms%nlo(ntyp),iintsp==jintsp)
IF (lop==lo) CYCLE !Do later
lp = atoms%llo(lop,ntyp)
IF (l == lp) THEN
fact3 = con**2 * fl2p1 * (&
......@@ -128,12 +128,12 @@ CONTAINS
cph(k,jintsp)*CONJG(cph(kp,iintsp))
ENDIF
END DO
ELSE
END IF
ENDIF
END DO
!---> calculate the overlap matrix elements of one local
!---> orbital with itself
DO nkvecp = 1,nkvec
lop=lo
DO nkvecp = 1,MERGE(nkvec,invsfct* (2*l+1),iintsp==jintsp)
kp = lapw%kvec(nkvecp,lo,na)
lorow=lapw%nv(iintsp)+lapw%index_lo(lo,na)+nkvecp
dotp = dot_PRODUCT(lapw%gk(:,k,jintsp),lapw%gk(:,kp,iintsp))
......@@ -146,7 +146,6 @@ CONTAINS
ENDIF
END DO
ENDIF ! mod(locol-1,n_size) = nrank
!-t3e
END DO
END DO
END IF
......
......@@ -6,10 +6,8 @@ MODULE m_alineso
! Eigenvalues and vectors (eig_so and zso) are returned
!----------------------------------------------------------------------
CONTAINS
SUBROUTINE alineso(eig_id,lapw,&
mpi,DIMENSION,atoms,sym,kpts,&
input,noco,cell,oneD, nk, usdus,rsoc,&
nsize,nmat, eig_so,zso)
SUBROUTINE alineso(eig_id,lapw,mpi,DIMENSION,atoms,sym,kpts,input,noco,&
cell,oneD, nk, usdus,rsoc,nsize,nmat, eig_so,zso)
#include"cpp_double.h"
USE m_types
......@@ -99,16 +97,12 @@ CONTAINS
zso(:,:,:)= CMPLX(0.,0.)
DO jsp = 1,input%jspins
CALL read_eig(&
eig_id,nk,jsp, neig=ne,eig=eig(:,jsp))
CALL read_eig(eig_id,nk,jsp, neig=ne,eig=eig(:,jsp))
IF (judft_was_argument("-debugtime")) THEN
WRITE(6,*) "Non-SOC ev for nk,jsp:",nk,jsp
WRITE(6,"(6(f10.6,1x))") eig(:ne,jsp)
ENDIF
CALL read_eig(&
eig_id,nk,jsp,&
n_start=1,n_end=ne,&
zmat=zmat(jsp))
CALL read_eig(eig_id,nk,jsp,n_start=1,n_end=ne,zmat=zmat(jsp))
! write(*,*) 'process',irank,' reads ',nk
......@@ -156,50 +150,36 @@ CONTAINS
nat_stop = atoms%nat
ENDIF
nat_l = nat_stop - nat_start + 1
!
! set up A and B coefficients
!
ALLOCATE ( ahelp(atoms%lmaxd*(atoms%lmaxd+2),nat_l,DIMENSION%neigd,input%jspins) )
ALLOCATE ( bhelp(atoms%lmaxd*(atoms%lmaxd+2),nat_l,DIMENSION%neigd,input%jspins) )
ALLOCATE ( chelp(-atoms%llod :atoms%llod, DIMENSION%neigd,atoms%nlod,nat_l,input%jspins) )
ALLOCATE (ahelp(atoms%lmaxd*(atoms%lmaxd+2),nat_l,DIMENSION%neigd,input%jspins))
ALLOCATE (bhelp(atoms%lmaxd*(atoms%lmaxd+2),nat_l,DIMENSION%neigd,input%jspins))
ALLOCATE (chelp(-atoms%llod :atoms%llod, DIMENSION%neigd,atoms%nlod,nat_l,input%jspins))
CALL timestart("alineso SOC: -help")
write(*,*) nat_start,nat_stop,nat_l
CALL hsohelp(&
& DIMENSION,atoms,sym,&
& input,lapw,nsz,&
& cell,&
& zmat,usdus,&
& zso,noco,oneD,&
& nat_start,nat_stop,nat_l,&
& ahelp,bhelp,chelp)
CALL hsohelp(DIMENSION,atoms,sym,input,lapw,nsz,cell,zmat,usdus,&
zso,noco,oneD,nat_start,nat_stop,nat_l,ahelp,bhelp,chelp)
CALL timestop("alineso SOC: -help")
!
! set up hamilton matrix
!
CALL timestart("alineso SOC: -ham")
#ifdef CPP_MPI
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
#endif
ALLOCATE ( hsomtx(DIMENSION%neigd,DIMENSION%neigd,2,2) )
ALLOCATE (hsomtx(DIMENSION%neigd,DIMENSION%neigd,2,2))
CALL hsoham(atoms,noco,input,nsz,dimension%neigd,chelp,rsoc,ahelp,bhelp,&
nat_start,nat_stop,mpi%n_rank,mpi%n_size,mpi%SUB_COMM,&
hsomtx)
write(*,*) 'after hsoham'
DEALLOCATE ( ahelp,bhelp,chelp )
nat_start,nat_stop,mpi%n_rank,mpi%n_size,mpi%SUB_COMM,hsomtx)
DEALLOCATE (ahelp,bhelp,chelp)
CALL timestop("alineso SOC: -ham")
IF (mpi%n_rank==0) THEN
!
! add e.v. on diagonal
!
! write(*,*) '!!!!!!!!!!! remove SOC !!!!!!!!!!!!!!'
! hsomtx = 0 !!!!!!!!!!!!
DO jsp = 1,input%jspins
DO i = 1,nsz(jsp)
hsomtx(i,i,jsp,jsp) = hsomtx(i,i,jsp,jsp) +&
& CMPLX(eig(i,jsp),0.)
hsomtx(i,i,jsp,jsp) = hsomtx(i,i,jsp,jsp) + CMPLX(eig(i,jsp),0.)
IF (input%jspins.EQ.1) THEN
hsomtx(i,i,2,2) = hsomtx(i,i,2,2) +&
& CMPLX(eig(i,jsp),0.)
hsomtx(i,i,2,2) = hsomtx(i,i,2,2) + CMPLX(eig(i,jsp),0.)
ENDIF
ENDDO
ENDDO
......@@ -207,34 +187,33 @@ CONTAINS
!
! resort H-matrix
!
ALLOCATE ( hso(2*DIMENSION%neigd,2*DIMENSION%neigd) )
ALLOCATE (hso(2*DIMENSION%neigd,2*DIMENSION%neigd))
DO jsp = 1,2
DO jsp1 = 1,2
IF (jsp.EQ.1) nn = 0
IF (jsp1.EQ.1) nn1 = 0
IF (jsp.EQ.2) nn = nsz(1)
IF (jsp1.EQ.2) nn1 = nsz(1)
!
!write(3333,'(2i3,4e15.8)') jsp,jsp1,hsomtx(jsp,jsp1,8,8),hsomtx(jsp,jsp1,32,109)
DO i = 1,nsz(jsp)
DO j = 1,nsz(jsp1)
hso(i+nn,j+nn1) = hsomtx(i,j,jsp,jsp1)
ENDDO
ENDDO
!
ENDDO
ENDDO
DEALLOCATE ( hsomtx )
DEALLOCATE (hsomtx)
!
! add Sigma-vxc (QSGW)
!
IF( l_qsgw ) THEN
IF(l_qsgw) THEN
nbas = lapw%nv(1) + atoms%nlotot
WRITE(*,'(A,I3,A,I5,A)') 'Read fleur.qsgw (',nk,',',nbas,')'
IF( input%jspins .EQ. 2 ) STOP 'alineso: GW+noco not implemented.'
ALLOCATE ( sigma_xc(2*nsz(1),2*nsz(1)) )
ALLOCATE ( sigma_xc_apw(nbas,nbas) )
ALLOCATE (sigma_xc(2*nsz(1),2*nsz(1)))
ALLOCATE (sigma_xc_apw(nbas,nbas))
INQUIRE(667,opened=l_open)
IF( .NOT.l_open ) THEN
IF( nk.NE.1 ) STOP 'unit 667 not opened but not at 1st k'
......@@ -260,12 +239,12 @@ CONTAINS
j = nsz(1) * (jsp2-1) + 1 ; j1 = nsz(1) * jsp2
if (l_real) THEN
sigma_xc(i:i1,j:j1) = &
& MATMUL ( TRANSPOSE(zmat(1)%data_r(:nbas,:)) ,&
& MATMUL ( sigma_xc_apw, zmat(1)%data_r(:nbas,:) ) )
MATMUL ( TRANSPOSE(zmat(1)%data_r(:nbas,:)) ,&
MATMUL ( sigma_xc_apw, zmat(1)%data_r(:nbas,:) ) )
else
sigma_xc(i:i1,j:j1) = &
& MATMUL ( CONJG(TRANSPOSE(zmat(1)%data_c(:nbas,:))) ,&
& MATMUL ( sigma_xc_apw, zmat(1)%data_c(:nbas,:) ) )
MATMUL ( CONJG(TRANSPOSE(zmat(1)%data_c(:nbas,:))) ,&
MATMUL ( sigma_xc_apw, zmat(1)%data_c(:nbas,:) ) )
endif
hso(i:i1,j:j1) = hso(i:i1,j:j1) + CONJG(sigma_xc(i:i1,j:j1))
IF(jsp1.NE.jsp2) THEN
......@@ -274,7 +253,7 @@ else
ENDIF
ENDDO
ENDDO
DEALLOCATE ( sigma_xc_apw )
DEALLOCATE (sigma_xc_apw)
ENDIF
!
......@@ -285,29 +264,25 @@ else
CALL timestart("alineso SOC: -diag")
ALLOCATE ( cwork(idim_c),rwork(idim_r) )
ALLOCATE (cwork(idim_c),rwork(idim_r))
IF (input%eonly) THEN
vectors= 'N'
ELSE
vectors= 'V'
ENDIF
CALL CPP_LAPACK_cheev(vectors,'U',nsize,&
& hso,2*DIMENSION%neigd,&
& eig_so,&
& cwork, idim_c, rwork, &
& info)
CALL CPP_LAPACK_cheev(vectors,'U',nsize,hso,2*DIMENSION%neigd,eig_so,&
cwork, idim_c, rwork, info)
IF (info.NE.0) WRITE (6,FMT=8000) info
8000 FORMAT (' AFTER CPP_LAPACK_cheev: info=',i4)
CALL timestop("alineso SOC: -diag")
DEALLOCATE ( cwork,rwork )
DEALLOCATE (cwork,rwork)
IF (input%eonly) THEN
IF(l_socvec) CALL juDFT_error&
& ("EONLY set. Vectors not calculated.",calledby ="alineso")
IF(l_socvec) CALL juDFT_error("EONLY set. Vectors not calculated.",calledby ="alineso")
ELSE
ALLOCATE ( zhelp2(DIMENSION%neigd,2*DIMENSION%neigd) )
ALLOCATE (zhelp2(DIMENSION%neigd,2*DIMENSION%neigd))
!
! proj. back to G - space: old eigenvector 'z' to new one 'Z'
! +
......@@ -354,11 +329,11 @@ else
& MATMUL ( sigma_xc , CONJG(hso(:nn,:nn)) ) )
WRITE(1014) nn
WRITE(1014) ((sigma_xc(i,j),i=1,j),j=1,nn)
DEALLOCATE ( sigma_xc )
DEALLOCATE (sigma_xc)
ENDIF
ENDIF
DEALLOCATE ( zhelp2 )
DEALLOCATE (zhelp2)
ENDIF ! (.NOT.input%eonly)
DEALLOCATE ( hso )
......
......@@ -148,7 +148,7 @@ CONTAINS
'branchLowest ','branchHighest','value '/),&
attributes,RESHAPE((/12,4,6,12,13,5,6,1,3,8,8,16/),(/6,2/)))
ENDIF
WRITE(6,'(a6,i3,i2,a1,a12,f6.2,a3,f6.2,a13,f8.4)') ' Atom',n,nqn,ch(l),' branch from',&
WRITE(6,'(a6,i5,i2,a1,a12,f6.2,a3,f6.2,a13,f8.4)') ' Atom',n,nqn,ch(l),' branch from',&
e_lo, ' to',e_up,' htr. ; e_l =',e
ENDIF
END FUNCTION priv_method1
......
......@@ -11,7 +11,7 @@ MODULE m_qfix
! qfix file no longer supported!
CONTAINS
SUBROUTINE qfix(stars,atoms,sym,vacuum,sphhar,input,cell,oneD,&
SUBROUTINE qfix(mpi,stars,atoms,sym,vacuum,sphhar,input,cell,oneD,&
den,l_noco,l_printData,force_fix,fix)
USE m_types
......@@ -20,6 +20,7 @@ CONTAINS
IMPLICIT NONE
! .. Scalar Arguments ..
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sym),INTENT(IN) :: sym
......@@ -51,7 +52,7 @@ CONTAINS
! qfix==0 means no qfix was given in inp.xml.
! In this case do nothing except when forced to fix!
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,den,.TRUE.,qtot,qis)
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,den,.TRUE.,qtot,qis)
!The total nucleii charge
zc=SUM(atoms%neq(:)*atoms%zatom(:))
......@@ -92,7 +93,7 @@ CONTAINS
IF (ABS(fix-1.0)<1.E-6) RETURN !no second calculation of cdntot as nothing was fixed
CALL openXMLElementNoAttributes('fixedCharges')
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,den,l_printData,qtot,qis)
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,den,l_printData,qtot,qis)
CALL closeXMLElement('fixedCharges')
IF (fix>1.1) CALL juDFT_WARN("You lost too much charge")
......
......@@ -565,6 +565,13 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
l_kpts = .TRUE.
kpts%specificationType = 3
kpts%posScale=1.0
! We need to set input%film for inpeig. Unfortunately this is actually initialized at a later stage.
! So we do it here additionally.
input%film = .FALSE.
numberNodes = xmlGetNumberOfNodes('/fleurInput/cell/filmLattice')
IF (numberNodes.EQ.1) input%film = .TRUE.
CALL inpeig(atoms,cell,input,.FALSE.,kpts,kptsFilename=TRIM(ADJUSTL(valueString)))
END IF
......@@ -2373,11 +2380,11 @@ input%preconditioning_param = evaluateFirstOnly(xmlGetAttributeValue('/fleurInpu
n=xmlGetNumberOfNodes(TRIM(ADJUSTL(path))//'/q')
ALLOCATE(q(3,n))
DO i = 1, n
PRINT *, path,'/q[',i,']'
!PRINT *, path,'/q[',i,']'
WRITE(xPathA,"(a,a,i0,a)") TRIM(ADJUSTL(path)),'/q[',i,']'
PRINT *,xpatha
!PRINT *,xpatha
valueString = TRIM(ADJUSTL(xmlGetAttributeValue(TRIM(ADJUSTL(xPathA)))))
PRINT *,"Q:",valueString
!PRINT *,"Q:",valueString
READ(valueString,*) q(1,i),q(2,i),q(3,i)
END DO
END FUNCTION priv_read_q_list
......
......@@ -114,6 +114,7 @@ SUBROUTINE writeBasis(input,noco,kpts,atoms,sym,cell,enpara,vTot,vCoul,vx,mpi,DI
integer(HSIZE_T) :: Hdim1(4)
INTEGER :: lmn, na,lm,n,nn, m
complex,parameter :: img=(0.,1.)
REAL :: bk(3)
LOGICAL l_zref,l_real, link_exists
INTEGER jsp,nk,l,itype
......@@ -314,8 +315,12 @@ SUBROUTINE writeBasis(input,noco,kpts,atoms,sym,cell,enpara,vTot,vCoul,vx,mpi,DI
! DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride
DO nk = 1,kpts%nkpt
CALL lapw%init(input,noco,kpts,atoms,sym,nk,cell,l_zref)
bk(:) = kpts%bk(:,nk)
IF(abs(bk(1)).LT.1e-7) bk(1) = abs(bk(1))
IF(abs(bk(2)).LT.1e-7) bk(2) = abs(bk(2))
IF(abs(bk(3)).LT.1e-7) bk(3) = abs(bk(3))
!write(kpt_name , '(2a,i0)') TRIM(ADJUSTL(jsp_name)),'/kpt_',nk
write(kpt_name , '(2a,f12.10,a,f12.10,a,f12.10)') TRIM(ADJUSTL(jsp_name)),'/kpt_',kpts%bk(1,nk),',',kpts%bk(2,nk),',',kpts%bk(3,nk)
write(kpt_name , '(2a,f12.10,a,f12.10,a,f12.10)') TRIM(ADJUSTL(jsp_name)),'/kpt_',bk(1),',',bk(2),',',bk(3)
CALL h5lexists_f(fileID, TRIM(ADJUSTL(kpt_name)), link_exists, hdfError)
IF (link_exists) CYCLE
CALL h5gcreate_f(fileID, TRIM(ADJUSTL(kpt_name)), kptGroupID, hdfError)
......@@ -447,8 +452,12 @@ SUBROUTINE writeBasis(input,noco,kpts,atoms,sym,cell,enpara,vTot,vCoul,vx,mpi,DI
! DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride
DO nk = 1,kpts%nkpt
CALL lapw%init(input,noco,kpts,atoms,sym,nk,cell,l_zref)
bk(:) = kpts%bk(:,nk)
IF(abs(bk(1)).LT.1e-7) bk(1) = abs(bk(1))
IF(abs(bk(2)).LT.1e-7) bk(2) = abs(bk(2))
IF(abs(bk(3)).LT.1e-7) bk(3) = abs(bk(3))
!write(kpt_name , '(2a,i0)') TRIM(ADJUSTL(jsp_name)),'/kpt_',nk
write(kpt_name , '(2a,f12.10,a,f12.10,a,f12.10)') TRIM(ADJUSTL(jsp_name)),'/kpt_',kpts%bk(1,nk),',',kpts%bk(2,nk),',',kpts%bk(3,nk)
write(kpt_name , '(2a,f12.10,a,f12.10,a,f12.10)') TRIM(ADJUSTL(jsp_name)),'/kpt_',bk(1),',',bk(2),',',bk(3)
CALL h5lexists_f(fileID, TRIM(ADJUSTL(kpt_name)), link_exists, hdfError)
IF (link_exists) CYCLE
CALL h5gcreate_f(fileID, TRIM(ADJUSTL(kpt_name)), kptGroupID, hdfError)
......
......@@ -164,7 +164,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
IF (vacuum%nstm == 3) CALL juDFT_end("VACWAVE OK",mpi%irank)
IF (mpi%irank == 0) THEN
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy)
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy)
CALL closeXMLElement('valenceDensity')
END IF ! mpi%irank = 0
......@@ -185,7 +185,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
IF (mpi%irank == 0) THEN
CALL openXMLElementNoAttributes('allElectronCharges')
CALL qfix(stars,atoms,sym,vacuum,sphhar,input,cell,oneD,outDen,noco%l_noco,.TRUE.,.true.,fix)
CALL qfix(mpi,stars,atoms,sym,vacuum,sphhar,input,cell,oneD,outDen,noco%l_noco,.TRUE.,.true.,fix)
CALL closeXMLElement('allElectronCharges')
IF (input%jspins == 2) THEN
......
......@@ -149,7 +149,7 @@ CONTAINS
CALL readDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,CDN_INPUT_DEN_const,&
0,results%ef,l_qfix,inDen)
CALL timestart("Qfix")
CALL qfix(stars,atoms,sym,vacuum, sphhar,input,cell,oneD,inDen,noco%l_noco,.FALSE.,.false.,fix)
CALL qfix(mpi,stars,atoms,sym,vacuum, sphhar,input,cell,oneD,inDen,noco%l_noco,.FALSE.,.false.,fix)
CALL timestop("Qfix")
CALL writeDensity(stars,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,CDN_INPUT_DEN_const,&
0,-1.0,results%ef,.FALSE.,inDen)
......
......@@ -265,7 +265,7 @@ contains
if( input%jspins == 2 ) call resDen%ChargeAndMagnetisationToSpins()
! fix the preconditioned density
call outDen%addPotDen( resDen, inDen )
call qfix( stars, atoms, sym, vacuum, sphhar, input, cell, oneD, outDen, noco%l_noco, .false., .true., fix )
call qfix(mpi,stars, atoms, sym, vacuum, sphhar, input, cell, oneD, outDen, noco%l_noco, .false., .true., fix )
call resDen%subPotDen( outDen, inDen )
call brysh1( input, stars, atoms, sphhar, noco, vacuum, sym, oneD, &
intfac, vacfac, resDen,<