Commit fdeca975 authored by Daniel Wortmann's avatar Daniel Wortmann

Removed lots of preprocessor dependencies, fixed BUG in last commit

parent 43beef12
This diff is collapsed.
......@@ -371,7 +371,7 @@ CONTAINS
isn = 1
#if ( defined(CPP_INVERSION) && !defined(CPP_SOC) )
CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
nw1,nw2,nw3,wsave,psir(ifftq3d), psir(-ifftq2))
nw1,nw2,nw3,wsave,psir(ifftq3d), psir(-ifftq2))
! GM forces part
IF (input%l_f) THEN
......@@ -566,8 +566,8 @@ CONTAINS
isn = -1
#if ( defined(CPP_INVERSION) && !defined(CPP_SOC) )
CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,wsave,psir(ifftq3d), rhon(-ifftq2))
CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,wsave,psir(ifftq3d), rhon(-ifftq2))
IF (input%l_f) CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,wsave,kpsir(ifftq3d), ekin(-ifftq2))
#else
......@@ -620,18 +620,19 @@ CONTAINS
DO istr = 1 , stars%ng3_fft
cwk(istr) = scale * cwk(istr) / REAL( stars%nstr(istr) )
ENDDO
#ifdef CPP_APW
IF (input%l_f) THEN
DO istr = 1 , stars%ng3_fft
ecwk(istr) = scale * ecwk(istr) / REAL( stars%nstr(istr) )
ENDDO
CALL forces_b8(&
atoms,ecwk,stars,&
sym,cell,&
jspin,&
forces,f_b8)
IF (input%l_useapw) THEN
IF (input%l_f) THEN
DO istr = 1 , stars%ng3_fft
ecwk(istr) = scale * ecwk(istr) / REAL( stars%nstr(istr) )
ENDDO
CALL force_b8(&
atoms,ecwk,stars,&
sym,cell,&
jspin,&
forces,f_b8)
ENDIF
ENDIF
#endif
!
!---> check charge neutralilty
!
......
MODULE m_abccoflo
USE m_juDFT
!*********************************************************************
! Calculates the (upper case) A, B and C coefficients for the local
! orbitals.
! Philipp Kurz 99/04
!*********************************************************************
CONTAINS
SUBROUTINE abccoflo(atoms, con1,rph,cph,ylm,ntyp,na,k,nv,&
l_lo1,alo1,blo1,clo1, nkvec, enough,alo,blo,clo,kvec)
!
!*************** ABBREVIATIONS ***************************************
! kvec : stores the number of the G-vectors, that have been used to
! construct the local orbitals
! nkvec : stores the number of G-vectors that have been found and
! accepted during the construction of the local orbitals.
! enough : enough is set to .true. when enough G-vectors have been
! accepted.
! linindq : if the norm of that part of a local orbital (contructed
! with a trial G-vector) that is orthogonal to the previous
! ones is larger than linindq, then this G-vector is
! accepted.
!*********************************************************************
!
USE m_constants
USE m_types
IMPLICIT NONE
TYPE(t_atoms),INTENT(IN) :: atoms
! ..
! .. Scalar Arguments ..
REAL, INTENT (IN) :: con1,cph ,rph
INTEGER, INTENT (IN) :: k,na,ntyp,nv
LOGICAL, INTENT (IN) :: l_lo1
LOGICAL, INTENT (OUT):: enough
! ..
! .. Array Arguments ..
INTEGER, INTENT (IN):: kvec(2* (2*atoms%llod+1),atoms%nlod) )
REAL, INTENT (IN) :: alo1(atoms%nlod),blo1(atoms%nlod),clo1(atoms%nlod)
COMPLEX, INTENT (IN) :: ylm( (atoms%lmaxd+1)**2 )
COMPLEX, INTENT (OUT):: alo(-atoms%llod:atoms%llod,2* (2*atoms%llod+1),atoms%nlod)
COMPLEX, INTENT (OUT):: blo(-atoms%llod:atoms%llod,2* (2*atoms%llod+1),atoms%nlod)
COMPLEX, INTENT (OUT):: clo(-atoms%llod:atoms%llod,2* (2*atoms%llod+1),atoms%nlod)
INTEGER,INTENT (INOUT):: nkvec(atoms%nlod)
! ..
! .. Local Scalars ..
COMPLEX term1
REAL,PARAMETER:: linindq=1.e-4
INTEGER l,lo ,mind,ll1,lm
LOGICAL linind
! ..
!
!---> the whole program is in hartree units, therefore 1/wronskian is
!---> (rmt**2)/2. the factor i**l, which usually appears in the a, b
!---> and c coefficients, is included in the t-matrices. thus, it does
!---> not show up in the formula above.
!
!-abccoflo1
IF ( l_lo1) THEN
DO lo = 1,atoms%nlo(ntyp)
IF ( (nkvec(lo).EQ.0).AND.(atoms%llo(lo,ntyp).EQ.0) ) THEN
enough = .FALSE.
nkvec(lo) = 1
m = 0
clo(m,nkvec(lo),lo) = con1* ((atoms%rmt**2)/2) / SQRT(fpi_const)
alo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*alo1(lo)
blo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*blo1(lo)
clo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*clo1(lo)
IF (kvec(nkvec(lo),lo)/=k) CALL juDFT_error("abccoflo:1"&
& ,calledby ="abccoflo")
ENDIF
ENDDO
ELSE
enough = .TRUE.
term1 = con1* ((atoms%rmt**2)/2)*CMPLX(rph,cph)
DO lo = 1,atoms%nlo(ntyp)
IF (atoms%invsat(na).EQ.0) THEN
IF ((nkvec(lo)).LT. (2*atoms%llo(lo,ntyp)+1)) THEN
enough = .FALSE.
nkvec(lo) = nkvec(lo) + 1
l = atoms%llo(lo,ntyp)
ll1 = l*(l+1) + 1
DO m = -l,l
lm = ll1 + m
clo(m,nkvec(lo),lo) = term1*ylm(lm)
END DO
IF ( kvec(nkvec(lo),lo) == k ) THEN
DO m = -l,l
alo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*alo1(lo)
blo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*blo1(lo)
clo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*clo1(lo)
END DO
! WRITE(6,9000) nkvec(lo),k,lo,na,
! + (clo(m,nkvec(lo),lo),m=-l,l)
! 9000 format(2i4,2i2,7(' (',e9.3,',',e9.3,')'))
ELSE
nkvec(lo) = nkvec(lo) - 1
ENDIF
ENDIF
ELSE
IF ((atoms%invsat(na).EQ.1) .OR. (atoms%invsat(na).EQ.2)) THEN
! only invsat=1 is needed invsat=2 for testing
IF ((nkvec(lo)).LT. (2* (2*atoms%llo(lo,ntyp)+1))) THEN
enough = .FALSE.
nkvec(lo) = nkvec(lo) + 1
l = atoms%llo(lo,ntyp)
ll1 = l*(l+1) + 1
DO m = -l,l
lm = ll1 + m
clo(m,nkvec(lo),lo) = term1*ylm(lm)
END DO
IF ( kvec(nkvec(lo),lo) == k ) THEN
DO m = -l,l
! if(l.eq.1) then
! WRITE(*,*)'k=',k,' clotmp=',clo(m,nkvec(lo),lo)
! WRITE(*,*)'clo1=',clo1(lo),' term1=',term1
! endif
alo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*alo1(lo)
blo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*blo1(lo)
clo(m,nkvec(lo),lo) = clo(m,nkvec(lo),lo)*clo1(lo)
! kvec(nkvec(lo),lo) = k
END DO
ELSE
nkvec(lo) = nkvec(lo) - 1
END IF
END IF
END IF
END IF
END DO
IF ((k.EQ.nv) .AND. (.NOT.enough)) THEN
WRITE (6,FMT=*)&
& 'abccoflo did not find enough linearly independent'
WRITE (6,FMT=*)&
& 'clo coefficient-vectors. the linear independence'
WRITE (6,FMT=*) 'quality, linindq, is set to: ',linindq,'.'
WRITE (6,FMT=*) 'this value might be to large.'
CALL juDFT_error&
& ("abccoflo: did not find enough lin. ind. clo-vectors"&
& ,calledby ="abccoflo")
END IF
ENDIF ! abccoflo1
END SUBROUTINE abccoflo
END MODULE m_abccoflo
MODULE m_abcof
CONTAINS
SUBROUTINE abcof(atoms,nobd,sym, cell, bkpt,lapw,ne,z,usdus,&
SUBROUTINE abcof(input,atoms,nobd,sym, cell, bkpt,lapw,ne,z,usdus,&
noco,jspin,kveclo,oneD, acof,bcof,ccof)
! ************************************************************
! subroutine constructs the a,b coefficients of the linearized
......@@ -16,7 +16,8 @@ CONTAINS
USE m_ylm
USE m_types
IMPLICIT NONE
TYPE(t_usdus),INTENT(IN) :: usdus
TYPE(t_input),INTENT(IN) :: input
TYPE(t_usdus),INTENT(IN) :: usdus
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_noco),INTENT(IN) :: noco
......@@ -79,9 +80,7 @@ CONTAINS
DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(l,n) = .true.
ENDDO
#ifdef CPP_APW
IF (atoms%lapw_l(n).GE.l) apw(l,n) = .false.
#endif
IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l,n) = .false.
ENDDO
DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true.
......
MODULE m_abcof3
CONTAINS
SUBROUTINE abcof3(atoms,sym,jspin, cell, bkpt,lapw,&
SUBROUTINE abcof3(input,atoms,sym,jspin, cell, bkpt,lapw,&
usdus, kveclo,oneD,a,b,bascof_lo)
! ************************************************************
! subroutine constructs the a,b coefficients of the linearized
......@@ -16,6 +16,7 @@ CONTAINS
USE m_ylm
USE m_types
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_usdus),INTENT(IN) :: usdus
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_oneD),INTENT(IN) :: oneD
......@@ -61,9 +62,8 @@ CONTAINS
DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(l,n) = .true.
ENDDO
#ifdef CPP_APW
IF (atoms%lapw_l(n).GE.l) apw(l,n) = .false.
#endif
IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l,n) = .false.
ENDDO
DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true.
......
......@@ -17,6 +17,8 @@ elseif ($ENV{FC} MATCHES "gfortran.*")
set (configfile "cmake/cmake.gfortran.config")
elseif ($ENV{FC} MATCHES "ifort.*")
set (configfile "cmake/cmake.ifort.config")
elseif (CMAKE_SYSTEM_NAME MATCHES "Darwin")
set (configfile "cmake/cmake.darwin.config")
elseif (${sitename} MATCHES "iff.*")
set (configfile "cmake/cmake.iff.config")
elseif (${sitename} MATCHES "jrl.*")
......@@ -28,8 +30,6 @@ elseif (${sitename} MATCHES "jrl.*")
endif()
elseif (${sitename} MATCHES "juquee.*")
set (configfile "cmake/cmake.juqueen.config")
elseif (CMAKE_SYSTEM_NAME MATCHES "Darwin")
set (configfile "cmake/cmake.darwin.config")
endif ()
if (${configfile} MATCHES "NOTFOUND")
......
......@@ -302,17 +302,11 @@ CONTAINS
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed'
CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani')
ENDIF
#ifdef CPP_T90
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca,1,1,desca,bsca,1,1, desca,&
0.0,1.0,1,m,abstol,num1,num2,eig2,orfac,eigvec,1,1,&
desceigv,work2,-1,rwork,-1,iwork,-1,ifail,iclustr,&
gap,ierr)
#else
CALL CPP_LAPACK_pzhegvx(1,'V','I','U',m,asca,1,1,desca,bsca,1,1, desca,&
0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec,1,1,&
desceigv,work2,-1,rwork,-1,iwork,-1,ifail,iclustr,&
gap,ierr)
#endif
IF (ABS(work2(1)).GT.lwork2) THEN
lwork2=work2(1)
DEALLOCATE (work2)
......
......@@ -56,7 +56,7 @@ CONTAINS
#ifdef CPP_SCALAPACK
USE m_chani
#endif
#ifdef CPP_elemental
#ifdef CPP_ELEMENTAL
USE m_elemental
#endif
IMPLICIT NONE
......
......@@ -24,17 +24,6 @@ CONTAINS
REAL, INTENT(OUT) :: eig(:)
INTEGER, INTENT(OUT) :: ne
#ifdef CPP_F90
#ifdef CPP_INVERSION
REAL, INTENT (INOUT) :: a(:),b(:)
REAL, INTENT (INOUT) :: z(:,:)
#else
COMPLEX, INTENT (INOUT)::a(:),b(:)
COMPLEX, INTENT (INOUT) :: z(:,:)
#endif
#else
#ifdef CPP_INVERSION
REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
......@@ -44,7 +33,6 @@ CONTAINS
COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#endif
#endif
! ... Local Variables ..
......@@ -82,9 +70,7 @@ CONTAINS
ENDDO
ENDDO
!save some storage by deallocation of unused array
#ifndef CPP_F90
DEALLOCATE (a)
#endif
!metric
ALLOCATE ( largeb(nsize,nsize), stat=err )
IF (err/=0) CALL juDFT_error("error allocating largeb",calledby ="geneigprobl")
......@@ -97,9 +83,7 @@ CONTAINS
ENDDO
ENDDO
!save some storage by deallocation of unused array
#ifndef CPP_F90
DEALLOCATE (b)
#endif
......@@ -120,7 +104,6 @@ CONTAINS
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
ALLOCATE ( isuppz(2*nsize), stat=err )
IF (err /= 0) CALL juDFT_error("error allocating isuppz",calledby ="geneigprobl")
#ifndef CPP_F90
IF (allocated(z)) THEN
IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z)
ENDIF
......@@ -131,10 +114,8 @@ CONTAINS
CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF
ENDIF
#endif
sizez= size(z,1)
iu = min(nsize,neigd)
#ifndef CPP_F90
IF (l_J) THEN
CALL CPP_LAPACK_ssyevr('N','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,&
sizez,isuppz,work,lwork,iwork,liwork,info)
......@@ -142,10 +123,6 @@ CONTAINS
CALL CPP_LAPACK_ssyevr('V','I','U',nsize,largea,nsize,lb,ub,1,iu,toler,ne,eigTemp,z,&
sizez,isuppz,work,lwork,iwork,liwork,info)
ENDIF
#else
eig = 0.0
eigTemp = 0.0
#endif
IF (info /= 0) CALL juDFT_error("error in ssyevr",calledby ="geneigprobl")
DEALLOCATE (isuppz,work,iwork)
......@@ -174,7 +151,6 @@ CONTAINS
lrwork = 84*nsize
ALLOCATE (work(lrwork), stat=err )
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
#ifndef CPP_F90
IF (allocated(z)) THEN
IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z)
ENDIF
......@@ -185,27 +161,15 @@ CONTAINS
CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF
ENDIF
#endif
sizez= size(z,1)
iu = min(nsize,neigd)
#ifndef CPP_F90
IF (l_J) THEN
CALL CPP_LAPACK_cheevr('N','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,&
sizez,isuppz,cwork,lwork,work,lrwork,iwork,liwork,info)
ELSE
#if (1==1)
CALL CPP_LAPACK_cheevr('V','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,&
sizez,isuppz,cwork,lwork,work,lrwork,iwork,liwork,info)
#else
CALL CPP_LAPACK_cheevx('V','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,&
sizez,cwork,lwork,work,iwork,isuppz,info)
#endif
ENDIF
#else
eig = 0.0
eigTemp = 0.0
#endif
IF (info /= 0) CALL juDFT_error("error in cheevr",calledby ="geneigprobl")
DEALLOCATE ( isuppz )
deallocate ( work )
......
......@@ -50,17 +50,6 @@ CONTAINS
! .. Array Arguments ..
INTEGER, INTENT (IN) :: matind(dimension%nbasfcn,2)
REAL, INTENT (OUT) :: eig(dimension%neigd)
#ifdef CPP_F90
#ifdef CPP_INVERSION
REAL, INTENT (INOUT) :: a(:),b(:)
REAL, INTENT (INOUT) :: z(:,:)
#else
COMPLEX, INTENT (INOUT)::a(:),b(:)
COMPLEX, INTENT (INOUT) :: z(:,:)
#endif
#else
#ifdef CPP_INVERSION
REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
......@@ -70,7 +59,6 @@ CONTAINS
COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#endif
#endif
#ifdef CPP_INVERSION
real locrec(atoms%nlotot,atoms%nlotot)
......@@ -105,9 +93,7 @@ CONTAINS
! print*,"in zsymsecloc"
#ifndef CPP_F90
deallocate(z)
#endif
!******************************************
! l_zref=.false. => simply call eigensolver
......@@ -115,10 +101,8 @@ CONTAINS
if(.not.sym%l_zref)then
call geneigprobl(dimension%nbasfcn, nsize,dimension%neigd,jij%l_j,a,b, z,eig,ne)
#ifndef CPP_F90
allocate(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
#endif
return
!******************************************
! l_zref=.true. => blockdiagonalize
......@@ -461,9 +445,7 @@ CONTAINS
! z1 holds eigenvectors of even block.
! z2 holds eigenvectors of odd block.
!********************************************************************
#ifndef CPP_F90
allocate(z(dimension%nbasfcn,dimension%neigd))
#endif
allocate(evensort(ne))
etemp1(ne1+1)=99.9e9
etemp2(ne2+1)=99.9e9
......@@ -529,10 +511,8 @@ CONTAINS
endif !evensort
enddo !ii
#ifndef CPP_F90
allocate(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
#endif
endif !sym%l_zref
deallocate ( z1,z2,etemp1,etemp2,evensort )
......
......@@ -453,7 +453,7 @@ CONTAINS
!---> set up interstitial hamiltonian and overlap matrices
!
call timestart("Interstitial Hamiltonian&Overlap")
CALL hsint(noco,jij,stars, vpw(:,jsp),lapw,jsp, n_size,n_rank,kpts%bk(:,nk),cell,atoms, a,b)
CALL hsint(input,noco,jij,stars, vpw(:,jsp),lapw,jsp, n_size,n_rank,kpts%bk(:,nk),cell,atoms, a,b)
call timestop("Interstitial Hamiltonian&Overlap")
!
......
This diff is collapsed.
......@@ -6,7 +6,7 @@
MODULE m_hsint
CONTAINS
SUBROUTINE hsint(noco,jij,stars, vpw,lapw,jspin,&
SUBROUTINE hsint(input,noco,jij,stars, vpw,lapw,jspin,&
n_size,n_rank,bkpt,cell,atoms,aa,bb)
!*********************************************************************
! initializes and sets up the hamiltonian and overlap matrices
......@@ -35,6 +35,7 @@ CONTAINS
!*********************************************************************
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
......@@ -114,16 +115,16 @@ CONTAINS
IF (in.EQ.0) CYCLE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
#ifdef CPP_APW
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
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)
......@@ -182,16 +183,16 @@ CONTAINS
ELSE
phase = stars%rgphs(i1,i2,i3)
!+APW_LO
#ifdef CPP_APW
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
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)
aa(ii) = th
......
......@@ -248,11 +248,11 @@ CONTAINS
IF(l_socfirst) fjstart = isp
#ifndef CPP_INVERSION
CALL slomat(&
atoms, n,na,lapw,con1,n_size,n_rank, gk,rph,cph,&
input,atoms, n,na,lapw,con1,n_size,n_rank, gk,rph,cph,&
fj(:,0:,:,fjstart:), gj(:,0:,:,fjstart:),&
kvec,isp,usdus,alo1,blo1,clo1,noco, ab_dim,1,1,chi11,chi22,chi21,&
iilos,locols,nkvecprevats,bbhlp)
CALL hlomat(atoms,isp,isp,n_size,n_rank,&
CALL hlomat(input,atoms,isp,isp,n_size,n_rank,&
n,na,lapw,ar(:,0:,1),br(:,0:,1),ai(:,0:,1),bi(:,0:,1),&
el(:,n,isp),alo,blo,clo,usdus, noco,1,1,chi11,chi22,chi21,&
iiloh,locolh,nkvecprevath,tlmplm,aahlp)
......@@ -261,11 +261,11 @@ CONTAINS
jd = 1 ; IF (noco%l_noco) jd = isp
DO iintsp = 1,nintsp
DO jintsp = 1,nintsp
CALL slomat(atoms,n,na,lapw,con1,n_size,n_rank,&
CALL slomat(input,atoms,n,na,lapw,con1,n_size,n_rank,&
gk,rph,cph,fj,gj, kvec,isp,usdus,alo1,blo1,clo1,noco,&
ab_dim,iintsp,jintsp,chi11,chi22,chi21,&
iilos,locols,nkvecprevats,bb)
CALL hlomat(atoms,isp,jd,n_size,n_rank,&
CALL hlomat(input,atoms,isp,jd,n_size,n_rank,&
n,na,lapw,ar(:,0:,jintsp),br(:,0:,jintsp),ai(:,0:,jintsp),bi(:,0:,jintsp),&
el(:,n,isp),alo,blo,clo,usdus, noco,iintsp,jintsp,chi11,chi22,chi21,&
iiloh,locolh,nkvecprevath,tlmplm,aa)
......
......@@ -7,7 +7,7 @@ MODULE m_hsmt_fjgj
use m_juDFT
implicit none
CONTAINS
SUBROUTINE hsmt_fjgj(atoms,isp,noco,l_socfirst,cell,nintsp, lapw,usdus,fj,gj)
SUBROUTINE hsmt_fjgj(input,atoms,isp,noco,l_socfirst,cell,nintsp, lapw,usdus,fj,gj)
!Calculate the fj&gj array which contain the part of the A,B matching coeff. depending on the
!radial functions at the MT boundary as contained in usdus
USE m_constants, ONLY : fpi_const
......@@ -15,6 +15,7 @@ CONTAINS
USE m_dsphbs
USE m_types
IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
......@@ -43,9 +44,8 @@ CONTAINS
DO n = 1,atoms%ntype
DO l = 0,atoms%lmax(n)
apw(l)=any(atoms%l_dulo(:atoms%nlo(n),n))
#ifdef CPP_APW
IF (atoms%lapw_l(n).GE.l) apw(l) = .false.
#endif
IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l) = .false.
ENDDO
DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n)) = .true.
......
This diff is collapsed.
MODULE m_hsvac
use m_juDFT
USE m_juDFT
CONTAINS
SUBROUTINE hsvac(&
vacuum,stars,dimension, atoms, jsp,input,vxy,vz,evac,cell,&
vacuum,stars,DIMENSION, atoms, jsp,input,vxy,vz,evac,cell,&
bkpt,lapw,sym, noco,jij, n_size,n_rank, aa,bb, nv2)
!*********************************************************************
! adds in the vacuum contributions to the the hamiltonian and
......@@ -17,7 +17,7 @@ CONTAINS
USE m_vacfun
USE m_types
IMPLICIT NONE
TYPE(t_dimension),INTENT(IN):: dimension
TYPE(t_dimension),INTENT(IN):: DIMENSION
TYPE(t_input),INTENT(IN) :: input
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_noco),INTENT(IN) :: noco
......@@ -33,9 +33,9 @@ CONTAINS
! ..
! .. Array Arguments ..
COMPLEX, INTENT (INOUT) :: vxy(vacuum%nmzxyd,stars%n2d-1,2)
INTEGER, INTENT (OUT):: nv2(dimension%jspd)
INTEGER, INTENT (OUT):: nv2(DIMENSION%jspd)
REAL, INTENT (INOUT) :: vz(vacuum%nmzd,2,4)
REAL, INTENT (IN) :: evac(2,dimension%jspd)
REAL, INTENT (IN) :: evac(2,DIMENSION%jspd)
REAL, INTENT (IN) :: bkpt(3)
#ifdef CPP_INVERSION
REAL, INTENT (INOUT) :: aa(:),bb(:)!(matsize)
......@@ -52,20 +52,20 @@ CONTAINS
INTEGER i_start,nc,nc_0
! ..
! .. Local Arrays ..
INTEGER kvac1(dimension%nv2d,dimension%jspd),kvac2(dimension%nv2d,dimension%jspd)
INTEGER map2(dimension%nvd,dimension%jspd)
COMPLEX tddv(dimension%nv2d,dimension%nv2d),tduv(dimension%nv2d,dimension%nv2d)
COMPLEX tudv(dimension%nv2d,dimension%nv2d),tuuv(dimension%nv2d,dimension%nv2d)
INTEGER kvac1(DIMENSION%nv2d,DIMENSION%jspd),kvac2(DIMENSION%nv2d,DIMENSION%jspd)
INTEGER map2(DIMENSION%nvd,DIMENSION%jspd)
COMPLEX tddv(DIMENSION%nv2d,DIMENSION%nv2d),tduv(DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX tudv(DIMENSION%nv2d,DIMENSION%nv2d),tuuv(DIMENSION%nv2d,DIMENSION%nv2d)
COMPLEX vxy_help(stars%n2d-1)
COMPLEX a(dimension%nvd,dimension%jspd),b(dimension%nvd,dimension%jspd)
REAL ddnv(dimension%nv2d,dimension%jspd),dudz(dimension%nv2d,dimension%jspd)
REAL duz(dimension%nv2d,dimension%jspd), udz(dimension%nv2d,dimension%jspd)
REAL uz(dimension%nv2d,dimension%jspd)
COMPLEX a(DIMENSION%nvd,DIMENSION%jspd),b(DIMENSION%nvd,DIMENSION%jspd)
REAL ddnv(DIMENSION%nv2d,DIMENSION%jspd),dudz(DIMENSION%nv2d,DIMENSION%jspd)
REAL duz(DIMENSION%nv2d,DIMENSION%jspd), udz(DIMENSION%nv2d,DIMENSION%jspd)
REAL uz(DIMENSION%nv2d,DIMENSION%jspd)
! l_J auxiliary potential array
COMPLEX, ALLOCATABLE :: vxy1(:,:,:)
! ..
d2 = sqrt(cell%omtil/cell%area)
d2 = SQRT(cell%omtil/cell%area)
IF (jij%l_J) ALLOCATE (vxy1(vacuum%nmzxyd,stars%n2d-1,2))
......@@ -80,13 +80,13 @@ CONTAINS
map2(k,jspin) = j
CYCLE k_loop
END IF
enddo
ENDDO
nv2(jspin) = nv2(jspin) + 1
IF