Commit 0ba38f36 authored by Matthias Redies's avatar Matthias Redies

remove d-notation

parent 45e3b727
...@@ -188,7 +188,7 @@ CONTAINS ...@@ -188,7 +188,7 @@ CONTAINS
wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin) - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin) wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin) - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin)
IF (apw(l,n)) THEN IF (apw(l,n)) THEN
fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin) fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin)
dfj(l) = 0.0d0 dfj(l) = 0.0
ELSE ELSE
dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk
fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk
......
...@@ -107,7 +107,7 @@ CONTAINS ...@@ -107,7 +107,7 @@ CONTAINS
wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin)-usdus%us(l,n,jspin)*usdus%duds(l,n,jspin) !Wronski determinante wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin)-usdus%us(l,n,jspin)*usdus%duds(l,n,jspin) !Wronski determinante
IF (apw(l,n)) THEN IF (apw(l,n)) THEN
fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin) fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin)
dfj(l) = 0.0d0 dfj(l) = 0.0
ELSE ELSE
dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk
fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk
......
...@@ -192,19 +192,19 @@ CONTAINS ...@@ -192,19 +192,19 @@ CONTAINS
n_col = indxl2g(i, nb, hmat%blacsdata%mycol, 0, hmat%blacsdata%npcol) n_col = indxl2g(i, nb, hmat%blacsdata%mycol, 0, hmat%blacsdata%npcol)
n_row = numroc (n_col, nb, hmat%blacsdata%myrow, 0, hmat%blacsdata%nprow) n_row = numroc (n_col, nb, hmat%blacsdata%myrow, 0, hmat%blacsdata%nprow)
IF (hmat%l_real) THEN IF (hmat%l_real) THEN
hmat%data_r(n_row+1:hmat%matsize1,i) = 0.d0 hmat%data_r(n_row+1:hmat%matsize1,i) = 0.0
ELSE ELSE
hmat%data_c(n_row+1:hmat%matsize1,i) = 0.d0 hmat%data_c(n_row+1:hmat%matsize1,i) = 0.0
ENDIF ENDIF
ENDDO ENDDO
! Use the ev_dist array to store the calculated values for the lower part. ! Use the ev_dist array to store the calculated values for the lower part.
IF (hmat%l_real) THEN IF (hmat%l_real) THEN
CALL pdtran(hmat%global_size1,hmat%global_size1,1.d0,hmat%data_r,1,1,& CALL pdtran(hmat%global_size1,hmat%global_size1,1.0,hmat%data_r,1,1,&
hmat%blacsdata%blacs_desc,0.d0,ev_dist%data_r,1,1,ev_dist%blacsdata%blacs_desc) hmat%blacsdata%blacs_desc,0.0,ev_dist%data_r,1,1,ev_dist%blacsdata%blacs_desc)
ELSE ELSE
CALL pztranc(hmat%global_size1,hmat%global_size2,cmplx(1.d0,0.d0),hmat%data_c,1,1,& CALL pztranc(hmat%global_size1,hmat%global_size2,cmplx(1.0,0.0),hmat%data_c,1,1,&
hmat%blacsdata%blacs_desc,cmplx(0.d0,0.d0),ev_dist%data_c,1,1,ev_dist%blacsdata%blacs_desc) hmat%blacsdata%blacs_desc,cmplx(0.0,0.0),ev_dist%data_c,1,1,ev_dist%blacsdata%blacs_desc)
ENDIF ENDIF
! Copy the calculated values to the lower part of the H matrix ! Copy the calculated values to the lower part of the H matrix
...@@ -259,11 +259,11 @@ CONTAINS ...@@ -259,11 +259,11 @@ CONTAINS
! 2b. tmp2 = ev_dist**T ! 2b. tmp2 = ev_dist**T
IF (hmat%l_real) THEN IF (hmat%l_real) THEN
CALL pdtran(ev_dist%global_size1,ev_dist%global_size1,1.d0,ev_dist%data_r,1,1,& CALL pdtran(ev_dist%global_size1,ev_dist%global_size1,1.0,ev_dist%data_r,1,1,&
ev_dist%blacsdata%blacs_desc,0.d0,tmp2_r,1,1,ev_dist%blacsdata%blacs_desc) ev_dist%blacsdata%blacs_desc,0.0,tmp2_r,1,1,ev_dist%blacsdata%blacs_desc)
ELSE ELSE
CALL pztranc(ev_dist%global_size1,ev_dist%global_size1,cmplx(1.0,0.0),ev_dist%data_c,1,1,& CALL pztranc(ev_dist%global_size1,ev_dist%global_size1,cmplx(1.0,0.0),ev_dist%data_c,1,1,&
ev_dist%blacsdata%blacs_desc,cmplx(0.d0,0.d0),tmp2_c,1,1,ev_dist%blacsdata%blacs_desc) ev_dist%blacsdata%blacs_desc,cmplx(0.0,0.0),tmp2_c,1,1,ev_dist%blacsdata%blacs_desc)
ENDIF ENDIF
! 2c. A = U**-T * tmp2 ( = U**-T * Aorig * U**-1 ) ! 2c. A = U**-T * tmp2 ( = U**-T * Aorig * U**-1 )
...@@ -307,11 +307,11 @@ CONTAINS ...@@ -307,11 +307,11 @@ CONTAINS
! Set lower half from upper half ! Set lower half from upper half
IF (hmat%l_real) THEN IF (hmat%l_real) THEN
CALL pdtran(hmat%global_size1,hmat%global_size1,1.d0,hmat%data_r,1,1,& CALL pdtran(hmat%global_size1,hmat%global_size1,1.0,hmat%data_r,1,1,&
hmat%blacsdata%blacs_desc,0.d0,ev_dist%data_r,1,1,ev_dist%blacsdata%blacs_desc) hmat%blacsdata%blacs_desc,0.0,ev_dist%data_r,1,1,ev_dist%blacsdata%blacs_desc)
ELSE ELSE
CALL pztranc(hmat%global_size1,hmat%global_size1,cmplx(1.0,0.0),hmat%data_c,1,1,& CALL pztranc(hmat%global_size1,hmat%global_size1,cmplx(1.0,0.0),hmat%data_c,1,1,&
hmat%blacsdata%blacs_desc,cmplx(0.d0,0.d0),ev_dist%data_c,1,1,ev_dist%blacsdata%blacs_desc) hmat%blacsdata%blacs_desc,cmplx(0.0,0.0),ev_dist%data_c,1,1,ev_dist%blacsdata%blacs_desc)
ENDIF ENDIF
...@@ -396,11 +396,11 @@ CONTAINS ...@@ -396,11 +396,11 @@ CONTAINS
! mult_ah_b_complex needs the transpose of U**-1, thus tmp2 = (U**-1)**T ! mult_ah_b_complex needs the transpose of U**-1, thus tmp2 = (U**-1)**T
IF (hmat%l_real) THEN IF (hmat%l_real) THEN
CALL pdtran(smat%global_size1,smat%global_size1,1.d0,smat%data_r,1,1,& CALL pdtran(smat%global_size1,smat%global_size1,1.0,smat%data_r,1,1,&
smat%blacsdata%blacs_desc,0.d0,tmp2_r,1,1,smat%blacsdata%blacs_desc) smat%blacsdata%blacs_desc,0.0,tmp2_r,1,1,smat%blacsdata%blacs_desc)
ELSE ELSE
CALL pztranc(smat%global_size1,smat%global_size1,cmplx(1.d0,0.d0),smat%data_c,1,1,& CALL pztranc(smat%global_size1,smat%global_size1,cmplx(1.0,0.0),smat%data_c,1,1,&
smat%blacsdata%blacs_desc,cmplx(0.d0,0.d0),tmp2_c,1,1,smat%blacsdata%blacs_desc) smat%blacsdata%blacs_desc,cmplx(0.0,0.0),tmp2_c,1,1,smat%blacsdata%blacs_desc)
ENDIF ENDIF
#if defined (CPP_ELPA_201705003) #if defined (CPP_ELPA_201705003)
......
...@@ -119,8 +119,8 @@ ...@@ -119,8 +119,8 @@
ENDDO ENDDO
IF ( l_mcd ) THEN ! create an energy grid for mcd-spectra IF ( l_mcd ) THEN ! create an energy grid for mcd-spectra
e_lo = 9.9d+9 e_lo = 9.9*10.0**9
e_up = -9.9d+9 e_up = -9.9*10.0**9
DO jspin = 1,input%jspins DO jspin = 1,input%jspins
DO n = 1,atoms%ntype DO n = 1,atoms%ntype
DO icore = 1 , mcd%ncore(n) DO icore = 1 , mcd%ncore(n)
......
...@@ -12,11 +12,11 @@ module m_corespec ...@@ -12,11 +12,11 @@ module m_corespec
! PARAMETERS ! PARAMETERS
complex, parameter :: cone = cmplx(1.d0,0.d0) complex, parameter :: cone = cmplx(1.0,0.0)
complex, parameter :: cimu = cmplx(0.d0,1.d0) complex, parameter :: cimu = cmplx(0.0,1.0)
real, parameter :: alpha = 7.29735257d-3 real, parameter :: alpha = 7.29735257*10.0**-3
real, parameter :: mec2 = 0.51099891d6 real, parameter :: mec2 = 0.51099891*10.0**6
real, parameter :: ecoredeep = 0.5d0 real, parameter :: ecoredeep = 0.5
integer, parameter :: edgel(11) = (/0,1,1,2,2,3,3,4,4,5,5/) integer, parameter :: edgel(11) = (/0,1,1,2,2,3,3,4,4,5,5/)
integer, parameter :: edgej(11) = (/1,1,3,3,5,5,7,7,9,9,11/) integer, parameter :: edgej(11) = (/1,1,3,3,5,5,7,7,9,9,11/)
......
...@@ -42,10 +42,10 @@ MODULE m_corespec_io ...@@ -42,10 +42,10 @@ MODULE m_corespec_io
csi%edge = "" csi%edge = ""
csi%edgeidx = 0 csi%edgeidx = 0
csi%lx = -1 csi%lx = -1
csi%ek0 = 0.d0 csi%ek0 = 0.0
csi%emn = -2.d0 csi%emn = -2.0
csi%emx = 20.d0 csi%emx = 20.0
csi%ein = 0.1d0 csi%ein = 0.1
csi%nqphi = 12 csi%nqphi = 12
csi%nqr = 20 csi%nqr = 20
...@@ -182,12 +182,12 @@ MODULE m_corespec_io ...@@ -182,12 +182,12 @@ MODULE m_corespec_io
&"maximum l: ","csi%lx = ",csi%lx,"will be used" &"maximum l: ","csi%lx = ",csi%lx,"will be used"
! csi%ek0 ! csi%ek0
if(csi%ek0.le.0.d0) then if(csi%ek0.le.0.0) then
write(*,csmsgs) trim(smeno),"found csi%ek0 <= 0.0 !"//csmsgerr ; stop write(*,csmsgs) trim(smeno),"found csi%ek0 <= 0.0 !"//csmsgerr ; stop
endif endif
csi%ek0 = csi%ek0*1000.d0 ! conversion from keV to eV csi%ek0 = csi%ek0*1000.0 ! conversion from keV to eV
csv%gamma = 1.d0+csi%ek0/mec2 csv%gamma = 1.0+csi%ek0/mec2
csv%beta = sqrt(1.d0-1.d0/(csv%gamma**2)) csv%beta = sqrt(1.0-1.0/(csv%gamma**2))
if(csi%verb.eq.1) then if(csi%verb.eq.1) then
write(*,csmsgses) trim(smeno),& write(*,csmsgses) trim(smeno),&
&"kinetic energy of incoming electrons: ","csi%ek0 = ",csi%ek0,& &"kinetic energy of incoming electrons: ","csi%ek0 = ",csi%ek0,&
...@@ -204,8 +204,8 @@ MODULE m_corespec_io ...@@ -204,8 +204,8 @@ MODULE m_corespec_io
if(csi%emn.gt.csi%emx) then if(csi%emn.gt.csi%emx) then
write(*,csmsgs) trim(smeno),"found csi%emn > csi%emx !"//csmsgerr ; stop write(*,csmsgs) trim(smeno),"found csi%emn > csi%emx !"//csmsgerr ; stop
endif endif
if(csi%ein.le.0.d0) then if(csi%ein.le.0.0) then
write(*,csmsgs) trim(smeno),"found csi%ein <= 0.d0 !"//csmsgerr ; stop write(*,csmsgs) trim(smeno),"found csi%ein <= 0.0 !"//csmsgerr ; stop
endif endif
if(((csi%emx-csi%emn)/csi%ein)-int((csi%emx-csi%emn)/csi%ein).ne.0) then if(((csi%emx-csi%emn)/csi%ein)-int((csi%emx-csi%emn)/csi%ein).ne.0) then
write(*,csmsgs) trim(smeno),& write(*,csmsgs) trim(smeno),&
...@@ -216,7 +216,7 @@ MODULE m_corespec_io ...@@ -216,7 +216,7 @@ MODULE m_corespec_io
csv%egrid = (/(csi%emn+csi%ein*dble(i), i = 0,csv%nex)/) csv%egrid = (/(csi%emn+csi%ein*dble(i), i = 0,csv%nex)/)
csv%nen = 0 csv%nen = 0
!!$ do i = 0,csv%nex !!$ do i = 0,csv%nex
!!$ if(csv%egrid(i).ge.0.d0) then !!$ if(csv%egrid(i).ge.0.0) then
!!$ csv%nen = i !!$ csv%nen = i
!!$ exit !!$ exit
!!$ endif !!$ endif
...@@ -240,9 +240,9 @@ MODULE m_corespec_io ...@@ -240,9 +240,9 @@ MODULE m_corespec_io
&csv%nen,"will be used" &csv%nen,"will be used"
if(.not.allocated(csv%eedge)) allocate(csv%eedge(csv%nljc)) if(.not.allocated(csv%eedge)) allocate(csv%eedge(csv%nljc))
csv%eedge = 0.d0 csv%eedge = 0.0
if(.not.allocated(csv%occ)) allocate(csv%occ(csv%nljc)) if(.not.allocated(csv%occ)) allocate(csv%occ(csv%nljc))
csv%occ = 0.d0 csv%occ = 0.0
l_cs = .true. l_cs = .true.
......
...@@ -44,7 +44,7 @@ CONTAINS ...@@ -44,7 +44,7 @@ CONTAINS
gg = rk(k)*gb(l) gg = rk(k)*gb(l)
IF ( apw(l) ) THEN IF ( apw(l) ) THEN
fj(k,l,ispin) = 1.0*con1 * ff / us(l,ispin) fj(k,l,ispin) = 1.0*con1 * ff / us(l,ispin)
gj(k,l,ispin) = 0.0d0 gj(k,l,ispin) = 0.0
ELSE ELSE
IF (l_flag) THEN IF (l_flag) THEN
DO jspin = 1, jspins DO jspin = 1, jspins
...@@ -167,7 +167,7 @@ CONTAINS ...@@ -167,7 +167,7 @@ CONTAINS
gg = lapw%rk(k,intspin)*gb(l) gg = lapw%rk(k,intspin)*gb(l)
IF ( apw(l) ) THEN IF ( apw(l) ) THEN
fj(k,l,ispin,intspin) = 1.0*con1 * ff / usdus%us(l,n,ispin) fj(k,l,ispin,intspin) = 1.0*con1 * ff / usdus%us(l,n,ispin)
gj(k,l,ispin,intspin) = 0.0d0 gj(k,l,ispin,intspin) = 0.0
ELSE ELSE
IF (noco%l_constr.or.l_socfirst) THEN IF (noco%l_constr.or.l_socfirst) THEN
DO jspin = 1, input%jspins DO jspin = 1, input%jspins
......
...@@ -398,8 +398,8 @@ SUBROUTINE hsmt_sph_cpu(n,atoms,mpi,isp,input,noco,iintsp,jintsp,chi,lapw,el,e_s ...@@ -398,8 +398,8 @@ SUBROUTINE hsmt_sph_cpu(n,atoms,mpi,isp,input,noco,iintsp,jintsp,chi,lapw,el,e_s
!---> update overlap and l-diagonal hamiltonian matrix !---> update overlap and l-diagonal hamiltonian matrix
kj_end = MIN(ki,lapw%nv(iintsp)) kj_end = MIN(ki,lapw%nv(iintsp))
VecHelpS = 0.d0 VecHelpS = 0.0
VecHelpH = 0.d0 VecHelpH = 0.0
DO l = 0,atoms%lmax(n) DO l = 0,atoms%lmax(n)
fjkiln = fj(ki,l,jintsp) fjkiln = fj(ki,l,jintsp)
gjkiln = gj(ki,l,jintsp) gjkiln = gj(ki,l,jintsp)
......
...@@ -88,7 +88,7 @@ CONTAINS ...@@ -88,7 +88,7 @@ CONTAINS
gg = lapw%rk(k,iintsp)*gb(l) gg = lapw%rk(k,iintsp)*gb(l)
! IF ( apw(l) ) THEN ! IF ( apw(l) ) THEN
! fj(k,l,n,iintsp) = 1.0*con1 * ff / usdus%us(l,n,isp) ! fj(k,l,n,iintsp) = 1.0*con1 * ff / usdus%us(l,n,isp)
! gj(k,l,n,iintsp) = 0.0d0 ! gj(k,l,n,iintsp) = 0.0
! ELSE ! ELSE
!---> in a spin-spiral calculation fj and gj are needed !---> in a spin-spiral calculation fj and gj are needed
!---> both interstitial spin directions at the same time !---> both interstitial spin directions at the same time
......
...@@ -139,7 +139,7 @@ CONTAINS ...@@ -139,7 +139,7 @@ CONTAINS
wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin) - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin) wronk = usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin) - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin)
IF (apw(l,n)) THEN IF (apw(l,n)) THEN
fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin) fj(l) = 1.0*const * fj(l)/usdus%us(l,n,jspin)
dfj(l) = 0.0d0 dfj(l) = 0.0
ELSE ELSE
dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk dfj(l) = const* (usdus%dus(l,n,jspin)*fj(l)-df*usdus%us(l,n,jspin))/wronk
fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk fj(l) = const* (df*usdus%uds(l,n,jspin)-fj(l)*usdus%duds(l,n,jspin))/wronk
......
...@@ -297,7 +297,7 @@ else ...@@ -297,7 +297,7 @@ else
IF (i1.EQ.1) nn = 0 IF (i1.EQ.1) nn = 0
IF (i1.EQ.2) nn = nsz(1) IF (i1.EQ.2) nn = nsz(1)
zhelp2(:,:) = 0.d0 zhelp2(:,:) = 0.0
DO j = 1,nsize DO j = 1,nsize
DO i = 1,nsz(jsp) DO i = 1,nsz(jsp)
zhelp2(i,j) = CONJG(hso(i+nn,j)) zhelp2(i,j) = CONJG(hso(i+nn,j))
...@@ -305,11 +305,11 @@ else ...@@ -305,11 +305,11 @@ else
ENDDO ! j ENDDO ! j
if (l_real) THEN if (l_real) THEN
CALL CPP_BLAS_cgemm("N","N",zmat(1)%matsize1,2*dimension%neigd,dimension%neigd,CMPLX(1.d0,0.d0),CMPLX(zmat(jsp)%data_r(:,:)),& CALL CPP_BLAS_cgemm("N","N",zmat(1)%matsize1,2*dimension%neigd,dimension%neigd,CMPLX(1.0,0.0),CMPLX(zmat(jsp)%data_r(:,:)),&
zmat(1)%matsize1, zhelp2,DIMENSION%neigd,CMPLX(0.d0,0.d0), zso(1,1,jsp2),zmat(1)%matsize1) zmat(1)%matsize1, zhelp2,DIMENSION%neigd,CMPLX(0.0,0.0), zso(1,1,jsp2),zmat(1)%matsize1)
else else
CALL CPP_BLAS_cgemm("N","N",zmat(1)%matsize1,2*dimension%neigd,dimension%neigd, CMPLX(1.d0,0.d0),zmat(jsp)%data_c(:,:),& CALL CPP_BLAS_cgemm("N","N",zmat(1)%matsize1,2*dimension%neigd,dimension%neigd, CMPLX(1.0,0.0),zmat(jsp)%data_c(:,:),&
zmat(1)%matsize1, zhelp2,DIMENSION%neigd,CMPLX(0.d0,0.d0), zso(:,:,jsp2),zmat(1)%matsize1) zmat(1)%matsize1, zhelp2,DIMENSION%neigd,CMPLX(0.0,0.0), zso(:,:,jsp2),zmat(1)%matsize1)
endif endif
ENDDO !isp ENDDO !isp
......
...@@ -287,10 +287,10 @@ c------------------------------------------------------------------- ...@@ -287,10 +287,10 @@ c-------------------------------------------------------------------
w=0 w=0
nqvect=0 nqvect=0
nshort=0 nshort=0
ReJq=0.d0 ReJq=0.0
ImJq=0.d0 ImJq=0.0
sqsin=(sin(thetaJ))**2 sqsin=(sin(thetaJ))**2
tpi = 2.d0 * pimach() tpi = 2.0 * pimach()
limit=nmagn-1 limit=nmagn-1
IF (nmagn.gt.mtypes) limit=mtypes IF (nmagn.gt.mtypes) limit=mtypes
...@@ -375,7 +375,7 @@ c... ...@@ -375,7 +375,7 @@ c...
DO ii=1,2 DO ii=1,2
Dabsq(:)=ABS(q(:,nn,qcount)+((-1)**ii)*q(:,nnn,qcount)) Dabsq(:)=ABS(q(:,nn,qcount)+((-1)**ii)*q(:,nnn,qcount))
IDabsq(:)=NINT(Dabsq(:)) IDabsq(:)=NINT(Dabsq(:))
divi(:)=ABS(Dabsq(:)/FLOAT(IDabsq(:))-1.d0) divi(:)=ABS(Dabsq(:)/FLOAT(IDabsq(:))-1.0)
IF(((Dabsq(1).LT.tol).OR.(divi(1).LT.tol)).AND. IF(((Dabsq(1).LT.tol).OR.(divi(1).LT.tol)).AND.
& ((Dabsq(2).LT.tol).OR.(divi(2).LT.tol)).AND. & ((Dabsq(2).LT.tol).OR.(divi(2).LT.tol)).AND.
& ((Dabsq(3).LT.tol).OR.(divi(3).LT.tol)))THEN & ((Dabsq(3).LT.tol).OR.(divi(3).LT.tol)))THEN
...@@ -397,12 +397,12 @@ c... ...@@ -397,12 +397,12 @@ c...
c... Now calculate Jq=Re(Jq)+i*Im(Jq) c... Now calculate Jq=Re(Jq)+i*Im(Jq)
mu=1 mu=1
DO imt=1,mtypes DO imt=1,mtypes
ReJq(mu,mu,qcount)=-2.d0*(seigv(mu,mu,qcount,1) ReJq(mu,mu,qcount)=-2.0*(seigv(mu,mu,qcount,1)
& -seigv0(mu,mu,1))/(M(mu)*M(mu)*sqsin) & -seigv0(mu,mu,1))/(M(mu)*M(mu)*sqsin)
ImJq(mu,mu,qcount)=0.d0 ImJq(mu,mu,qcount)=0.0
DO remt=mu+1,mu+nmagtype(imt)-1 DO remt=mu+1,mu+nmagtype(imt)-1
ReJq(remt,remt,qcount)=ReJq(mu,mu,qcount) ReJq(remt,remt,qcount)=ReJq(mu,mu,qcount)
ImJq(remt,remt,qcount)=0.d0 ImJq(remt,remt,qcount)=0.0
ENDDO!remt ENDDO!remt
mu=mu+nmagtype(imt) mu=mu+nmagtype(imt)
ENDDO !imt ENDDO !imt
...@@ -411,10 +411,10 @@ c... Now calculate Jq=Re(Jq)+i*Im(Jq) ...@@ -411,10 +411,10 @@ c... Now calculate Jq=Re(Jq)+i*Im(Jq)
DO nu=mu+1,nmagn DO nu=mu+1,nmagn
ReJq(mu,nu,qcount)=((seigv0(mu,nu,2)- ReJq(mu,nu,qcount)=((seigv0(mu,nu,2)-
& seigv(mu,nu,qcount,1))/(M(mu)*M(nu)*sqsin)) & seigv(mu,nu,qcount,1))/(M(mu)*M(nu)*sqsin))
& -(0.5d0*M(mu)*ReJq(mu,mu,qcount)/M(nu))- & -(0.5*M(mu)*ReJq(mu,mu,qcount)/M(nu))-
& (0.5d0*M(nu)*ReJq(nu,nu,qcount)/M(mu)) & (0.5*M(nu)*ReJq(nu,nu,qcount)/M(mu))
IF(invs)THEN IF(invs)THEN
ImJq(mu,nu,qcount)=0.d0 ImJq(mu,nu,qcount)=0.0
ELSE ELSE
ImJq(mu,nu,qcount)=((seigv(mu,nu,qcount,2) ImJq(mu,nu,qcount)=((seigv(mu,nu,qcount,2)
& -seigv(mu,nu,qcount,1))/ & -seigv(mu,nu,qcount,1))/
...@@ -479,7 +479,7 @@ c ... for one magnetic atom per unit cell ...@@ -479,7 +479,7 @@ c ... for one magnetic atom per unit cell
qcount=nqpt-1 qcount=nqpt-1
lwork=2*nshort lwork=2*nshort
ALLOCATE (Cmat(qcount,nshort),DelE(qcount),work(lwork)) ALLOCATE (Cmat(qcount,nshort),DelE(qcount),work(lwork))
Cmat=0.d0 Cmat=0.0
IF (nshort.GE.nqpt)THEN IF (nshort.GE.nqpt)THEN
WRITE(*,*) ' Please supply the data for', nshort, WRITE(*,*) ' Please supply the data for', nshort,
& 'q-points different from zero' & 'q-points different from zero'
...@@ -492,7 +492,7 @@ c ... for one magnetic atom per unit cell ...@@ -492,7 +492,7 @@ c ... for one magnetic atom per unit cell
scp=(q(1,1,n)*R(1,atsh,nn) scp=(q(1,1,n)*R(1,atsh,nn)
& +q(2,1,n)*R(2,atsh,nn) & +q(2,1,n)*R(2,atsh,nn)
& +q(3,1,n)*R(3,atsh,nn))*tpi & +q(3,1,n)*R(3,atsh,nn))*tpi
Cmat(n,nn)=Cmat(n,nn)-1.d0+cos(scp) Cmat(n,nn)=Cmat(n,nn)-1.0+cos(scp)
ENDDO ENDDO
ENDDO ENDDO
DelE(n)=ReJq(1,1,n)*2000 ! multiply by 2000 to get [mRy/muB**2] DelE(n)=ReJq(1,1,n)*2000 ! multiply by 2000 to get [mRy/muB**2]
...@@ -504,7 +504,7 @@ c ... for one magnetic atom per unit cell ...@@ -504,7 +504,7 @@ c ... for one magnetic atom per unit cell
& work,lwork,info) & work,lwork,info)
c The routine dgels returns the solution, J(n), in the array DelE(n) c The routine dgels returns the solution, J(n), in the array DelE(n)
Tc=0.d0 Tc=0.0
DO n=1,nshort DO n=1,nshort
Tc=Tc+nat(n)*DelE(n) !Mean-field Tc=1/3*(Sum_i(J_0,i)) Tc=Tc+nat(n)*DelE(n) !Mean-field Tc=1/3*(Sum_i(J_0,i))
WRITE(115,5005) n,lenR(n),DelE(n) ! J in units [mRy/muB**2] WRITE(115,5005) n,lenR(n),DelE(n) ! J in units [mRy/muB**2]
...@@ -527,7 +527,7 @@ c... Perform the back-Fourier transform ...@@ -527,7 +527,7 @@ c... Perform the back-Fourier transform
wrJ=0 wrJ=0
DO atsh=1,nat(nnn) DO atsh=1,nat(nnn)
IF(atsh.gt.shmax) STOP 'jcoff2:increase shmax!' IF(atsh.gt.shmax) STOP 'jcoff2:increase shmax!'
J=0.d0 J=0.0
DO n=1,nqpt-1 DO n=1,nqpt-1
DO nn=1,nop DO nn=1,nop
IF(w(nn,n).EQ.1)THEN IF(w(nn,n).EQ.1)THEN
...@@ -539,7 +539,7 @@ c... Perform the back-Fourier transform ...@@ -539,7 +539,7 @@ c... Perform the back-Fourier transform
ENDIF ENDIF
ENDDO !nn ENDDO !nn
ENDDO !n (qpts) ENDDO !n (qpts)
J=(J/float(nqvect))*2000.d0 ! J in units [mRy/muB**2] J=(J/float(nqvect))*2000.0 ! J in units [mRy/muB**2]
DO i=1,wrJ !A check for non-equivalent sub-shells DO i=1,wrJ !A check for non-equivalent sub-shells
IF(ABS(J-Jw(i)).LE.(tol))GOTO 55 IF(ABS(J-Jw(i)).LE.(tol))GOTO 55
ENDDO ENDDO
...@@ -565,7 +565,7 @@ c... In case of only one magnetic atom per unit cell, calculate the mean-field ...@@ -565,7 +565,7 @@ c... In case of only one magnetic atom per unit cell, calculate the mean-field
mu=mu+nmagtype(imt) mu=mu+nmagtype(imt)
ENDDO !imt ENDDO !imt
IF(nmagn.EQ.1) THEN IF(nmagn.EQ.1) THEN
Tc=157.889*M(1)*M(1)*Tc/3.d0 Tc=157.889*M(1)*M(1)*Tc/3.0
WRITE(115,*) '# Tc(mean field)= ',Tc WRITE(115,*) '# Tc(mean field)= ',Tc
ENDIF ENDIF
5008 FORMAT(i4,i4,7(1x,f14.10)) 5008 FORMAT(i4,i4,7(1x,f14.10))
......
...@@ -44,7 +44,7 @@ SUBROUTINE gen_map(atoms,sym,oneD,hybrid) ...@@ -44,7 +44,7 @@ SUBROUTINE gen_map(atoms,sym,oneD,hybrid)
ratom = 0 ratom = 0
DO ieq1 = 1,atoms%neq(itype) DO ieq1 = 1,atoms%neq(itype)
IF( all(abs(modulo(rtaual-atoms%taual(:,iatom0 + ieq1)+1d-12,1d0)).lt. 1d-10) ) THEN IF( all(abs(modulo(rtaual-atoms%taual(:,iatom0 + ieq1)+10.0**-12,1.0)).lt. 10.0**-10) ) THEN
ratom = iatom0 + ieq1 ratom = iatom0 + ieq1
hybrid%map ( iatom,isym) = ratom hybrid%map ( iatom,isym) = ratom
hybrid%tvec(:,iatom,isym) = nint ( rtaual-atoms%taual(:,ratom) ) hybrid%tvec(:,iatom,isym) = nint ( rtaual-atoms%taual(:,ratom) )
......
...@@ -107,7 +107,7 @@ C ...@@ -107,7 +107,7 @@ C
WRITE (ibfile,'('' sum = dvec**2 = '',f13.6)') sum WRITE (ibfile,'('' sum = dvec**2 = '',f13.6)') sum
ENDDO ENDDO
sum = sqrt(sum) sum = sqrt(sum)
ddist(n) = 0.5d0*sum ddist(n) = 0.5*sum
WRITE (ibfile,'(/'' ddist('',i3,'')=(.5*sum**.5) '',f13.6)') WRITE (ibfile,'(/'' ddist('',i3,'')=(.5*sum**.5) '',f13.6)')
> n,ddist(n) > n,ddist(n)
sum = 1.0/sum sum = 1.0/sum
......
...@@ -82,8 +82,8 @@ C ...@@ -82,8 +82,8 @@ C
C ---> save and data statements C ---> save and data statements
c c
save one,zero,half,eps,eps1 save one,zero,half,eps,eps1
data zero/0.0d0/,one/1.0d0/,half/0.5d0/, data zero/0.0/,one/1.0/,half/0.5/,
+ eps/1.0d-8/,eps1/1.0d-5/ + eps/1.0*10.0**-8/,eps1/1.0*10.0**-5/
c c
c----------------------------------------------------------------------- c-----------------------------------------------------------------------
if (kpri .ge. 3) then if (kpri .ge. 3) then
......
...@@ -96,7 +96,7 @@ ...@@ -96,7 +96,7 @@
IF( all( matmul(rot(:,:,i),rot(:,:,j)) IF( all( matmul(rot(:,:,i),rot(:,:,j))
& .eq.reshape((/1,0,0,0,1,0,0,0,1/),(/3,3/))) & .eq.reshape((/1,0,0,0,1,0,0,0,1/),(/3,3/)))
& .and.all(modulo(matmul(rot(:,:,i),rtau(:,j))+rtau(:,i),1.0) & .and.all(modulo(matmul(rot(:,:,i),rtau(:,j))+rtau(:,i),1.0)
& .lt.1d-10) )THEN & .lt.10.0**-10) )THEN
IF(invtab(i).ne.0) STOP 'kptgen: inverse operation