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 ...@@ -371,7 +371,7 @@ CONTAINS
isn = 1 isn = 1
#if ( defined(CPP_INVERSION) && !defined(CPP_SOC) ) #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,& 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 ! GM forces part
IF (input%l_f) THEN IF (input%l_f) THEN
...@@ -566,8 +566,8 @@ CONTAINS ...@@ -566,8 +566,8 @@ CONTAINS
isn = -1 isn = -1
#if ( defined(CPP_INVERSION) && !defined(CPP_SOC) ) #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,& 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)) 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,& 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)) stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,wsave,kpsir(ifftq3d), ekin(-ifftq2))
#else #else
...@@ -620,18 +620,19 @@ CONTAINS ...@@ -620,18 +620,19 @@ CONTAINS
DO istr = 1 , stars%ng3_fft DO istr = 1 , stars%ng3_fft
cwk(istr) = scale * cwk(istr) / REAL( stars%nstr(istr) ) cwk(istr) = scale * cwk(istr) / REAL( stars%nstr(istr) )
ENDDO ENDDO
#ifdef CPP_APW IF (input%l_useapw) THEN
IF (input%l_f) THEN
DO istr = 1 , stars%ng3_fft IF (input%l_f) THEN
ecwk(istr) = scale * ecwk(istr) / REAL( stars%nstr(istr) ) DO istr = 1 , stars%ng3_fft
ENDDO ecwk(istr) = scale * ecwk(istr) / REAL( stars%nstr(istr) )
CALL forces_b8(& ENDDO
atoms,ecwk,stars,& CALL force_b8(&
sym,cell,& atoms,ecwk,stars,&
jspin,& sym,cell,&
forces,f_b8) jspin,&
forces,f_b8)
ENDIF
ENDIF ENDIF
#endif
! !
!---> check charge neutralilty !---> 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 MODULE m_abcof
CONTAINS 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) noco,jspin,kveclo,oneD, acof,bcof,ccof)
! ************************************************************ ! ************************************************************
! subroutine constructs the a,b coefficients of the linearized ! subroutine constructs the a,b coefficients of the linearized
...@@ -16,7 +16,8 @@ CONTAINS ...@@ -16,7 +16,8 @@ CONTAINS
USE m_ylm USE m_ylm
USE m_types USE m_types
IMPLICIT NONE 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_lapw),INTENT(IN) :: lapw
TYPE(t_oneD),INTENT(IN) :: oneD TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_noco),INTENT(IN) :: noco TYPE(t_noco),INTENT(IN) :: noco
...@@ -79,9 +80,7 @@ CONTAINS ...@@ -79,9 +80,7 @@ CONTAINS
DO lo = 1,atoms%nlo(n) DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(l,n) = .true. IF (atoms%l_dulo(lo,n)) apw(l,n) = .true.
ENDDO ENDDO
#ifdef CPP_APW IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l,n) = .false.
IF (atoms%lapw_l(n).GE.l) apw(l,n) = .false.
#endif
ENDDO ENDDO
DO lo = 1,atoms%nlo(n) DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true. IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true.
......
MODULE m_abcof3 MODULE m_abcof3
CONTAINS 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) usdus, kveclo,oneD,a,b,bascof_lo)
! ************************************************************ ! ************************************************************
! subroutine constructs the a,b coefficients of the linearized ! subroutine constructs the a,b coefficients of the linearized
...@@ -16,6 +16,7 @@ CONTAINS ...@@ -16,6 +16,7 @@ CONTAINS
USE m_ylm USE m_ylm
USE m_types USE m_types
IMPLICIT NONE IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_usdus),INTENT(IN) :: usdus TYPE(t_usdus),INTENT(IN) :: usdus
TYPE(t_lapw),INTENT(IN) :: lapw TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_oneD),INTENT(IN) :: oneD TYPE(t_oneD),INTENT(IN) :: oneD
...@@ -61,9 +62,8 @@ CONTAINS ...@@ -61,9 +62,8 @@ CONTAINS
DO lo = 1,atoms%nlo(n) DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(l,n) = .true. IF (atoms%l_dulo(lo,n)) apw(l,n) = .true.
ENDDO ENDDO
#ifdef CPP_APW IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l,n) = .false.
IF (atoms%lapw_l(n).GE.l) apw(l,n) = .false.
#endif
ENDDO ENDDO
DO lo = 1,atoms%nlo(n) DO lo = 1,atoms%nlo(n)
IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true. IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n),n) = .true.
......
...@@ -17,6 +17,8 @@ elseif ($ENV{FC} MATCHES "gfortran.*") ...@@ -17,6 +17,8 @@ elseif ($ENV{FC} MATCHES "gfortran.*")
set (configfile "cmake/cmake.gfortran.config") set (configfile "cmake/cmake.gfortran.config")
elseif ($ENV{FC} MATCHES "ifort.*") elseif ($ENV{FC} MATCHES "ifort.*")
set (configfile "cmake/cmake.ifort.config") set (configfile "cmake/cmake.ifort.config")
elseif (CMAKE_SYSTEM_NAME MATCHES "Darwin")
set (configfile "cmake/cmake.darwin.config")
elseif (${sitename} MATCHES "iff.*") elseif (${sitename} MATCHES "iff.*")
set (configfile "cmake/cmake.iff.config") set (configfile "cmake/cmake.iff.config")
elseif (${sitename} MATCHES "jrl.*") elseif (${sitename} MATCHES "jrl.*")
...@@ -28,8 +30,6 @@ elseif (${sitename} MATCHES "jrl.*") ...@@ -28,8 +30,6 @@ elseif (${sitename} MATCHES "jrl.*")
endif() endif()
elseif (${sitename} MATCHES "juquee.*") elseif (${sitename} MATCHES "juquee.*")
set (configfile "cmake/cmake.juqueen.config") set (configfile "cmake/cmake.juqueen.config")
elseif (CMAKE_SYSTEM_NAME MATCHES "Darwin")
set (configfile "cmake/cmake.darwin.config")
endif () endif ()
if (${configfile} MATCHES "NOTFOUND") if (${configfile} MATCHES "NOTFOUND")
......
...@@ -302,17 +302,11 @@ CONTAINS ...@@ -302,17 +302,11 @@ CONTAINS
WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed' WRITE (*,*) 'ERROR: chani.F: Allocating rwork failed'
CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani') CALL juDFT_error('Failed to allocated "rwork"', calledby ='chani')
ENDIF 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,& 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,& 0.0,1.0,1,num,abstol,num1,num2,eig2,orfac,eigvec,1,1,&
desceigv,work2,-1,rwork,-1,iwork,-1,ifail,iclustr,& desceigv,work2,-1,rwork,-1,iwork,-1,ifail,iclustr,&
gap,ierr) gap,ierr)
#endif
IF (ABS(work2(1)).GT.lwork2) THEN IF (ABS(work2(1)).GT.lwork2) THEN
lwork2=work2(1) lwork2=work2(1)
DEALLOCATE (work2) DEALLOCATE (work2)
......
...@@ -56,7 +56,7 @@ CONTAINS ...@@ -56,7 +56,7 @@ CONTAINS
#ifdef CPP_SCALAPACK #ifdef CPP_SCALAPACK
USE m_chani USE m_chani
#endif #endif
#ifdef CPP_elemental #ifdef CPP_ELEMENTAL
USE m_elemental USE m_elemental
#endif #endif
IMPLICIT NONE IMPLICIT NONE
......
...@@ -24,17 +24,6 @@ CONTAINS ...@@ -24,17 +24,6 @@ CONTAINS
REAL, INTENT(OUT) :: eig(:) REAL, INTENT(OUT) :: eig(:)
INTEGER, INTENT(OUT) :: ne 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 #ifdef CPP_INVERSION
REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:) REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
...@@ -44,7 +33,6 @@ CONTAINS ...@@ -44,7 +33,6 @@ CONTAINS
COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:) COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#endif #endif
#endif
! ... Local Variables .. ! ... Local Variables ..
...@@ -82,9 +70,7 @@ CONTAINS ...@@ -82,9 +70,7 @@ CONTAINS
ENDDO ENDDO
ENDDO ENDDO
!save some storage by deallocation of unused array !save some storage by deallocation of unused array
#ifndef CPP_F90
DEALLOCATE (a) DEALLOCATE (a)
#endif
!metric !metric
ALLOCATE ( largeb(nsize,nsize), stat=err ) ALLOCATE ( largeb(nsize,nsize), stat=err )
IF (err/=0) CALL juDFT_error("error allocating largeb",calledby ="geneigprobl") IF (err/=0) CALL juDFT_error("error allocating largeb",calledby ="geneigprobl")
...@@ -97,9 +83,7 @@ CONTAINS ...@@ -97,9 +83,7 @@ CONTAINS
ENDDO ENDDO
ENDDO ENDDO
!save some storage by deallocation of unused array !save some storage by deallocation of unused array
#ifndef CPP_F90
DEALLOCATE (b) DEALLOCATE (b)
#endif
...@@ -120,7 +104,6 @@ CONTAINS ...@@ -120,7 +104,6 @@ CONTAINS
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl") IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
ALLOCATE ( isuppz(2*nsize), stat=err ) ALLOCATE ( isuppz(2*nsize), stat=err )
IF (err /= 0) CALL juDFT_error("error allocating isuppz",calledby ="geneigprobl") IF (err /= 0) CALL juDFT_error("error allocating isuppz",calledby ="geneigprobl")
#ifndef CPP_F90
IF (allocated(z)) THEN IF (allocated(z)) THEN
IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z) IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z)
ENDIF ENDIF
...@@ -131,10 +114,8 @@ CONTAINS ...@@ -131,10 +114,8 @@ CONTAINS
CALL juDFT_error("error allocating z",calledby ="geneigprobl") CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF ENDIF
ENDIF ENDIF
#endif
sizez= size(z,1) sizez= size(z,1)
iu = min(nsize,neigd) iu = min(nsize,neigd)
#ifndef CPP_F90
IF (l_J) THEN IF (l_J) THEN
CALL CPP_LAPACK_ssyevr('N','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,& 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) sizez,isuppz,work,lwork,iwork,liwork,info)
...@@ -142,10 +123,6 @@ CONTAINS ...@@ -142,10 +123,6 @@ CONTAINS
CALL CPP_LAPACK_ssyevr('V','I','U',nsize,largea,nsize,lb,ub,1,iu,toler,ne,eigTemp,z,& 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) sizez,isuppz,work,lwork,iwork,liwork,info)
ENDIF ENDIF
#else
eig = 0.0
eigTemp = 0.0
#endif
IF (info /= 0) CALL juDFT_error("error in ssyevr",calledby ="geneigprobl") IF (info /= 0) CALL juDFT_error("error in ssyevr",calledby ="geneigprobl")
DEALLOCATE (isuppz,work,iwork) DEALLOCATE (isuppz,work,iwork)
...@@ -174,7 +151,6 @@ CONTAINS ...@@ -174,7 +151,6 @@ CONTAINS
lrwork = 84*nsize lrwork = 84*nsize
ALLOCATE (work(lrwork), stat=err ) ALLOCATE (work(lrwork), stat=err )
IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl") IF (err/=0) CALL juDFT_error(" error allocating work",calledby ="geneigprobl")
#ifndef CPP_F90
IF (allocated(z)) THEN IF (allocated(z)) THEN
IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z) IF (.not.(size(z,1)==nbasfcn.and.size(z,2)==neigd)) deallocate(z)
ENDIF ENDIF
...@@ -185,27 +161,15 @@ CONTAINS ...@@ -185,27 +161,15 @@ CONTAINS
CALL juDFT_error("error allocating z",calledby ="geneigprobl") CALL juDFT_error("error allocating z",calledby ="geneigprobl")
ENDIF ENDIF
ENDIF ENDIF
#endif
sizez= size(z,1) sizez= size(z,1)
iu = min(nsize,neigd) iu = min(nsize,neigd)
#ifndef CPP_F90
IF (l_J) THEN IF (l_J) THEN
CALL CPP_LAPACK_cheevr('N','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,& 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) sizez,isuppz,cwork,lwork,work,lrwork,iwork,liwork,info)
ELSE ELSE
#if (1==1)
CALL CPP_LAPACK_cheevr('V','I','U',nsize,largea, nsize,lb,ub,1,iu,toler,ne,eigTemp,z,& 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) 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 ENDIF
#else
eig = 0.0
eigTemp = 0.0
#endif
IF (info /= 0) CALL juDFT_error("error in cheevr",calledby ="geneigprobl") IF (info /= 0) CALL juDFT_error("error in cheevr",calledby ="geneigprobl")
DEALLOCATE ( isuppz ) DEALLOCATE ( isuppz )
deallocate ( work ) deallocate ( work )
......
...@@ -50,17 +50,6 @@ CONTAINS ...@@ -50,17 +50,6 @@ CONTAINS
! .. Array Arguments .. ! .. Array Arguments ..
INTEGER, INTENT (IN) :: matind(dimension%nbasfcn,2) INTEGER, INTENT (IN) :: matind(dimension%nbasfcn,2)
REAL, INTENT (OUT) :: eig(dimension%neigd) 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 #ifdef CPP_INVERSION
REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:) REAL, ALLOCATABLE, INTENT (INOUT) :: a(:),b(:)
...@@ -70,7 +59,6 @@ CONTAINS ...@@ -70,7 +59,6 @@ CONTAINS
COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:) COMPLEX, ALLOCATABLE, INTENT (INOUT) :: z(:,:)
#endif #endif
#endif
#ifdef CPP_INVERSION #ifdef CPP_INVERSION
real locrec(atoms%nlotot,atoms%nlotot) real locrec(atoms%nlotot,atoms%nlotot)
...@@ -105,9 +93,7 @@ CONTAINS ...@@ -105,9 +93,7 @@ CONTAINS
! print*,"in zsymsecloc" ! print*,"in zsymsecloc"
#ifndef CPP_F90
deallocate(z) deallocate(z)
#endif
!****************************************** !******************************************
! l_zref=.false. => simply call eigensolver ! l_zref=.false. => simply call eigensolver
...@@ -115,10 +101,8 @@ CONTAINS ...@@ -115,10 +101,8 @@ CONTAINS
if(.not.sym%l_zref)then if(.not.sym%l_zref)then
call geneigprobl(dimension%nbasfcn, nsize,dimension%neigd,jij%l_j,a,b, z,eig,ne) 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(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2)) allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
#endif
return return
!****************************************** !******************************************
! l_zref=.true. => blockdiagonalize ! l_zref=.true. => blockdiagonalize
...@@ -461,9 +445,7 @@ CONTAINS ...@@ -461,9 +445,7 @@ CONTAINS
! z1 holds eigenvectors of even block. ! z1 holds eigenvectors of even block.
! z2 holds eigenvectors of odd block. ! z2 holds eigenvectors of odd block.
!******************************************************************** !********************************************************************
#ifndef CPP_F90
allocate(z(dimension%nbasfcn,dimension%neigd)) allocate(z(dimension%nbasfcn,dimension%neigd))
#endif
allocate(evensort(ne)) allocate(evensort(ne))
etemp1(ne1+1)=99.9e9 etemp1(ne1+1)=99.9e9
etemp2(ne2+1)=99.9e9 etemp2(ne2+1)=99.9e9
...@@ -529,10 +511,8 @@ CONTAINS ...@@ -529,10 +511,8 @@ CONTAINS
endif !evensort endif !evensort
enddo !ii enddo !ii
#ifndef CPP_F90
allocate(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2)) allocate(a(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2)) allocate(b(dimension%nbasfcn*(dimension%nbasfcn+1)/2))
#endif
endif !sym%l_zref endif !sym%l_zref
deallocate ( z1,z2,etemp1,etemp2,evensort ) deallocate ( z1,z2,etemp1,etemp2,evensort )
......
...@@ -453,7 +453,7 @@ CONTAINS ...@@ -453,7 +453,7 @@ CONTAINS
!---> set up interstitial hamiltonian and overlap matrices !---> set up interstitial hamiltonian and overlap matrices
! !
call timestart("Interstitial Hamiltonian&Overlap") 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") call timestop("Interstitial Hamiltonian&Overlap")
! !
......
This diff is collapsed.
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
MODULE m_hsint MODULE m_hsint
CONTAINS 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) n_size,n_rank,bkpt,cell,atoms,aa,bb)
!********************************************************************* !*********************************************************************
! initializes and sets up the hamiltonian and overlap matrices ! initializes and sets up the hamiltonian and overlap matrices
...@@ -35,6 +35,7 @@ CONTAINS ...@@ -35,6 +35,7 @@ CONTAINS
!********************************************************************* !*********************************************************************
USE m_types USE m_types
IMPLICIT NONE IMPLICIT NONE
TYPE(t_input),INTENT(IN) :: input
TYPE(t_noco),INTENT(IN) :: noco TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_jij),INTENT(IN) :: jij TYPE(t_jij),INTENT(IN) :: jij
TYPE(t_stars),INTENT(IN) :: stars TYPE(t_stars),INTENT(IN) :: stars
...@@ -114,16 +115,16 @@ CONTAINS ...@@ -114,16 +115,16 @@ CONTAINS
IF (in.EQ.0) CYCLE IF (in.EQ.0) CYCLE
phase = stars%rgphs(i1,i2,i3) phase = stars%rgphs(i1,i2,i3)
!+APW_LO !+APW_LO
#ifdef CPP_APW IF (input%l_useapw) THEN
b1(1) = bkpt(1)+lapw%k1(i,ispin) ; b2(1) = bkpt(1)+lapw%k1(j,ispin) 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(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) b1(3) = bkpt(3)+lapw%k3(i,ispin) ; b2(3) = bkpt(3)+lapw%k3(j,ispin)
r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1) r2 = DOT_PRODUCT(MATMUL(b2,cell%bbmat),b1)
th = phase*(0.5*r2*stars%ustep(in)+vpw(in)) th = phase*(0.5*r2*stars%ustep(in)+vpw(in))
#else ELSE
th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in)) th = phase* (0.25* (lapw%rk(i,ispin)**2+lapw%rk(j,ispin)**2)*stars%ustep(in) + vpw(in))
#endif ENDIF
!-APW_LO !-APW_LO
!---> determine matrix element and store !---> determine matrix element and store