scnc
/
quantum-espresso
mirror of https://gitlab.com/QEF/q-e.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

General cleanup of intrinsic functions: 

conversion to real    => DBLE
(including real part of a complex number)
conversion to complex => CMPLX
complex conjugate     => CONJG
imaginary part        => AIMAG

All functions are uppercase.
CMPLX is preprocessed by f_defs.h and performs an explicit cast:
#define CMPLX(a,b)  cmplx(a,b,kind=DP)
This implies that 1) f_defs.h must be included whenever a CMPLX is present,
2) CMPLX should stay in a single line, 3) DP must be defined.

All occurrences of real, float, dreal, dfloat, dconjg, dimag, dcmplx
removed - please do not reintroduce any of them.
Tested only with ifc7 and g95 - beware unintended side effects

Maybe not the best solution (explicit casts everywhere would be better)
but it can be easily changed with a script if the need arises.
The following code might be used to test for possible trouble:

program test_intrinsic

  implicit none
  integer, parameter :: dp = selected_real_kind(14,200)
  real (kind=dp) :: a = 0.123456789012345_dp
  real (kind=dp) :: b = 0.987654321098765_dp
  complex (kind=dp) :: c = ( 0.123456789012345_dp, 0.987654321098765_dp)

  print *, '      A = ', a
  print *, ' DBLE(A)= ', DBLE(a)
  print *, '      C = ', c
  print *, 'CONJG(C)= ', CONJG(c)
  print *, 'DBLE(c),AIMAG(C)  = ', DBLE(c), AIMAG(c)
  print *, 'CMPLX(A,B,kind=dp)= ', CMPLX( a, b, kind=dp)

end program test_intrinsic

Note that CMPLX and REAL without a cast yield single precision numbers on
ifc7 and g95 !!!


git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@2133 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
giannozz 2005-08-26 17:44:42 +00:00
parent 8bad2898c6
commit bf4bfe222f
246 changed files with 1685 additions and 1847 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
CPV/adjef.f90
View File

@ -58,7 +58,7 @@
! end of declarations
! ----------------------------------------------
! qtot=dfloat(nel)
! qtot=DBLE(nel)
sumq=0.d0
sume=0.d0
emin=e(1,1,1)
@ -174,7 +174,7 @@
integer iter,ie
real(dbl) t,emin,emax,stepf
real(dbl) sumq,fac,qtot,drange
QTOT=DFLOAT(NEL)
QTOT=DBLE(NEL)
SUMQ=0.D0
SUME=0.D0
EMIN=E(1)

2
CPV/berryion.f90
View File

@ -70,7 +70,7 @@ subroutine berryion( tau0,fion, tfor,ipol,evalue,enbi)
enddo
enddo
enbi=aimag(log(exp(temp)))/gmes!this sounds stupid it's just a Riemann plane
enbi=AIMAG(log(exp(temp)))/gmes!this sounds stupid it's just a Riemann plane
! write(6,*) 'Pola :', pola!ATTENZIONE
return
end subroutine berryion

8
CPV/bforceion.f90
View File

@ -99,10 +99,10 @@ subroutine bforceion(fion,tfor,ipol,qmatinv,bec0,becdr,gqq,evalue)
enddo
isa = isa + 1
fion(ipol,isa) = fion(ipol,isa) - 2.*evalue*aimag(temp)/gmes
fion(1,isa) = fion(1,isa) - 2.*evalue*aimag(temp1)/gmes
fion(2,isa) = fion(2,isa) - 2.*evalue*aimag(temp2)/gmes
fion(3,isa) = fion(3,isa) - 2.*evalue*aimag(temp3)/gmes
fion(ipol,isa) = fion(ipol,isa) - 2.*evalue*AIMAG(temp)/gmes
fion(1,isa) = fion(1,isa) - 2.*evalue*AIMAG(temp1)/gmes
fion(2,isa) = fion(2,isa) - 2.*evalue*AIMAG(temp2)/gmes
fion(3,isa) = fion(3,isa) - 2.*evalue*AIMAG(temp3)/gmes
end do
end do
end do

72
CPV/cg_sub.f90
View File

@ -5,7 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!=======================================================================
!
@ -13,7 +13,7 @@
rhor, rhog, rhos, rhoc, ei1, ei2, ei3, sfac, fion, ema0bg, becdr, &
lambdap, lambda )
use kinds, only: dp
use control_flags, only: iprint, thdyn, tpre, tbuff, iprsta, trhor, &
tfor, tvlocw, trhow, taurdr, tprnfor
use control_flags, only: ndr, ndw, nbeg, nomore, tsde, tortho, tnosee, &
@ -279,8 +279,8 @@
hpsi(1:ngw, i)=c2(1:ngw)
hpsi(1:ngw,i+1)=c3(1:ngw)
if (ng0.eq.2) then
hpsi(1, i)=cmplx(real(hpsi(1, i)))
hpsi(1,i+1)=cmplx(real(hpsi(1,i+1)))
hpsi(1, i)=CMPLX(DBLE(hpsi(1, i)), 0.d0)
hpsi(1,i+1)=CMPLX(DBLE(hpsi(1,i+1)), 0.d0)
end if
enddo
@ -303,10 +303,10 @@
! do j=i,n
! lambda(i,j)=0.d0
! do ig=1,ngw
! lambda(i,j)=lambda(i,j)-2.d0*real(conjg(c0(ig,i,1,1))*hpsi(ig,j))
! lambda(i,j)=lambda(i,j)-2.d0*DBLE(CONJG(c0(ig,i,1,1))*hpsi(ig,j))
! enddo
! if(ng0.eq.2) then
! lambda(i,j)=lambda(i,j)+real(conjg(c0(1,i,1,1))*hpsi(1,j))
! lambda(i,j)=lambda(i,j)+DBLE(CONJG(c0(1,i,1,1))*hpsi(1,j))
! endif
! lambda(j,i)=lambda(i,j)
! enddo
@ -336,10 +336,10 @@
do j=1,n
lambda(i,j)=0.d0
do ig=1,ngw
lambda(i,j)=lambda(i,j)-2.d0*real(conjg(c0(ig,i,1,1))*gi(ig,j))
lambda(i,j)=lambda(i,j)-2.d0*DBLE(CONJG(c0(ig,i,1,1))*gi(ig,j))
enddo
if(ng0.eq.2) then
lambda(i,j)=lambda(i,j)+real(conjg(c0(1,i,1,1))*gi(1,j))
lambda(i,j)=lambda(i,j)+DBLE(CONJG(c0(1,i,1,1))*gi(1,j))
endif
enddo
enddo
@ -397,10 +397,10 @@
call calbec(1,nsp,eigr,gi,becm)
do i=1,n
do ig=1,ngw
gamma=gamma+2*real(conjg(gi(ig,i))*gi(ig,i))
gamma=gamma+2*DBLE(CONJG(gi(ig,i))*gi(ig,i))
enddo
if (ng0.eq.2) then
gamma=gamma-real(conjg(gi(1,i))*gi(1,i))
gamma=gamma-DBLE(CONJG(gi(1,i))*gi(1,i))
endif
enddo
call mp_sum(gamma)
@ -424,10 +424,10 @@
do i=1,n
do j=1,n
do ig=1,ngw
gamma=gamma+2*real(conjg(gi(ig,i))*gi(ig,j))*fmat0(j,i,1)
gamma=gamma+2*DBLE(CONJG(gi(ig,i))*gi(ig,j))*fmat0(j,i,1)
enddo
if (ng0.eq.2) then
gamma=gamma-real(conjg(gi(1,i))*gi(1,j))*fmat0(j,i,1)
gamma=gamma-DBLE(CONJG(gi(1,i))*gi(1,j))*fmat0(j,i,1)
endif
enddo
enddo
@ -450,10 +450,10 @@
call calbec(1,nsp,eigr,gi,becm)
do i=1,n
do ig=1,ngw
gamma=gamma+2*real(conjg(gi(ig,i))*gi(ig,i))
gamma=gamma+2*DBLE(CONJG(gi(ig,i))*gi(ig,i))
enddo
if (ng0.eq.2) then
gamma=gamma-real(conjg(gi(1,i))*gi(1,i))
gamma=gamma-DBLE(CONJG(gi(1,i))*gi(1,i))
endif
enddo
@ -478,10 +478,10 @@
do i=1,n
do j=1,n
do ig=1,ngw
gamma=gamma+2*real(conjg(gi(ig,i))*gi(ig,j))*fmat0(j,i,1)
gamma=gamma+2*DBLE(CONJG(gi(ig,i))*gi(ig,j))*fmat0(j,i,1)
enddo
if (ng0.eq.2) then
gamma=gamma-real(conjg(gi(1,i))*gi(1,j))*fmat0(j,i,1)
gamma=gamma-DBLE(CONJG(gi(1,i))*gi(1,j))*fmat0(j,i,1)
endif
enddo
enddo
@ -514,10 +514,10 @@
if(.not.tens) then
do i=1,n
do ig=1,ngw
dene0=dene0-4.d0*real(conjg(hi(ig,i))*hpsi(ig,i))!ATTENZION iera gi
dene0=dene0-4.d0*DBLE(CONJG(hi(ig,i))*hpsi(ig,i))!ATTENZION iera gi
enddo
if (ng0.eq.2) then
dene0=dene0+2.d0*real(conjg(hi(1,i))*hpsi(1,i))!ATTENZION iera gi
dene0=dene0+2.d0*DBLE(CONJG(hi(1,i))*hpsi(1,i))!ATTENZION iera gi
endif
end do
else
@ -527,13 +527,13 @@
do i=1,n
do j=1,n
do ig=1,ngw
dene0=dene0-2.d0*real(conjg(hi(ig,i))*hpsi(ig,j))*fmat0(j,i,1)
dene0=dene0-2.d0*DBLE(CONJG(hi(ig,i))*hpsi(ig,j))*fmat0(j,i,1)
!ATTENZIONE solo caso nspin=1!!!!!
dene0=dene0-2.d0*real(conjg(hpsi(ig,i))*hi(ig,j))*fmat0(j,i,1)
dene0=dene0-2.d0*DBLE(CONJG(hpsi(ig,i))*hi(ig,j))*fmat0(j,i,1)
enddo
if (ng0.eq.2) then
dene0=dene0+real(conjg(hi(1,i))*hpsi(1,j))*fmat0(j,i,1)
dene0=dene0+real(conjg(hpsi(1,i))*hi(1,j))*fmat0(j,i,1)
dene0=dene0+DBLE(CONJG(hi(1,i))*hpsi(1,j))*fmat0(j,i,1)
dene0=dene0+DBLE(CONJG(hpsi(1,i))*hi(1,j))*fmat0(j,i,1)
end if
enddo
enddo
@ -614,7 +614,7 @@
cm(1:ngw,1:n,1,1)=c0(1:ngw,1:n,1,1)+spasso*passo*hi(1:ngw,1:n)
if(ng0.eq.2) then
cm(1,:,1,1)=0.5d0*(cm(1,:,1,1)+conjg(cm(1,:,1,1)))
cm(1,:,1,1)=0.5d0*(cm(1,:,1,1)+CONJG(cm(1,:,1,1)))
endif
! call ordina(cm,e0)
@ -811,11 +811,11 @@
c0hc0(k,i,is)=0.d0
do ig=1,ngw
c0hc0(k,i,is)=c0hc0(k,i,is)- &
& 2.0*real(conjg(c0(ig,k+istart-1,1,1))*h0c0(ig,i+istart-1))
& 2.0*DBLE(CONJG(c0(ig,k+istart-1,1,1))*h0c0(ig,i+istart-1))
enddo
if (ng0.eq.2) then
c0hc0(k,i,is)=c0hc0(k,i,is)+&
& real(conjg(c0(1,k+istart-1,1,1))*h0c0(1,i+istart-1))
& DBLE(CONJG(c0(1,k+istart-1,1,1))*h0c0(1,i+istart-1))
endif
end do
end do
@ -897,8 +897,8 @@
! initialization when xmin is determined by sampling
do il=1,1
! this loop is useful to check that the sampling is correct
!x=0.1*real(il)
x=1.*real(il)
!x=0.1*DBLE(il)
x=1.*DBLE(il)
do is=1,nspin
nss=nupdwn(is)
fmatx(1:nss,1:nss,is)=fmat0(1:nss,1:nss,is)+x*dfmat(1:nss,1:nss,is)
@ -989,11 +989,11 @@
c0hc0(k,i,is)=0.d0
do ig=1,ngw
c0hc0(k,i,is)=c0hc0(k,i,is)-&
2.0*real(conjg(c0(ig,k+istart-1,1,1))*h0c0(ig,i+istart-1))
2.0*DBLE(CONJG(c0(ig,k+istart-1,1,1))*h0c0(ig,i+istart-1))
enddo
if (ng0.eq.2) then
c0hc0(k,i,is)=c0hc0(k,i,is)+&
real(conjg(c0(1,k+istart-1,1,1))*h0c0(1,i+istart-1))
DBLE(CONJG(c0(1,k+istart-1,1,1))*h0c0(1,i+istart-1))
endif
end do
end do
@ -1063,7 +1063,7 @@
do il=0,2000
x=0.0005*real(il)
x=0.0005*DBLE(il)
entropy2=0.0
do is=1,nspin
@ -1164,9 +1164,9 @@
! do j=1,n
! add=0.d0
! do ig=1,ngw
! add = add + 2*real(conjg(c0diag(ig,i))*c0diag(ig,j))
! add = add + 2*DBLE(CONJG(c0diag(ig,i))*c0diag(ig,j))
! enddo
! add = add - real(conjg(c0diag(1,i))*c0diag(1,j))
! add = add - DBLE(CONJG(c0diag(1,i))*c0diag(1,j))
! write(*,*) 'Conrollo c0diag', i,j, add
! enddo
! enddo
@ -1247,18 +1247,18 @@
gi(ig,i+1)=c3(ig)
end do
if (ng0.eq.2) then
gi(1, i)=cmplx(real(gi(1, i)))
gi(1,i+1)=cmplx(real(gi(1,i+1)))
gi(1, i)=CMPLX(DBLE(gi(1, i)),0.d0)
gi(1,i+1)=CMPLX(DBLE(gi(1,i+1)),0.d0)
end if
enddo
do i=1,n
do j=i,n
lambda(i,j)=0.d0
do ig=1,ngw
lambda(i,j)=lambda(i,j)-2.d0*real(conjg(c0(ig,i,1,1))*gi(ig,j))
lambda(i,j)=lambda(i,j)-2.d0*DBLE(CONJG(c0(ig,i,1,1))*gi(ig,j))
enddo
if(ng0.eq.2) then
lambda(i,j)=lambda(i,j)+real(conjg(c0(1,i,1,1))*gi(1,j))
lambda(i,j)=lambda(i,j)+DBLE(CONJG(c0(1,i,1,1))*gi(1,j))
endif
lambda(j,i)=lambda(i,j)
enddo

27
CPV/cglib.f90
View File

@ -5,7 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!-------------------------------------------------------------------------
subroutine calphiid(c0,bec,betae,phi)
!-----------------------------------------------------------------------
@ -15,7 +15,6 @@
! where s'=s(r(t))
!
!ATTENZION no usa el preconditioning
use ions_base, only: na, nsp
use io_global, only: stdout
use cvan
@ -69,7 +68,7 @@
do j=1,n
do i=1,ngw
emtot=emtot &
& +2.*real(phi(i,j)*conjg(c0(i,j)))
& +2.*DBLE(phi(i,j)*CONJG(c0(i,j)))
end do
end do
emtot=emtot/n
@ -135,7 +134,7 @@
!-----------------------------------------------------------------------
subroutine rotate(z0,c0,bec,c0diag,becdiag)
!-----------------------------------------------------------------------
use kinds, only: dp
use cvan
use electrons_base, only: nudx, nspin, nupdwn, iupdwn, nx => nbspx, n => nbsp
use uspp_param, only: nh
@ -158,7 +157,7 @@
! do nj=1,nss
! do j=1,ngw
! c0diag(j,ni+istart-1)=c0diag(j,ni+istart-1)+ &
! & cmplx(z0(ni,nj,iss),0.0)*c0(j,nj+istart-1)
! & CMPLX(z0(ni,nj,iss),0.0)*c0(j,nj+istart-1)
! end do
! end do
! end do
@ -176,7 +175,7 @@
becdiag(jnl,ni+istart-1)=0.0
do nj=1,nss
becdiag(jnl,ni+istart-1)=becdiag(jnl,ni+istart-1)+ &
& cmplx(z0(ni,nj,iss),0.0)*bec(jnl,nj+istart-1)
& CMPLX(z0(ni,nj,iss),0.d0)*bec(jnl,nj+istart-1)
end do
end do
end do
@ -327,13 +326,13 @@ subroutine pc2(a,beca,b,becb)
do j=1,n
sca=0.
if (ng0.eq.2) then
b(1,i)=0.5d0*(b(1,i)+conjg(b(1,i)))
b(1,i)=0.5d0*(b(1,i)+CONJG(b(1,i)))
endif
do ig=1,ngw !loop on g vectors
sca=sca+2.d0*real(conjg(a(ig,j))*b(ig,i)) !2. for real weavefunctions
sca=sca+2.d0*DBLE(CONJG(a(ig,j))*b(ig,i)) !2. for real wavefunctions
enddo
if (ng0.eq.2) then
sca=sca-real(conjg(a(1,j))*b(1,i))
sca=sca-DBLE(CONJG(a(1,j))*b(1,i))
endif
call mp_sum( sca )
@ -358,7 +357,7 @@ subroutine pc2(a,beca,b,becb)
enddo
! this to prevent numerical errors
if (ng0.eq.2) then
b(1,i)=0.5d0*(b(1,i)+conjg(b(1,i)))
b(1,i)=0.5d0*(b(1,i)+CONJG(b(1,i)))
endif
enddo
@ -400,13 +399,13 @@ subroutine pcdaga2(a,as ,b )
do j=1,n
sca=0.
if (ng0.eq.2) then
b(1,i)=0.5d0*(b(1,i)+conjg(b(1,i)))
b(1,i)=0.5d0*(b(1,i)+CONJG(b(1,i)))
endif
do ig=1,ngw !loop on g vectors
sca=sca+2.*real(conjg(a(ig,j))*b(ig,i)) !2. for real weavefunctions
sca=sca+2.*DBLE(CONJG(a(ig,j))*b(ig,i)) !2. for real weavefunctions
enddo
if (ng0.eq.2) then
sca=sca-real(conjg(a(1,j))*b(1,i))
sca=sca-DBLE(CONJG(a(1,j))*b(1,i))
endif
call mp_sum(sca)
do ig=1,ngw
@ -414,7 +413,7 @@ subroutine pcdaga2(a,as ,b )
enddo
! this to prevent numerical errors
if (ng0.eq.2) then
b(1,i)=0.5d0*(b(1,i)+conjg(b(1,i)))
b(1,i)=0.5d0*(b(1,i)+CONJG(b(1,i)))
endif
enddo
enddo

28
CPV/chargedensity.f90
View File

@ -110,7 +110,7 @@
ALLOCATE( comp( nz ) )
fact = omega / REAL( nx * ny * nz )
fact = omega / DBLE( nx * ny * nz )
DO ispin = 1, nspin
@ -269,7 +269,7 @@
DO ispin = 1, nspin
rsum1 = SUM( rhoe( 1:nxl, 1:nyl, 1:nzl, ispin ) )
rsum1 = rsum1 * omega / REAL( nr1 * nr2 * nr3 )
rsum1 = rsum1 * omega / DBLE( nr1 * nr2 * nr3 )
! ... sum over all processors
@ -331,15 +331,15 @@
DO ib = 1, cdesc%nbl( ispin )
wdot = ZDOTC( ( cdesc%ngwl - 1 ), c(2,ib), 1, c(2,ib), 1 )
wdot = wdot + REAL( c(1,ib), dbl )**2 / 2.0d0
rsum = rsum + fi(ib) * REAL( wdot )
wdot = wdot + DBLE( c(1,ib) )**2 / 2.0d0
rsum = rsum + fi(ib) * DBLE( wdot )
END DO
ELSE
DO ib = 1, cdesc%nbl( ispin )
wdot = ZDOTC( cdesc%ngwl, c(1,ib), 1, c(1,ib), 1 )
rsum = rsum + fi(ib) * REAL( wdot )
rsum = rsum + fi(ib) * DBLE( wdot )
END DO
END IF
@ -507,7 +507,7 @@
! ... extract wave functions from psi2
r1 = DREAL( psi2(i,j,k) )
r1 = DBLE( psi2(i,j,k) )
r2 = AIMAG( psi2(i,j,k) )
! ... add squared moduli to charge density
@ -540,7 +540,7 @@
! ... extract wave functions from psi2
r1 = REAL( psi2(i,j,k) )
r1 = DBLE( psi2(i,j,k) )
! ... add squared moduli to charge density
@ -579,7 +579,7 @@
! ... add squared modulus to charge density
rho(i,j,k) = rho(i,j,k) + coef3 * REAL( psi2(i,j,k) * CONJG(psi2(i,j,k)) )
rho(i,j,k) = rho(i,j,k) + coef3 * DBLE( psi2(i,j,k) * CONJG(psi2(i,j,k)) )
END DO
END DO
@ -670,7 +670,7 @@
DO ipol = 1, 3
DO ig = 1, SIZE( rhoeg )
rg = rhoeg(ig) * gx( ipol, ig )
tgrho(ig) = tpiba * CMPLX( - AIMAG(rg), REAL(rg) )
tgrho(ig) = tpiba * CMPLX( - AIMAG(rg), DBLE(rg) )
END DO
CALL pinvfft( grho(:,:,:,ipol), tgrho )
END DO
@ -725,11 +725,11 @@
end do
do ig=1,ng
v(np(ig))= ci*tpiba*gx(1,ig)*rhog(ig,iss)
v(nm(ig))=conjg(ci*tpiba*gx(1,ig)*rhog(ig,iss))
v(nm(ig))=CONJG(ci*tpiba*gx(1,ig)*rhog(ig,iss))
end do
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
gradr(ir,1,iss)=real(v(ir))
gradr(ir,1,iss)=DBLE(v(ir))
end do
do ig=1,nnr
v(ig)=(0.0,0.0)
@ -737,13 +737,13 @@
do ig=1,ng
v(np(ig))= tpiba*( ci*gx(2,ig)*rhog(ig,iss)- &
& gx(3,ig)*rhog(ig,iss) )
v(nm(ig))= tpiba*(conjg(ci*gx(2,ig)*rhog(ig,iss)+ &
v(nm(ig))= tpiba*(CONJG(ci*gx(2,ig)*rhog(ig,iss)+ &
& gx(3,ig)*rhog(ig,iss)))
end do
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
gradr(ir,2,iss)= real(v(ir))
gradr(ir,3,iss)=aimag(v(ir))
gradr(ir,2,iss)= DBLE(v(ir))
gradr(ir,3,iss)=AIMAG(v(ir))
end do
end do
!

2
CPV/chi2.f90
View File

@ -5,7 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
module chi2
USE kinds

4
CPV/cp_fpmd.f90
View File

@ -1332,7 +1332,7 @@ END SUBROUTINE gshcount
CASE (3)
exgc_info = 'PERDEW BURKE ERNZERHOF'
CASE (7)
exgc_info = 'META-TPSS'
exgc_info = 'META-TPSS'
CASE DEFAULT
exgc_info = 'UNKNOWN'
END SELECT
@ -1348,7 +1348,7 @@ END SUBROUTINE gshcount
CASE (4)
cogc_info = 'PERDEW BURKE ERNZERHOF'
CASE (6)
cogc_info = 'META-TPSS'
cogc_info = 'META-TPSS'
CASE DEFAULT
cogc_info = 'UNKNOWN'
END SELECT

2
CPV/cp_restart.f90
View File

@ -404,7 +404,7 @@ MODULE cp_restart
call iotk_write_attr (attr,"dw",nupdwn(2))
CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd, ATTR = attr )
ELSE
CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd )
CALL iotk_write_dat( iunpun, "NUMBER_OF_BANDS", nbnd )
END IF
!
CALL iotk_write_begin( iunpun, "EIGENVALUES_AND_EIGENVECTORS" )

297
CPV/cplib.f90
View File

@ -301,7 +301,7 @@
do j=1,n
do i=1,ngw
emtot=emtot &
& +2.*real(phi(i,j)*conjg(c0(i,j)))*ema0bg(i)**(-2.)
& +2.*DBLE(phi(i,j)*CONJG(c0(i,j)))*ema0bg(i)**(-2.)
end do
end do
emtot=emtot/n
@ -354,7 +354,7 @@
!
allocate(temp(ngw))
do ig=1,ngw
temp(ig)=real(conjg(cp(ig,i))*cp(ig,i))
temp(ig)=DBLE(CONJG(cp(ig,i))*cp(ig,i))
end do
rsum=2.*SUM(temp)
if (gstart == 2) rsum=rsum-temp(1)
@ -419,7 +419,7 @@
do i=1,n
sk(i)=0.d0
do ig=gstart,ngw
sk(i)=sk(i)+real(conjg(c(ig,i))*c(ig,i))*gtmp(ig)
sk(i)=sk(i)+DBLE(CONJG(c(ig,i))*c(ig,i))*gtmp(ig)
end do
end do
do i=1,n
@ -483,12 +483,12 @@
enddo
if (gstart == 2) vtemp(1)=(0.d0,0.d0)
do ig=gstart,ng
vtemp(ig)=conjg(rhotmp(ig))*rhotmp(ig)/(tpiba2*g(ig))**2 &
vtemp(ig)=CONJG(rhotmp(ig))*rhotmp(ig)/(tpiba2*g(ig))**2 &
& * tpiba2*gx(i,ig)*(gx(1,ig)*ainv(j,1)+ &
& gx(2,ig)*ainv(j,2)+gx(3,ig)*ainv(j,3)) + &
& conjg(rhotmp(ig))/(tpiba2*g(ig))*drhotmp(ig,i,j)
& CONJG(rhotmp(ig))/(tpiba2*g(ig))*drhotmp(ig,i,j)
enddo
dh(i,j)=fpi*omega*real(SUM(vtemp))*wz
dh(i,j)=fpi*omega*DBLE(SUM(vtemp))*wz
enddo
enddo
@ -543,16 +543,16 @@
enddo
do is=1,nsp
do ig=1,ngs
vtemp(ig)=vtemp(ig)-conjg(rhotmp(ig))*sfac(ig,is)* &
vtemp(ig)=vtemp(ig)-CONJG(rhotmp(ig))*sfac(ig,is)* &
& dvps(ig,is)*2.d0*tpiba2*gx(i,ig)* &
& (gx(1,ig)*ainv(j,1) + &
& gx(2,ig)*ainv(j,2) + &
& gx(3,ig)*ainv(j,3) ) + &
& conjg(drhotmp(ig,i,j))*sfac(ig,is)*vps(ig,is)
& CONJG(drhotmp(ig,i,j))*sfac(ig,is)*vps(ig,is)
enddo
enddo
dps(i,j)=omega*real(wz*SUM(vtemp))
if (gstart == 2) dps(i,j)=dps(i,j)-omega*real(vtemp(1))
dps(i,j)=omega*DBLE(wz*SUM(vtemp))
if (gstart == 2) dps(i,j)=dps(i,j)-omega*DBLE(vtemp(1))
enddo
enddo
@ -564,13 +564,14 @@
!-------------------------------------------------------------------------
subroutine dforce (bec,betae,i,c,ca,df,da,v)
!-----------------------------------------------------------------------
!computes: the generalized force df=cmplx(dfr,dfi) acting on the i-th
!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th
! electron state at the gamma point of the brillouin zone
! represented by the vector c=cmplx(cr,ci)
! represented by the vector c=CMPLX(cr,ci)
!
! d_n(g) = f_n { 0.5 g^2 c_n(g) + [vc_n](g) +
! sum_i,ij d^q_i,ij (-i)**l beta_i,i(g)
! e^-ig.r_i < beta_i,j | c_n >}
use kinds, only: dp
use control_flags, only: iprint, tbuff
use gvecs
use gvecw, only: ngw
@ -619,7 +620,7 @@
!
psi (:) = (0.d0, 0.d0)
do ig=1,ngw
psi(nms(ig))=conjg(c(ig)-ci*ca(ig))
psi(nms(ig))=CONJG(c(ig)-ci*ca(ig))
psi(nps(ig))=c(ig)+ci*ca(ig)
end do
!
@ -651,8 +652,7 @@
end if
!
do ir=1,nnrsx
psi(ir)=cmplx(v(ir,iss1)* real(psi(ir)), &
& v(ir,iss2)*aimag(psi(ir)) )
psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v(ir,iss2)*AIMAG(psi(ir)) )
end do
!
call fwfftw(psi,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
@ -673,8 +673,8 @@
do ig=1,ngw
fp= psi(nps(ig)) + psi(nms(ig))
fm= psi(nps(ig)) - psi(nms(ig))
df(ig)= fi*(tpiba2*ggp(ig)* c(ig)+cmplx(real(fp), aimag(fm)))
da(ig)=fip*(tpiba2*ggp(ig)*ca(ig)+cmplx(aimag(fp),-real(fm)))
df(ig)= fi*(tpiba2*ggp(ig)* c(ig)+CMPLX(DBLE(fp), AIMAG(fm)))
da(ig)=fip*(tpiba2*ggp(ig)*ca(ig)+CMPLX(AIMAG(fp),-DBLE(fm)))
end do
if(ismeta) call dforce_meta(c,ca,df,da,psi,iss1,iss2,fi,fip) !METAGGA
@ -776,10 +776,10 @@
!
do k=1,kmax
do ig=1,ngw
temp(ig)=conjg(cp(ig,k))*cp(ig,i)
temp(ig)=CONJG(cp(ig,k))*cp(ig,i)
end do
csc(k)=2.*real(SUM(temp))
if (gstart == 2) csc(k)=csc(k)-real(temp(1))
csc(k)=2.*DBLE(SUM(temp))
if (gstart == 2) csc(k)=csc(k)-DBLE(temp(1))
end do
call mp_sum( csc( 1:kmax ) )
@ -821,6 +821,7 @@
! On input rhor and rhog must contain the smooth part only !!!
! Output in module derho (drhor, drhog)
!
use kinds, only: dp
use control_flags, only: iprint
use parameters, only: natx, nsx
use ions_base, only: na, nsp, nat, nas => nax
@ -933,14 +934,14 @@
qv(npb(ig)) = eigrb(ig,isa )*dqgbt(ig,1) &
& + ci* eigrb(ig,isa+1 )*dqgbt(ig,2)
qv(nmb(ig))= &
& conjg(eigrb(ig,isa )*dqgbt(ig,1)) &
& + ci*conjg(eigrb(ig,isa+1)*dqgbt(ig,2))
& CONJG(eigrb(ig,isa )*dqgbt(ig,1)) &
& + ci*CONJG(eigrb(ig,isa+1)*dqgbt(ig,2))
end do
else
do ig=1,ngb
qv(npb(ig)) = eigrb(ig,isa)*dqgbt(ig,1)
qv(nmb(ig)) = &
& conjg(eigrb(ig,isa)*dqgbt(ig,1))
& CONJG(eigrb(ig,isa)*dqgbt(ig,1))
end do
endif
!
@ -959,7 +960,7 @@
end do
!
do ir=1,nnr
drhor(ir,iss,i,j)=drhor(ir,iss,i,j)+real(v(ir))
drhor(ir,iss,i,j)=drhor(ir,iss,i,j)+DBLE(v(ir))
end do
!
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
@ -1015,8 +1016,8 @@
do ig=1,ngb
qv(npb(ig))= eigrb(ig,isa)*dqgbt(ig,1) &
& + ci* eigrb(ig,isa)*dqgbt(ig,2)
qv(nmb(ig))= conjg(eigrb(ig,isa)*dqgbt(ig,1)) &
& + ci*conjg(eigrb(ig,isa)*dqgbt(ig,2))
qv(nmb(ig))= CONJG(eigrb(ig,isa)*dqgbt(ig,1)) &
& + ci*CONJG(eigrb(ig,isa)*dqgbt(ig,2))
end do
!
call ivfftb(qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,irb3)
@ -1032,8 +1033,8 @@
end do
!
do ir=1,nnr
drhor(ir,isup,i,j) = drhor(ir,isup,i,j) + real(v(ir))
drhor(ir,isdw,i,j) = drhor(ir,isdw,i,j) +aimag(v(ir))
drhor(ir,isup,i,j) = drhor(ir,isup,i,j) + DBLE(v(ir))
drhor(ir,isdw,i,j) = drhor(ir,isdw,i,j) +AIMAG(v(ir))
enddo
!
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
@ -1041,9 +1042,9 @@
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
drhog(ig,isup,i,j) = drhog(ig,isup,i,j) + &
& 0.5*cmplx( real(fp),aimag(fm))
& 0.5*CMPLX( DBLE(fp),AIMAG(fm))
drhog(ig,isdw,i,j) = drhog(ig,isdw,i,j) + &
& 0.5*cmplx(aimag(fp),-real(fm))
& 0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
!
end do
@ -1082,7 +1083,7 @@
do i=1,n
sk(i)=0.0
do ig=gstart,ngw
sk(i)=sk(i)+real(conjg(c(ig,i))*c(ig,i))*ggp(ig)
sk(i)=sk(i)+DBLE(CONJG(c(ig,i))*c(ig,i))*ggp(ig)
end do
end do
@ -1181,6 +1182,7 @@
!
! Contribution to ionic forces from local pseudopotential
!
use kinds, only: dp
use constants, only: pi, fpi
use electrons_base, only: nspin
use gvecs
@ -1221,32 +1223,32 @@
iss=1
if (gstart == 2) vtemp(1)=0.0
do ig=gstart,ngs
vcgs=conjg(rhotemp(ig))*fpi/(tpiba2*g(ig))
vcgs=CONJG(rhotemp(ig))*fpi/(tpiba2*g(ig))
cnvg=rhops(ig,is)*vcgs
cvn=vps(ig,is)*conjg(rhog(ig,iss))
cvn=vps(ig,is)*CONJG(rhog(ig,iss))
i = mill_l(1,ig)
j = mill_l(2,ig)
k = mill_l(3,ig)
eigrx=ei1(i,isa)*ei2(j,isa)*ei3(k,isa)
vtemp(ig)=eigrx*(cnvg+cvn)*cmplx(0.0,gx(ix,ig))
vtemp(ig)=eigrx*(cnvg+cvn)*CMPLX(0.d0,gx(ix,ig))
end do
else
isup=1
isdw=2
if (gstart == 2) vtemp(1)=0.0
do ig=gstart,ngs
vcgs=conjg(rhotemp(ig))*fpi/(tpiba2*g(ig))
vcgs=CONJG(rhotemp(ig))*fpi/(tpiba2*g(ig))
cnvg=rhops(ig,is)*vcgs
cvn=vps(ig,is)*conjg(rhog(ig,isup) &
cvn=vps(ig,is)*CONJG(rhog(ig,isup) &
& +rhog(ig,isdw))
i = mill_l(1,ig)
j = mill_l(2,ig)
k = mill_l(3,ig)
eigrx=ei1(i,isa)*ei2(j,isa)*ei3(k,isa)
vtemp(ig)=eigrx*(cnvg+cvn)*cmplx(0.0,gx(ix,ig))
vtemp(ig)=eigrx*(cnvg+cvn)*CMPLX(0.d0,gx(ix,ig))
end do
endif
fion1(ix,isa) = fion1(ix,isa) + tpiba*omega* wz*real(SUM(vtemp))
fion1(ix,isa) = fion1(ix,isa) + tpiba*omega* wz*DBLE(SUM(vtemp))
end do
end do
end do
@ -1405,8 +1407,8 @@
!
do inl=1,nhsavb
do ig=1,ngw
temp(ig)=cp(1,ig,i)* real(betae(ig,inl))+ &
& cp(2,ig,i)*aimag(betae(ig,inl))
temp(ig)=cp(1,ig,i)* DBLE(betae(ig,inl))+ &
& cp(2,ig,i)*AIMAG(betae(ig,inl))
end do
bec(inl,i)=2.*SUM(temp)
if (gstart == 2) bec(inl,i)= bec(inl,i)-temp(1)
@ -1677,6 +1679,7 @@
! where
! rho_lm = \sum_j f_j <psi_j|beta_l><beta_m|psi_j>
!
use kinds, only: dp
use uspp_param, only: nh, nhm
use uspp, only: deeq
use cvan, only: nvb
@ -1712,7 +1715,7 @@
!
call start_clock( 'newd' )
ci=(0.d0,1.d0)
fac=omegab/float(nr1b*nr2b*nr3b)
fac=omegab/DBLE(nr1b*nr2b*nr3b)
deeq (:,:,:,:) = 0.d0
fvan (:,:,:) = 0.d0
@ -1745,15 +1748,15 @@
do ig=1,ngb
qv(npb(ig))= eigrb(ig,isa )*qgb(ig,ijv,is) &
& + ci*eigrb(ig,isa+1)*qgb(ig,ijv,is)
qv(nmb(ig))= conjg( &
qv(nmb(ig))= CONJG( &
& eigrb(ig,isa )*qgb(ig,ijv,is)) &
& + ci*conjg( &
& + ci*CONJG( &
& eigrb(ig,isa+1)*qgb(ig,ijv,is))
end do
else
do ig=1,ngb
qv(npb(ig)) = eigrb(ig,isa)*qgb(ig,ijv,is)
qv(nmb(ig)) = conjg( &
qv(nmb(ig)) = CONJG( &
& eigrb(ig,isa)*qgb(ig,ijv,is))
end do
end if
@ -1821,25 +1824,25 @@
endif
if (nfft.eq.2) then
do ig=1,ngb
facg1 = cmplx(0.d0,-gxb(ik,ig)) * &
facg1 = CMPLX(0.d0,-gxb(ik,ig)) * &
& qgb(ig,ijv,is) * fac1
facg2 = cmplx(0.d0,-gxb(ik,ig)) * &
facg2 = CMPLX(0.d0,-gxb(ik,ig)) * &
& qgb(ig,ijv,is) * fac2
qv(npb(ig)) = qv(npb(ig)) &
& + eigrb(ig,isa )*facg1 &
& + ci*eigrb(ig,isa+1)*facg2
qv(nmb(ig)) = qv(nmb(ig)) &
& + conjg(eigrb(ig,isa )*facg1)&
& +ci*conjg(eigrb(ig,isa+1)*facg2)
& + CONJG(eigrb(ig,isa )*facg1)&
& +ci*CONJG(eigrb(ig,isa+1)*facg2)
end do
else
do ig=1,ngb
facg1 = cmplx(0.d0,-gxb(ik,ig)) * &
facg1 = CMPLX(0.d0,-gxb(ik,ig)) * &
& qgb(ig,ijv,is)*fac1
qv(npb(ig)) = qv(npb(ig)) &
& + eigrb(ig,isa)*facg1
qv(nmb(ig)) = qv(nmb(ig)) &
& + conjg( eigrb(ig,isa)*facg1)
& + CONJG( eigrb(ig,isa)*facg1)
end do
end if
end do
@ -1885,14 +1888,14 @@
fac2= fac*tpibab*rhovan(ijv,isa,isdw)
end if
do ig=1,ngb
facg1 = fac1 * cmplx(0.d0,-gxb(ik,ig)) * &
facg1 = fac1 * CMPLX(0.d0,-gxb(ik,ig)) * &
& qgb(ig,ijv,is) * eigrb(ig,isa)
facg2 = fac2 * cmplx(0.d0,-gxb(ik,ig)) * &
facg2 = fac2 * CMPLX(0.d0,-gxb(ik,ig)) * &
& qgb(ig,ijv,is) * eigrb(ig,isa)
qv(npb(ig)) = qv(npb(ig)) &
& + facg1 + ci*facg2
qv(nmb(ig)) = qv(nmb(ig)) &
& +conjg(facg1)+ci*conjg(facg2)
& +CONJG(facg1)+ci*conjg(facg2)
end do
end do
end do
@ -2372,7 +2375,7 @@
if (gstart == 2) then
do l=1,n_atomic_wfc
do m=1,n_atomic_wfc
overlap(m,l)=overlap(m,l)-real(wfc(1,m))*real(swfc(1,l))
overlap(m,l)=overlap(m,l)-DBLE(wfc(1,m))*DBLE(swfc(1,l))
end do
end do
end if
@ -2412,7 +2415,7 @@
allocate(temp(ngw))
do m=1,n
do l=1,n_atomic_wfc
temp(:)=real(conjg(c(:,m))*wfc(:,l))
temp(:)=DBLE(CONJG(c(:,m))*wfc(:,l))
proj(m,l)=2.d0*SUM(temp)
if (gstart == 2) proj(m,l)=proj(m,l)-temp(1)
end do
@ -2527,7 +2530,7 @@
! ranf1=.5-randy()
! ranf2=.5-randy()
! ampexp=ampre*exp(-(4.*j)/ngw)
! c(j,i)=c(j,i)+ampexp*cmplx(ranf1,ranf2)
! c(j,i)=c(j,i)+ampexp*CMPLX(ranf1,ranf2)
! end do
! end do
!
@ -2568,6 +2571,7 @@
!
! e_v = sum_i,ij rho_i,ij d^ion_is,ji
!
use kinds, only: dp
use control_flags, only: iprint, tbuff, iprsta, thdyn, tpre, trhor
use ions_base, only: nat, nas => nax, nsp
use parameters, only: natx, nsx
@ -2647,7 +2651,7 @@
if(nspin.eq.1)then
iss=1
do ir=1,nnr
psi(ir)=cmplx(rhor(ir,iss),0.)
psi(ir)=CMPLX(rhor(ir,iss),0.d0)
end do
call fwfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
@ -2657,14 +2661,14 @@
isup=1
isdw=2
do ir=1,nnr
psi(ir)=cmplx(rhor(ir,isup),rhor(ir,isdw))
psi(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw))
end do
call fwfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
fp=psi(np(ig))+psi(nm(ig))
fm=psi(np(ig))-psi(nm(ig))
rhog(ig,isup)=0.5*cmplx( real(fp),aimag(fm))
rhog(ig,isdw)=0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
!
@ -2685,7 +2689,7 @@
do i=1,n,2
psis (:) = (0.d0, 0.d0)
do ig=1,ngw
psis(nms(ig))=conjg(c(ig,i))+ci*conjg(c(ig,i+1))
psis(nms(ig))=CONJG(c(ig,i))+ci*conjg(c(ig,i+1))
psis(nps(ig))=c(ig,i)+ci*c(ig,i+1)
! write(6,'(I6,4F15.10)') ig, psis(nms(ig)), psis(nps(ig))
end do
@ -2709,8 +2713,8 @@
sa2=0.0
end if
do ir=1,nnrsx
rhos(ir,iss1)=rhos(ir,iss1) + sa1*( real(psis(ir)))**2
rhos(ir,iss2)=rhos(ir,iss2) + sa2*(aimag(psis(ir)))**2
rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2
rhos(ir,iss2)=rhos(ir,iss2) + sa2*(AIMAG(psis(ir)))**2
end do
!
@ -2732,7 +2736,7 @@
if(nspin.eq.1)then
iss=1
do ir=1,nnrsx
psis(ir)=cmplx(rhos(ir,iss),0.)
psis(ir)=CMPLX(rhos(ir,iss),0.d0)
end do
call fwffts(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ig=1,ngs
@ -2742,14 +2746,14 @@
isup=1
isdw=2
do ir=1,nnrsx
psis(ir)=cmplx(rhos(ir,isup),rhos(ir,isdw))
psis(ir)=CMPLX(rhos(ir,isup),rhos(ir,isdw))
end do
call fwffts(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ig=1,ngs
fp= psis(nps(ig)) + psis(nms(ig))
fm= psis(nps(ig)) - psis(nms(ig))
rhog(ig,isup)=0.5*cmplx( real(fp),aimag(fm))
rhog(ig,isdw)=0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
!
@ -2760,12 +2764,12 @@
iss=1
psi (:) = (0.d0, 0.d0)
do ig=1,ngs
psi(nm(ig))=conjg(rhog(ig,iss))
psi(nm(ig))=CONJG(rhog(ig,iss))
psi(np(ig))= rhog(ig,iss)
end do
call invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,iss)=real(psi(ir))
rhor(ir,iss)=DBLE(psi(ir))
end do
else
!
@ -2775,20 +2779,20 @@
isdw=2
psi (:) = (0.d0, 0.d0)
do ig=1,ngs
psi(nm(ig))=conjg(rhog(ig,isup))+ci*conjg(rhog(ig,isdw))
psi(nm(ig))=CONJG(rhog(ig,isup))+ci*conjg(rhog(ig,isdw))
psi(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
end do
call invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,isup)= real(psi(ir))
rhor(ir,isdw)=aimag(psi(ir))
rhor(ir,isup)= DBLE(psi(ir))
rhor(ir,isdw)=AIMAG(psi(ir))
end do
endif
if (ismeta) call kedtauofr_meta(c, psi, psis) ! METAGGA
!
if(iprsta.ge.3)then
do iss=1,nspin
rsumg(iss)=omega*real(rhog(1,iss))
rsumg(iss)=omega*DBLE(rhog(1,iss))
rsumr(iss)=SUM(rhor(:,iss))*omega/dble(nr1*nr2*nr3)
end do
@ -2836,7 +2840,7 @@
if( nfi == 0 .or. mod(nfi, iprint) == 0 ) then
do iss=1,nspin
rsumg(iss)=omega*real(rhog(1,iss))
rsumg(iss)=omega*DBLE(rhog(1,iss))
rsumr(iss)=SUM(rhor(:,iss),1)*omega/dble(nr1*nr2*nr3)
end do
@ -2922,7 +2926,7 @@
do j=1,nss
do i=1,nss
rho(i,j) = rho(i,j) - &
& real(phi(1,i+ist-1))*real(cp(1,j+ist-1))
& DBLE(phi(1,i+ist-1))*DBLE(cp(1,j+ist-1))
end do
end do
end if
@ -2954,6 +2958,7 @@
!
! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g)
!
use kinds, only: dp
use ions_base, only: nas => nax, nat, na, nsp
use io_global, only: stdout
use parameters, only: natx, nsx
@ -3052,13 +3057,13 @@
eigrb(ig,isa )*qgbt(ig,1) &
+ ci* eigrb(ig,isa+1)*qgbt(ig,2)
qv(nmb(ig))= &
conjg(eigrb(ig,isa )*qgbt(ig,1)) &
+ ci*conjg(eigrb(ig,isa+1)*qgbt(ig,2))
CONJG(eigrb(ig,isa )*qgbt(ig,1)) &
+ ci*CONJG(eigrb(ig,isa+1)*qgbt(ig,2))
end do
else
do ig=1,ngb
qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1)
qv(nmb(ig)) = conjg(eigrb(ig,isa)*qgbt(ig,1))
qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1))
end do
endif
@ -3071,13 +3076,13 @@
if(iprsta.gt.2) then
ca = SUM(qv)
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', &
& omegab*real(qgbt(1,1))
& omegab*DBLE(qgbt(1,1))
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', &
& omegab*real(ca)/(nr1b*nr2b*nr3b)
& omegab*DBLE(ca)/(nr1b*nr2b*nr3b)
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom g-sp = ', &
& omegab*real(qgbt(1,2))
& omegab*DBLE(qgbt(1,2))
WRITE( stdout,'(a,f12.8)') ' rhov: 1-atom r-sp = ', &
& omegab*aimag(ca)/(nr1b*nr2b*nr3b)
& omegab*AIMAG(ca)/(nr1b*nr2b*nr3b)
endif
!
! add qv(r) to v(r), in real space on the dense grid
@ -3092,7 +3097,7 @@
! rhor(r) = total (smooth + US) charge density in real space
!
do ir=1,nnr
rhor(ir,iss)=rhor(ir,iss)+real(v(ir))
rhor(ir,iss)=rhor(ir,iss)+DBLE(v(ir))
end do
!
if(iprsta.gt.2) then
@ -3119,7 +3124,7 @@
end do
!
if(iprsta.gt.1) WRITE( stdout,'(a,2f12.8)') &
& ' rhov: n_v(g=0) = ',omega*real(rhog(1,iss))
& ' rhov: n_v(g=0) = ',omega*DBLE(rhog(1,iss))
!
else
!
@ -3156,8 +3161,8 @@
do ig=1,ngb
qv(npb(ig)) = eigrb(ig,isa)*qgbt(ig,1) &
& + ci* eigrb(ig,isa)*qgbt(ig,2)
qv(nmb(ig)) = conjg(eigrb(ig,isa)*qgbt(ig,1)) &
& + ci* conjg(eigrb(ig,isa)*qgbt(ig,2))
qv(nmb(ig)) = CONJG(eigrb(ig,isa)*qgbt(ig,1)) &
& + ci* CONJG(eigrb(ig,isa)*qgbt(ig,2))
end do
!
call ivfftb(qv,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,irb3)
@ -3168,13 +3173,13 @@
if(iprsta.gt.2) then
ca = SUM(qv)
WRITE( stdout,'(a,f12.8)') ' rhov: up g-space = ', &
& omegab*real(qgbt(1,1))
& omegab*DBLE(qgbt(1,1))
WRITE( stdout,'(a,f12.8)') ' rhov: up r-sp = ', &
& omegab*real(ca)/(nr1b*nr2b*nr3b)
& omegab*DBLE(ca)/(nr1b*nr2b*nr3b)
WRITE( stdout,'(a,f12.8)') ' rhov: dw g-space = ', &
& omegab*real(qgbt(1,2))
& omegab*DBLE(qgbt(1,2))
WRITE( stdout,'(a,f12.8)') ' rhov: dw r-sp = ', &
& omegab*aimag(ca)/(nr1b*nr2b*nr3b)
& omegab*AIMAG(ca)/(nr1b*nr2b*nr3b)
endif
!
! add qv(r) to v(r), in real space on the dense grid
@ -3186,8 +3191,8 @@
end do
!
do ir=1,nnr
rhor(ir,isup)=rhor(ir,isup)+real(v(ir))
rhor(ir,isdw)=rhor(ir,isdw)+aimag(v(ir))
rhor(ir,isup)=rhor(ir,isup)+DBLE(v(ir))
rhor(ir,isdw)=rhor(ir,isdw)+AIMAG(v(ir))
end do
!
if(iprsta.gt.2) then
@ -3201,25 +3206,25 @@
if(iprsta.gt.2) then
WRITE( stdout,*) 'rhov: smooth up',omega*rhog(1,isup)
WRITE( stdout,*) 'rhov: smooth dw',omega*rhog(1,isdw)
WRITE( stdout,*) 'rhov: vander up',omega*real(v(1))
WRITE( stdout,*) 'rhov: vander dw',omega*aimag(v(1))
WRITE( stdout,*) 'rhov: vander up',omega*DBLE(v(1))
WRITE( stdout,*) 'rhov: vander dw',omega*AIMAG(v(1))
WRITE( stdout,*) 'rhov: all up', &
& omega*(rhog(1,isup)+real(v(1)))
& omega*(rhog(1,isup)+DBLE(v(1)))
WRITE( stdout,*) 'rhov: all dw', &
& omega*(rhog(1,isdw)+aimag(v(1)))
& omega*(rhog(1,isdw)+AIMAG(v(1)))
endif
!
do ig=1,ng
fp= v(np(ig)) + v(nm(ig))
fm= v(np(ig)) - v(nm(ig))
rhog(ig,isup)=rhog(ig,isup) + 0.5*cmplx(real(fp),aimag(fm))
rhog(ig,isdw)=rhog(ig,isdw) + 0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=rhog(ig,isup) + 0.5*CMPLX(DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=rhog(ig,isdw) + 0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
!
if(iprsta.gt.2) WRITE( stdout,'(a,2f12.8)') &
& ' rhov: n_v(g=0) up = ',omega*real (rhog(1,isup))
& ' rhov: n_v(g=0) up = ',omega*DBLE (rhog(1,isup))
if(iprsta.gt.2) WRITE( stdout,'(a,2f12.8)') &
& ' rhov: n_v(g=0) down = ',omega*real(rhog(1,isdw))
& ' rhov: n_v(g=0) down = ',omega*DBLE(rhog(1,isdw))
!
endif
@ -3333,7 +3338,7 @@
do j=1,nss
do i=1,nss
sig(i,j) = sig(i,j) + &
& real(cp(1,i+ist-1))*real(cp(1,j+ist-1))
& DBLE(cp(1,i+ist-1))*DBLE(cp(1,j+ist-1))
end do
end do
end if
@ -3459,7 +3464,7 @@
do i=1,nup
overlap(i,j)=0.d0
do ig=1,ngw
temp(ig)=real(conjg(c(ig,i))*c(ig,jj))
temp(ig)=DBLE(CONJG(c(ig,i))*c(ig,jj))
end do
overlap(i,j) = 2.d0*SUM(temp)
if (gstart == 2) overlap(i,j) = overlap(i,j) - temp(1)
@ -3546,7 +3551,7 @@
do j=1,nss
do i=1,nss
tau(i,j) = tau(i,j) - &
& real(phi(1,i+ist-1))*real(phi(1,j+ist-1))
& DBLE(phi(1,i+ist-1))*DBLE(phi(1,j+ist-1))
end do
end do
end if
@ -3677,6 +3682,7 @@
! rhor output: total potential on dense real space grid
! rhos output: total potential on smooth real space grid
!
use kinds, only: dp
use control_flags, only: iprint, tvlocw, iprsta, thdyn, tpre, tfor, tprnfor
use io_global, only: stdout
use parameters, only: natx, nsx
@ -3779,11 +3785,11 @@
vtemp=(0.,0.)
do is=1,nsp
do ig=1,ngs
vtemp(ig)=vtemp(ig)+conjg(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
vtemp(ig)=vtemp(ig)+CONJG(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
end do
end do
!
epseu=wz*real(SUM(vtemp))
epseu=wz*DBLE(SUM(vtemp))
if (gstart == 2) epseu=epseu-vtemp(1)
call reduce(1,epseu)
epseu=epseu*omega
@ -3800,10 +3806,10 @@
end do
if (gstart == 2) vtemp(1)=0.0
do ig=gstart,ng
vtemp(ig)=conjg(rhotmp(ig))*rhotmp(ig)/g(ig)
vtemp(ig)=CONJG(rhotmp(ig))*rhotmp(ig)/g(ig)
end do
!
eh=real(SUM(vtemp))*wz*0.5*fpi/tpiba2
eh=DBLE(SUM(vtemp))*wz*0.5*fpi/tpiba2
call reduce(1,eh)
if(tpre) call denh(rhotmp,drhotmp,sfac,vtemp,eh,dh)
if(tpre) deallocate(drhotmp)
@ -3845,7 +3851,7 @@
if(nspin.eq.1) then
iss=1
do ir=1,nnr
v(ir)=cmplx(rhor(ir,iss),0.0)
v(ir)=CMPLX(rhor(ir,iss),0.d0)
end do
!
! v_xc(r) --> v_xc(g)
@ -3863,14 +3869,14 @@
isup=1
isdw=2
do ir=1,nnr
v(ir)=cmplx(rhor(ir,isup),rhor(ir,isdw))
v(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw))
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
rhog(ig,isup)=vtemp(ig)+0.5*cmplx( real(fp),aimag(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=vtemp(ig)+0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
!
@ -3895,7 +3901,7 @@
iss=1
do ig=1,ng
v(np(ig))=rhog(ig,iss)
v(nm(ig))=conjg(rhog(ig,iss))
v(nm(ig))=CONJG(rhog(ig,iss))
end do
!
! v(g) --> v(r)
@ -3903,7 +3909,7 @@
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
do ir=1,nnr
rhor(ir,iss)=real(v(ir))
rhor(ir,iss)=DBLE(v(ir))
end do
!
! calculation of average potential
@ -3914,13 +3920,13 @@
isdw=2
do ig=1,ng
v(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
v(nm(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
v(nm(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
!
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,isup)= real(v(ir))
rhor(ir,isdw)=aimag(v(ir))
rhor(ir,isup)= DBLE(v(ir))
rhor(ir,isdw)=AIMAG(v(ir))
end do
!
! calculation of average potential
@ -3936,26 +3942,26 @@
if(nspin.eq.1)then
iss=1
do ig=1,ngs
vs(nms(ig))=conjg(rhog(ig,iss))
vs(nms(ig))=CONJG(rhog(ig,iss))
vs(nps(ig))=rhog(ig,iss)
end do
!
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
!
do ir=1,nnrsx
rhos(ir,iss)=real(vs(ir))
rhos(ir,iss)=DBLE(vs(ir))
end do
else
isup=1
isdw=2
do ig=1,ngs
vs(nps(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
vs(nms(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
vs(nms(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ir=1,nnrsx
rhos(ir,isup)= real(vs(ir))
rhos(ir,isdw)=aimag(vs(ir))
rhos(ir,isup)= DBLE(vs(ir))
rhos(ir,isdw)=AIMAG(vs(ir))
end do
endif
if(ismeta) call vofrho_meta(v,vs) !METAGGA
@ -4069,6 +4075,7 @@
! rhor output: total potential on dense real space grid
! rhos output: total potential on smooth real space grid
!
use kinds, only: dp
use control_flags, only: iprint, tvlocw, iprsta, thdyn, tpre, tfor, tprnfor
use io_global, only: stdout
use parameters, only: natx, nsx
@ -4189,11 +4196,11 @@
vtemp=(0.,0.)
do is=1,nsp
do ig=1,ngs
vtemp(ig)=vtemp(ig)+conjg(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
vtemp(ig)=vtemp(ig)+CONJG(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
end do
end do
!
epseu=wz*real(SUM(vtemp(1:ngs)))
epseu=wz*DBLE(SUM(vtemp(1:ngs)))
if (ng0.eq.2) epseu=epseu-vtemp(1)
call reduce(1,epseu)
epseu=epseu*omega
@ -4212,10 +4219,10 @@
end do
if (ng0.eq.2) vtemp(1)=0.0
do ig=ng0,ng
vtemp(ig)=conjg(rhotmp(ig))*rhotmp(ig)/g(ig)
vtemp(ig)=CONJG(rhotmp(ig))*rhotmp(ig)/g(ig)
end do
!
eh=real(SUM(vtemp(1:ng)))*wz*0.5*fpi/tpiba2
eh=DBLE(SUM(vtemp(1:ng)))*wz*0.5*fpi/tpiba2
call reduce(1,eh)
if(tpre) call denh(rhotmp,drhotmp,sfac,vtemp,eh,dh)
if(tpre) deallocate(drhotmp)
@ -4251,7 +4258,7 @@
! -------------------------------------------------------------------
v(:) = (0.d0, 0.d0)
do ig=1,ng
v(nm(ig))=conjg(rhotmp(ig))
v(nm(ig))=CONJG(rhotmp(ig))
v(np(ig))=rhotmp(ig)
end do
!
@ -4260,7 +4267,7 @@
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
do ir=1,nnr
rhortot(ir)=real(v(ir))
rhortot(ir)=DBLE(v(ir))
end do
!
call poles(rhortot,dipole,quadrupole)
@ -4309,7 +4316,7 @@
if(nspin.eq.1) then
iss=1
do ir=1,nnr
v(ir)=cmplx(rhor(ir,iss),0.0)
v(ir)=CMPLX(rhor(ir,iss),0.d0)
end do
!
! v_xc(r) --> v_xc(g)
@ -4327,14 +4334,14 @@
isup=1
isdw=2
do ir=1,nnr
v(ir)=cmplx(rhor(ir,isup),rhor(ir,isdw))
v(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw))
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
rhog(ig,isup)=vtemp(ig)+0.5*cmplx( real(fp),aimag(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=vtemp(ig)+0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
!
@ -4358,7 +4365,7 @@
iss=1
do ig=1,ng
v(np(ig))=rhog(ig,iss)
v(nm(ig))=conjg(rhog(ig,iss))
v(nm(ig))=CONJG(rhog(ig,iss))
end do
!
! v(g) --> v(r)
@ -4366,24 +4373,24 @@
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
do ir=1,nnr
rhor(ir,iss)=real(v(ir))
rhor(ir,iss)=DBLE(v(ir))
end do
!
! calculation of average potential
!
vave=SUM(rhor(1:nnr,iss))/dfloat(nr1*nr2*nr3)
vave=SUM(rhor(1:nnr,iss))/DBLE(nr1*nr2*nr3)
else
isup=1
isdw=2
do ig=1,ng
v(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
v(nm(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
v(nm(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
!
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,isup)= real(v(ir))
rhor(ir,isdw)=aimag(v(ir))
rhor(ir,isup)= DBLE(v(ir))
rhor(ir,isdw)=AIMAG(v(ir))
end do
! write(6,*) 'Average Potential'
@ -4391,7 +4398,7 @@
! calculation of average potential
!
vave=(SUM(rhor(1:nnr,isup))+SUM(rhor(1:nnr,isdw))) &
& /2.0/dfloat(nr1*nr2*nr3)
& /2.0/DBLE(nr1*nr2*nr3)
endif
call reduce(1,vave)
! ===================================================================
@ -4401,26 +4408,26 @@
if(nspin.eq.1)then
iss=1
do ig=1,ngs
vs(nms(ig))=conjg(rhog(ig,iss))
vs(nms(ig))=CONJG(rhog(ig,iss))
vs(nps(ig))=rhog(ig,iss)
end do
!
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
!
do ir=1,nnrsx
rhos(ir,iss)=real(vs(ir))
rhos(ir,iss)=DBLE(vs(ir))
end do
else
isup=1
isdw=2
do ig=1,ngs
vs(nps(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
vs(nms(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
vs(nms(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ir=1,nnrsx
rhos(ir,isup)= real(vs(ir))
rhos(ir,isdw)=aimag(vs(ir))
rhos(ir,isup)= DBLE(vs(ir))
rhos(ir,isdw)=AIMAG(vs(ir))
end do
endif
@ -4572,7 +4579,7 @@
call reduce(3,mu)
!
do ix=1,3
mu(ix)=mu(ix)*omega/dfloat(nr1*nr2*nr3)
mu(ix)=mu(ix)*omega/DBLE(nr1*nr2*nr3)
end do
!
dipole=sqrt(mu(1)**2+mu(2)**2+mu(3)**2)
@ -4622,7 +4629,7 @@
call reduce(6,quad)
do ix=1,6
quad(ix)=quad(ix)*omega/dfloat(nr1*nr2*nr3)
quad(ix)=quad(ix)*omega/DBLE(nr1*nr2*nr3)
end do
!
quadrupole=quad(1)+quad(2)+quad(3)-rzero*qbac

68
CPV/cplib_meta.f90
View File

@ -7,11 +7,13 @@
!
subroutine dforce_meta (c,ca,df,da, psi,iss1,iss2,fi,fip)
!-----------------------------------------------------------------------
!computes: the generalized force df=cmplx(dfr,dfi) acting on the i-th
!computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th
! electron state at the gamma point of the brillouin zone
! represented by the vector c=cmplx(cr,ci)
! represented by the vector c=CMPLX(cr,ci)
!
! contribution from metaGGA
! contribution from metaGGA
#include "f_defs.h"
use kinds, only: dp
use reciprocal_vectors
use gvecs
use gvecw, only : ngw
@ -33,23 +35,23 @@
ci=(0.0,1.0)
!
do ipol = 1, 3
psi(:)=(0.d0,0.d0)
psi(:)=(0.d0,0.d0)
do ig=1,ngw
psi(nps(ig))=gx(ipol,ig)* (ci*c(ig) - ca(ig))
psi(nms(ig))=gx(ipol,ig)* (conjg(ci*c(ig) + ca(ig)))
psi(nms(ig))=gx(ipol,ig)* (CONJG(ci*c(ig) + ca(ig)))
end do
call ivfftw(psi,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
! on smooth grids--> grids for charge density
do ir=1, nnrs
psi(ir) = cmplx(kedtaus(ir,iss1)*real(psi(ir)), &
kedtaus(ir,iss2)*aimag(psi(ir)))
psi(ir) = &
CMPLX(kedtaus(ir,iss1)*DBLE(psi(ir)), kedtaus(ir,iss2)*AIMAG(psi(ir)))
end do
call fwfftw(psi,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ig=1,ngw
fp= (psi(nps(ig)) + psi(nms(ig)))
fm= (psi(nps(ig)) - psi(nms(ig)))
df(ig)= df(ig) - ci*fi*tpiba2*gx(ipol,ig)*cmplx(real(fp), aimag(fm))
da(ig)= da(ig) - ci*fip*tpiba2*gx(ipol,ig)*cmplx(aimag(fp),-real(fm))
df(ig)= df(ig) - ci*fi*tpiba2*gx(ipol,ig)*CMPLX(DBLE(fp), AIMAG(fm))
da(ig)= da(ig) - ci*fip*tpiba2*gx(ipol,ig)*CMPLX(AIMAG(fp),-DBLE(fm))
end do
end do
@ -62,6 +64,7 @@
subroutine kedtauofr_meta (c, psi, psis)
!-----------------------------------------------------------------------
!
use kinds, only: dp
use control_flags, only: tpre
use gvecs
use gvecw, only: ngw
@ -124,14 +127,14 @@
psis(:)=(0.d0,0.d0)
do ig=1,ngw
psis(nps(ig))=tpiba*gx(ipol,ig)* (ci*c(ig,i) - c(ig,i+1))
psis(nms(ig))=tpiba*gx(ipol,ig)*conjg(ci*c(ig,i)+c(ig,i+1))
psis(nms(ig))=tpiba*gx(ipol,ig)*CONJG(ci*c(ig,i)+c(ig,i+1))
end do
! gradient of wfc in real space
call ivfftw(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
! on smooth grids--> grids for charge density
do ir=1, nnrsx
kedtaus(ir,iss1)=kedtaus(ir,iss1)+0.5d0*sa1*real(psis(ir))**2
kedtaus(ir,iss2)=kedtaus(ir,iss2)+0.5d0*sa2*aimag(psis(ir))**2
kedtaus(ir,iss1)=kedtaus(ir,iss1)+0.5d0*sa1*DBLE(psis(ir))**2
kedtaus(ir,iss2)=kedtaus(ir,iss2)+0.5d0*sa2*AIMAG(psis(ir))**2
end do
if(tpre) then
do ir=1, nnrsx
@ -147,9 +150,9 @@
ipol2xy(iy,ix)=ipol
do ir=1,nnrsx
crosstaus(ir,ipol,iss1) = crosstaus(ir,ipol,iss1) +&
sa1*real(gradwfc(ir,ix))*real(gradwfc(ir,iy))
sa1*DBLE(gradwfc(ir,ix))*DBLE(gradwfc(ir,iy))
crosstaus(ir,ipol,iss2) = crosstaus(ir,ipol,iss2) +&
sa2*aimag(gradwfc(ir,ix))*aimag(gradwfc(ir,iy))
sa2*AIMAG(gradwfc(ir,ix))*AIMAG(gradwfc(ir,iy))
end do
ipol=ipol+1
end do
@ -177,7 +180,7 @@
if(nspin.eq.1)then
iss=1
psis(1:nnrsx)=cmplx(kedtaus(1:nnrsx,iss),0.)
psis(1:nnrsx)=CMPLX(kedtaus(1:nnrsx,iss),0.)
call fwffts(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
kedtaug(1:ngs,iss)=psis(nps(1:ngs))
@ -185,13 +188,13 @@
isup=1
isdw=2
psis(1:nnrsx)=cmplx(kedtaus(1:nnrsx,isup),kedtaus(1:nnrsx,isdw))
psis(1:nnrsx)=CMPLX(kedtaus(1:nnrsx,isup),kedtaus(1:nnrsx,isdw))
call fwffts(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ig=1,ngs
fp= psis(nps(ig)) + psis(nms(ig))
fm= psis(nps(ig)) - psis(nms(ig))
kedtaug(ig,isup)=0.5*cmplx( real(fp),aimag(fm))
kedtaug(ig,isdw)=0.5*cmplx(aimag(fp),-real(fm))
kedtaug(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
kedtaug(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
@ -203,10 +206,10 @@
iss=1
psi(:) = (0.d0,0.d0)
psi(nm(1:ngs))=conjg(kedtaug(1:ngs,iss))
psi(nm(1:ngs))=CONJG(kedtaug(1:ngs,iss))
psi(np(1:ngs))= kedtaug(1:ngs,iss)
call invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
kedtaur(1:nnr,iss)=real(psi(1:nnr))
kedtaur(1:nnr,iss)=DBLE(psi(1:nnr))
else
! ==================================================================
@ -217,12 +220,12 @@
psi(:) = (0.d0,0.d0)
do ig=1,ngs
psi(nm(ig))=conjg(kedtaug(ig,isup))+ci*conjg(kedtaug(ig,isdw))
psi(nm(ig))=CONJG(kedtaug(ig,isup))+ci*conjg(kedtaug(ig,isdw))
psi(np(ig))=kedtaug(ig,isup)+ci*kedtaug(ig,isdw)
end do
call invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
kedtaur(1:nnr,isup)= real(psi(1:nnr))
kedtaur(1:nnr,isdw)=aimag(psi(1:nnr))
kedtaur(1:nnr,isup)= DBLE(psi(1:nnr))
kedtaur(1:nnr,isdw)=AIMAG(psi(1:nnr))
endif
!
@ -244,6 +247,7 @@
! rhor output: total potential on dense real space grid
! rhos output: total potential on smooth real space grid
!
use kinds, only: dp
use control_flags, only: iprint, tvlocw, iprsta, thdyn, tpre, tfor, tprnfor
use io_global, only: stdout
use parameters, only: natx, nsx
@ -303,7 +307,7 @@
if(nspin.eq.1) then
iss=1
do ir=1,nnr
v(ir)=cmplx(kedtaur(ir,iss),0.0)
v(ir)=CMPLX(kedtaur(ir,iss),0.0)
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
@ -314,13 +318,13 @@
isup=1
isdw=2
v(1:nnr)=cmplx(kedtaur(1:nnr,isup),kedtaur(1:nnr,isdw))
v(1:nnr)=CMPLX(kedtaur(1:nnr,isup),kedtaur(1:nnr,isdw))
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
kedtaug(ig,isup)=0.5*cmplx( real(fp),aimag(fm))
kedtaug(ig,isdw)=0.5*cmplx(aimag(fp),-real(fm))
kedtaug(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
kedtaug(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
@ -329,23 +333,23 @@
if(nspin.eq.1)then
iss=1
do ig=1,ngs
vs(nms(ig))=conjg(kedtaug(ig,iss))
vs(nms(ig))=CONJG(kedtaug(ig,iss))
vs(nps(ig))=kedtaug(ig,iss)
end do
!
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
!
kedtaus(1:nnrs,iss)=real(vs(1:nnrs))
kedtaus(1:nnrs,iss)=DBLE(vs(1:nnrs))
else
isup=1
isdw=2
do ig=1,ngs
vs(nps(ig))=kedtaug(ig,isup)+ci*kedtaug(ig,isdw)
vs(nms(ig))=conjg(kedtaug(ig,isup)) +ci*conjg(kedtaug(ig,isdw))
vs(nms(ig))=CONJG(kedtaug(ig,isup)) +ci*conjg(kedtaug(ig,isdw))
end do
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
kedtaus(1:nnrs,isup)= real(vs(1:nnrs))
kedtaus(1:nnrs,isdw)=aimag(vs(1:nnrs))
kedtaus(1:nnrs,isup)= DBLE(vs(1:nnrs))
kedtaus(1:nnrs,isdw)=AIMAG(vs(1:nnrs))
endif
!calculate dkedxc in real space on smooth grids !metagga
if(tpre) then

4
CPV/cprsub.f90
View File

@ -428,7 +428,7 @@ subroutine qvan2b(ngy,iv,jv,is,ylm,qg)
if (lp > lmaxq*lmaxq) call errore(' qvan2b ',' lp out of bounds ',lp)
!
! extraction of angular momentum l from lp:
! l = int ( sqrt( float(l-1) + epsilon) ) + 1
! l = int ( sqrt( DBLE(l-1) + epsilon) ) + 1
!
if (lp == 1) then
l=1
@ -506,7 +506,7 @@ subroutine dqvan2b(ngy,iv,jv,is,ylm,dylm,dqg)
if (lp > lmaxq*lmaxq) call errore(' dqvan2b ',' lp out of bounds ',lp)
! extraction of angular momentum l from lp:
! l = int ( sqrt( float(l-1) + epsilon) ) + 1
! l = int ( sqrt( DBLE(l-1) + epsilon) ) + 1
!
if (lp == 1) then
l=1

6
CPV/crayfft.f90
View File

@ -86,7 +86,7 @@
& jump,nr3,lot,isign)
!
if (isign.eq.-1) then
fac=1.d0/dfloat(nr1*nr2*nr3)
fac=1.d0/DBLE(nr1*nr2*nr3)
call SSCAL(2*nr1x*nr2x*nr3x,fac,f,1)
end if
!
@ -161,7 +161,7 @@
& jump,nr3b,lot,isign)
!
if (isign.eq.-1) then
fac=1.d0/dfloat(nr1b*nr2b*nr3b)
fac=1.d0/DBLE(nr1b*nr2b*nr3b)
call SSCAL(2*nr1bx*nr2bx*nr3bx,fac,f,1)
end if
!
@ -247,7 +247,7 @@
& jump,nr3s,lot,isign)
!
if (isign.eq.-1) then
fac=1.d0/dfloat(nr1s*nr2s*nr3s)
fac=1.d0/DBLE(nr1s*nr2s*nr3s)
call SSCAL(2*nr1sx*nr2sx*nr3sx,fac,f,1)
end if
!

10
CPV/dforceb.f90
View File

@ -83,16 +83,16 @@ subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df)
if(ctabin(ig,2).ge.0) then
dtemp(ig)=dtemp(ig)+c0(ctabin(ig,2),j)*qmat(j,i)
else
dtemp(ig)=dtemp(ig)+conjg(c0(-ctabin(ig,2),j))*qmat(j,i)
dtemp(ig)=dtemp(ig)+CONJG(c0(-ctabin(ig,2),j))*qmat(j,i)
endif
endif
enddo
do ig=1,ngw
if(ctabin(ig,1) .ne. (ngw+1)) then
if(ctabin(ig,1).ge.0) then
dtemp(ig)=dtemp(ig)-c0(ctabin(ig,1),j)*conjg(qmat(j,i))
dtemp(ig)=dtemp(ig)-c0(ctabin(ig,1),j)*CONJG(qmat(j,i))
else
dtemp(ig)=dtemp(ig)-conjg(c0(-ctabin(ig,1),j))*conjg(qmat(j,i))
dtemp(ig)=dtemp(ig)-CONJG(c0(-ctabin(ig,1),j))*conjg(qmat(j,i))
endif
endif
enddo
@ -136,7 +136,7 @@ subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df)
jnl=ish(is)+(jv-1)*na(is)+ia
do j=1,n !loop on states
afrc(inl)=afrc(inl)+gqq(iv,jv,ia,is)*bec0(jnl,j)*qmat(j,i)&
& -conjg(gqq(jv,iv,ia,is))*bec0(jnl,j)*conjg(qmat(i,j))
& -CONJG(gqq(jv,iv,ia,is))*bec0(jnl,j)*conjg(qmat(i,j))
end do
@ -194,7 +194,7 @@ subroutine dforceb(c0, i, betae, ipol, bec0, ctabin, gqq, gqqm, qmat, dq2, df)
endif
enb = 2.*aimag(log(detq))/gmes!ATTENZIONE al segno
enb = 2.*AIMAG(log(detq))/gmes!ATTENZIONE al segno
! write(6,*) detq, enb
return

16
CPV/diis.f90
View File

@ -287,7 +287,7 @@
IF( gemax_l < ABS( c(iabs,i,ik) ) ) THEN
gemax_l = ABS( c(iabs,i,ik) )
END IF
cnormk = cnormk + REAL( zdotc( cdesc%ngwl, c(1,i,ik), 1, c(1,i,ik), 1) )
cnormk = cnormk + DBLE( zdotc( cdesc%ngwl, c(1,i,ik), 1, c(1,i,ik), 1) )
END DO
cnormk = cnormk * weight(ik)
cnorm = cnorm + cnormk
@ -350,7 +350,7 @@
IF( .NOT. PRESENT(ik) ) THEN
IF(gzero) THEN
DO i = 1, nsp
vp = vp + REAL( sfac(1,i) ) * vps(1,i)
vp = vp + DBLE( sfac(1,i) ) * vps(1,i)
END DO
END IF
CALL mp_sum(vp, group)
@ -398,7 +398,7 @@
REAL(dbl) :: eig(:,:,:), efermi, sume, ent, temp, entk, qtot
INTEGER :: ik, ispin, nel, nb
qtot = REAL( nel )
qtot = DBLE( nel )
CALL fermi_energy( eig, occ, wke, efermi, qtot, temp, sume)
! ... compute the enthropic correction
@ -555,10 +555,10 @@
IF(oqnr_diis ) ff = fm1(k)
fff=2.0d0*ff*ff*vvpp
DO i=1,nsize-1
rri=REAL(grade(l,k,1,i))
rri=DBLE(grade(l,k,1,i))
rii=AIMAG(grade(l,k,1,i))
DO j=1,i
rrj=REAL(grade(l,k,1,j))
rrj=DBLE(grade(l,k,1,j))
rij=AIMAG(grade(l,k,1,j))
bc(i,j)=bc(i,j)+(rri*rrj+rii*rij)*fff
END DO
@ -571,9 +571,9 @@
IF(oqnr_diis ) ff = fm1(k)
fff=ff*ff*vpp(1)*vpp(1)
DO i=1,nsize-1
r1=REAL(grade(1,k,1,i))
r1=DBLE(grade(1,k,1,i))
DO j=1,i
r2=REAL(grade(1,k,1,j))
r2=DBLE(grade(1,k,1,j))
bc(i,j)=bc(i,j)+r1*r2*fff
END DO
END DO
@ -895,7 +895,7 @@
DO ik = 1, cdesc%nkl
c(:,:,ik) = c(:,:,ik) + var2 * cgrad(:,:,ik)
IF ( cdesc%gzero ) THEN
c(1,:,ik) = CMPLX( REAL( c(1,:,ik) ), 0.d0 )
c(1,:,ik) = CMPLX( DBLE( c(1,:,ik) ), 0.d0 )
END IF
END DO
RETURN

18
CPV/dipol_matrix.f90
View File

@ -79,14 +79,14 @@
! the center of mass of the system is moved
shift(1) = 0.5d0*l1 - cm(1)
tp(1) = nint(shift(1)*dfloat(nr1)/ll1)
shift(1) = 0.d0 !dfloat(tp(1))*ll1/dfloat(nr1)
tp(1) = nint(shift(1)*DBLE(nr1)/ll1)
shift(1) = 0.d0 !DBLE(tp(1))*ll1/DBLE(nr1)
shift(2) = 0.5d0*l2 - cm(2)
tp(2) = nint(shift(2)*dfloat(nr2)/ll2)
shift(2) = 0.d0 !dfloat(tp(2))*ll2/dfloat(nr2)
tp(2) = nint(shift(2)*DBLE(nr2)/ll2)
shift(2) = 0.d0 !DBLE(tp(2))*ll2/DBLE(nr2)
shift(3) = 0.5d0*l3 - cm(3)
tp(3) = nint(shift(3)*dfloat(nr3)/ll3)
shift(3) = 0.d0 !dfloat(tp(3))*ll3/dfloat(nr3)
tp(3) = nint(shift(3)*DBLE(nr3)/ll3)
shift(3) = 0.d0 !DBLE(tp(3))*ll3/DBLE(nr3)
#ifdef __PARA
@ -138,9 +138,9 @@
#else
rho_aux = rho(ir) !rho(ipn)
#endif
dipol(1)=dipol(1)+rho_aux*real(ir1)*ll1/real(nr1)
dipol(2)=dipol(2)+rho_aux*real(ir2)*ll2/real(nr2)
dipol(3)=dipol(3)+rho_aux*real(ir3)*ll3/real(nr3)
dipol(1)=dipol(1)+rho_aux*DBLE(ir1)*ll1/DBLE(nr1)
dipol(2)=dipol(2)+rho_aux*DBLE(ir2)*ll2/DBLE(nr2)
dipol(3)=dipol(3)+rho_aux*DBLE(ir3)*ll3/DBLE(nr3)
end do
end do
end do

6
CPV/efermi.f90
View File

@ -177,7 +177,7 @@
stop
end if
fspin=float(nspin)
fspin=DBLE(nspin)
entrofac=3.0-fspin
if ((nspin.eq.2).and.(ismear.ne.2)) then
@ -214,10 +214,10 @@
! note that this has to be changed if k-points are introduced !
do nkp=1,nkpts
weight(nkp)=1.0/float(nkpts)
weight(nkp)=1.0/DBLE(nkpts)
end do
Z = FLOAT(NEL)
Z = DBLE (NEL)
! COPY EIGVAL INTO SORT ARRAY.

6
CPV/electrons.f90
View File

@ -8,7 +8,7 @@
!=----------------------------------------------------------------------------=!
MODULE electrons_module
!=----------------------------------------------------------------------------=!
#include "f_defs.h"
USE kinds
USE parameters, ONLY: nspinx
USE parallel_toolkit, ONLY: pdspev_drv, dspev_drv, pzhpev_drv, zhpev_drv
@ -373,7 +373,7 @@
IF ( gamma_symmetry ) THEN
ei(i) = gam(ib_local(i),i) / ftmp(i)
ELSE
ei(i) = REAL(cgam(ib_local(i),i)) / ftmp(i)
ei(i) = DBLE(cgam(ib_local(i),i)) / ftmp(i)
END IF
END IF
END DO
@ -447,7 +447,7 @@
nrl = SIZE(cgam, 1)
n = SIZE(cgam, 2)
IF( PRESENT( caux ) ) THEN
caux = CMPLX(0.0d0)
caux = CMPLX(0.0d0, 0.d0)
IF( mpime < n ) THEN
DO i = 1, n
j = mpime + 1

6
CPV/emptystates.f90
View File

@ -284,7 +284,7 @@
DO I = 1, NE
SF = 0.D0
IF( wfill%gzero ) THEN
CALL DAXPY( nf, - REAL( ce(1,i) ), cf(1,1), 2*ngw, sf, 1 )
CALL DAXPY( nf, -DBLE( ce(1,i) ), cf(1,1), 2*ngw, sf, 1 )
END IF
CALL DGEMV( 'T', 2*ngw, nf, 2.0d0, cf(1,1), ldw, ce(1,i), 1, 1.d0, sf, 1 )
CALL mp_sum( SF, group )
@ -294,7 +294,7 @@
IF( I > 1 ) THEN
SE = 0.D0
IF( wfill%gzero ) THEN
CALL DAXPY( i-1, -REAL( ce(1,i) ), ce(1,1), 2*ngw, se, 1 )
CALL DAXPY( i-1, -DBLE( ce(1,i) ), ce(1,1), 2*ngw, se, 1 )
END IF
CALL DGEMV( 'T', 2*ngw, i-1, 2.0d0, ce(1,1), ldw, ce(1,i), 1, 1.d0, se, 1 )
CALL mp_sum( SE, group )
@ -342,7 +342,7 @@
IF(.NOT.TORTHO) THEN
anorm = 0.0d0
do ig = 1, ngw
anorm = anorm + REAL( ce(ig,i) * CONJG(ce(ig,i)) )
anorm = anorm + DBLE( ce(ig,i) * CONJG(ce(ig,i)) )
enddo
CALL mp_sum(anorm,group)
anorm = 1.0d0 / MAX( sqrt(anorm), 1.d-14 )

20
CPV/ensemble_dft.f90
View File

@ -91,11 +91,11 @@ CONTAINS
integer, intent(in) :: nspin
real(dbl) :: f2
entropy=0.0
if ((f.gt.1.0d-20).and.(f.lt.(2.0/float(nspin)-1.0d-20))) then
f2=float(nspin)*f/2.0
if ((f.gt.1.0d-20).and.(f.lt.(2.0/DBLE(nspin)-1.0d-20))) then
f2=DBLE(nspin)*f/2.0
entropy=-f2*log(f2)-(1.-f2)*log(1.-f2)
end if
entropy=-etemp*2.0*entropy/float(nspin)
entropy=-etemp*2.0*entropy/DBLE(nspin)
END SUBROUTINE compute_entropy
@ -108,12 +108,12 @@ CONTAINS
integer :: i
entropy=0.0
do i=1,n
if ((f(i).gt.1.0d-20).and.(f(i).lt.(2.0/float(nspin)-1.0d-20))) then
f2=float(nspin)*f(i)/2.0
if ((f(i).gt.1.0d-20).and.(f(i).lt.(2.0/DBLE(nspin)-1.0d-20))) then
f2=DBLE(nspin)*f(i)/2.0
entropy=entropy-f2*log(f2)-(1.-f2)*log(1.-f2)
end if
end do
entropy=-etemp*2.0*entropy/float(nspin)
entropy=-etemp*2.0*entropy/DBLE(nspin)
return
END SUBROUTINE compute_entropy2
@ -127,17 +127,17 @@ CONTAINS
integer :: i
! calculation of the entropy derivative at x
do i=1,n
if ((fx(i).gt.1.0d-200).and.(fx(i).lt.(2.0/float(nspin)-1.0d-200))) then
ex(i)=(log((2.0/float(nspin)-fx(i))/fx(i)))
if ((fx(i).gt.1.0d-200).and.(fx(i).lt.(2.0/DBLE(nspin)-1.0d-200))) then
ex(i)=(log((2.0/DBLE(nspin)-fx(i))/fx(i)))
else if (fx(i).le.1.0d-200) then
xx=1.0d-200
ex(i)=log(2.0/float(nspin)/xx-1)
ex(i)=log(2.0/DBLE(nspin)/xx-1)
else
! the calculation of ex_i is done using ex_i=-log(mf/(1-f_i)-1)
! instead of ex_i=log(mf/f_i-1)
! to avoid numerical errors
xx=1.0d-200
ex(i)=-log(2.0/float(nspin)/xx-1)
ex(i)=-log(2.0/DBLE(nspin)/xx-1)
end if
end do

42
CPV/exch_corr.f90
View File

@ -8,6 +8,7 @@
!=----------------------------------------------------------------------------=!
MODULE exchange_correlation
!=----------------------------------------------------------------------------=!
#include "f_defs.h"
USE kinds, ONLY: dbl
@ -28,6 +29,7 @@
SUBROUTINE v2gc(v2xc, grho, rhoer, vpot)
USE kinds, ONLY: DP
USE fft
USE fft_base, ONLY: dfftp
USE cell_base, ONLY: tpiba
@ -153,7 +155,7 @@
END DO
END DO
END DO
gcpail(ic) = - REAL(nspin) * stre * omega / REAL(nr1*nr2*nr3)
gcpail(ic) = - DBLE(nspin) * stre * omega / DBLE(nr1*nr2*nr3)
END DO
RETURN
@ -164,8 +166,9 @@
SUBROUTINE stress_xc( dexc, strvxc, sfac, vxc, grho, v2xc, &
gagx_l, tnlcc, rhocp, box)
use ions_base, only: nsp
USE cell_module, only: boxdimensions
USE kinds, ONLY: DP
USE ions_base, ONLY: nsp
USE cell_module, ONLY: boxdimensions
USE cell_base, ONLY: tpiba
USE funct, ONLY: igcx, igcc
USE reciprocal_vectors, ONLY: gstart, g
@ -209,14 +212,14 @@
tex1 = (0.0_dbl , 0.0_dbl)
DO is=1,nsp
IF ( tnlcc(is) ) THEN
tex1 = tex1 + sfac( ig, is ) * CMPLX(rhocp(ig,is))
tex1 = tex1 + sfac( ig, is ) * CMPLX(rhocp(ig,is), 0.d0)
END IF
END DO
tex2 = 0.0_dbl
DO ispin = 1, nspin
tex2 = tex2 + CONJG( vxc(ig, ispin) )
END DO
tex3 = REAL(tex1 * tex2) / SQRT( g( ig ) ) / tpiba
tex3 = DBLE(tex1 * tex2) / SQRT( g( ig ) ) / tpiba
dexc = dexc + tex3 * gagx_l(:,ig)
END DO
dexc = dexc * 2.0_dbl * omega
@ -250,10 +253,10 @@
COMPLEX(dbl) :: rhoetg(:,:)
REAL (dbl) :: grho(:,:,:,:,:)
REAL (dbl) :: vpot(:,:,:,:)
REAL(dbl) :: sxc ! E_xc energy
REAL(dbl) :: vxc ! SUM ( v(r) * rho(r) )
REAL (dbl) :: sxc ! E_xc energy
REAL (dbl) :: vxc ! SUM ( v(r) * rho(r) )
REAL (dbl) :: v2xc(:,:,:,:,:)
REAL(dbl) :: ddot
REAL (dbl) :: ddot
INTEGER :: nspin, nnr, ispin, j, k, i
@ -408,6 +411,7 @@
! calculate the second part of gradient corrected xc potential
! plus the gradient-correction contribution to pressure
!
USE kinds, ONLY: DP
use control_flags, only: iprint, tpre
use reciprocal_vectors, only: gx
use recvecs_indexes, only: np, nm
@ -438,7 +442,7 @@
! second part xc-potential: 3 forward ffts
!
do ir=1,nnr
v(ir)=cmplx(gradr(ir,1,iss),0.0)
v(ir)=CMPLX(gradr(ir,1,iss),0.d0)
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ng
@ -449,17 +453,17 @@
do i=1,3
do j=1,3
do ig=1,ng
vtemp(ig) = omega*ci*conjg(v(np(ig)))* &
vtemp(ig) = omega*ci*CONJG(v(np(ig)))* &
& tpiba*(-rhog(ig,iss)*gx(i,ig)*ainv(j,1)+ &
& gx(1,ig)*drhog(ig,iss,i,j))
end do
dexc(i,j) = real(SUM(vtemp))*2.0
dexc(i,j) = DBLE(SUM(vtemp))*2.0
end do
end do
endif
!
do ir=1,nnr
v(ir)=cmplx(gradr(ir,2,iss),gradr(ir,3,iss))
v(ir)=CMPLX(gradr(ir,2,iss),gradr(ir,3,iss))
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
@ -467,9 +471,9 @@
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
x(ig) = x(ig) + &
& ci*tpiba*gx(2,ig)*0.5*cmplx( real(fp),aimag(fm))
& ci*tpiba*gx(2,ig)*0.5*CMPLX( DBLE(fp),AIMAG(fm))
x(ig) = x(ig) + &
& ci*tpiba*gx(3,ig)*0.5*cmplx(aimag(fp),-real(fm))
& ci*tpiba*gx(3,ig)*0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
!
if(tpre) then
@ -479,14 +483,14 @@
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
vtemp(ig) = omega*ci* &
& (0.5*cmplx(real(fp),-aimag(fm))* &
& (0.5*CMPLX(DBLE(fp),-AIMAG(fm))* &
& tpiba*(-rhog(ig,iss)*gx(i,ig)*ainv(j,2)+ &
& gx(2,ig)*drhog(ig,iss,i,j))+ &
& 0.5*cmplx(aimag(fp),real(fm))*tpiba* &
& 0.5*CMPLX(AIMAG(fp),DBLE(fm))*tpiba* &
& (-rhog(ig,iss)*gx(i,ig)*ainv(j,3)+ &
& gx(3,ig)*drhog(ig,iss,i,j)))
end do
dexc(i,j) = dexc(i,j) + 2.0*real(SUM(vtemp))
dexc(i,j) = dexc(i,j) + 2.0*DBLE(SUM(vtemp))
end do
end do
endif
@ -498,11 +502,11 @@
end do
do ig=1,ng
v(np(ig))=x(ig)
v(nm(ig))=conjg(x(ig))
v(nm(ig))=CONJG(x(ig))
end do
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,iss)=rhor(ir,iss)-real(v(ir))
rhor(ir,iss)=rhor(ir,iss)-DBLE(v(ir))
end do
end do
!

14
CPV/fft.f90
View File

@ -244,7 +244,7 @@
ALLOCATE( psi( SIZE(A,1), SIZE(A,2), SIZE(A,3) ), STAT=ierr)
IF( ierr /= 0 ) call errore(' PFWFFT ', ' allocation of psi failed ' ,0)
psi = CMPLX( A )
psi = CMPLX( A, 0.d0 )
#if defined __PARA
@ -338,9 +338,9 @@
#endif
IF( .NOT. PRESENT( alpha ) ) THEN
c = REAL( psi )
c = DBLE( psi )
ELSE
c = c + alpha * REAL( psi )
c = c + alpha * DBLE( psi )
END IF
DEALLOCATE(psi, STAT=ierr)
@ -770,14 +770,14 @@
CASE ( 1 )
!
do ig = 1, ng
psi( nms( ig ) ) = conjg( c( ig ) )
psi( nms( ig ) ) = CONJG( c( ig ) )
psi( nps( ig ) ) = c( ig )
end do
!
CASE ( 2 )
!
do ig = 1, ng
psi( nms( ig ) ) = conjg( c( ig ) ) + ci * conjg( ca( ig ) )
psi( nms( ig ) ) = CONJG( c( ig ) ) + ci * conjg( ca( ig ) )
psi( nps( ig ) ) = c( ig ) + ci * ca( ig )
end do
@ -793,14 +793,14 @@
CASE ( 11 )
!
do ig = 1, ng
psi( nm( ig ) ) = conjg( c( ig ) )
psi( nm( ig ) ) = CONJG( c( ig ) )
psi( np( ig ) ) = c( ig )
end do
!
CASE ( 12 )
!
do ig = 1, ng
psi( nm( ig ) ) = conjg( c( ig ) ) + ci * conjg( ca( ig ) )
psi( nm( ig ) ) = CONJG( c( ig ) ) + ci * conjg( ca( ig ) )
psi( np( ig ) ) = c( ig ) + ci * ca( ig )
end do
!

12
CPV/forces.f90
View File

@ -73,8 +73,8 @@
DO ig = 1, SIZE(co)
fp = dco(ig) + dce(ig)
fm = dco(ig) - dce(ig)
aro = CMPLX( REAL(fp), AIMAG(fm) )
are = CMPLX( AIMAG(fp),-REAL(fm))
aro = CMPLX( DBLE(fp), AIMAG(fm) )
are = CMPLX( AIMAG(fp), -DBLE(fm))
arg = tpiba2 * hg(ig)
dco(ig) = -fioby2 * (arg * co(ig) + aro)
dce(ig) = -fieby2 * (arg * ce(ig) + are)
@ -90,9 +90,9 @@
SUBROUTINE dforce2(fio, fie, df, da, fnlo, fnle, hg, gx, eigr, wsg, wnl)
! this routine computes:
! the generalized force df=cmplx(dfr,dfi) acting on the i-th
! the generalized force df=CMPLX(dfr,dfi) acting on the i-th
! electron state at the ik-th point of the Brillouin zone
! represented by the vector c=cmplx(cr,ci)
! represented by the vector c=CMPLX(cr,ci)
! ----------------------------------------------
! ... declare modules
@ -174,9 +174,9 @@
SUBROUTINE dforce2_bec( fio, fie, df, da, eigr, beco, bece )
! this routine computes:
! the generalized force df=cmplx(dfr,dfi) acting on the i-th
! the generalized force df=CMPLX(dfr,dfi) acting on the i-th
! electron state at the ik-th point of the Brillouin zone
! represented by the vector c=cmplx(cr,ci)
! represented by the vector c=CMPLX(cr,ci)
! ----------------------------------------------
USE ions_base, ONLY: na

2
CPV/grid.f90
View File

@ -27,7 +27,7 @@
integer, intent(in) :: nproc
integer, intent(out) :: nprow, npcol
integer sqrtnp,i
sqrtnp = INT( SQRT( REAL(nproc) ) + 1 )
sqrtnp = INT( SQRT( DBLE(nproc) ) + 1 )
DO i=1,sqrtnp
IF(MOD(nproc,i).EQ.0) nprow = i
END DO

4
CPV/guess.f90
View File

@ -363,8 +363,8 @@
DO j=1,ngw
jp1 = j + j - 1
jp2 = j + j
tmp(i,jp1) = real(a(j,i))
tmp(i,jp2) = aimag(a(j,i))
tmp(i,jp1) = DBLE(a(j,i))
tmp(i,jp2) = AIMAG(a(j,i))
END DO
END DO

6
CPV/indices.f90
View File

@ -297,9 +297,9 @@
! end of declarations
! ----------------------------------------------
gsq = ( REAL(i)*b1(1) + REAL(j)*b2(1) + REAL(k)*b3(1) ) ** 2
gsq = gsq + ( REAL(i)*b1(2) + REAL(j)*b2(2) + REAL(k)*b3(2) ) ** 2
gsq = gsq + ( REAL(i)*b1(3) + REAL(j)*b2(3) + REAL(k)*b3(3) ) ** 2
gsq = ( DBLE(i)*b1(1) + DBLE(j)*b2(1) + DBLE(k)*b3(1) ) ** 2
gsq = gsq + ( DBLE(i)*b1(2) + DBLE(j)*b2(2) + DBLE(k)*b3(2) ) ** 2
gsq = gsq + ( DBLE(i)*b1(3) + DBLE(j)*b2(3) + DBLE(k)*b3(3) ) ** 2
miller2gsq = gsq

2
CPV/ions.f90
View File

@ -284,7 +284,7 @@
CALL s_to_r(sdist, rdist, ht)
r2 = r2 + SUM( ( rdist(:) - tau_ref(:,isa) )**2 )
END DO
dis(k) = dis(k) + r2 / REAL(atoms%na(k))
dis(k) = dis(k) + r2 / DBLE(atoms%na(k))
END DO
RETURN

4
CPV/ksstates.f90
View File

@ -604,7 +604,7 @@
zcomp( izl : ( izl + nr3_l - 1 ) ) = psi2( i, j, 1 : nr3_l )
CALL mp_sum( zcomp(1:nr3_g) )
IF ( ionode ) THEN
rcomp2 = REAL(zcomp)**2
rcomp2 = DBLE(zcomp)**2
WRITE(ksunit, fmt='(F10.5)') ( rcomp2(k), k=1, nr3_g )
charge = charge + SUM(rcomp2)
END IF
@ -615,7 +615,7 @@
IF ( ionode ) THEN
CLOSE(ksunit)
WRITE( stdout,'(3X,A15," integrated charge : ",F14.5)') &
& file_name(1:istr), charge / REAL(nr1_g*nr2_g*nr3_g)
& file_name(1:istr), charge / DBLE(nr1_g*nr2_g*nr3_g)
END IF
DEALLOCATE(zcomp, rcomp2, psi2)
! ...

6
CPV/miller.f90
View File

@ -31,9 +31,9 @@
! end of declarations
! ----------------------------------------------
gsq = ( REAL(i)*b1(1) + REAL(j)*b2(1) + REAL(k)*b3(1) ) ** 2
gsq = gsq + ( REAL(i)*b1(2) + REAL(j)*b2(2) + REAL(k)*b3(2) ) ** 2
gsq = gsq + ( REAL(i)*b1(3) + REAL(j)*b2(3) + REAL(k)*b3(3) ) ** 2
gsq = ( DBLE(i)*b1(1) + DBLE(j)*b2(1) + DBLE(k)*b3(1) ) ** 2
gsq = gsq + ( DBLE(i)*b1(2) + DBLE(j)*b2(2) + DBLE(k)*b3(2) ) ** 2
gsq = gsq + ( DBLE(i)*b1(3) + DBLE(j)*b2(3) + DBLE(k)*b3(3) ) ** 2
miller2gsqr = gsq

2
CPV/nl.f90
View File

@ -301,7 +301,7 @@
ELSE
DO ia = 1, atoms%na(is)
isa = isa+1
tt = REAL( CONJG( dfnl%c(isa,igh,ib) ) * fnl(ik)%c(isa,igh,ib) )
tt = DBLE( CONJG( dfnl%c(isa,igh,ib) ) * fnl(ik)%c(isa,igh,ib) )
atoms%for(k,isa) = atoms%for(k,isa) - tt * temp
END DO
END IF

38
CPV/nl_base.f90
View File

@ -76,7 +76,7 @@
ELSE
DO ia = 1, na(is)
tt = fnl%c(isa+ia,igh,ib)
fsum = fsum + REAL( CONJG(tt) * tt )
fsum = fsum + DBLE( CONJG(tt) * tt )
END DO
END IF
enl = enl + fi(ib) * wsg(igh, is) * fsum
@ -109,7 +109,7 @@
! input : beta(ig,l,is), eigr, c
! output: becp as parameter
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE mp, ONLY : mp_sum
USE mp_global, ONLY : nproc
USE ions_base, only : na, nax, nat
@ -173,18 +173,16 @@
! q = 0 component (with weight 1.0)
!
if (gstart == 2) then
wrk2(1,ia)= cmplx( &
& signre*beta(1,iv,is)*eigr(ixr,1,ia+isa), &
& signim*beta(1,iv,is)*eigr(ixi,1,ia+isa) )
wrk2(1,ia)= &
CMPLX(signre*beta(1,iv,is)*eigr(ixr,1,ia+isa),signim*beta(1,iv,is)*eigr(ixi,1,ia+isa) )
end if
!
! q > 0 components (with weight 2.0)
!
do ig = gstart, ngw
arg = 2.0*beta(ig,iv,is)
wrk2(ig,ia) = cmplx( &
& signre*arg*eigr(ixr,ig,ia+isa), &
& signim*arg*eigr(ixi,ig,ia+isa) )
wrk2(ig,ia) = &
CMPLX(signre*arg*eigr(ixr,ig,ia+isa),signim*arg*eigr(ixi,ig,ia+isa) )
end do
!
end do
@ -229,7 +227,7 @@
! output: becdr
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
use ions_base, only : nax, nsp, na, nat
use uspp, only : nhtol, beta !, nkb
use cvan, only : ish
@ -297,16 +295,14 @@
do ia=1,na(is)
if (gstart == 2) then
! q = 0 component (with weight 1.0)
wrk2(1,ia) = cmplx ( &
& signre*gk(1)*beta(1,iv,is)*eigr(ixr,1,ia+isa), &
& signim*gk(1)*beta(1,iv,is)*eigr(ixi,1,ia+isa) )
wrk2(1,ia) = &
CMPLX (signre*gk(1)*beta(1,iv,is)*eigr(ixr,1,ia+isa),signim*gk(1)*beta(1,iv,is)*eigr(ixi,1,ia+isa) )
! q > 0 components (with weight 2.0)
end if
do ig=gstart,ngw
arg = 2.0*gk(ig)*beta(ig,iv,is)
wrk2(ig,ia) = cmplx ( &
& signre*arg*eigr(ixr,ig,ia+isa), &
& signim*arg*eigr(ixi,ig,ia+isa) )
wrk2(ig,ia) = &
CMPLX (signre*arg*eigr(ixr,ig,ia+isa),signim*arg*eigr(ixi,ig,ia+isa) )
end do
end do
inl=ish(is)+(iv-1)*na(is)+1
@ -537,7 +533,7 @@ SUBROUTINE caldbec( ngw, nkb, n, nspmn, nspmx, eigr, c, dbec, tred )
!
! routine makes use of c(-g)=c*(g) and beta(-g)=beta*(g)
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
use mp, only : mp_sum
use mp_global, only : nproc
use ions_base, only : na, nax, nat
@ -600,16 +596,14 @@ SUBROUTINE caldbec( ngw, nkb, n, nspmn, nspmx, eigr, c, dbec, tred )
do ia=1,na(is)
if (gstart == 2) then
! q = 0 component (with weight 1.0)
wrk2(1,ia)= cmplx( &
& signre*dbeta(1,iv,is,i,j)*eigr(ixr,1,ia+isa), &
& signim*dbeta(1,iv,is,i,j)*eigr(ixi,1,ia+isa) )
wrk2(1,ia)= &
CMPLX(signre*dbeta(1,iv,is,i,j)*eigr(ixr,1,ia+isa),signim*dbeta(1,iv,is,i,j)*eigr(ixi,1,ia+isa) )
end if
! q > 0 components (with weight 2.0)
do ig = gstart, ngw
arg = 2.0*dbeta(ig,iv,is,i,j)
wrk2(ig,ia) = cmplx( &
& signre*arg*eigr(ixr,ig,ia+isa), &
& signim*arg*eigr(ixi,ig,ia+isa) )
wrk2(ig,ia) = &
CMPLX(signre*arg*eigr(ixr,ig,ia+isa),signim*arg*eigr(ixi,ig,ia+isa) )
end do
end do
inl=ish(is)+(iv-1)*na(is)+1

29
CPV/nlcc.f90
View File

@ -105,7 +105,7 @@
!=----------------------------------------------------------------------------=!
subroutine add_core_charge( rhoetg, rhoetr, sfac, rhoc, nsp)
!=----------------------------------------------------------------------------=!
USE kinds, ONLY: DP
USE fft, ONLY: pinvfft
use electrons_base, only: nspin
use gvecp, only: ngm
@ -124,7 +124,7 @@
integer :: is, ig
ALLOCATE( vtemp( ngm ) )
vtemp = CMPLX( 0.0d0 )
vtemp = CMPLX( 0.0d0, 0.0d0 )
fac = 1.0d0 / DBLE( nspin )
DO is = 1, nsp
@ -155,7 +155,7 @@
! This subroutine computes the non local core correction
! contribution to the atomic forces
USE constants
USE kinds, ONLY : DP
USE cell_base, ONLY: tpiba
USE cell_module, ONLY: boxdimensions
USE brillouin, ONLY: kpoints, kp
@ -226,9 +226,9 @@
END IF
DO isa = 1, atoms%nat
FION(1,ISA) = FION(1,ISA) + REAL(ftmp(1,ISA)) * cost
FION(2,ISA) = FION(2,ISA) + REAL(ftmp(2,ISA)) * cost
FION(3,ISA) = FION(3,ISA) + REAL(ftmp(3,ISA)) * cost
FION(1,ISA) = FION(1,ISA) + DBLE(ftmp(1,ISA)) * cost
FION(2,ISA) = FION(2,ISA) + DBLE(ftmp(2,ISA)) * cost
FION(3,ISA) = FION(3,ISA) + DBLE(ftmp(3,ISA)) * cost
END DO
DEALLOCATE( ftmp )
@ -317,6 +317,7 @@
! same logic as in newd - uses box grid. For parallel execution:
! the sum over node contributions is done in the calling routine
!
USE kinds, ONLY: DP
use core, only: rhocb
use electrons_base, only: nspin
use gvecb, only: gxb, ngb, npb, nmb
@ -374,17 +375,17 @@
qv(:) = (0.d0, 0.d0)
if (nfft.eq.2) then
do ig=1,ngb
facg = tpibab*cmplx(0.d0,gxb(ix,ig))*rhocb(ig,is)
facg = tpibab*CMPLX(0.d0,gxb(ix,ig))*rhocb(ig,is)
qv(npb(ig)) = eigrb(ig,ia+isa )*facg &
& + ci * eigrb(ig,ia+isa+1)*facg
qv(nmb(ig)) = conjg(eigrb(ig,ia+isa )*facg) &
& + ci * conjg(eigrb(ig,ia+isa+1)*facg)
qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa )*facg) &
& + ci * CONJG(eigrb(ig,ia+isa+1)*facg)
end do
else
do ig=1,ngb
facg = tpibab*cmplx(0.d0,gxb(ix,ig))*rhocb(ig,is)
facg = tpibab*CMPLX(0.d0,gxb(ix,ig))*rhocb(ig,is)
qv(npb(ig)) = eigrb(ig,ia+isa)*facg
qv(nmb(ig)) = conjg(eigrb(ig,ia+isa)*facg)
qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa)*facg)
end do
end if
!
@ -476,13 +477,13 @@
do ig=1,ngb
qv(npb(ig))= eigrb(ig,ia +isa)*rhocb(ig,is) &
& + ci*eigrb(ig,ia+1+isa)*rhocb(ig,is)
qv(nmb(ig))= conjg(eigrb(ig,ia +isa)*rhocb(ig,is)) &
& + ci*conjg(eigrb(ig,ia+1+isa)*rhocb(ig,is))
qv(nmb(ig))= CONJG(eigrb(ig,ia +isa)*rhocb(ig,is)) &
& + ci*CONJG(eigrb(ig,ia+1+isa)*rhocb(ig,is))
end do
else
do ig=1,ngb
qv(npb(ig)) = eigrb(ig,ia+isa)*rhocb(ig,is)
qv(nmb(ig)) = conjg(eigrb(ig,ia+isa)*rhocb(ig,is))
qv(nmb(ig)) = CONJG(eigrb(ig,ia+isa)*rhocb(ig,is))
end do
endif
!

7
CPV/optical.f90
View File

@ -5,6 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
MODULE optical_properties
USE kinds
@ -41,7 +42,7 @@
END IF
nfreq = noptical
maxdie = woptical / au
ddie = maxdie / REAL(nfreq)
ddie = maxdie / DBLE(nfreq)
temperature = boptical
ALLOCATE( dielec_total(nfreq), sigma_total(nfreq), n_total(nfreq) )
dielec_total = 0.0d0
@ -378,7 +379,7 @@
WRITE( dielecunit, 30 ) nfi, tm
DO I = 1, SIZE(dielec_total)
w = (REAL(i)-0.5d0) * ddie
w = (DBLE(i)-0.5d0) * ddie
! WRITE(dielecunit,100) &
! w * au, dielec_total(i) / w / w, sigma_total(i) * au_to_ohmcmm1 / w, n_total(i)
WRITE(dielecunit,100) &
@ -397,7 +398,7 @@
WRITE( stdout,40)
WRITE( stdout,50)
DO I = 1, SIZE(dielec_total)
w = (REAL(i)-0.5d0) * ddie
w = (DBLE(i)-0.5d0) * ddie
! WRITE( stdout,110) w * au, sigma_total(i) * au_to_ohmcmm1 / w, n_total(i)
WRITE( stdout,110) w * au, sigma_total(i) * au_to_ohmcmm1 / ddie, n_total(i)
END DO

4
CPV/ortho.f90
View File

@ -834,8 +834,8 @@
DO I=1,N
X1(I,J) = SIG(I,J) - BLAM(I,J) - CLAM(I,J)
X1(I,J) = X1(I,J) / ( RHOD(I)+RHOD(J) ) ! +SIGD(I)+SIGD(J))
difgam=max(abs(REAL(X1(I,J))-REAL(X0(I,J))),difgam)
difgam=max(abs(aimag(X1(I,J))-aimag(X0(I,J))),difgam)
difgam=max(abs( DBLE(X1(I,J))- DBLE(X0(I,J))),difgam)
difgam=max(abs(AIMAG(X1(I,J))-AIMAG(X0(I,J))),difgam)
ENDDO
ENDDO

8
CPV/ortho_base.f90
View File

@ -234,14 +234,14 @@
! DO i = 1, nb
! DO j = 1, nb
! DO k = 1, ngw
! sig(i,j) = - 2.0d0 * ( REAL(cp(k,i))*REAL(cp(k,j))+AIMAG(cp(k,i))*AIMAG(cp(k,j)) )
! sig(i,j) = - 2.0d0 * ( DBLE(cp(k,i))*DBLE(cp(k,j))+AIMAG(cp(k,i))*AIMAG(cp(k,j)) )
! END DO
! END DO
! END DO
CALL DGEMM('T','N', n, n, twongw, -2.0d0, cp(1,1), ldc, cp(1,1), ldc, zero, sig(1,1), lds)
DO i = 1, n
sig(i,i) = sig(i,i) + one / REAL(nproc)
sig(i,i) = sig(i,i) + one / DBLE(nproc)
END DO
! WRITE( stdout,*) ' SIGSET 2 ', SUM(sig) ! DEBUG
@ -287,7 +287,7 @@
CALL ZGEMM('C','N',NX,NX,NGW,mcone,CP(1,1),ldc,CP(1,1),ldc,czero,sig(1,1),lds)
DO i = 1, nx
sig(i,i) = sig(i,i) + cone / REAL(nproc)
sig(i,i) = sig(i,i) + cone / DBLE(nproc)
END DO
#if defined __SHMEM
@ -482,7 +482,7 @@
c0ji = c0(j,i)
c0ji = c0ji * ebpmss(j)
c0(j,i) = c0ji
ctmp(i,jp1) = REAL(c0ji)
ctmp(i,jp1) = DBLE(c0ji)
ctmp(i,jp2) = AIMAG(c0ji)
ENDDO
ENDDO

12
CPV/para.f90
View File

@ -490,14 +490,14 @@ end module para_mod
! the center of mass of the system is moved
shift(1) = 0.5d0*l1 - cm(1)
tp(1) = nint(shift(1)*dfloat(nr1)/ll1)
shift(1) = 0.d0 !dfloat(tp(1))*ll1/dfloat(nr1)
tp(1) = nint(shift(1)*DBLE(nr1)/ll1)
shift(1) = 0.d0 !DBLE(tp(1))*ll1/DBLE(nr1)
shift(2) = 0.5d0*l2 - cm(2)
tp(2) = nint(shift(2)*dfloat(nr2)/ll2)
shift(2) = 0.d0 !dfloat(tp(2))*ll2/dfloat(nr2)
tp(2) = nint(shift(2)*DBLE(nr2)/ll2)
shift(2) = 0.d0 !DBLE(tp(2))*ll2/DBLE(nr2)
shift(3) = 0.5d0*l3 - cm(3)
tp(3) = nint(shift(3)*dfloat(nr3)/ll3)
shift(3) = 0.d0 !dfloat(tp(3))*ll3/dfloat(nr3)
tp(3) = nint(shift(3)*DBLE(nr3)/ll3)
shift(3) = 0.d0 !DBLE(tp(3))*ll3/DBLE(nr3)
#ifdef __PARA
! in parallel execution, only the first nodes writes

4
CPV/phasefactor.f90
View File

@ -60,7 +60,7 @@
! END manual
USE kinds, ONLY: dbl
USE kinds, ONLY: dbl, DP
USE constants, ONLY: tpi
! ... declare subroutine arguments
@ -178,7 +178,7 @@
! ----------------------------------------------
! END manual
USE kinds, ONLY: dbl
USE kinds, ONLY: dbl, DP
USE ions_base, ONLY: nat, na, nsp
use grid_dimensions, only: nr1, nr2, nr3

6
CPV/polarization.f90
View File

@ -194,7 +194,7 @@
CALL ZGEFA(DUMM,NX,N,IPIV,INFO)
CALL ZGEDI(DUMM,NX,N,IPIV,DETC,AUX,10)
DET=DETC(1)*10.D0**DETC(2)
D1=DATAN2(AIMAG(DET),REAL(DET))
D1=DATAN2(AIMAG(DET),DBLE(DET))
IF(.NOT.FIRST) THEN
IF(ABS(D1-D1OLD).GT.PI) THEN
D1 = D1 - SIGN(2*PI,D1-D1OLD)
@ -239,7 +239,7 @@
CALL ZGEFA(DUMM,NX,N,IPIV,INFO)
CALL ZGEDI(DUMM,NX,N,IPIV,DETC,AUX,10)
DET=DETC(1)*10.D0**DETC(2)
D2=DATAN2(AIMAG(DET),REAL(DET))
D2=DATAN2(AIMAG(DET),DBLE(DET))
IF(.NOT.FIRST) THEN
IF(ABS(D2-D2OLD).GT.PI) THEN
D2 = D2 - SIGN(2*PI,D2-D2OLD)
@ -277,7 +277,7 @@
CALL ZGEFA(DUMM,NX,N,IPIV,INFO)
CALL ZGEDI(DUMM,NX,N,IPIV,DETC,AUX,10)
DET=DETC(1)*10.D0**DETC(2)
D3=DATAN2(AIMAG(DET),REAL(DET))
D3=DATAN2(AIMAG(DET),DBLE(DET))
IF(.NOT.FIRST) THEN
IF(ABS(D3-D3OLD).GT.PI) THEN
D3 = D3 - SIGN(2*PI,D3-D3OLD)

60
CPV/potentials.f90
View File

@ -157,7 +157,7 @@
(gx(ipiano2,IG).EQ.0.d0))THEN
vcg = fpi_tpiba2 * (rhoeg(ig) + rp) / g(ig)
gxt = gx(iasse, ig) * tpiba
vrmean(ir) = vrmean(ir) + REAL(vcg) * COS(gxt*r)
vrmean(ir) = vrmean(ir) + DBLE(vcg) * COS(gxt*r)
vrmean(ir) = vrmean(ir) - AIMAG(vcg) * SIN(gxt*r)
END IF
END DO
@ -509,7 +509,7 @@
IF( ionode ) THEN
write(stdout,*)
write(stdout,*) ' KIND of SELF_INTERACTION CHOOSEN == ', self_interaction
write(stdout,*) ' EXC before SIC corr == ', sxcp * omega / REAL( nr1_g * nr2_g * nr3_g )
write(stdout,*) ' EXC before SIC corr == ', sxcp * omega / DBLE( nr1_g * nr2_g * nr3_g )
write(stdout,*)
END IF
END IF
@ -551,8 +551,8 @@
edft%sxc = sxcp + self_sxcp !- self_sxcp
vxc = vxc - self_vxc
edft%self_sxc = self_sxcp * omega / REAL(nr1_g*nr2_g*nr3_g)
self_vxc = self_vxc * omega / REAL(nr1_g*nr2_g*nr3_g)
edft%self_sxc = self_sxcp * omega / DBLE(nr1_g*nr2_g*nr3_g)
self_vxc = self_vxc * omega / DBLE(nr1_g*nr2_g*nr3_g)
CASE(2)
@ -586,8 +586,8 @@
edft%self_sxc= sxcp - self_sxcp
edft%sxc = self_sxcp !!sxcp - edft%self_sxc
vxc = self_vxc
edft%self_sxc = edft%self_sxc * omega / REAL(nr1_g*nr2_g*nr3_g)
self_vxc = self_vxc * omega / REAL(nr1_g*nr2_g*nr3_g)
edft%self_sxc = edft%self_sxc * omega / DBLE(nr1_g*nr2_g*nr3_g)
self_vxc = self_vxc * omega / DBLE(nr1_g*nr2_g*nr3_g)
END SELECT
@ -597,14 +597,14 @@
IF( ttsic ) THEN
write(stdout,*) ' Exchange-correlation Energy introducing the SIC'
write(stdout,*) ' -----------------------------------------------'
write(stdout,*) ' SXCP from first call :: ', sxcp * omega / REAL( nr1_g * nr2_g * nr3_g )
write(stdout,*) ' SXC after SIC-correction :: ', edft%sxc * omega / REAL( nr1_g * nr2_g * nr3_g )
write(stdout,*) ' SXCP from first call :: ', sxcp * omega / DBLE( nr1_g * nr2_g * nr3_g )
write(stdout,*) ' SXC after SIC-correction :: ', edft%sxc * omega / DBLE( nr1_g * nr2_g * nr3_g )
write(stdout,*) ' D_SIC SIC correction :: ', edft%self_sxc
write(stdout,*) ' -----------------------------------------------'
END IF
IF ( ttstress ) THEN
strvxc = ( edft%sxc - vxc ) * omega / REAL( nr1_g * nr2_g * nr3_g )
strvxc = ( edft%sxc - vxc ) * omega / DBLE( nr1_g * nr2_g * nr3_g )
END IF
IF( nlcc_any ) THEN
@ -639,7 +639,7 @@
!
! WRITE(6,*) 'DEBUG vofloc = ', SUM(fion)
! edft%ehte = REAL ( ehtep )
! edft%ehte = DBLE ( ehtep )
edft%self_ehte = 0.d0
@ -662,7 +662,7 @@
CALL pinvfft(self_vpot(:,:,:,1), self_vloc(:))
self_vpot(:,:,:,1) = si_epsilon * self_vpot(:,:,:,1)
edft%self_ehte = si_epsilon * REAL(self_ehtep)
edft%self_ehte = si_epsilon * DBLE(self_ehtep)
vpot(:,:,:,1) = vpot(:,:,:,1) - self_vpot(:,:,:,1)
vpot(:,:,:,2) = vpot(:,:,:,2) + self_vpot(:,:,:,1)
@ -671,15 +671,15 @@
END IF
edft%eh = REAL( ehp ) - edft%self_ehte
edft%eh = DBLE( ehp ) - edft%self_ehte
IF ( ttsic ) THEN
IF ( ionode ) THEN
write(stdout,*) ' Hartree Energy Contribution when SIC is introduced'
write(stdout,*) ' --------------------------------------------------'
write(stdout,*) ' HARTREE Potential == ' , REAL( edft%eh )
write(stdout,*) ' EH(rhoup+rhodwn) == ' , REAL( ehp )
write(stdout,*) ' EH(rhoup-rhodwn) == ' , REAL( edft%self_ehte )
write(stdout,*) ' HARTREE Potential == ' , DBLE( edft%eh )
write(stdout,*) ' EH(rhoup+rhodwn) == ' , DBLE( ehp )
write(stdout,*) ' EH(rhoup-rhodwn) == ' , DBLE( edft%self_ehte )
write(stdout,*) ' --------------------------------------------------'
END IF
END IF
@ -886,11 +886,11 @@
IF( MOD(nr1_g * nr2_g * nr3_g, 2) /= 0 ) fact = -fact
DO k = 1, nr3_l
s(3) = REAL ( (k-1) + (ir3 - 1) ) / nr3_g - 0.5d0
s(3) = DBLE ( (k-1) + (ir3 - 1) ) / nr3_g - 0.5d0
DO j = 1, nr2_l
s(2) = REAL ( (j-1) + (ir2 - 1) ) / nr2_g - 0.5d0
s(2) = DBLE ( (j-1) + (ir2 - 1) ) / nr2_g - 0.5d0
DO i = 1, nr1_l
s(1) = REAL ( (i-1) + (ir1 - 1) ) / nr1_g - 0.5d0
s(1) = DBLE ( (i-1) + (ir1 - 1) ) / nr1_g - 0.5d0
CALL S_TO_R(S, R, box)
rmod = SQRT( r(1)**2 + r(2)**2 + r(3)**2 )
IF( rmod < gsmall ) THEN
@ -935,7 +935,7 @@
! vloc_h(ig) = fpi / ( g(ig) * tpiba2 ) * { rho_e(ig) + rho_I(ig) }
! vloc_ps(ig) = (sum over is) sfac(is,ig) * vps(ig,is)
!
! Eps = Fact * omega * (sum over ig) CMPLX( rho_e(ig) ) * vloc_ps(ig)
! Eps = Fact * omega * (sum over ig) cmplx ( rho_e(ig) ) * vloc_ps(ig)
! if Gamma symmetry Fact = 2 else Fact = 1
!
! Eh = Fact * omega * (sum over ig) * fpi / ( g(ig) * tpiba2 ) *
@ -1058,8 +1058,8 @@
vloc(ig) = vp + fpibg * rhog
eh = eh + fpibg * rhog * CONJG(rhog)
eps = eps + vp * CONJG(rhet)
ehte = ehte + fpibg * REAL(rhet * CONJG(rhet))
ehti = ehti + fpibg * REAL( rp * CONJG(rp))
ehte = ehte + fpibg * DBLE(rhet * CONJG(rhet))
ehti = ehti + fpibg * DBLE( rp * CONJG(rp))
IF(TTFORCE) THEN
ig1 = mill_l(1,IG)
@ -1094,7 +1094,7 @@
ELSE
cost = ht%deth * tpiba
END IF
FION = FION + REAL(ftmp) * cost
FION = FION + DBLE(ftmp) * cost
END IF
! ... G = 0 element
@ -1114,8 +1114,8 @@
rhog = rhet + rp
vloc(1) = VP + vscreen * rhog
eh = eh + vscreen * rhog * CONJG(rhog)
ehte = ehte + vscreen * REAL(rhet * CONJG(rhet))
ehti = ehti + vscreen * REAL( rp * CONJG(rp))
ehte = ehte + vscreen * DBLE(rhet * CONJG(rhet))
ehti = ehti + vscreen * DBLE( rp * CONJG(rp))
DO ispin = 1, nspin
IF( gamma_only ) THEN
eps = eps + vp * CONJG(RHOEG(1,ispin)) * 0.5d0
@ -1290,13 +1290,13 @@
END IF
DO IX=-IESR,IESR
SXLM(1) = XLM + REAL(IX)
SXLM(1) = XLM + DBLE(IX)
DO IY=-IESR,IESR
SXLM(2) = YLM + REAL(IY)
SXLM(2) = YLM + DBLE(IY)
DO IZ=-IESR,IESR
TSHIFT= IX.EQ.0 .AND. IY.EQ.0 .AND. IZ.EQ.0
IF(.NOT.(TZERO.AND.TSHIFT)) THEN
SXLM(3) = ZLM + REAL(IZ)
SXLM(3) = ZLM + DBLE(IZ)
CALL S_TO_R(SXLM,RXLM,ht)
ERRE2 = RXLM(1)**2 + RXLM(2)**2 + RXLM(3)**2
RLM = SQRT(ERRE2)
@ -1516,7 +1516,7 @@
ALLOCATE( k_density( ngm ) )
CALL pw_invfft( cpsi(:,:,:), wfc(:), wfc(:) )
psi = REAL( cpsi, dbl )
psi = DBLE( cpsi )
DEALLOCATE( cpsi )
isa_sorted = 0
@ -1584,7 +1584,7 @@
FPIBG = fpi / ( g(ig) * tpiba2 )
END IF
ehte = ehte + fpibg * REAL(rhog * CONJG(rhog))
ehte = ehte + fpibg * DBLE(rhog * CONJG(rhog))
END DO
@ -1597,7 +1597,7 @@
vscreen = 0.0d0
END IF
rhog = k_density(1)
ehte = ehte + vscreen * REAL(rhog * CONJG(rhog))
ehte = ehte + vscreen * DBLE(rhog * CONJG(rhog))
END IF
! ...
IF( .NOT. gamma_only ) THEN

6
CPV/print_out.f90
View File

@ -549,7 +549,7 @@
END IF
IF ( texit ) THEN
IF( index > 0 ) timeav = timesum / REAL( MAX( index, 1 ) )
IF( index > 0 ) timeav = timesum / DBLE( MAX( index, 1 ) )
IF (ionode) THEN
WRITE( stdout,*)
WRITE( stdout, fmt='(3X,"Execution time statistics (SEC)")')
@ -669,8 +669,8 @@
CALL printrho(nfi, rhoe, desc, atoms, ht)
END IF
avgs = avgs / REAL( nfi )
avgs_run = avgs_run / REAL( nstep_run )
avgs = avgs / DBLE( nfi )
avgs_run = avgs_run / DBLE( nstep_run )
IF( ionode ) THEN
WRITE( stdout,1949)

24
CPV/pseudopot.f90
View File

@ -339,10 +339,10 @@ CONTAINS
xgmax = tpiba * SQRT( MAXVAL( g ) )
CALL mp_max(xgmax, group)
xgmax = xgmax + (xgmax-xgmin)
dxg = (xgmax - xgmin) / REAL(nval-1)
dxg = (xgmax - xgmin) / DBLE(nval-1)
!
DO ig = 1, SIZE( xgtab )
xgtab(ig) = xgmin + REAL(ig-1) * dxg
xgtab(ig) = xgmin + DBLE(ig-1) * dxg
END DO
!
xgtabmax = xgtab( SIZE( xgtab ) )
@ -1014,7 +1014,7 @@ CONTAINS
do ig = 1, ngw
gg = g( ig ) * tpiba * tpiba / refg
jj = int( gg ) + 1
betagl = betagx( jj+1, iv, is ) * ( gg - real(jj-1) ) + betagx( jj, iv, is ) * ( real(jj) - gg )
betagl = betagx( jj+1, iv, is ) * ( gg - DBLE(jj-1) ) + betagx( jj, iv, is ) * ( DBLE(jj) - gg )
beta( ig, iv, is ) = c * ylm( ig, lp ) * betagl
end do
end do
@ -1043,10 +1043,10 @@ CONTAINS
do ig=gstart,ngw
gg=g(ig)*tpiba*tpiba/refg
jj=int(gg)+1
betagl = betagx(jj+1,iv,is)*(gg-real(jj-1)) + &
& betagx(jj,iv,is)*(real(jj)-gg)
dbetagl= dbetagx(jj+1,iv,is)*(gg-real(jj-1)) + &
& dbetagx(jj,iv,is)*(real(jj)-gg)
betagl = betagx(jj+1,iv,is)*(gg-DBLE(jj-1)) + &
& betagx(jj,iv,is)*(DBLE(jj)-gg)
dbetagl= dbetagx(jj+1,iv,is)*(gg-DBLE(jj-1)) + &
& dbetagx(jj,iv,is)*(DBLE(jj)-gg)
do i=1,3
do j=1,3
dbeta(ig,iv,is,i,j)= &
@ -1135,8 +1135,8 @@ CONTAINS
qradb(ig,jv,iv,l,is)=qradb(ig,iv,jv,l,is)
else
qradb(ig,iv,jv,l,is)= &
& c*qradx(jj+1,iv,jv,l,is)*(gg-real(jj-1))+ &
& c*qradx(jj,iv,jv,l,is)*(real(jj)-gg)
& c*qradx(jj+1,iv,jv,l,is)*(gg-DBLE(jj-1))+ &
& c*qradx(jj,iv,jv,l,is)*(DBLE(jj)-gg)
qradb(ig,jv,iv,l,is)=qradb(ig,iv,jv,l,is)
endif
enddo
@ -1158,7 +1158,7 @@ CONTAINS
ijv=ijv+1
call qvan2b(ngb,iv,jv,is,ylmb,qgb(1,ijv,is) )
!
qq(iv,jv,is)=omegab*real(qgb(1,ijv,is))
qq(iv,jv,is)=omegab*DBLE(qgb(1,ijv,is))
qq(jv,iv,is)=qq(iv,jv,is)
!
end do
@ -1189,8 +1189,8 @@ CONTAINS
dqradb(ig,iv,jv,l,is) = 0.
else
dqradb(ig,iv,jv,l,is) = &
& dqradx(jj+1,iv,jv,l,is)*(gg-real(jj-1))+ &
& dqradx(jj,iv,jv,l,is)*(real(jj)-gg)
& dqradx(jj+1,iv,jv,l,is)*(gg-DBLE(jj-1))+ &
& dqradx(jj,iv,jv,l,is)*(DBLE(jj)-gg)
endif
enddo
do i=1,3

6
CPV/qmatrixd.f90
View File

@ -86,7 +86,7 @@ subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq)
do ig=1,ngw
if(ctable(ig,1).ne.(ngw+1))then
if(ctable(ig,1).ge.0) then
sca=sca+conjg(c0(ctable(ig,1),ix))*c0(ig,jx)
sca=sca+CONJG(c0(ctable(ig,1),ix))*c0(ig,jx)
endif
endif
enddo
@ -109,7 +109,7 @@ subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq)
do ig=ng0,ngw
if(ctable(ig,2).ne.(ngw+1)) then
if(ctable(ig,2).lt.0) then
sca=sca+c0(-ctable(ig,2),ix)*conjg(c0(ig,jx))
sca=sca+c0(-ctable(ig,2),ix)*CONJG(c0(ig,jx))
endif
endif
enddo
@ -119,7 +119,7 @@ subroutine qmatrixd(c0, bec0,ctable, gqq, qmat, detq)
do ig=ng0,ngw
if(ctable(ig,2).ne.(ngw+1)) then
if(ctable(ig,2).ge.0) then
sca=sca+conjg(c0(ctable(ig,2),ix))*conjg(c0(ig,jx))
sca=sca+CONJG(c0(ctable(ig,2),ix))*conjg(c0(ig,jx))
endif
endif
enddo

12
CPV/qqberry.f90
View File

@ -189,13 +189,13 @@ subroutine qqberry2( gqq,gqqm, ipol)
do ia=1,na(is)
! gqq(iv,jv,ia,is)=qgbs*eigr(igi,ia,is)!ATTENZIONE era cosi'
! gqq(jv,iv,ia,is)=qgbs*eigr(igi,ia,is)
! gqqm(iv,jv,ia,is)=conjg(gqq(iv,jv,ia,is))
! gqqm(jv,iv,ia,is)=conjg(gqq(iv,jv,ia,is))
! gqqm(iv,jv,ia,is)=CONJG(gqq(iv,jv,ia,is))
! gqqm(jv,iv,ia,is)=CONJG(gqq(iv,jv,ia,is))
gqqm(iv,jv,ia,is)=qgbs
gqqm(jv,iv,ia,is)=qgbs
gqq(iv,jv,ia,is)=conjg(gqqm(iv,jv,ia,is))
gqq(jv,iv,ia,is)=conjg(gqqm(iv,jv,ia,is))
gqq(iv,jv,ia,is)=CONJG(gqqm(iv,jv,ia,is))
gqq(jv,iv,ia,is)=CONJG(gqqm(iv,jv,ia,is))
end do
end do
enddo
@ -281,8 +281,8 @@ subroutine qqupdate(eigr, gqqm0, gqq, gqqm, ipol)
do jv=iv,nh(is)
gqqm(iv,jv,ia,is)= gqqm0(iv,jv,ia,is)*eigr(igi,isa)
gqqm(jv,iv,ia,is)= gqqm0(iv,jv,ia,is)*eigr(igi,isa)
gqq(iv,jv,ia,is)=conjg(gqqm(iv,jv,ia,is))
gqq(jv,iv,ia,is)=conjg(gqqm(iv,jv,ia,is))
gqq(iv,jv,ia,is)=CONJG(gqqm(iv,jv,ia,is))
gqq(jv,iv,ia,is)=CONJG(gqqm(iv,jv,ia,is))
enddo
enddo
isa = isa + 1

6
CPV/read_pseudo.f90
View File

@ -162,7 +162,7 @@ REAL(dbl) FUNCTION calculate_dx( a, m )
n = MIN( SIZE( a ), m )
ra = a(1)
rb = a(n)
calculate_dx = LOG( rb / ra ) / REAL( n - 1 )
calculate_dx = LOG( rb / ra ) / DBLE( n - 1 )
RETURN
END FUNCTION calculate_dx
@ -417,7 +417,7 @@ END FUNCTION calculate_dx
zmesh = 6.0d0
dx = 0.025d0
DO ir = 1, mesh
x = xmin + REAL(ir-1) * dx
x = xmin + DBLE(ir-1) * dx
ap%rw(ir) = EXP(x) / zmesh
END DO
ap%mesh = mesh
@ -1575,7 +1575,7 @@ END SUBROUTINE read_atomic_cc
! compute the radial mesh
!
do ir = 1, mesh(is)
x = xmin + float(ir-1) * dx
x = xmin + DBLE(ir-1) * dx
r(ir,is) = exp(x) / zmesh
rab(ir,is) = dx * r(ir,is)
end do

30
CPV/runcp.f90
View File

@ -294,8 +294,8 @@
CALL wave_verlet( cp(:,i+1,1,is), c0(:,i+1,1,is), svar1, svar2, svar3, c3 )
END IF
IF( cdesc%gzero ) cp(1,i,1,is) = REAL( cp(1,i,1,is), dbl )
IF( cdesc%gzero ) cp(1,i+1,1,is) = REAL( cp(1,i+1,1,is), dbl )
IF( cdesc%gzero ) cp(1,i,1,is) = DBLE( cp(1,i,1,is) )
IF( cdesc%gzero ) cp(1,i+1,1,is)= DBLE( cp(1,i+1,1,is) )
END DO
@ -319,7 +319,7 @@
cp(:,nb,1,is) = cm(:,nb,1,is)
CALL wave_verlet( cp(:,nb,1,is), c0(:,nb,1,is), svar1, svar2, svar3, c2 )
END IF
IF( cdesc%gzero ) cp(1,nb,1,is) = REAL( cp(1,nb,1,is), dbl )
IF( cdesc%gzero ) cp(1,nb,1,is) = DBLE( cp(1,nb,1,is) )
END IF
@ -482,7 +482,7 @@
if ( nupdwn(1) == (nupdwn(2) + 1) ) then
!
intermed = sum ( c0( :, nupdwn(1), ik, 1 ) * conjg( c0( :, nupdwn(1), ik, 1 ) ) )
intermed = sum ( c0( :, nupdwn(1), ik, 1 ) * CONJG( c0( :, nupdwn(1), ik, 1 ) ) )
! prodotto delle wf relative all'unpaired el
! lavoro sugli n processori e' per quetso che sommo ...
! vengono messi nella variabile temporanea ei_t(:,:,2)
@ -546,10 +546,10 @@
if ( nupdwn(1) > nupdwn(2) ) then
intermed = sum ( c2* conjg(c2) )
intermed2 = sum ( c3* conjg(c3) )
intermed3 = sum ( c2* conjg( c0(:,nupdwn(1),ik,1) ) )
intermed4 = sum ( c3* conjg( c0(:,nupdwn(1),ik,1) ) )
intermed = sum ( c2* CONJG(c2) )
intermed2 = sum ( c3* CONJG(c3) )
intermed3 = sum ( c2* CONJG( c0(:,nupdwn(1),ik,1) ) )
intermed4 = sum ( c3* CONJG( c0(:,nupdwn(1),ik,1) ) )
CALL mp_sum ( intermed, group )
CALL mp_sum ( intermed2, group )
CALL mp_sum ( intermed3, group )
@ -572,8 +572,8 @@
CALL wave_verlet( cp(:,i+1,ik,1), c0(:,i+1,ik,1), svar1, svar2, svar3, c3 )
END IF
IF( cdesc%gzero ) cp(1,i,ik,1) = REAL( cp(1,i,ik,1), dbl )
IF( cdesc%gzero ) cp(1,i+1,ik,1) = REAL( cp(1,i+1,ik,1), dbl )
IF( cdesc%gzero ) cp(1,i,ik,1) = DBLE( cp(1,i,ik,1) )
IF( cdesc%gzero ) cp(1,i+1,ik,1)= DBLE( cp(1,i+1,ik,1) )
END DO ! bande
@ -593,8 +593,8 @@
IF( ttprint .and. ( nupdwn(1) > nupdwn(2) ) ) THEN
CALL update_lambda( nb, gam( :, :), c0(:,:,ik,1), cdesc, c2 )
if ( nupdwn(1) > nupdwn(2) ) then
intermed = sum ( c2 * conjg(c2) )
intermed3 = sum ( c2 * conjg( c0(:, nupdwn(1), ik, 1) ) )
intermed = sum ( c2 * CONJG(c2) )
intermed3 = sum ( c2 * CONJG( c0(:, nupdwn(1), ik, 1) ) )
CALL mp_sum ( intermed, group )
CALL mp_sum ( intermed3, group )
ei_t(nb,ik,1) = intermed * ei_t(nb,ik,2) ! <Phi|H H|Phi>*<Phiunpaired|Phiunpaired>
@ -608,7 +608,7 @@
cp(:,nb,ik,1) = cm(:,nb,ik,1)
CALL wave_verlet( cp(:,nb,ik,1), c0(:,nb,ik,1), svar1, svar2, svar3, c2 )
END IF
IF( cdesc%gzero ) cp(1,nb,ik,1) = REAL( cp(1,nb,ik,1), dbl )
IF( cdesc%gzero ) cp(1,nb,ik,1) = DBLE( cp(1,nb,ik,1) )
END IF
@ -806,8 +806,8 @@
CALL wave_verlet( cm(:, i+1), c0(:, i+1), verl1, verl2, emaver, c3 )
endif
if ( gstart == 2 ) then
cm(1, i)=cmplx(real(cm(1, i)),0.0)
cm(1,i+1)=cmplx(real(cm(1,i+1)),0.0)
cm(1, i)=CMPLX(DBLE(cm(1, i)),0.d0)
cm(1,i+1)=CMPLX(DBLE(cm(1,i+1)),0.d0)
end if
end do
end if

10
CPV/rundiis.f90
View File

@ -6,7 +6,7 @@
! or http://www.gnu.org/copyleft/gpl.txt .
!
MODULE rundiis_module
#include "f_defs.h"
IMPLICIT NONE
SAVE
@ -157,7 +157,7 @@
ekinc = 100.0d0
edft%ent = 0.0d0
eold = 1.0d10 ! a large number
nel = 2.0d0 * cdesc%nbt( 1 ) / REAL( cdesc%nspin )
nel = 2.0d0 * cdesc%nbt( 1 ) / DBLE( cdesc%nspin )
IF( force_pairing ) &
CALL errore(' rundiis ', ' force pairing not implemented ', 1 )
@ -317,7 +317,7 @@
ELSE
DO ik = 1, kp%nkpt
DO ib=1,nrl
edft%etot = edft%etot + REAL(clambda(ib,(ib-1)*nproc+mpime+1,ik))
edft%etot = edft%etot + DBLE(clambda(ib,(ib-1)*nproc+mpime+1,ik))
END DO
END DO
END IF
@ -650,11 +650,11 @@
INTEGER ik, ib, ibl, nrl, nk
nrl = SIZE(clambda, 1)
nk = SIZE(clambda, 3)
clambda = cmplx(0.d0,0.d0)
clambda = CMPLX(0.d0,0.d0)
DO ik = 1, nk
ib = mpime + 1
DO ibl = 1, nrl
clambda(ibl,ib,ik) = cmplx(1.0d0, 0.0d0) ! diagonal elements
clambda(ibl,ib,ik) = CMPLX(1.0d0, 0.0d0) ! diagonal elements
ib = ib + nproc
END DO
END DO

2
CPV/smcp.f90
View File

@ -1491,7 +1491,7 @@ SUBROUTINE smdmain( tau, fion_out, etot_out, nat_out )
! Calculate statistics
anor=1.d0/dfloat(nfi)
anor=1.d0/DBLE(nfi)
DO i=1,nacc
rep(sm_k)%acc(i)=rep(sm_k)%acc(i)*anor
END DO

12
CPV/spline.f90
View File

@ -92,7 +92,7 @@
CALL errore(' allocate_spline ', ' wrong interval ', 1)
spl%xmin = xmin
spl%xmax = xmax
spl%h = ( xmax - xmin ) / REAL( nn - 1 )
spl%h = ( xmax - xmin ) / DBLE( nn - 1 )
spl%invh = 1.0d0 / spl%h
ELSE
spl%xmin = 0
@ -371,7 +371,7 @@
! fast spline for pair potentials without checks
h = spl%h
invh = spl%invh
d=xx-spl%x(1); i=INT(d*spl%invh); d0=REAL(i)*h; i=i+1
d=xx-spl%x(1); i=INT(d*spl%invh); d0=DBLE(i)*h; i=i+1
i = (xx-spl%x(1))*invh + 1
a = (spl%x(i+1)-xx)*invh
@ -547,7 +547,7 @@
REAL(dbl) :: p, qn, sig, un, dx
REAL(dbl) :: u(n)
dx = (xmax-xmin)/REAL(n-1)
dx = (xmax-xmin)/DBLE(n-1)
if ( yp1 .gt. 0.99d30 ) then
y2(1)=0.d0
u(1)=0.0d0
@ -585,7 +585,7 @@
REAL(dbl), INTENT(OUT) :: y
INTEGER :: khi,klo
REAL(dbl) :: a,b,h,dx,xhi,xlo
dx = (xmax-xmin)/REAL(n-1)
dx = (xmax-xmin)/DBLE(n-1)
klo = INT(x/dx)
khi = klo+1
IF(klo.LT.1) THEN
@ -594,8 +594,8 @@
IF(khi.GT.n) THEN
CALL errore(' splintdx ',' khi grether than N ',khi)
END IF
xlo = xmin + REAL(klo-1) * dx
xhi = xmin + REAL(khi-1) * dx
xlo = xmin + DBLE(klo-1) * dx
xhi = xmin + DBLE(khi-1) * dx
a = (xhi-x)/dx
b = (x-xlo)/dx

20
CPV/vanderwaals.f90
View File

@ -95,11 +95,11 @@
end if
do ix=-iesr,iesr
sij_image(1)= sij(1)+REAL(ix)
sij_image(1)= sij(1)+DBLE(ix)
do iy=-iesr,iesr
sij_image(2)= sij(2)+REAL(iy)
sij_image(2)= sij(2)+DBLE(iy)
do iz=-iesr,iesr
sij_image(3)= sij(3)+REAL(iz)
sij_image(3)= sij(3)+DBLE(iz)
tshift=ix.eq.0 .and. iy.eq.0 .and. iz.eq.0
if(.not.(tzero.and.tshift)) then
call s_to_r(sij_image,rij,box)
@ -210,7 +210,7 @@
do j = 1,nvec
bar(i) = bar(i) + vectors(i,j)
end do
bar(i) = bar(i) / REAL(nvec)
bar(i) = bar(i) / DBLE(nvec)
end do
return
end subroutine baricentro
@ -299,9 +299,9 @@
! DO IZ=-IESR,IESR
! ISHFT=IX*IX+IY*IY+IZ*IZ
! IF(.NOT.(TZERO.AND.ISHFT.EQ.0)) THEN
! SXLM(1) = XLM + DFLOAT(IX)
! SXLM(2) = YLM + DFLOAT(IY)
! SXLM(3) = ZLM + DFLOAT(IZ)
! SXLM(1) = XLM + DBLE(IX)
! SXLM(2) = YLM + DBLE(IY)
! SXLM(3) = ZLM + DBLE(IZ)
! CALL S_TO_R(SXLM,RXLM)
! ERRE2 = RXLM(1)**2 + RXLM(2)**2 + RXLM(3)**2
! RLM = SQRT(ERRE2)
@ -424,9 +424,9 @@
! DO IZ=-IESR,IESR
! ISHFT=IX*IX+IY*IY+IZ*IZ
! IF(.NOT.(TZERO.AND.ISHFT.EQ.0)) THEN
! SXLM(1) = XLM + DFLOAT(IX)
! SXLM(2) = YLM + DFLOAT(IY)
! SXLM(3) = ZLM + DFLOAT(IZ)
! SXLM(1) = XLM + DBLE(IX)
! SXLM(2) = YLM + DBLE(IY)
! SXLM(3) = ZLM + DBLE(IZ)
! CALL S_TO_R(SXLM,RXLM)
! ERRE2 = RXLM(1)**2 + RXLM(2)**2 + RXLM(3)**2
! RLM = SQRT(ERRE2)

52
CPV/vofrho2.f90
View File

@ -5,6 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!-----------------------------------------------------------------------
subroutine vofrho2(nfi,rhor,rhog,rhos,rhoc,tfirst,tlast, &
& ei1,ei2,ei3,irb,eigrb,sfac,tau0,fion,v0s,vhxcs)
@ -22,6 +23,7 @@
! v0s output : total local pseudopotential on smooth real space grid
! vhxcs out : hartree-xc potential on smooth real space grid
!
use kinds, only: dp
use control_flags, only: iprint, tvlocw, iprsta, thdyn, tpre, tfor
use io_global, only: stdout
use parameters, only: natx, nsx
@ -128,11 +130,11 @@
vtemp=(0.,0.)
do is=1,nsp
do ig=1,ngs
vtemp(ig)=vtemp(ig)+conjg(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
vtemp(ig)=vtemp(ig)+CONJG(rhotmp(ig))*sfac(ig,is)*vps(ig,is)
end do
end do
!
epseu = wz * real( SUM( vtemp( 1:ngs ) ) )
epseu = wz * DBLE( SUM( vtemp( 1:ngs ) ) )
if (ng0.eq.2) epseu=epseu-vtemp(1)
call mp_sum( epseu )
@ -151,10 +153,10 @@
end do
if (ng0.eq.2) vtemp(1)=0.0
do ig=ng0,ngm
vtemp(ig)=conjg(rhotmp(ig))*rhotmp(ig)/g(ig)
vtemp(ig)=CONJG(rhotmp(ig))*rhotmp(ig)/g(ig)
end do
!
eh=real( SUM( vtemp( 1:ngm ) ) ) *wz*0.5*fpi/tpiba2
eh=DBLE( SUM( vtemp( 1:ngm ) ) ) *wz*0.5*fpi/tpiba2
call mp_sum( eh )
@ -184,7 +186,7 @@
vs = 0.0d0
do is=1,nsp
do ig=1,ngs
vs(nms(ig))=vs(nms(ig))+conjg(sfac(ig,is)*vps(ig,is))
vs(nms(ig))=vs(nms(ig))+CONJG(sfac(ig,is)*vps(ig,is))
vs(nps(ig))=vs(nps(ig))+sfac(ig,is)*vps(ig,is)
end do
end do
@ -192,7 +194,7 @@
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
!
do ir=1,nnrsx
v0s(ir)=real(vs(ir))
v0s(ir)=DBLE(vs(ir))
end do
@ -215,7 +217,7 @@
if(nspin.eq.1) then
iss=1
do ir=1,nnr
v(ir)=cmplx(rhor(ir,iss),0.0)
v(ir)=CMPLX(rhor(ir,iss),0.0)
end do
!
! v_xc(r) --> v_xc(g)
@ -233,14 +235,14 @@
isup=1
isdw=2
do ir=1,nnr
v(ir)=cmplx(rhor(ir,isup),rhor(ir,isdw))
v(ir)=CMPLX(rhor(ir,isup),rhor(ir,isdw))
end do
call fwfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ig=1,ngm
fp=v(np(ig))+v(nm(ig))
fm=v(np(ig))-v(nm(ig))
rhog(ig,isup)=vtemp(ig)+0.5*cmplx( real(fp),aimag(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*cmplx(aimag(fp),-real(fm))
rhog(ig,isup)=vtemp(ig)+0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=vtemp(ig)+0.5*CMPLX(AIMAG(fp),-DBLE(fm))
end do
endif
!
@ -264,7 +266,7 @@
iss=1
do ig=1,ngm
v(np(ig))=rhog(ig,iss)
v(nm(ig))=conjg(rhog(ig,iss))
v(nm(ig))=CONJG(rhog(ig,iss))
end do
!
! v(g) --> v(r)
@ -272,30 +274,30 @@
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
!
do ir=1,nnr
rhor(ir,iss)=real(v(ir))
rhor(ir,iss)=DBLE(v(ir))
end do
!
! calculation of average potential
!
vave= SUM( rhor(1:nnr,iss) ) /dfloat(nr1*nr2*nr3)
vave= SUM( rhor(1:nnr,iss) ) /DBLE(nr1*nr2*nr3)
else
isup=1
isdw=2
do ig=1,ngm
v(np(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
v(nm(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
v(nm(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
!
call invfft(v,nr1,nr2,nr3,nr1x,nr2x,nr3x)
do ir=1,nnr
rhor(ir,isup)= real(v(ir))
rhor(ir,isdw)=aimag(v(ir))
rhor(ir,isup)= DBLE(v(ir))
rhor(ir,isdw)=AIMAG(v(ir))
end do
!
! calculation of average potential
!
vave=( SUM( rhor(1:nnr,isup) ) + SUM( rhor(1:nnr,isdw) ) ) &
& /2.0/dfloat(nr1*nr2*nr3)
& /2.0/DBLE(nr1*nr2*nr3)
endif
call mp_sum( vave )
@ -309,31 +311,31 @@
if(nspin.eq.1)then
iss=1
do ig=1,ngs
vs(nms(ig))=conjg(rhog(ig,iss))
vs(nms(ig))=CONJG(rhog(ig,iss))
vs(nps(ig))=rhog(ig,iss)
end do
!
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
!
do ir=1,nnrsx
vhxcs(ir,iss)=real(vs(ir))-v0s(ir)
rhos(ir,iss)=real(vs(ir))
vhxcs(ir,iss)=DBLE(vs(ir))-v0s(ir)
rhos(ir,iss)=DBLE(vs(ir))
end do
else
isup=1
isdw=2
do ig=1,ngs
vs(nps(ig))=rhog(ig,isup)+ci*rhog(ig,isdw)
vs(nms(ig))=conjg(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
vs(nms(ig))=CONJG(rhog(ig,isup)) +ci*conjg(rhog(ig,isdw))
end do
call ivffts(vs,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
do ir=1,nnrsx
vhxcs(ir,isup)= real(vs(ir))-v0s(ir)
vhxcs(ir,isdw)=aimag(vs(ir))-v0s(ir)
vhxcs(ir,isup)= DBLE(vs(ir))-v0s(ir)
vhxcs(ir,isdw)=AIMAG(vs(ir))-v0s(ir)
rhos(ir,isup)= real(vs(ir))
rhos(ir,isdw)=aimag(vs(ir))
rhos(ir,isup)= DBLE(vs(ir))
rhos(ir,isdw)=AIMAG(vs(ir))
end do
endif

7
CPV/wannier.f90
View File

@ -7,6 +7,7 @@
!
! ... wannier function dynamics and electric field
! - M.S
#include "f_defs.h"
!
!----------------------------------------------------------------------------
MODULE efcalc
@ -184,7 +185,7 @@ END MODULE electric_field_module
MODULE wannier_subroutines
!--------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
!
IMPLICIT NONE
@ -564,8 +565,8 @@ MODULE wannier_subroutines
CALL wave_verlet( cm(:, i+1), c0(:, i+1), verl1, verl2, emaver, c3 )
ENDIF
IF (gstart.EQ.2) THEN
cm(1, i)=CMPLX(REAL(cm(1, i)),0.0)
cm(1,i+1)=CMPLX(REAL(cm(1,i+1)),0.0)
cm(1, i)=CMPLX(DBLE(cm(1, i)),0.d0)
cm(1,i+1)=CMPLX(DBLE(cm(1,i+1)),0.d0)
END IF
END DO

16
CPV/wave.f90
View File

@ -173,9 +173,9 @@
DO ib = 1, cdesc%nbl( ispin )
skm = 0.d0
DO ig = 2, cdesc%ngwl
skm = skm + g2(ig) * REAL( CONJG( c(ig,ib) ) * c(ig,ib), dbl) * pmss(ig)
skm = skm + g2(ig) * DBLE( CONJG(c(ig,ib)) * c(ig,ib) ) * pmss(ig)
END DO
skm = skm + g2(1) * REAL( c(1,ib), dbl )**2 * pmss(1) / 2.0d0
skm = skm + g2(1) * DBLE( c(1,ib) )**2 * pmss(1) / 2.0d0
xmkin = xmkin + fi(ib) * skm * 0.5d0
END DO
@ -184,7 +184,7 @@
DO ib = 1, cdesc%nbl( ispin )
skm = 0.d0
DO ig = 1, cdesc%ngwl
skm = skm + g2(ig) * REAL( CONJG( c( ig, ib ) ) * c( ig, ib ) ) * pmss(ig)
skm = skm + g2(ig) * DBLE( CONJG( c( ig, ib ) ) * c( ig, ib ) ) * pmss(ig)
END DO
xmkin = xmkin + fi(ib) * skm * 0.5d0
END DO
@ -226,9 +226,9 @@
DO ib = 1, cdesc%nbl( ispin )
sk1 = 0.d0
DO ig = 2, cdesc%ngwl
sk1 = sk1 + g2(ig) * REAL( CONJG( c(ig,ib) ) * c(ig,ib), dbl )
sk1 = sk1 + g2(ig) * DBLE( CONJG( c(ig,ib) ) * c(ig,ib) )
END DO
sk1 = sk1 + g2(1) * REAL( c(1,ib), dbl )**2 / 2.0d0
sk1 = sk1 + g2(1) * DBLE( c(1,ib) )**2 / 2.0d0
xkin = xkin + fi(ib) * sk1 * 0.5d0
END DO
@ -237,7 +237,7 @@
DO ib = 1, cdesc%nbl( ispin )
sk1 = 0.d0
DO ig = 1, cdesc%ngwl
sk1 = sk1 + g2(ig) * REAL( CONJG( c(ig,ib) ) * c(ig,ib), dbl )
sk1 = sk1 + g2(ig) * DBLE( CONJG( c(ig,ib) ) * c(ig,ib) )
END DO
xkin = xkin + fi(ib) * sk1 * 0.5d0
END DO
@ -367,7 +367,7 @@
IF( cdesc%gzero ) THEN
DO i = 1, cdesc%nbl( ispin )
c( 1, i ) = REAL( c( 1, i ), dbl )
c( 1, i ) = DBLE( c( 1, i ) )
END DO
END IF
@ -1031,7 +1031,7 @@
DO ig = 3, ntest
rranf1 = 0.5d0 - rranf()
rranf2 = rranf()
pwt( ig ) = ampre * DCMPLX(rranf1, rranf2)
pwt( ig ) = ampre * CMPLX(rranf1, rranf2)
END DO
CALL splitwf ( cm( :, ib ), pwt, ngw, ig_l2g, mpime, nproc, 0 )
END DO

125
CPV/wf.f90
View File

@ -947,7 +947,7 @@ SUBROUTINE wf( clwf, c, bec, eigr, eigrb, taub, irb, &
isa = isa + 1
END DO
END DO
t1=omega/dfloat(nr1*nr2*nr3)
t1=omega/DBLE(nr1*nr2*nr3)
X=X*t1
DO i=1, nbsp
DO j=i+1, nbsp
@ -1258,7 +1258,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
! ... obtain the wannier function at time(t+delta). It also updates the
! ... quantities bec and becdr
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
USE wannier_base, ONLY : wf_friction, nsteps, tolw, adapt, wf_q, &
weight, nw, wfdt
@ -1338,7 +1338,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
t0=0.D0 !use t0 to store the value of omega
DO inw=1, nw
DO i=1, m
t0=t0+REAL(CONJG(Oc(inw, i, i))*Oc(inw, i, i))
t0=t0+DBLE(CONJG(Oc(inw, i, i))*Oc(inw, i, i))
END DO
END DO
@ -1373,7 +1373,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
t2=weight(inw)
DO i=1,m
DO j=1,m
W(i,j)=W(i,j)+t2*REAL(Oc(inw,i,j)*CONJG(Oc(inw,i,i) &
W(i,j)=W(i,j)+t2*DBLE(Oc(inw,i,j)*CONJG(Oc(inw,i,i) &
-Oc(inw,j,j))+CONJG(Oc(inw,j,i))*(Oc(inw,i,i)-Oc(inw,j,j)))
END DO
END DO
@ -1396,7 +1396,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
DO i=1, m
DO j=i,m
wp(i + (j-1)*j/2) = CMPLX(0.0, Aplus(i,j))
wp(i + (j-1)*j/2) = CMPLX(0.d0, Aplus(i,j))
END DO
END DO
@ -1425,7 +1425,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
U2=ZERO
! call ZGEMUL(U3, m, 'nbsp', z, m, 'c', U2, m, m,m,m)
CALL ZGEMM ('nbsp','c', m,m,m,ONE,U3,m,z,m,ZERO,U2,m)
U=REAL(U2)
U=DBLE(U2)
U2=ZERO
U3=ZERO
@ -1479,7 +1479,7 @@ SUBROUTINE ddyn( m, Omat, Umat, b1, b2, b3 )
241 DEALLOCATE(wr, W)
spread=0.0
DO i=1, m
mt=1.D0-REAL(Oc(:,i,i)*CONJG(Oc(:,i,i)))
mt=1.D0-DBLE(Oc(:,i,i)*CONJG(Oc(:,i,i)))
sp= (alat*autoaf/tpi)**2*SUM(mt*weight)
#ifdef __PARA
IF(me.EQ.1) THEN
@ -1522,7 +1522,7 @@ SUBROUTINE wfunc_init( clwf, b1, b2, b3, ibrav )
!----------------------------------------------------------------------------
!
USE io_global, ONLY : stdout
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE reciprocal_vectors, ONLY : gx, mill_l, gstart
USE gvecw, ONLY : ngw
USE electrons_base, ONLY : nbsp
@ -2514,7 +2514,7 @@ END SUBROUTINE wfunc_init
SUBROUTINE grid_map()
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE efcalc, ONLY : xdist, ydist, zdist
USE smooth_grid_dimensions, ONLY : nnrsx, nr1s, nr2s, nr3s, &
nr1sx, nr2sx, nr3sx
@ -2539,11 +2539,11 @@ SUBROUTINE grid_map()
DO ir2=1,nr2s
DO ir1=1,nr1s
xdist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = &
& ((ir1-1)/dfloat(nr1sx))
& ((ir1-1)/DBLE(nr1sx))
ydist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = &
& ((ir2-1)/dfloat(nr2sx))
& ((ir2-1)/DBLE(nr2sx))
zdist(ir1+(ir2-1)*nr1sx+(ibig3-1)*nr1sx*nr2sx) = &
& ((ir3-1)/dfloat(nr3sx))
& ((ir3-1)/DBLE(nr3sx))
!
END DO
END DO
@ -2562,7 +2562,7 @@ SUBROUTINE tric_wts( rp1, rp2, rp3, alat, wts )
! ... R.P. translations in the WF calculation in the case
! ... of ibrav=0 or ibrav=14
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE constants, ONLY : pi
USE cell_base, ONLY : tpiba, tpiba2
!
@ -2647,7 +2647,7 @@ END SUBROUTINE tric_wts
SUBROUTINE small_box_wf( i_1, j_1, k_1, nw1 )
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
USE constants, ONLY : fpi
USE wannier_base, ONLY : expo
@ -2675,9 +2675,9 @@ SUBROUTINE small_box_wf( i_1, j_1, k_1, nw1 )
#endif
DO ir2=1,nr2
DO ir1=1,nr1
x = (((ir1-1)/dfloat(nr1x))*i_1(inw) + &
& ((ir2-1)/dfloat(nr2x))*j_1(inw) + &
& ((ir3-1)/dfloat(nr3x))*k_1(inw))*0.5d0*fpi
x = (((ir1-1)/DBLE(nr1x))*i_1(inw) + &
& ((ir2-1)/DBLE(nr2x))*j_1(inw) + &
& ((ir3-1)/DBLE(nr3x))*k_1(inw))*0.5d0*fpi
expo(ir1+(ir2-1)*nr1x+(ibig3-1)*nr1x*nr2x,inw) = CMPLX(COS(x), -SIN(x))
END DO
END DO
@ -2700,7 +2700,7 @@ FUNCTION boxdotgridcplx(irb,qv,vr)
!
! use ion_parameters
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE grid_dimensions, ONLY : nnrx, nr1, nr2, nr3, nr1x, nr2x, nr3x
USE smallbox_grid_dimensions, ONLY : nnrbx, nr1b, nr2b, nr3b, &
nr1bx, nr2bx, nr3bx
@ -2748,7 +2748,7 @@ END FUNCTION boxdotgridcplx
SUBROUTINE write_rho_g( rhog )
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
USE gvecp, ONLY : ngm
USE reciprocal_vectors, ONLY : gx, mill_l
@ -2895,7 +2895,7 @@ END SUBROUTINE write_rho_g
SUBROUTINE macroscopic_average( rhog, tau0, e_tuned )
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE reciprocal_vectors, ONLY : gx
USE gvecp, ONLY : ngm
USE electrons_base, ONLY : nspin
@ -3110,11 +3110,11 @@ SUBROUTINE macroscopic_average( rhog, tau0, e_tuned )
DO j=1,npts
dz(j)=(j-1)*zlen/(npts*1.D0)
DO i=1,ngz
vbar(j)=vbar(j)-REAL(EXP(CI*gz(i)*dz(j))*v_1(i))
v_mr(j)=v_mr(j)-REAL(EXP(CI*gz(i)*dz(j))*vmac(i))
cdel(j)=cdel(j)-REAL(EXP(CI*gz(i)*dz(j))*rhogz(i))
cdion(j)=cdion(j)+REAL(EXP(CI*gz(i)*dz(j))*rho_ion(i))
cd(j)=cd(j)+REAL(EXP(CI*gz(i)*dz(j))*rho_tot(i))
vbar(j)=vbar(j)-DBLE(EXP(CI*gz(i)*dz(j))*v_1(i))
v_mr(j)=v_mr(j)-DBLE(EXP(CI*gz(i)*dz(j))*vmac(i))
cdel(j)=cdel(j)-DBLE(EXP(CI*gz(i)*dz(j))*rhogz(i))
cdion(j)=cdion(j)+DBLE(EXP(CI*gz(i)*dz(j))*rho_ion(i))
cd(j)=cd(j)+DBLE(EXP(CI*gz(i)*dz(j))*rho_tot(i))
END DO
! WRITE( stdout, * ) vbar(j), v_mr(j), cdel(j), cdion(j)
END DO
@ -3157,7 +3157,7 @@ END SUBROUTINE macroscopic_average
SUBROUTINE least_square( npts, x, y, slope, intercept )
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
!
IMPLICIT NONE
!
@ -3180,8 +3180,8 @@ SUBROUTINE least_square( npts, x, y, slope, intercept )
sumx2=sumx2+x(i)*x(i)
END DO
sumsqx=sumx**2
xav=sumx/dfloat(npts)
yav=sumy/dfloat(npts)
xav=sumx/DBLE(npts)
yav=sumy/DBLE(npts)
slope=(npts*sumxy - sumx*sumy)/(npts*sumx2 - sumsqx)
@ -3195,7 +3195,7 @@ END SUBROUTINE least_square
SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
!----------------------------------------------------------------------------
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
USE wannier_base, ONLY : nw, weight, nit, tolw, wfdt, maxwfdt, nsd
USE control_flags, ONLY : iprsta
@ -3267,7 +3267,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
t01=0.D0 !use t1 to store the value of omiga
DO inw=1, nw
DO i=1, m
t01=t01+REAL(CONJG(Oc(inw, i, i))*Oc(inw, i, i))
t01=t01+DBLE(CONJG(Oc(inw, i, i))*Oc(inw, i, i))
END DO
END DO
@ -3298,7 +3298,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
t2=weight(inw)
DO i=1,m
DO j=i+1,m
W(i,j)=W(i,j)+t2*REAL(Oc(inw,i,j)*CONJG(Oc(inw,i,i) &
W(i,j)=W(i,j)+t2*DBLE(Oc(inw,i,j)*CONJG(Oc(inw,i,i) &
-Oc(inw,j,j))+CONJG(Oc(inw,j,i))*(Oc(inw,i,i)-Oc(inw,j,j)))
END DO
END DO
@ -3315,7 +3315,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
DO tk=1, m
t2=0.D0
DO inw=1, nw
t2=t2+REAL(Oc(inw,tj,tk)*CONJG(Oc(inw,tj,tj)+Oc(inw,tk,tk) &
t2=t2+DBLE(Oc(inw,tj,tk)*CONJG(Oc(inw,tj,tj)+Oc(inw,tk,tk) &
-2.D0*Oc(inw,ti,ti))-4.D0*Oc(inw,ti,tk) &
*CONJG(Oc(inw,ti,tj)))*weight(inw)
END DO
@ -3338,7 +3338,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
! schd=schd*maxwfdt
DO i=1, m
DO j=i, m
wp1(i + (j-1)*j/2) = CMPLX(0.0, schd(i,j))
wp1(i + (j-1)*j/2) = CMPLX(0.d0, schd(i,j))
END DO
END DO
@ -3386,7 +3386,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
! schd=schd*maxwfdt
DO i=1, m
DO j=i, m
wp1(i + (j-1)*j/2) = CMPLX(0.0, schd(i,j))
wp1(i + (j-1)*j/2) = CMPLX(0.d0, schd(i,j))
END DO
END DO
@ -3409,7 +3409,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
CALL ZGEMM ('nbsp', 'nbsp', m,m,m,ONE,z,m,d,m,ZERO,U3,m)
U2=ZERO
CALL ZGEMM ('nbsp','c', m,m,m,ONE,U3,m,z,m,ZERO,U2,m)
U=REAL(U2)
U=DBLE(U2)
U2=ZERO
U3=ZERO
!
@ -3436,7 +3436,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
t21=0.D0 !use t21 to store the value of omiga
DO inw=1, nw
DO i=1, m
t21=t21+REAL(CONJG(Oc2(inw, i, i))*Oc2(inw, i, i))
t21=t21+DBLE(CONJG(Oc2(inw, i, i))*Oc2(inw, i, i))
END DO
END DO
@ -3475,7 +3475,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
CALL ZGEMM ('nbsp', 'nbsp', m,m,m,ONE,z,m,d,m,ZERO,U3,m)
U2=ZERO
CALL ZGEMM ('nbsp','c', m,m,m,ONE,U3,m,z,m,ZERO,U2,m)
U=REAL(U2)
U=DBLE(U2)
U2=ZERO
U3=ZERO
@ -3521,7 +3521,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
!
! write(24, *) "spread: (unit \AA^2)"
DO i=1, m
mt=1.D0-REAL(Oc(:,i,i)*CONJG(Oc(:,i,i)))
mt=1.D0-DBLE(Oc(:,i,i)*CONJG(Oc(:,i,i)))
sp = (alat*autoaf/tpi)**2*SUM(mt*weight)
#ifdef __PARA
IF(me.EQ.1) THEN
@ -3536,7 +3536,7 @@ SUBROUTINE wfsteep( m, Omat, Umat, b1, b2, b3 )
spread=spread+sp
!
END DO
spread=spread/dfloat(m)
spread=spread/DBLE(m)
#ifdef __PARA
IF(me.EQ.1) THEN
@ -3554,15 +3554,15 @@ END SUBROUTINE wfsteep
SUBROUTINE dforce_field( bec, deeq, betae, i, c, ca, df, da, v, v1 )
!----------------------------------------------------------------------------
!
! ... computes: the generalized force df=cmplx(dfr,dfi) acting on the i-th
! ... computes: the generalized force df=CMPLX(dfr,dfi) acting on the i-th
! ... electron state at the gamma point of the brillouin zone
! ... represented by the vector c=cmplx(cr,CI)
! ... represented by the vector c=CMPLX(cr,CI)
!
! ... d_n(g) = f_n { 0.5 g^2 c_n(g) + [vc_n](g) +
! ... sum_i,ij d^q_i,ij (-i)**l beta_i,i(g)
! ... e^-ig.r_i < beta_i,j | c_n > }
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE control_flags, ONLY : iprint, tbuff
USE gvecs, ONLY : nms, nps
USE gvecw, ONLY : ngw
@ -3637,8 +3637,7 @@ SUBROUTINE dforce_field( bec, deeq, betae, i, c, ca, df, da, v, v1 )
END IF
!
DO ir=1,nnrsx
psi(ir)=CMPLX(v(ir,iss1)* REAL(psi(ir)), &
& v1(ir,iss2)*AIMAG(psi(ir)) )
psi(ir)=CMPLX(v(ir,iss1)* DBLE(psi(ir)), v1(ir,iss2)*AIMAG(psi(ir)) )
END DO
!
CALL fwfftw(psi,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
@ -3652,8 +3651,8 @@ SUBROUTINE dforce_field( bec, deeq, betae, i, c, ca, df, da, v, v1 )
DO ig=1,ngw
fp= psi(nps(ig)) + psi(nms(ig))
fm= psi(nps(ig)) - psi(nms(ig))
df(ig)= fi*(tpiba2*ggp(ig)* c(ig)+CMPLX(REAL(fp), AIMAG(fm)))
da(ig)=fip*(tpiba2*ggp(ig)*ca(ig)+CMPLX(AIMAG(fp),-REAL(fm)))
df(ig)= fi*(tpiba2*ggp(ig)* c(ig)+CMPLX(DBLE(fp), AIMAG(fm)))
da(ig)=fip*(tpiba2*ggp(ig)*ca(ig)+CMPLX(AIMAG(fp),-DBLE(fm)))
END DO
!
! aa_i,i,nbsp = sum_j d_i,ij <beta_i,j|c_n>
@ -3716,7 +3715,7 @@ SUBROUTINE write_psi( c, jw )
! ... for calwf 5 - M.S
! ... collect wavefunctions on first node and write to file
!
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE io_global, ONLY : stdout
USE gvecs, ONLY : nps
USE electrons_base, ONLY : nbspx
@ -3859,7 +3858,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
! e_v = sum_i,ij rho_i,ij d^ion_is,ji
!
USE constants, ONLY : bohr_radius_angs
USE kinds, ONLY : dbl
USE kinds, ONLY : dbl, dp
USE control_flags, ONLY : iprint, tbuff, iprsta, thdyn, tpre, trhor
USE ions_base, ONLY : nax, nat, nsp, na
USE cell_base, ONLY : a1, a2, a3
@ -3967,7 +3966,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
IF(nspin.EQ.1)THEN
iss=1
DO ir=1,nnrx
psi(ir)=CMPLX(rhor(ir,iss),0.)
psi(ir)=CMPLX(rhor(ir,iss),0.d0)
END DO
CALL fwfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
DO ig=1,ngm
@ -3983,8 +3982,8 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
DO ig=1,ngm
fp=psi(np(ig))+psi(nm(ig))
fm=psi(np(ig))-psi(nm(ig))
rhog(ig,isup)=0.5*CMPLX( REAL(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-REAL(fm))
rhog(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
END DO
ENDIF
!
@ -4030,7 +4029,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
sa2=0.0
! end if
DO ir=1,nnrsx
rhos(ir,iss1)=rhos(ir,iss1) + sa1*( REAL(psis(ir)))**2
rhos(ir,iss1)=rhos(ir,iss1) + sa1*( DBLE(psis(ir)))**2
rhos(ir,iss2)=rhos(ir,iss2) + sa2*(AIMAG(psis(ir)))**2
END DO
!
@ -4053,7 +4052,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
IF(nspin.EQ.1)THEN
iss=1
DO ir=1,nnrsx
psis(ir)=CMPLX(rhos(ir,iss),0.)
psis(ir)=CMPLX(rhos(ir,iss),0.d0)
END DO
CALL fwffts(psis,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx)
DO ig=1,ngs
@ -4069,8 +4068,8 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
DO ig=1,ngs
fp= psis(nps(ig)) + psis(nms(ig))
fm= psis(nps(ig)) - psis(nms(ig))
rhog(ig,isup)=0.5*CMPLX( REAL(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-REAL(fm))
rhog(ig,isup)=0.5*CMPLX( DBLE(fp),AIMAG(fm))
rhog(ig,isdw)=0.5*CMPLX(AIMAG(fp),-DBLE(fm))
END DO
ENDIF
!
@ -4086,7 +4085,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
END DO
CALL invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
DO ir=1,nnrx
rhor(ir,iss)=REAL(psi(ir))
rhor(ir,iss)=DBLE(psi(ir))
END DO
ELSE
! ==================================================================
@ -4101,7 +4100,7 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
END DO
CALL invfft(psi,nr1,nr2,nr3,nr1x,nr2x,nr3x)
DO ir=1,nnrx
rhor(ir,isup)= REAL(psi(ir))
rhor(ir,isup)= DBLE(psi(ir))
rhor(ir,isdw)=AIMAG(psi(ir))
END DO
ENDIF
@ -4109,8 +4108,8 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
! if(iprsta.ge.3)then
WRITE( stdout,*) 'Smooth part of charge density :'
DO iss=1,nspin
rsumg(iss)=omega*REAL(rhog(1,iss))
rsumr(iss)=SUM(rhor(1:nnrx,iss))*omega/dfloat(nr1*nr2*nr3)
rsumg(iss)=omega*DBLE(rhog(1,iss))
rsumr(iss)=SUM(rhor(1:nnrx,iss))*omega/DBLE(nr1*nr2*nr3)
END DO
#ifdef __PARA
IF (gstart.NE.2) THEN
@ -4169,8 +4168,8 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
!
IF(iprsta.GE.2) THEN
CALL checkrho(nnrx,nspin,rhor,rmin,rmax,rsum,rnegsum)
rnegsum=rnegsum*omega/dfloat(nr1*nr2*nr3)
rsum=rsum*omega/dfloat(nr1*nr2*nr3)
rnegsum=rnegsum*omega/DBLE(nr1*nr2*nr3)
rsum=rsum*omega/DBLE(nr1*nr2*nr3)
WRITE( stdout,'(a,4(1x,f12.6))') &
& ' rhoofr: rmin rmax rnegsum rsum ',rmin,rmax,rnegsum,rsum
END IF
@ -4180,8 +4179,8 @@ SUBROUTINE rhoiofr( nfi, c, irb, eigrb, bec, &
WRITE( stdout, * )
WRITE( stdout, * ) 'Smooth part + Augmentatio Part: '
DO iss=1,nspin
rsumg(iss)=omega*REAL(rhog(1,iss))
rsumr(iss)=SUM(rhor(1:nnrx,iss))*omega/dfloat(nr1*nr2*nr3)
rsumg(iss)=omega*DBLE(rhog(1,iss))
rsumr(iss)=SUM(rhor(1:nnrx,iss))*omega/DBLE(nr1*nr2*nr3)
END DO
#ifdef __PARA
IF (gstart.NE.2) THEN

2
D3/d0rhod2v.f90
View File

@ -85,7 +85,7 @@ SUBROUTINE d0rhod2v (ipert, drhoscf)
g(2,ng)*tau(2,na) + &
g(3,ng)*tau(3,na) )
fac = DCMPLX(COS(gtau),SIN(gtau))
fac = CMPLX(COS(gtau),SIN(gtau))
d3dywrk(na_icart,na_jcart) = &
d3dywrk(na_icart,na_jcart) - &

2
D3/d3_exc.f90
View File

@ -61,7 +61,7 @@ SUBROUTINE d3_exc
CALL davcio_drho (work2, lrdrho, iudrho, jpert, - 1)
DO kpert = 1, 3 * nat
CALL davcio_drho (work3, lrdrho, iudrho, kpert, - 1)
aux = DCMPLX (0.d0, 0.d0)
aux = CMPLX (0.d0, 0.d0)
DO ir = 1, nrxx
aux = aux + &
d2muxc (ir) * work1 (ir) * &

6
D3/d3_summary.f90
View File

@ -158,14 +158,14 @@ subroutine d3_summary
2, isym) / nr2 + at (3, 3) * ftau (3, isym) / nr3
WRITE( stdout, '(1x,"cryst.",3x,"s(",i2,") = (",3(i6,5x), &
&" ) f =( ",f10.7," )")') isymq, (s (1, ipol, isym),&
ipol = 1, 3) , float (ftau (1, isym) ) / float (nr1)
ipol = 1, 3) , DBLE (ftau (1, isym) ) / DBLE (nr1)
WRITE( stdout, '(17x," (",3(i6,5x), &
& " ) ( ",f10.7," )")') &
(s (2, ipol, &
&isym) , ipol = 1, 3) , float (ftau (2, isym) ) / float (nr2)
&isym) , ipol = 1, 3) , DBLE (ftau (2, isym) ) / DBLE (nr2)
WRITE( stdout, '(17x," (",3(i6,5x), &
& " ) ( ",f10.7," )"/)') (s (3, ipol, &
& isym) , ipol = 1, 3) , float (ftau (3, isym) ) / float (nr3)
& isym) , ipol = 1, 3) , DBLE (ftau (3, isym) ) / DBLE (nr3)
WRITE( stdout, '(1x,"cart.",3x,"s(",i2,") = (",3f11.7, &
& " ) f =( ",f10.7," )")') isymq, (sr (1 &
&, ipol) , ipol = 1, 3) , ft1

4
D3/d3_symdyn.f90
View File

@ -68,8 +68,8 @@ subroutine d3_symdyn (d3dyn, u, ug0, xq, s, invs, rtau, irt, irgq, &
do om = 1, 3 * nat
do mu = 1, 3 * nat
do nu = 1, 3 * nat
work = work + conjg (ug0 (i1, om) ) * u (i, mu) * &
d3dyn (om, mu, nu) * conjg (u (j, nu) )
work = work + CONJG(ug0 (i1, om) ) * u (i, mu) * &
d3dyn (om, mu, nu) * CONJG(u (j, nu) )
enddo
enddo
enddo

14
D3/d3_symdynph.f90
View File

@ -69,9 +69,9 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
do jpol = 1, 3
phi (kpol, ipol, jpol, nc, na, nb) = 0.5d0 * &
(phi (kpol, ipol, jpol, nc, na, nb) + &
conjg (phi (kpol, jpol, ipol, nc, nb, na) ) )
CONJG(phi (kpol, jpol, ipol, nc, nb, na) ) )
phi (kpol, jpol, ipol, nc, nb, na) = &
conjg (phi (kpol, ipol, jpol, nc, na, nb) )
CONJG(phi (kpol, ipol, jpol, nc, na, nb) )
enddo
enddo
enddo
@ -104,7 +104,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
rtau (kpol, irotmq, nb) ) )
enddo
arg = arg * tpi
fase = DCMPLX (cos (arg), sin (arg) )
fase = CMPLX (cos (arg), sin (arg) )
do npol = 1, 3
do kpol = 1, 3
do lpol = 1, 3
@ -118,7 +118,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
enddo
phip (mpol, ipol, jpol, nc, na, nb) = &
(phi (mpol, ipol, jpol, nc, na, nb) + &
conjg (work (mpol, ipol, jpol) ) ) * 0.5d0
CONJG(work (mpol, ipol, jpol) ) ) * 0.5d0
enddo
enddo
enddo
@ -161,7 +161,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
rtau (ipol, irot, nb) ) )
enddo
arg = arg * tpi
faseq (isymq) = DCMPLX (cos (arg), sin (arg) )
faseq (isymq) = CMPLX (cos (arg), sin (arg) )
do mpol = 1, 3
do ipol = 1, 3
do jpol = 1, 3
@ -199,7 +199,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
s (ipol, kpol, invs (irot) ) * &
s (jpol, lpol, invs (irot) ) * &
work (npol, kpol, lpol) * &
conjg (faseq (isymq) )
CONJG(faseq (isymq) )
enddo
enddo
enddo
@ -212,7 +212,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
enddo
enddo
enddo
phi = phi / float(nsymq)
phi = phi / DBLE(nsymq)
deallocate (iflb)
return
end subroutine d3_symdynph

16
D3/d3_valence.f90
View File

@ -103,7 +103,7 @@ subroutine d3_valence
endif
aux1 (nu_i, nu_j, nu_k) = aux1 (nu_i, nu_j, nu_k) + &
2.d0 * wrk * wk (ikk) * pdvp_i (ibnd, jbnd) * &
conjg (pdvp_j (kbnd, jbnd) ) * pdvp_k (kbnd, ibnd)
CONJG(pdvp_j (kbnd, jbnd) ) * pdvp_k (kbnd, ibnd)
enddo
enddo
enddo
@ -136,7 +136,7 @@ subroutine d3_valence
do nu_i = 1, 3 * nat
if (q0mode (nu_i) .or.lgamma) then
wrk1 = DCMPLX (0.d0, 0.d0)
wrk1 = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
do jbnd = 1, nbnd
de1 = et (ibnd, ikk) - et (jbnd, ikq)
@ -148,7 +148,7 @@ subroutine d3_valence
wrk = - w_1gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
/ (degauss**2)
endif
wrk1 = wrk1 + wk (ikk) * wrk * ef_sh (nu_i) * conjg (pdvp_j ( &
wrk1 = wrk1 + wk (ikk) * wrk * ef_sh (nu_i) * CONJG(pdvp_j ( &
jbnd, ibnd) ) * pdvp_k (jbnd, ibnd)
enddo
enddo
@ -158,7 +158,7 @@ subroutine d3_valence
aux2 (nu_k, nu_i, nu_j) = aux2 (nu_k, nu_i, nu_j) + wrk1
aux2 (nu_j, nu_k, nu_i) = aux2 (nu_j, nu_k, nu_i) + wrk1
endif
wrk1 = DCMPLX (0.d0, 0.d0)
wrk1 = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
wrk1 = wrk1 + wk (ikk) * ef_sh (nu_i) * dpsidvpsi (ibnd, ibnd) &
* w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) / &
@ -166,14 +166,14 @@ subroutine d3_valence
enddo
aux2 (nu_i, nu_j, nu_k) = aux2 (nu_i, nu_j, nu_k) + wrk1
aux2 (nu_i, nu_k, nu_j) = aux2 (nu_i, nu_k, nu_j) + &
conjg (wrk1)
CONJG(wrk1)
if (lgamma) then
aux2 (nu_k, nu_i, nu_j) = aux2 (nu_k, nu_i, nu_j) + wrk1
aux2 (nu_j, nu_i, nu_k) = aux2 (nu_j, nu_i, nu_k) + &
conjg (wrk1)
CONJG(wrk1)
aux2 (nu_j, nu_k, nu_i) = aux2 (nu_j, nu_k, nu_i) + wrk1
aux2 (nu_k, nu_j, nu_i) = aux2 (nu_k, nu_j, nu_i) + &
conjg (wrk1)
CONJG(wrk1)
endif
endif
enddo
@ -185,7 +185,7 @@ subroutine d3_valence
if (.not.q0mode (nu_i) ) then
do nu_j = 1, 3 * nat
do nu_k = 1, 3 * nat
aux2 (nu_i, nu_j, nu_k) = DCMPLX (0.d0, 0.d0)
aux2 (nu_i, nu_j, nu_k) = CMPLX (0.d0, 0.d0)
enddo
enddo
endif

28
D3/d3dyn_cc.f90
View File

@ -59,7 +59,7 @@ subroutine d3dyn_cc
do ig = 1, ngm
arg = - tpi * (g (1, ig) * tau (1, na) + g (2, ig) * tau (2, na) &
+ g (3, ig) * tau (3, na) )
exc = DCMPLX (cos (arg), sin (arg) )
exc = CMPLX (cos (arg), sin (arg) )
drc_exp (ig, na) = d0rc (ig, nta) * exc
enddo
enddo
@ -69,7 +69,7 @@ subroutine d3dyn_cc
arhox = abs (rhox)
if (arhox > 1.0e-30) then
call xc (arhox, ex, ec, vx, vc)
aux (ir) = DCMPLX (e2 * (vx + vc), 0.d0)
aux (ir) = CMPLX (e2 * (vx + vc), 0.d0)
endif
enddo
@ -82,10 +82,10 @@ subroutine d3dyn_cc
do k_cart = 1, 3
na_k = k_cart + 3 * (na - 1)
work = DCMPLX (0.d0, 0.d0)
work = CMPLX (0.d0, 0.d0)
do ig = 1, ngm
work = work + DCMPLX (0.d0, 1.d0) * g (i_cart, ig) * g (j_cart, ig) &
* g (k_cart, ig) * conjg (aux (nl (ig) ) ) * drc_exp (ig, na)
work = work + CMPLX (0.d0, 1.d0) * g (i_cart, ig) * g (j_cart, ig) &
* g (k_cart, ig) * CONJG(aux (nl (ig) ) ) * drc_exp (ig, na)
enddo
@ -114,9 +114,9 @@ subroutine d3dyn_cc
na_i = i_cart + 3 * (na - 1)
do j_cart = 1, 3
na_j = j_cart + 3 * (na - 1)
work = DCMPLX (0.d0, 0.d0)
work = CMPLX (0.d0, 0.d0)
do ig = 1, ngm
work = work - conjg (aux (nl (ig) ) ) * g (i_cart, ig) * g ( &
work = work - CONJG(aux (nl (ig) ) ) * g (i_cart, ig) * g ( &
j_cart, ig) * drc_exp (ig, na)
enddo
@ -137,7 +137,7 @@ subroutine d3dyn_cc
do ig = 1, ngm
arg = - tpi * ( (g (1, ig) + xq (1) ) * tau (1, na) + (g (2, ig) &
+ xq (2) ) * tau (2, na) + (g (3, ig) + xq (3) ) * tau (3, na) )
exc = DCMPLX (cos (arg), sin (arg) )
exc = CMPLX (cos (arg), sin (arg) )
drc_exp (ig, na) = drc (ig, nta) * exc
enddo
enddo
@ -163,14 +163,14 @@ subroutine d3dyn_cc
do j_cart = 1, 3
na_j = j_cart + 3 * (na - 1)
work = DCMPLX (0.d0, 0.d0)
work = CMPLX (0.d0, 0.d0)
do ig = 1, ngm
work = work - conjg (aux (nl (ig) ) ) * drc_exp (ig, na) * &
work = work - CONJG(aux (nl (ig) ) ) * drc_exp (ig, na) * &
(g (i_cart, ig) + xq (i_cart) ) * (g (j_cart, ig) + xq (j_cart) )
enddo
d3dyn2 (na_i, nu_i, na_j) = work * omega * tpiba2
d3dyn3 (na_i, na_j, nu_i) = conjg (work) * omega * tpiba2
d3dyn3 (na_i, na_j, nu_i) = CONJG(work) * omega * tpiba2
enddo
enddo
enddo
@ -204,7 +204,7 @@ subroutine d3dyn_cc
do na_icart = 1, 3 * nat
do nb_jcart = 1, 3 * nat
work0 = work0 + ug0 (nc_kcart, nu_k) * &
conjg (u (na_icart, nu_i) ) * &
CONJG(u (na_icart, nu_i) ) * &
d3dyn0 (nc_kcart, na_icart, nb_jcart) * &
u (nb_jcart, nu_j)
enddo
@ -214,7 +214,7 @@ subroutine d3dyn_cc
work1 = (0.d0, 0.d0)
do na_icart = 1, 3 * nat
do nb_jcart = 1, 3 * nat
work1 = work1 + conjg (u (na_icart, nu_i) ) * d3dyn1 (nu_k, &
work1 = work1 + CONJG(u (na_icart, nu_i) ) * d3dyn1 (nu_k, &
na_icart, nb_jcart) * u (nb_jcart, nu_j)
enddo
enddo
@ -231,7 +231,7 @@ subroutine d3dyn_cc
do nc_kcart = 1, 3 * nat
do na_icart = 1, 3 * nat
work3 = work3 + ug0 (nc_kcart, nu_k) * &
conjg (u (na_icart, nu_i) ) * &
CONJG(u (na_icart, nu_i) ) * &
d3dyn3 (nc_kcart, na_icart, nu_j)
enddo
enddo

26
D3/d3ionq.f90
View File

@ -133,7 +133,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
arg = tpi * ( (g (1, ng) ) * (tau (1, na) - tau (1, nb) ) &
+ (g (2, ng) ) * (tau (2, na) - tau (2, nb) ) &
+ (g (3, ng) ) * (tau (3, na) - tau (3, nb) ) )
facg = fac * zv (nta) * zv (ntb) * cmplx (sin (arg), 0.d0)
facg = fac * zv (nta) * zv (ntb) * CMPLX (sin (arg), 0.d0)
fnat = fnat + facg
enddo
endif
@ -157,7 +157,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
arg = tpi * ( (g (1, ng) ) * (tau (1, na) - tau (1, nb) ) + &
(g (2, ng) ) * (tau (2, na) - tau (2, nb) ) + &
(g (3, ng) ) * (tau (3, na) - tau (3, nb) ) )
fnat = fac * zv (nta) * zv (ntb) * cmplx (sin (arg), 0.d0)
fnat = fac * zv (nta) * zv (ntb) * CMPLX (sin (arg), 0.d0)
do jcart = 1, 3
nu_j = 3 * (nb - 1) + jcart
do kcart = 1, 3
@ -189,7 +189,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
+ (g (2, ng) + q (2) ) * (tau (2, nb) - tau (2, na) ) &
+ (g (3, ng) + q (3) ) * (tau (3, nb) - tau (3, na) ) )
facg = facq * zv (nta) * zv (ntb) * &
cmplx ( - sin (argq), - cos (argq) )
CMPLX ( - sin (argq), - cos (argq) )
do jcart = 1, 3
nu_j = 3 * (nb - 1) + jcart
do kcart = 1, 3
@ -197,7 +197,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
d3dy2 (nu_j, nu_i, nu_k) = d3dy2 (nu_j, nu_i, nu_k) + facg * &
(q (icart) + g (icart, ng) ) * (q (jcart) + g (jcart, ng) ) &
* (q (kcart) + g (kcart, ng) )
d3dy3 (nu_j, nu_k, nu_i) = d3dy3 (nu_j, nu_k, nu_i) - conjg (facg) &
d3dy3 (nu_j, nu_k, nu_i) = d3dy3 (nu_j, nu_k, nu_i) - CONJG(facg) &
* (q (icart) + g (icart, ng) ) * (q (jcart) + g (jcart, ng) ) &
* (q (kcart) + g (kcart, ng) )
enddo
@ -258,21 +258,21 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
do kcart = 1, 3
nu_k = (nb - 1) * 3 + kcart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d3f * alat**3 * r (icart, nr) * r (jcart, nr) * r (kcart, nr)
if (icart == jcart) then
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - &
e2 * zv (nta) * zv (ntb) * d2f * &
DCMPLX (cos (qrg), sin (qrg) ) * alat * r (kcart, nr)
CMPLX (cos (qrg), sin (qrg) ) * alat * r (kcart, nr)
end if
enddo
nu_k = (nb - 1) * 3 + icart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d2f * alat * r (jcart, nr)
nu_k = (nb - 1) * 3 + jcart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d2f * alat * r (icart, nr)
!
! nc = na case
@ -280,21 +280,21 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
do kcart = 1, 3
nu_k = (na - 1) * 3 + kcart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d3f * alat**3 * r (icart, nr) * r (jcart, nr) * r (kcart, nr)
if (icart == jcart) then
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 *&
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) &
* d2f * alat * r (kcart, nr)
end if
enddo
nu_k = (na - 1) * 3 + icart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d2f * alat * r (jcart, nr)
nu_k = (na - 1) * 3 + jcart
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * &
zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) * &
d2f * alat * r (icart, nr)
!
! na = nb case (NB: role of nu_k and nu_j are interchanged)
@ -363,7 +363,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
do na_icart = 1, 3 * nat
do nb_jcart = 1, 3 * nat
work = work + ug0 (nc_kcart, nu_k) * &
conjg (u (na_icart, nu_i) ) * &
CONJG(u (na_icart, nu_i) ) * &
d3dy1 (nc_kcart, na_icart, nb_jcart) * &
u (nb_jcart, nu_j)
enddo

10
D3/d3vrho.f90
View File

@ -46,7 +46,7 @@ subroutine d3vrho
d3dynwrk (:,:,:) = (0.d0, 0.d0)
do ir = 1, nrxx
rhog (ir) = cmplx (rho (ir, 1), 0.d0)
rhog (ir) = CMPLX (rho (ir, 1), 0.d0)
enddo
call cft3 (rhog, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
@ -63,8 +63,8 @@ subroutine d3vrho
gtau = tpi * (g (1, ng) * tau (1, na) + g (2, ng) * tau (2, na) &
+ g (3, ng) * tau (3, na) )
fac = vloc (igtongl (ng), ityp (na) ) * tpiba2 * tpiba * omega *&
(real (rhog (nl (ng) ) ) * sin (gtau) + &
DIMAG (rhog (nl (ng) ) ) * cos (gtau) )
(DBLE (rhog (nl (ng) ) ) * sin (gtau) + &
AIMAG (rhog (nl (ng) ) ) * cos (gtau) )
d3dynwrk (na_i, na_j, na_k) = d3dynwrk (na_i, na_j, na_k) + &
fac * g (icart, ng) * g (jcart, ng) * g (kcart, ng)
enddo
@ -132,7 +132,7 @@ subroutine d3vrho
#endif
d3dynwrk (na_k, na_i, na_j) = d3dynwrk (na_k, na_i, na_j) - &
2.0d0 * dvan(ikb,ikb,nt) * wgg * &
DIMAG(alpha(1)*alpha(2) + alpha(3)*alpha(4) +&
AIMAG(alpha(1)*alpha(2) + alpha(3)*alpha(4) +&
alpha(5)*alpha(6) + alpha(7)*alpha(8))
enddo
endif
@ -159,7 +159,7 @@ subroutine d3vrho
do kcart = 1, 3 * nat
do icart = 1, 3 * nat
do jcart = 1, 3 * nat
work = work + ug0 (kcart, na_k) * conjg (u (icart, na_i) ) &
work = work + ug0 (kcart, na_k) * CONJG(u (icart, na_i) ) &
* d3dynwrk (kcart, icart, jcart) * u (jcart, na_j)
enddo
enddo

14
D3/dpsidpsidv.f90
View File

@ -82,8 +82,8 @@ subroutine dpsidpsidv
nrec = nu_z + (ik - 1) * 3 * nat
call davcio (psidqvpsi, lrpdqvp, iupd0vp, nrec, - 1)
wrk0 = DCMPLX (0.d0, 0.d0)
wrk = DCMPLX (0.d0, 0.d0)
wrk0 = CMPLX (0.d0, 0.d0)
wrk = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
do jbnd = 1, nbnd
if (degauss /= 0.d0) then
@ -93,7 +93,7 @@ subroutine dpsidpsidv
wg2 = wga (jbnd) / deltae
wrk0 = wrk0 + psidqvpsi (jbnd, ibnd) * &
(wg1 * ps1_ij (ibnd, jbnd) - &
wg2 * conjg (ps1_ji (jbnd, ibnd) ) )
wg2 * CONJG(ps1_ji (jbnd, ibnd) ) )
else
wg1 = wga (ibnd)
wwg = w0g (ibnd)
@ -143,8 +143,8 @@ subroutine dpsidpsidv
nrec = nu_z + (ik - 1) * 3 * nat
call davcio (psidqvpsi, lrpdqvp, iupdqvp, nrec, - 1)
wrk0 = DCMPLX (0.d0, 0.d0)
wrk = DCMPLX (0.d0, 0.d0)
wrk0 = CMPLX (0.d0, 0.d0)
wrk = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
do jbnd = 1, nbnd
if (degauss /= 0.d0) then
@ -154,7 +154,7 @@ subroutine dpsidpsidv
wg2 = wgq (jbnd) / deltae
wrk0 = wrk0 + psidqvpsi (jbnd, ibnd) * &
(wg1 * ps2_ji (ibnd, jbnd) - &
wg2 * conjg (ps3_ij (jbnd, ibnd) ) )
wg2 * CONJG(ps3_ij (jbnd, ibnd) ) )
else
wg1 = wga (ibnd)
wwg = w0g (ibnd)
@ -178,7 +178,7 @@ subroutine dpsidpsidv
d3dyn2 (nu_i, nu_j, nu_z) = d3dyn2 (nu_i, nu_j, nu_z) &
+ wrk
d3dyn3 (nu_i, nu_z, nu_j) = d3dyn3 (nu_i, nu_z, nu_j) &
+ conjg (wrk)
+ CONJG(wrk)
enddo
endif
enddo

6
D3/dpsidvdpsi.f90
View File

@ -79,7 +79,7 @@ subroutine dpsidvdpsi (nu_q0)
do nu_j = 1, 3 * nat
nrec = (nu_j - 1) * nksq + ik
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
wrk = DCMPLX (0.d0, 0.d0)
wrk = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
if (degauss /= 0.d0) wg1 = wk (ikk) * wga (ibnd)
wrk = wrk + 2.d0 * wg1 * &
@ -130,7 +130,7 @@ subroutine dpsidvdpsi (nu_q0)
do nu_j = 1, 3 * nat
nrec = (nu_j - 1) * nksq + ik
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
wrk = DCMPLX (0.d0, 0.d0)
wrk = CMPLX (0.d0, 0.d0)
do ibnd = 1, nbnd
if (degauss.ne.0.d0) wg1 = wk (ikk) * wga (ibnd)
wrk = wrk + 2.d0 * wg1 * &
@ -140,7 +140,7 @@ subroutine dpsidvdpsi (nu_q0)
call reduce (2, wrk)
#endif
d3dyn2 (nu_i, nu_z, nu_j) = d3dyn2 (nu_i, nu_z, nu_j) + wrk
d3dyn3 (nu_i, nu_j, nu_z) = d3dyn3 (nu_i, nu_j, nu_z) + conjg(wrk)
d3dyn3 (nu_i, nu_j, nu_z) = d3dyn3 (nu_i, nu_j, nu_z) + CONJG(wrk)
enddo
enddo
enddo

2
D3/dqrhod2v.f90
View File

@ -74,7 +74,7 @@ SUBROUTINE dqrhod2v (ipert, drhoscf)
gtau = tpi * ( (xq (1) + g (1, ng) ) * tau (1, na) + &
(xq (2) + g (2, ng) ) * tau (2, na) + &
(xq (3) + g (3, ng) ) * tau (3, na) )
fac = DCMPLX (COS (gtau), - SIN (gtau) )
fac = CMPLX (COS (gtau), - SIN (gtau) )
d3dywrk (na_icart, na_jcart) = d3dywrk (na_icart, na_jcart) &
- tpiba2 * omega * (xq (icart) + g (icart, ng) ) * &
(xq (jcart) + g (jcart, ng) ) * &

4
D3/drho_drc.f90
View File

@ -59,8 +59,8 @@ SUBROUTINE drho_drc (iudrho_x, u_x, xq_x, drc_x, scale)
guexp = tpiba * ( (g (1, ig) + xq_x (1) ) * uact (mu + 1) &
+ (g (2, ig) + xq_x (2) ) * uact (mu + 2) &
+ (g (3, ig) + xq_x (3) ) * uact (mu + 3) )&
* DCMPLX (0.d0, - 1.d0) &
* DCMPLX (COS (gtau), - SIN (gtau) )
* CMPLX (0.d0, - 1.d0) &
* CMPLX (COS (gtau), - SIN (gtau) )
drhoc (nl (ig) ) = drhoc (nl (ig) ) + drc_x (ig, nt) * guexp
ENDDO
ENDIF

4
D3/dvdpsi.f90
View File

@ -84,7 +84,7 @@ subroutine dvdpsi (nu_i, xq_, dvloc, vkb_, vkbq_, psi_, dvpsi_)
!
do ig = 1, npw
wrk2 (ig) = vkb_(ig,jkb) * &
conjg(DCMPLX(0.d0,1.d0) *tpiba * &
CONJG(CMPLX(0.d0,1.d0) *tpiba * &
(g (1, igk (ig) ) * u_x (mu + 1, nu_i) + &
g (2, igk (ig) ) * u_x (mu + 2, nu_i) + &
g (3, igk (ig) ) * u_x (mu + 3, nu_i) ) )
@ -99,7 +99,7 @@ subroutine dvdpsi (nu_i, xq_, dvloc, vkb_, vkbq_, psi_, dvpsi_)
call reduce (4 * nbnd, ps)
#endif
do ig = 1, npwq
wrk2 (ig) = vkbq_(ig,jkb) * DCMPLX(0.d0,-1.d0) * tpiba * &
wrk2 (ig) = vkbq_(ig,jkb) * CMPLX(0.d0,-1.d0) * tpiba * &
( (g (1, igkq (ig) ) + xq_ (1) ) * u_x (mu+1, nu_i) +&
(g (2, igkq (ig) ) + xq_ (2) ) * u_x (mu+2, nu_i) +&
(g (3, igkq (ig) ) + xq_ (3) ) * u_x (mu+3, nu_i) )

2
D3/dvscf.f90
View File

@ -106,7 +106,7 @@ subroutine dvscf (nu_i, dvloc, xq_x)
guexp = tpiba * ( (g(1,ig) + xq_x(1)) * u_x(mu+1,nu_i) + &
(g(2,ig) + xq_x(2)) * u_x(mu+2,nu_i) + &
(g(3,ig) + xq_x(3)) * u_x(mu+3,nu_i) ) * &
DCMPLX(0.d0,-1.d0) * DCMPLX(cos(gtau),-sin(gtau))
CMPLX(0.d0,-1.d0) * CMPLX(cos(gtau),-sin(gtau))
aux1 (nl(ig)) = aux1 (nl(ig)) + vloc_x (ig,nt) * guexp
if (nlcc(nt)) then
aux2 (nl(ig)) = aux2 (nl(ig)) + drc_x(ig,nt) * guexp

2
D3/incdrhoscf2.f90
View File

@ -95,7 +95,7 @@ subroutine incdrhoscf2 (drhoscf, weight, ik, dbecsum, mode, flag)
call cft3s (dpsic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, + 2)
do ir = 1, nrxxs
drhoscf (ir) = drhoscf (ir) + wgt * conjg (psi (ir) ) * dpsic (ir)
drhoscf (ir) = drhoscf (ir) + wgt * CONJG(psi (ir) ) * dpsic (ir)
! if (ir.lt.20) WRITE( stdout,*) drhoscf(ir)
enddo

4
D3/qstar_d3.f90
View File

@ -92,7 +92,7 @@ subroutine qstar_d3 (d3dyn, at, bg, nat, nsym, s, invs, irt, rtau, &
rtau, sxq (1, iq) )
endif
enddo
phi2 = phi2 / float (nsq)
phi2 = phi2 / DBLE (nsq)
!
! Back to cartesian coordinates
!
@ -112,7 +112,7 @@ subroutine qstar_d3 (d3dyn, at, bg, nat, nsym, s, invs, irt, rtau, &
!
! if -q is not in the star recovers its matrix by time reversal
!
phi2 (:,:,:,:,:,:) = conjg (phi2 (:,:,:,:,:,:) )
phi2 (:,:,:,:,:,:) = CONJG(phi2 (:,:,:,:,:,:) )
!
! and writes it (changing temporarily sign to q)
!

4
D3/rotate_and_add_d3.f90
View File

@ -65,11 +65,11 @@ subroutine rotate_and_add_d3 (phi, phi2, nat, isym, s, invs, irt, &
arg = (sxq (1) * (rtau(1,isym,na) - rtau(1,isym,nb) ) &
+ sxq (2) * (rtau(2,isym,na) - rtau(2,isym,nb) ) &
+ sxq (3) * (rtau(3,isym,na) - rtau(3,isym,nb) ) ) * tpi
phase = DCMPLX(cos(arg),-sin(arg))
phase = CMPLX(cos(arg),-sin(arg))
do m = 1, 3
do i = 1, 3
do j = 1, 3
work = DCMPLX(0.d0, 0.d0)
work = CMPLX(0.d0, 0.d0)
do k = 1, 3
do l = 1, 3
do n = 1, 3

2
D3/set_efsh.f90
View File

@ -81,7 +81,7 @@ subroutine set_efsh (drhoscf, imode0, irr, npe)
!
call sym_def1 (def, irr)
do ipert = 1, npe
ef_sh (imode0 + ipert) = DREAL (def (ipert) )
ef_sh (imode0 + ipert) = DBLE (def (ipert) )
enddo
WRITE( stdout, '(5x,"Pert. #",i3,": Fermi energy shift (Ryd) =", &

4
D3/set_sym_irr.f90
View File

@ -165,9 +165,9 @@ SUBROUTINE set_sym_irr (nat, at, bg, xq, s, invs, nsym, rtau, irt, &
ENDDO
arg = arg * tpi
IF (isymq.EQ.nsymtot.AND.minus_q) THEN
fase = DCMPLX (COS (arg), SIN (arg) )
fase = CMPLX (COS (arg), SIN (arg) )
ELSE
fase = DCMPLX (COS (arg), - SIN (arg) )
fase = CMPLX (COS (arg), - SIN (arg) )
ENDIF
DO ipol = 1, 3
DO jpol = 1, 3

4
D3/sym_def1.f90
View File

@ -36,7 +36,7 @@ subroutine sym_def1 (def, irr)
! the fermi energy changes (work array)
do ipert = 1, npertg0 (irr)
def (ipert) = DREAL (def (ipert) )
def (ipert) = DBLE (def (ipert) )
enddo
if (nsymq == 1) return
!
@ -55,7 +55,7 @@ subroutine sym_def1 (def, irr)
!
! normalize and exit
!
def (:) = w_def(:) / float(nsymq)
def (:) = w_def(:) / DBLE(nsymq)
return
end subroutine sym_def1

4
D3/symd0rho.f90
View File

@ -37,7 +37,7 @@ subroutine symd0rho (max_irr_dim, nper, irr, d0rho, s, ftau, nsymq, &
do j = 1, nr2
do i = 1, nr1
do ipert = 1, nper
d0rho (i, j, k, ipert) = DREAL (d0rho (i, j, k, ipert) )
d0rho (i, j, k, ipert) = DBLE (d0rho (i, j, k, ipert) )
enddo
enddo
enddo
@ -78,7 +78,7 @@ subroutine symd0rho (max_irr_dim, nper, irr, d0rho, s, ftau, nsymq, &
enddo
enddo
d0rho (:,:,:,:) = aux1 (:,:,:,:) / float (nsymq)
d0rho (:,:,:,:) = aux1 (:,:,:,:) / DBLE (nsymq)
deallocate (aux1)

6
D3/w_1gauss.f90
View File

@ -53,10 +53,10 @@ hp = 2.d0 * x * exp ( - arg)
ni = 1
a = 1.0 / sqrt (pi)
do i = 1, n
hd = 2.0d0 * x * hp - 2.0d0 * float (ni) * hd
hd = 2.0d0 * x * hp - 2.0d0 * DBLE (ni) * hd
ni = ni + 1
a = - a / (float (i) * 4.0d0)
hp = 2.0d0 * x * hd-2.0d0 * float (ni) * hp
a = - a / (DBLE (i) * 4.0d0)
hp = 2.0d0 * x * hd-2.0d0 * DBLE (ni) * hp
ni = ni + 1
w_1gauss = w_1gauss - a * hp
enddo

24
Gamma/a_h.f90
View File

@ -45,7 +45,7 @@ subroutine A_h(e,h,ah)
do ibnd = 1,nbnd
! set to zero the imaginary part of h at G=0
! needed for numerical stability
if (gstart==2) h(1,ibnd) = cmplx(DREAL(h(1,ibnd)),0.d0)
if (gstart==2) h(1,ibnd) = CMPLX( DBLE(h(1,ibnd)),0.d0)
do j = 1,npw
ah(j,ibnd) = (g2kin(j)-e(ibnd)) * h(j,ibnd)
end do
@ -59,22 +59,22 @@ subroutine A_h(e,h,ah)
do j = 1,npw
psic (nl (igk(j))) = evc(j,ibnd) + (0.0,1.d0)* evc(j,ibnd+1)
dpsic(nl (igk(j))) = h(j,ibnd) + (0.0,1.d0)* h(j,ibnd+1)
psic (nlm(igk(j)))= conjg(evc(j,ibnd)-(0.0,1.d0)* evc(j,ibnd+1))
dpsic(nlm(igk(j)))= conjg( h(j,ibnd)-(0.0,1.d0)* h(j,ibnd+1))
psic (nlm(igk(j)))= CONJG(evc(j,ibnd)-(0.0,1.d0)* evc(j,ibnd+1))
dpsic(nlm(igk(j)))= CONJG( h(j,ibnd)-(0.0,1.d0)* h(j,ibnd+1))
end do
else
do j = 1,npw
psic (nl (igk(j))) = evc(j,ibnd)
dpsic(nl (igk(j))) = h(j,ibnd)
psic (nlm(igk(j))) = conjg( evc(j,ibnd))
dpsic(nlm(igk(j))) = conjg( h(j,ibnd))
psic (nlm(igk(j))) = CONJG( evc(j,ibnd))
dpsic(nlm(igk(j))) = CONJG( h(j,ibnd))
end do
end if
call cft3s( psic,nr1,nr2,nr3,nrx1,nr2,nr3,2)
call cft3s(dpsic,nr1,nr2,nr3,nrx1,nr2,nr3,2)
do j = 1,nrxx
drho(j) = drho(j) - 2.0*degspin/omega * &
DREAL(psic(j)*conjg(dpsic(j)))
DBLE(psic(j)*CONJG(dpsic(j)))
dpsic(j) = dpsic(j) * vrs(j,current_spin)
end do
call cft3s(dpsic,nr1,nr2,nr3,nrx1,nr2,nr3,-2)
@ -83,8 +83,8 @@ subroutine A_h(e,h,ah)
do j = 1,npw
fp = (dpsic (nl(igk(j))) + dpsic (nlm(igk(j))))*0.5d0
fm = (dpsic (nl(igk(j))) - dpsic (nlm(igk(j))))*0.5d0
ah(j,ibnd ) = ah(j,ibnd) +cmplx(DREAL(fp), DIMAG(fm))
ah(j,ibnd+1) = ah(j,ibnd+1)+cmplx(DIMAG(fp),-DREAL(fm))
ah(j,ibnd ) = ah(j,ibnd) +CMPLX( DBLE(fp), AIMAG(fm))
ah(j,ibnd+1) = ah(j,ibnd+1)+CMPLX(AIMAG(fp),- DBLE(fm))
end do
else
do j = 1,npw
@ -99,7 +99,7 @@ subroutine A_h(e,h,ah)
if (nkb.gt.0) call add_vuspsi (npwx, npw, nbnd, h, ah)
!
do j = 1,nrxx
drhoc(j) = DCMPLX(drho(j),0.d0)
drhoc(j) = CMPLX(drho(j),0.d0)
end do
call cft3(drhoc,nr1,nr2,nr3,nrx1,nr2,nr3,-1)
!
@ -130,7 +130,7 @@ subroutine A_h(e,h,ah)
!
do j = gstart,ngm
drhoc(nl (j)) = e2*fpi*drhoc(nl(j))/ (tpiba2*gg(j))
drhoc(nlm(j)) = conjg(drhoc(nl (j)))
drhoc(nlm(j)) = CONJG(drhoc(nl (j)))
end do
call cft3(drhoc,nr1,nr2,nr3,nrx1,nr2,nr3,+1)
!
@ -138,7 +138,7 @@ subroutine A_h(e,h,ah)
!
dv => auxr
do j = 1,nrxx
dv(j) = - DREAL(dvxc(j)) - DREAL(drhoc(j))
dv(j) = - DBLE(dvxc(j)) - DBLE(drhoc(j))
end do
!
call vloc_psi(npwx, npw, nbnd, evc, dv, ah)
@ -147,7 +147,7 @@ subroutine A_h(e,h,ah)
! needed for numerical stability
if (gstart.eq.2) then
do ibnd = 1, nbnd
ah(1,ibnd) = cmplx(DREAL(ah(1,ibnd)),0.d0)
ah(1,ibnd) = CMPLX( DBLE(ah(1,ibnd)),0.d0)
end do
end if
!

20
Gamma/dgradcorr.f90
View File

@ -183,16 +183,16 @@ subroutine gradient1(nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
do n = 1, ngm
gaux(nl (n)) = CMPLX(0.d0, g(ipol , n))* a (nl(n)) - &
g(ipol+1, n) * a (nl(n))
gaux(nlm(n)) = CMPLX(0.d0, - g(ipol , n))* conjg(a (nl(n))) + &
g(ipol+1, n) * conjg(a (nl(n)))
gaux(nlm(n)) = CMPLX(0.d0, - g(ipol , n))* CONJG(a (nl(n))) + &
g(ipol+1, n) * CONJG(a (nl(n)))
enddo
! bring back to R-space, (\grad_ipol a)(r) ...
call cft3 (gaux, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
! ...and add the factor 2\pi/a missing in the definition of q+G
do n = 1, nrxx
ga (ipol , n) = DREAL(gaux (n)) * tpiba
ga (ipol+1, n) = DIMAG(gaux (n)) * tpiba
ga (ipol , n) = DBLE(gaux (n)) * tpiba
ga (ipol+1, n) = AIMAG(gaux (n)) * tpiba
enddo
! z
ipol=3
@ -201,13 +201,13 @@ subroutine gradient1(nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
enddo
do n = 1, ngm
gaux(nl (n)) = CMPLX(0.d0, g(ipol, n)) * a (nl(n))
gaux(nlm(n)) = conjg(gaux(nl(n)))
gaux(nlm(n)) = CONJG(gaux(nl(n)))
enddo
! bring back to R-space, (\grad_ipol a)(r) ...
call cft3 (gaux, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
! ...and add the factor 2\pi/a missing in the definition of q+G
do n = 1, nrxx
ga (ipol, n) = DREAL(gaux (n)) * tpiba
ga (ipol, n) = DBLE(gaux (n)) * tpiba
enddo
! enddo
deallocate (gaux)
@ -243,7 +243,7 @@ subroutine grad_dot1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
ipol=1
! copy a(ipol,r) to a complex array...
do n = 1, nrxx
aux (n) = CMPLX(DREAL(a(ipol, n)),DREAL(a(ipol+1, n)))
aux (n) = CMPLX( DBLE(a(ipol, n)), DBLE(a(ipol+1, n)))
enddo
! bring a(ipol,r) to G-space, a(G) ...
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
@ -251,8 +251,8 @@ subroutine grad_dot1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
do n = 1, ngm
fp = (aux(nl (n)) + aux (nlm(n)))*0.5d0
fm = (aux(nl (n)) - aux (nlm(n)))*0.5d0
aux1 = cmplx(DREAL(fp), DIMAG(fm))
aux2 = cmplx(DIMAG(fp),-DREAL(fm))
aux1 = CMPLX( DBLE(fp), AIMAG(fm))
aux2 = CMPLX(AIMAG(fp),- DBLE(fm))
da (nl(n)) = da (nl(n)) + CMPLX(0.d0, g(ipol , n)) * aux1 + &
CMPLX(0.d0, g(ipol+1, n)) * aux2
end do
@ -270,7 +270,7 @@ subroutine grad_dot1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
enddo
!!! enddo
do n = 1, ngm
da(nlm(n)) = conjg(da(nl(n)))
da(nlm(n)) = CONJG(da(nl(n)))
enddo
! bring back to R-space, (\grad_ipol a)(r) ...
call cft3 (da, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)

14
Gamma/dvpsi_kb.f90
View File

@ -52,29 +52,29 @@ subroutine dvpsi_kb(kpoint,nu)
gu = tpiba*( g(1,ng)*u(mu+1,nu) + &
g(2,ng)*u(mu+2,nu) + &
g(3,ng)*u(mu+3,nu) )
exc = gu * cmplx(-sin(gtau),-cos(gtau))
exc = gu * CMPLX(-sin(gtau),-cos(gtau))
dvloc (nl(ng))=dvloc (nl(ng)) + vloc(igtongl(ng),nt)*exc
if (nlcc(nt)) dvb_cc(nl(ng)) = dvb_cc(nl(ng)) + workcc(ng) * exc
end do
end if
end do
do ng = gstart,ngm
dvloc (nlm(ng))=conjg(dvloc(nl(ng)))
dvloc (nlm(ng))=CONJG(dvloc(nl(ng)))
end do
!
! dVloc/dtau in real space
!
call cft3(dvloc, nr1,nr2,nr3,nrx1,nr2,nr3,+1)
do ir = 1,nrxx
dv(ir) = DREAL(dvloc(ir))
dv(ir) = DBLE(dvloc(ir))
end do
if (has_nlcc) then
do ng = gstart,ngm
dvb_cc (nlm(ng))=conjg(dvb_cc(nl(ng)))
dvb_cc (nlm(ng))=CONJG(dvb_cc(nl(ng)))
end do
call cft3(dvb_cc,nr1,nr2,nr3,nrx1,nr2,nr3,+1)
do ir = 1,nrxx
dv(ir) = dv(ir) + DREAL(dvb_cc(ir)) * dmuxc(ir)
dv(ir) = dv(ir) + DBLE(dvb_cc(ir)) * dmuxc(ir)
end do
end if
!
@ -102,8 +102,8 @@ subroutine dvpsi_kb(kpoint,nu)
!
do ih = 1,nh(nt)
do ik = 1,npw
work(ik,ih) = vkb(ik,jkb+ih) * &
cmplx(0.d0,-tpiba*( g(1,igk(ik))*u(mu+1,nu) + &
work(ik,ih) = vkb(ik,jkb+ih) * CMPLX(0.d0,-1.d0) * &
(tpiba*( g(1,igk(ik))*u(mu+1,nu) + &
g(2,igk(ik))*u(mu+2,nu) + &
g(3,igk(ik))*u(mu+3,nu) ) )
end do

16
Gamma/dynmatcc.f90
View File

@ -56,17 +56,17 @@ subroutine dynmatcc(dyncc)
exg = tpi* ( g(1,ig)*tau(1,na) + &
g(2,ig)*tau(2,na) + &
g(3,ig)*tau(3,na) )
exc = cmplx(cos(exg),-sin(exg))*tpiba2
work1(ig)= drhocc(ig)* exc * conjg(vxc(nl(ig)))
gc(ig,1) = g(1,ig) * exc * cmplx(0.0,-1.0)
gc(ig,2) = g(2,ig) * exc * cmplx(0.0,-1.0)
gc(ig,3) = g(3,ig) * exc * cmplx(0.0,-1.0)
exc = CMPLX(cos(exg),-sin(exg))*tpiba2
work1(ig)= drhocc(ig)* exc * CONJG(vxc(nl(ig)))
gc(ig,1) = g(1,ig) * exc * CMPLX(0.0,-1.0)
gc(ig,2) = g(2,ig) * exc * CMPLX(0.0,-1.0)
gc(ig,3) = g(3,ig) * exc * CMPLX(0.0,-1.0)
end do
do i=1,3
do j=1,3
do ig=1,ngm
dyncc1(i,na,j,na) = dyncc1(i,na,j,na) - &
real(work1(ig)) * g(i,ig) * g(j,ig)
DBLE(work1(ig)) * g(i,ig) * g(j,ig)
end do
end do
end do
@ -84,14 +84,14 @@ subroutine dynmatcc(dyncc)
exg = tpi* ( g(1,ig)*tau(1,nb) + &
g(2,ig)*tau(2,nb) + &
g(3,ig)*tau(3,nb) )
exc = -cmplx(sin(exg),cos(exg))
exc = -CMPLX(sin(exg),cos(exg))
work1(ig) = exc * drhocc(ig)
end do
do i=1,3
do j=1,3
do ig=1,ngm
dyncc1(i,na,j,nb) = dyncc1(i,na,j,nb) + &
real( work1(ig)*conjg(gc(ig,i)))*g(j,ig)
DBLE( work1(ig)*CONJG(gc(ig,i)))*g(j,ig)
end do
end do
end do

4
Gamma/h_h.f90
View File

@ -33,7 +33,7 @@ subroutine H_h(e,h,Ah)
do ibnd = 1,nbnd
! set to zero the imaginary part of h at G=0
! needed for numerical stability
if (gstart==2) h(1,ibnd) = cmplx(DREAL(h(1,ibnd)),0.d0)
if (gstart==2) h(1,ibnd) = CMPLX( DBLE(h(1,ibnd)),0.d0)
do j = 1,npw
ah(j,ibnd) = (g2kin(j)-e(ibnd)) * h(j,ibnd)
end do
@ -47,7 +47,7 @@ subroutine H_h(e,h,Ah)
! needed for numerical stability
if (gstart==2) then
do ibnd = 1, nbnd
ah(1,ibnd) = cmplx(DREAL(ah(1,ibnd)),0.d0)
ah(1,ibnd) = CMPLX( DBLE(ah(1,ibnd)),0.d0)
end do
end if
!

4
Gamma/pw_dot.f90
View File

@ -24,11 +24,11 @@ subroutine pw_dot(sum_over_nodes,n,m,a,lda,b,ldb,c)
real(kind=DP) :: c(m)
! local
integer i
real(kind=DP) :: DDOT
real(kind=DP), EXTERNAL :: DDOT
!
do i= 1,m
c(i) = 2.d0*DDOT(2*n,a(1,i),1,b(1,i),1)
if (gstart==2) c(i) = c(i) - real(a(1,i))*real(b(1,i))
if (gstart==2) c(i) = c(i) - DBLE(a(1,i))*DBLE(b(1,i))
end do
#ifdef __PARA
if (sum_over_nodes.eq.'y'.or.sum_over_nodes.eq.'Y') call reduce(m,c)

6
Gamma/rhod2vkb.f90
View File

@ -55,8 +55,8 @@ subroutine rhod2vkb(dyn0)
g(2,ng)*tau(2,na) + &
g(3,ng)*tau(3,na) )
fac = omega * vloc(igtongl(ng),ityp(na)) * tpiba2 * &
( real(psic(nl(ng)))*cos(gtau) - &
DIMAG(psic(nl(ng)))*sin(gtau) )
( DBLE(psic(nl(ng)))*cos(gtau) - &
AIMAG(psic(nl(ng)))*sin(gtau) )
dynloc(nu_i,nu_j) = dynloc(nu_i,nu_j) + fac * &
( g(1,ng) * u(mu_i+1,nu_i) + &
g(2,ng) * u(mu_i+2,nu_i) + &
@ -105,7 +105,7 @@ subroutine rhod2vkb(dyn0)
do ipol = 1, 3
do jkb = 1, nkb
do i = 1,npw
dvkb(i,jkb) = vkb(i,jkb) * cmplx(0.d0,-tpiba) * g(ipol,igk(i))
dvkb(i,jkb) = vkb(i,jkb) * CMPLX(0.d0,-tpiba) * g(ipol,igk(i))
end do
end do
!

4
Modules/cell_base.f90
View File

@ -396,7 +396,7 @@
REAL(dbl), INTENT(IN) :: X1,Y1,Z1
REAL(dbl), INTENT(OUT) :: X2,Y2,Z2
REAL(dbl) MIC
MIC = REAL(M)
MIC = DBLE(M)
X2 = X1 - DNINT(X1/MIC)*MIC
Y2 = Y1 - DNINT(Y1/MIC)*MIC
Z2 = Z1 - DNINT(Z1/MIC)*MIC
@ -413,7 +413,7 @@
REAL(dbl), INTENT(IN) :: v(3)
REAL(dbl), INTENT(OUT) :: w(3)
REAL(dbl) :: MIC
MIC = REAL(M)
MIC = DBLE(M)
w(1) = v(1) - DNINT(v(1)/MIC)*MIC
w(2) = v(2) - DNINT(v(2)/MIC)*MIC
w(3) = v(3) - DNINT(v(3)/MIC)*MIC

2
Modules/electrons_base.f90
View File

@ -251,7 +251,7 @@
!
do iss = 1, nspin
do i = iupdwn ( iss ), iupdwn ( iss ) - 1 + nupdwn ( iss )
f (i) = nel (iss) / real (nupdwn (iss))
f (i) = nel (iss) / DBLE (nupdwn (iss))
end do
end do
!

6
Modules/energies.f90
View File

@ -105,8 +105,8 @@
self_vxc = self_vxc_in
EXC = edft%sxc * omega / REAL(NNR) !EEXC * omega / REAL(NNR)
VXC = VVXC * omega / REAL(NNR)
EXC = edft%sxc * omega / DBLE(NNR) !EEXC * omega / DBLE(NNR)
VXC = VVXC * omega / DBLE(NNR)
edft%exc = exc
edft%vxc = vxc
@ -115,7 +115,7 @@
edft%eht = edft%eh + esr - eself ! = eht
EHT = edft%eht
EPSEU = REAL(eps)
EPSEU = DBLE(eps)
edft%epseu = epseu
ETOT = EKIN + EHT + EPSEU + ENL + EXC + EVDW - ENT

4
Modules/fft_base.f90
View File

@ -5,8 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!----------------------------------------------------------------------
! FFT base Module.
! Written by Carlo Cavazzoni
@ -629,7 +628,6 @@ subroutine fft_scatter (f_in, nrx3, nxx_, f_aux, ncp_, npp_, sign)
!
! The output is overwritten on f_in ; f_aux is used as work space
!
#include "f_defs.h"
#ifdef __PARA
USE parallel_include
#endif

2
Modules/fft_scalar.f90
View File

@ -1287,7 +1287,7 @@ function allowed (nr)
pwr = 0
factors_loop: do i = 1, 5
fac = factors (i)
maxpwr = NINT ( LOG( REAL (mr) ) / LOG( REAL (fac) ) ) + 1
maxpwr = NINT ( LOG( DBLE (mr) ) / LOG( DBLE (fac) ) ) + 1
do p = 1, maxpwr
if ( mr == 1 ) EXIT factors_loop
if ( MOD (mr, fac) == 0 ) then

4
Modules/mp_wave.f90
View File

@ -5,7 +5,7 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
! Copyright (C) 2002 CP90 group
! This file is distributed under the terms of the
@ -634,7 +634,7 @@
#endif
ALLOCATE( my_buffer( ngw ) )
ALLOCATE( ibuf( nproc ) )
ctmp = CMPLX( 0.0d0 )
ctmp = CMPLX( 0.0d0, 0.d0 )
! WRITE( stdout,*) 'D: ', nproc, mpime, group

24
Modules/ptoolkit.f90
View File

@ -448,7 +448,7 @@
ioff = ib_s - 1
DO j = 1, n
DO i = 1, nb
auxa( ibuf + i ) = DCONJG( a( j, i + ioff ) )
auxa( ibuf + i ) = CONJG( a( j, i + ioff ) )
END DO
ibuf = ibuf + ldx
END DO
@ -1670,8 +1670,8 @@
EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV
! ..
! .. Intrinsic Functions ..
INTRINSIC DABS, REAL, DCMPLX, AIMAG, SIGN
INTRINSIC DABS, DBLE, AIMAG, SIGN
! cmplx removed because preprocessed
!
! .. Executable Statements ..
!
@ -1695,7 +1695,7 @@
! Reduce the lower triangle of A.
!
IF (OW(1).EQ.ME) THEN
AP( IL(1), 1 ) = REAL( AP( IL(1), 1 ) )
AP( IL(1), 1 ) = DBLE( AP( IL(1), 1 ) )
END IF
DO I = 1, N - 1
@ -1737,7 +1737,7 @@
XNORM = 0.0D0
ENDIF
ALPHR = REAL( ALPHA )
ALPHR = DBLE( ALPHA )
ALPHI = AIMAG( ALPHA )
IF( XNORM.EQ.RZERO .AND. ALPHI.EQ.RZERO ) THEN
TAUI = RZERO
@ -1773,10 +1773,10 @@
XNORM = 0.0D0
ENDIF
ALPHA = DCMPLX( ALPHR, ALPHI )
ALPHA = CMPLX( ALPHR, ALPHI )
BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
TAUI = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA)
ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA )
ALPHA = ZLADIV( ONE, ALPHA-BETA )
IF(NI1.GT.0) THEN
CALL ZSCAL( NI1, ALPHA, AP( I2, I ), 1 )
@ -1789,8 +1789,8 @@
ELSE
TAUI = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA)
ALPHA = ZLADIV( DCMPLX( RONE ), ALPHA-BETA )
TAUI = CMPLX( (BETA-ALPHR)/BETA, -ALPHI/BETA )
ALPHA = ZLADIV( ONE, ALPHA-BETA )
IF(NI1.GT.0) THEN
CALL ZSCAL( NI1, ALPHA, AP( I2, I ), 1 )
@ -1961,7 +1961,7 @@
AP(IL(I+1),I) = E( I )
END IF
IF(OW(I).EQ.ME) THEN
D( I ) = REAL(AP( IL(I),I ))
D( I ) = DBLE(AP( IL(I),I ))
END IF
#if defined __PARA
# if defined __MPI
@ -1971,7 +1971,7 @@
TAU( I ) = TAUI
END DO
IF(OW(I).EQ.ME) THEN
D( N ) = REAL(AP( IL(I),I ))
D( N ) = DBLE(AP( IL(I),I ))
END IF
#if defined __PARA
# if defined __MPI

3
Modules/read_cards.f90
View File

@ -201,9 +201,8 @@ MODULE read_cards_module
input_line( i : i ) = capital( input_line( i : i ) )
END DO
!
! WRITE(*,*) 'CARD=', card
!
WRITE(*,*) 'CARD=', card
IF ( TRIM(card) == 'AUTOPILOT' ) THEN
!
CALL card_autopilot( input_line )

24
Modules/stick_base.f90
View File

@ -76,9 +76,9 @@
DO k= 1, ub(3)
kip = k + ABS(lb(3)) + 1
IF( MOD( kip, nproc_pool ) == me_pool ) THEN
gsq= (REAL(i)*b1(1)+REAL(j)*b2(1)+REAL(k)*b3(1) )**2
gsq=gsq+(REAL(i)*b1(2)+REAL(j)*b2(2)+REAL(k)*b3(2) )**2
gsq=gsq+(REAL(i)*b1(3)+REAL(j)*b2(3)+REAL(k)*b3(3) )**2
gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2
gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2
gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2
IF(gsq.LE.gcut ) THEN
st(i,j) = st(i,j) + 1
IF(gsq.LE.gcutw) THEN
@ -98,9 +98,9 @@
DO k = lb(3), ub(3)
kip = k + ABS(lb(3)) + 1
IF( MOD( kip, nproc_pool) == me_pool ) THEN
gsq= (REAL(i)*b1(1)+REAL(j)*b2(1)+REAL(k)*b3(1) )**2
gsq=gsq+(REAL(i)*b1(2)+REAL(j)*b2(2)+REAL(k)*b3(2) )**2
gsq=gsq+(REAL(i)*b1(3)+REAL(j)*b2(3)+REAL(k)*b3(3) )**2
gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2
gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2
gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2
IF(gsq.LE.gcut ) THEN
st(i,j) = st(i,j) + 1
IF(gsq.LE.gcutw) THEN
@ -120,9 +120,9 @@
DO k = lb(3), ub(3)
kip = k + ABS(lb(3)) + 1
IF( MOD( kip, nproc_pool) == me_pool ) THEN
gsq= (REAL(i)*b1(1)+REAL(j)*b2(1)+REAL(k)*b3(1) )**2
gsq=gsq+(REAL(i)*b1(2)+REAL(j)*b2(2)+REAL(k)*b3(2) )**2
gsq=gsq+(REAL(i)*b1(3)+REAL(j)*b2(3)+REAL(k)*b3(3) )**2
gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2
gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2
gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2
IF(gsq.LE.gcut ) THEN
st(i,j) = st(i,j) + 1
IF(gsq.LE.gcutw) THEN
@ -144,9 +144,9 @@
DO k= lb(3), ub(3)
kip = k + ABS(lb(3)) + 1
IF( MOD( kip, nproc_pool ) == me_pool ) THEN
gsq= (REAL(i)*b1(1)+REAL(j)*b2(1)+REAL(k)*b3(1) )**2
gsq=gsq+(REAL(i)*b1(2)+REAL(j)*b2(2)+REAL(k)*b3(2) )**2
gsq=gsq+(REAL(i)*b1(3)+REAL(j)*b2(3)+REAL(k)*b3(3) )**2
gsq= (DBLE(i)*b1(1)+DBLE(j)*b2(1)+DBLE(k)*b3(1) )**2
gsq=gsq+(DBLE(i)*b1(2)+DBLE(j)*b2(2)+DBLE(k)*b3(2) )**2
gsq=gsq+(DBLE(i)*b1(3)+DBLE(j)*b2(3)+DBLE(k)*b3(3) )**2
IF(gsq.LE.gcut ) THEN
st(i,j) = st(i,j) + 1
END IF

19
Modules/wave_base.f90
View File

@ -80,7 +80,7 @@
CALL ZGEMV &
('N', ngw, ib-1, onem, wf(1,1), ngw, s(1), 1, one, wf(1,ib), 1)
END IF
anorm = SUM( REAL( wf(:,ib) * CONJG(wf(:,ib)) ) )
anorm = SUM( DBLE( wf(:,ib) * CONJG(wf(:,ib)) ) )
CALL mp_sum(anorm, gid)
anorm = 1.0d0 / MAX( SQRT(anorm), small )
CALL ZDSCAL(ngw, anorm, wf(1,ib), 1)
@ -138,7 +138,7 @@
s = zero
! ... only the processor that own G=0
IF(gzero) THEN
wftmp = -REAL(wf(1,ib))
wftmp = -DBLE(wf(1,ib))
CALL DAXPY(ib-1, wftmp, wf(1,1), nwfr, s(1), 1)
END IF
@ -149,7 +149,7 @@
END IF
IF(gzero) THEN
anorm = DNRM2( 2*(ngw-1), wf(2,ib), 1)
anorm = 2.d0 * anorm**2 + REAL( wf(1,ib) * CONJG(wf(1,ib)) )
anorm = 2.d0 * anorm**2 + DBLE( wf(1,ib) * CONJG(wf(1,ib)) )
ELSE
anorm = DNRM2( 2*ngw, wf(1,ib), 1)
anorm = 2.d0 * anorm**2
@ -231,12 +231,11 @@
IF(gzero) THEN
DO jb = 1, nx
hpsi_gamma(jb) = &
- REAL( (2.d0 * ZDOTC(ngw-1, c(2,jb), 1, dc(2), 1) + c(1,jb)*dc(1)), dbl )
- DBLE( (2.d0 * ZDOTC(ngw-1, c(2,jb), 1, dc(2), 1) + c(1,jb)*dc(1)) )
END DO
ELSE
DO jb = 1, nx
hpsi_gamma(jb) = &
- REAL( (2.d0 * ZDOTC(ngw, c(1,jb), 1, dc(1), 1)), dbl )
hpsi_gamma(jb) = - DBLE( (2.d0 * ZDOTC(ngw, c(1,jb), 1, dc(1), 1)) )
END DO
END IF
RETURN
@ -342,7 +341,7 @@
IF( gemax_l < ABS( cgrad(iabs,i,ik) ) ) THEN
gemax_l = ABS( cgrad(iabs,i,ik) )
END IF
cnormk = cnormk + REAL( ZDOTC(ngw, cgrad(1,i,ik), 1, cgrad(1,i,ik), 1), dbl)
cnormk = cnormk + DBLE( ZDOTC(ngw, cgrad(1,i,ik), 1, cgrad(1,i,ik), 1))
END DO
cnormk = cnormk * weight(ik)
cnorm = cnorm + cnormk
@ -381,7 +380,7 @@
IF (gzero) THEN
wdot_gamma = DDOT( 2*(n-1), a(2), 1, b(2), 1)
wdot_gamma = 2.0d0 * wdot_gamma + REAL( a(1) ) * REAL( b(1) )
wdot_gamma = 2.0d0 * wdot_gamma + DBLE( a(1) ) * DBLE( b(1) )
ELSE
wdot_gamma = 2.0d0 * DDOT( 2*n, a(1), 1, b(1), 1)
END IF
@ -424,7 +423,7 @@
!
IF (gzero) THEN
dot_tmp = DDOT( 2*(n-1), a(2), 1, b(2), 1)
dot_tmp = 2.0d0 * dot_tmp + REAL( a(1) ) * REAL( b(1) )
dot_tmp = 2.0d0 * dot_tmp + DBLE( a(1) ) * DBLE( b(1) )
ELSE
dot_tmp = DDOT( 2*n, a(1), 1, b(1), 1)
dot_tmp = 2.0d0*dot_tmp
@ -607,7 +606,7 @@
DO j = 1, SIZE( wf )
rranf1 = 0.5d0 - rranf()
rranf2 = 0.5d0 - rranf()
wf(j) = wf(j) + ampre * DCMPLX(rranf1, rranf2)
wf(j) = wf(j) + ampre * CMPLX(rranf1, rranf2)
END DO
RETURN
END SUBROUTINE rande_base_s

2
Nmr/Makefile
View File

@ -132,7 +132,6 @@ MODULES = \
../Modules/parser.o \
../Modules/printout_base.o \
../Modules/pseudo_types.o \
../Modules/read_cards.o \
../Modules/read_namelists.o \
../Modules/readpseudo.o \
../Modules/recvec.o \
@ -157,7 +156,6 @@ PWOBJS = \
../PW/atomic_rho.o \
../PW/atomic_wfc.o \
../PW/atomic_wfc_nc.o \
../PW/bachel.o \
../PW/becmod.o \
../PW/c_gemm.o \
../PW/ccalbec.o \

2
Nmr/add_j_bare.f90
View File

@ -42,7 +42,7 @@ subroutine add_j_bare (phi1, phi2, weight, rho)
do i = 1, nrxx
rho(i) = rho(i) + conjg(aux1(i)) * aux2(i) * weight
rho(i) = rho(i) + CONJG(aux1(i)) * aux2(i) * weight
enddo
enddo

20
Nmr/nmr.f90
View File

@ -195,7 +195,7 @@ program nmr
! tmp2(:)=dev(:,ibnd)
call add_j_bare (evc, dev, &
sign(real(iperm0,dp),real(1-isign,dp)) *wk(ik),&
sign(DBLE(iperm0),DBLE(1-isign)) *wk(ik),&
j_bare(1,b0,idir))
enddo
@ -205,7 +205,7 @@ program nmr
call grad(ik, evc, idir, dev )
call add_j_bare (dpsi, dev, &
- sign(real(iperm0,dp),real(1-isign,dp)) &
- sign(DBLE(iperm0),DBLE(1-isign)) &
*wk(ik), j_bare(1,b0,idir))
enddo
@ -228,8 +228,8 @@ program nmr
dchi = dchi+ ZDOTC(npw,evc(1,ibnd),1,dev(1,ibnd),1)
enddo
dchi = real(iperm1,dp)*real(iperm0,dp)*wk(ik)* &
(dchi-kkterm_hh(p0,p1)*real(nbnd,dp))
dchi = DBLE(iperm1)*DBLE(iperm0)*wk(ik)* &
(dchi-kkterm_hh(p0,p1)*DBLE(nbnd))
if (b0 .eq. b1) then
chihh(b0,b1) = chihh(b0,b1) + dchi
else
@ -246,8 +246,8 @@ program nmr
dchi = dchi+ ZDOTC(npw,evc(1,ibnd),1,dev(1,ibnd),1)
enddo
print *,'dchi',dchi
dchi = real(iperm1,dp)*real(iperm0,dp)*wk(ik)* &
(dchi-kkterm_vv(p0,p1)*real(nbnd,dp))
dchi = DBLE(iperm1)*DBLE(iperm0)*wk(ik)* &
(dchi-kkterm_vv(p0,p1)*DBLE(nbnd))
if (b0 .eq. b1) then
chivv(b0,b1) = chivv(b0,b1) + dchi
else
@ -262,18 +262,18 @@ program nmr
enddo
enddo
b_length = 0.001d0
chihh = -2.d0*real(chihh(:,:),dp)/(b_length**2)
chihh = -2.d0*DBLE(chihh(:,:))/(b_length**2)
chihh = chihh *(.529177d-8)**3*0.6022d24/(137.036**2)*1.d6
chi_macro= real(chihh(1,1)+chihh(2,2)+chihh(3,3),dp)/3.d0
chi_macro= DBLE(chihh(1,1)+chihh(2,2)+chihh(3,3))/3.d0
print *,'chihh_macro',chi_macro
chivv = -2.d0*real(chivv(:,:),dp)/(b_length**2)
chivv = -2.d0*DBLE(chivv(:,:))/(b_length**2)
chivv = chivv *(.529177d-8)**3*0.6022d24/(137.036**2)*1.d6
chi_macro= real(chivv(1,1)+chivv(2,2)+chivv(3,3),dp)/3.d0
chi_macro= DBLE(chivv(1,1)+chivv(2,2)+chivv(3,3))/3.d0
print *,'chivv_macro',chi_macro

4
PH/addnlcc.f90
View File

@ -55,7 +55,7 @@ subroutine addnlcc (imode0, drhoscf, npe)
! compute the exchange and correlation potential for this mode
!
nrtot = nr1 * nr2 * nr3
fac = 1.d0 / float (nspin)
fac = 1.d0 / DBLE (nspin)
do ipert = 1, npe
mode = imode0 + ipert
@ -93,7 +93,7 @@ subroutine addnlcc (imode0, drhoscf, npe)
do is = 1, nspin
dyn1 (mode, mode1) = dyn1 (mode, mode1) + &
ZDOTC (nrxx, dvaux (1, is), 1, drhoc, 1) * &
omega * fac / float (nrtot)
omega * fac / DBLE (nrtot)
enddo
enddo
enddo

2
PH/addnlcc_zstar_eu_us.f90
View File

@ -44,7 +44,7 @@ SUBROUTINE addnlcc_zstar_eu_us( drhoscf )
! compute the exchange and correlation potential for this mode
!
nrtot = nr1 * nr2 * nr3
fac = 1.d0 / float (nspin)
fac = 1.d0 / DBLE (nspin)
DO ipert = 1, npe
mode = imode0 + ipert

6
PH/addusdbec.f90
View File

@ -89,15 +89,15 @@ subroutine addusdbec (ik, wgt, psi, dbecsum)
ikb = ijkb0 + ih
do ibnd = startb, lastb
dbecsum (ijh, na) = dbecsum (ijh, na) + &
w * ( conjg(becp1(ikb,ibnd,ik)) * dbecq(ikb,ibnd) )
w * ( CONJG(becp1(ikb,ibnd,ik)) * dbecq(ikb,ibnd) )
enddo
ijh = ijh + 1
do jh = ih + 1, nh (nt)
jkb = ijkb0 + jh
do ibnd = startb, lastb
dbecsum (ijh, na) = dbecsum (ijh, na) + &
w * ( conjg(becp1(ikb,ibnd,ik)) * dbecq(jkb,ibnd) + &
conjg(becp1(jkb,ibnd,ik)) * dbecq(ikb,ibnd) )
w * ( CONJG(becp1(ikb,ibnd,ik)) * dbecq(jkb,ibnd) + &
CONJG(becp1(jkb,ibnd,ik)) * dbecq(ikb,ibnd) )
enddo
ijh = ijh + 1
enddo

2
PH/addusddens.f90
View File

@ -94,7 +94,7 @@ subroutine addusddens (drhoscf, dbecsum, irr, mode0, npe, iflag)
qmod (ig) = sqrt (gg (ig) )
enddo
endif
fact = 0.5d0 * DCMPLX (0.d0, - tpiba)
fact = 0.5d0 * CMPLX (0.d0, - tpiba)
aux(:,:,:) = (0.d0, 0.d0)
do nt = 1, ntyp
if (tvanp (nt) ) then

Some files were not shown because too many files have changed in this diff Show More