Skip to content

GitLab

Commit 3fcb97cc authored by Gustav Bihlmayer's avatar Gustav Bihlmayer
Browse files

changed behavior of setab.f to differentiate between noangles=t (scale 

the coordinate system) and noangles=f (scale the lattice vectors). The
variable is passed from lattice2.f, where also settings for latsys='rho'
have been updated.
parent 07348bb5
Hide whitespace changes
Inline Side-by-side
inpgen/crystal.f
View file @ 3fcb97cc
......@@ -8,7 +8,7 @@
> dbgfh,errfh,outfh,dispfh,dispfn,
> cal_symm,cartesian,symor,oldfleur,
> natin,natmax,nop48,
> atomid,atompos,a1,a2,a3,aa,scale,
> atomid,atompos,a1,a2,a3,aa,scale,noangles,
< invs,zrfs,invs2,nop,nop2,
< ngen,mmrot,ttr,ntype,nat,nops,
< neq,ntyrep,zatom,natype,natrep,natmap,
......@@ -25,7 +25,7 @@
IMPLICIT NONE
!===> Arguments
LOGICAL, INTENT(IN) :: cal_symm,cartesian,oldfleur
LOGICAL, INTENT(IN) :: cal_symm,cartesian,oldfleur,noangles
INTEGER, INTENT(IN) :: ngen,natmax,nop48
INTEGER, INTENT(IN) :: dbgfh,errfh,outfh,dispfh ! file handles, mainly 6
REAL, INTENT(IN) :: aa
......@@ -98,9 +98,8 @@
!
!---> generate lattice matrices (everything in mod_lattice)
!
write(*,*) aa,scale
CALL setab(
> a1,a2,a3,aa,scale,
> a1,a2,a3,aa,scale,noangles,
< amat,bmat,aamat,bbmat,amatinv,omtil)
......
inpgen/inpgen.f90
View file @ 3fcb97cc
......@@ -22,7 +22,7 @@ PROGRAM inpgen
INTEGER natmax,nop48,nline,natin,ngen,i,j
INTEGER nops,no3,no2,na,numSpecies
INTEGER infh,errfh,bfh,warnfh,symfh,dbgfh,outfh,dispfh
LOGICAL cal_symm,checkinp,newSpecies
LOGICAL cal_symm,checkinp,newSpecies,noangles
LOGICAL cartesian,oldfleur,l_hyb ,inistop
REAL aa
......@@ -71,7 +71,7 @@ PROGRAM inpgen
& natmax,nop48,&
& nline,xl_buffer,buffer,&
& title,input%film,cal_symm,checkinp,sym%symor,&
& cartesian,oldfleur,a1,a2,a3,vacuum%dvac,aa,scale,&
& cartesian,oldfleur,a1,a2,a3,vacuum%dvac,aa,scale,noangles,&
& factor,natin,atomid,atompos,ngen,mmrot,ttr,&
& l_hyb,noco%l_soc,noco%l_ss,noco%theta,noco%phi,noco%qss,inistop)!keep
......@@ -111,7 +111,7 @@ PROGRAM inpgen
& dbgfh,errfh,outfh,dispfh,dispfn,&
& cal_symm,cartesian,sym%symor,input%film,&
& natin,natmax,nop48,&
& atomid,atompos,a1,a2,a3,aa,scale,&
& atomid,atompos,a1,a2,a3,aa,scale,noangles,&
& sym%invs,sym%zrfs,sym%invs2,sym%nop,sym%nop2,&
& ngen,mmrot,ttr,atoms%ntype,atoms%nat,nops,&
& atoms%neq,ntyrep,atoms%zatom,natype,natrep,natmap,&
......
inpgen/lattice2.f
View file @ 3fcb97cc
......@@ -8,7 +8,7 @@
CONTAINS
SUBROUTINE lattice2(
> buffer,xl_buffer,errfh,bfh,nline,
< a1,a2,a3,aa,scale,ios )
< a1,a2,a3,aa,scale,noangles,ios )
USE m_constants
IMPLICIT NONE
......@@ -21,18 +21,17 @@
REAL, INTENT (OUT) :: aa
REAL, INTENT (OUT) :: scale(3)
INTEGER, INTENT (OUT) :: ios
LOGICAL, INTENT (OUT) :: noangles
!==> Local Variables
CHARACTER(len=40) :: latsys
REAL :: a0
REAL :: a,b,c
REAL :: alpha,beta,gamma
REAL :: e1,e2,e3
REAL :: c1(3),c2(3),c3(3)
REAL :: ar,br,cr,b1,b2,am(3,3),rmat(3,3)
REAL :: ar,br,cr,b1,b2,am(3,3)
REAL :: ca,cb,at
INTEGER :: i,j,err,i1,i2
LOGICAL :: noangles
REAL, PARAMETER :: eps = 1.0e-7
REAL, PARAMETER :: h = 0.5, o = 0.0 ,
......@@ -71,12 +70,11 @@
!===> 13: monoclinic-P (mS) (mA) (mB) (mC)
!===> namelists
NAMELIST /lattice/ latsys,a0,a,b,c,alpha,beta,gamma,e1,e2,e3
NAMELIST /lattice/ latsys,a0,a,b,c,alpha,beta,gamma
noangles = .false.
latsys = ' ' ; a0 = 0.0
a = 0.0 ; b = 0.0 ; c = 0.0
e1 = 0.0 ; e2 = 0.0 ; e3 = 0.0
alpha = 0.0 ; beta = 0.0 ; gamma = 0.0
READ (bfh,lattice,err=911,end=911,iostat=ios)
......@@ -99,10 +97,6 @@
cr = gamma
ENDIF
e1 = e1 * pi_const / 180.0 ! for rhomboedral lattices only
e2 = e2 * pi_const / 180.0
e3 = e3 * pi_const / 180.0
latsys = ADJUSTL(latsys)
!===> 1: cubic-P (cP) sc
......@@ -178,56 +172,23 @@
noangles=.false.
i = 5
a1 = lmat(:,1,i) ! /sqrt(3.0)
a2 = lmat(:,2,i) ! /sqrt(3.0)
a3 = lmat(:,3,i) ! /sqrt(3.0)
a1 = lmat(:,1,i)
a2 = lmat(:,2,i)
a3 = lmat(:,3,i)
IF ( a.NE.b ) err = 51
IF ( alpha.EQ.0.0 .OR.
& alpha.NE.beta .OR. alpha.NE.gamma ) err = 52
! at = a
! a = 2.0 * at * sin(ar/2.0)
! b = a
! c = at * sqrt( 4.0 / 3.0 * ( 1 + 2.0 * cos(ar) ) )
at = sqrt( 2.0 / 3.0 * ( 1 - cos(ar) ) )
a = at
b = at
c = cos( asin(at) )
!dbg+
at = sqrt( 2.0 / 3.0 * ( 1 - cos(ar) ) )
am(:,1) = a1 ; am(:,2) = a2 ; am(:,3) = a3
am(1,:) = a0*a*am(1,:)
am(2,:) = a0*b*am(2,:)
am(3,:) = a0*c*am(3,:)
a1 = am(:,1)/a0 ; a2 = am(:,2)/a0 ; a3 = am(:,3)/a0
a = 1.0 ; b = 1.0 ; c = 1.0
CALL angles( am )
!dbg-
! rmat = 0.0
! rmat(1,1) = cos(e1)
! rmat(2,2) = cos(e1)
! rmat(1,2) = -sin(e1)
! rmat(2,1) = sin(e1)
! rmat(3,3) = 1.0
!
! c1(:) = 0.0 ; c2(:) = 0.0 ; c3(:) = 0.0
! DO i = 1, 3
! DO j = 1, 3
! c1(i) = c1(i) + rmat(i,j)*a1(j)
! c2(i) = c2(i) + rmat(i,j)*a2(j)
! c3(i) = c3(i) + rmat(i,j)*a3(j)
! ENDDO
! ENDDO
! a1 = c1 ; a2 = c2 ; a3 = c3
!!dbg+
! am(:,1) = a1 ; am(:,2) = a2 ; am(:,3) = a3
! am(1,:) = a0*a*am(1,:)
! am(2,:) = a0*b*am(2,:)
! am(3,:) = a0*c*am(3,:)
! call angles( am )
!!dbg-
am(1,:) = at * am(1,:)
am(2,:) = at * am(2,:)
am(3,:) = cos(asin(at)) * am(3,:)
a1 = am(:,1) ; a2 = am(:,2) ; a3 = am(:,3)
CALL angles( am )
!===> 5.2: hexagonal-R (hR) trigonal,( rhombohedral )
ELSEIF (latsys =='hexagonal-R2'.OR.latsys =='hR2'.OR.latsys =='r2'
......@@ -537,9 +498,9 @@
c1 = (ca - cg*cb ) / sg
c2 = sqrt( 1 - cb**2 - c1**2 )
am(1,1) = 1.0 ; am(2,1) = 0.0 ; am(3,1) = 0.0
am(1,1) = 1.0 ; am(2,1) = 0.0 ; am(3,1) = 0.0
am(1,2) = cg ; am(2,2) = sg ; am(3,2) = 0.0
am(1,3) = cb ; am(2,3) = c1 ; am(3,3) = c2
am(1,3) = cb ; am(2,3) = c1 ; am(3,3) = c2
END SUBROUTINE brvmat
......
inpgen/setab.f
View file @ 3fcb97cc
......@@ -5,7 +5,7 @@
!*********************************************************************
CONTAINS
SUBROUTINE setab(
> a1,a2,a3,aa,scale,
> a1,a2,a3,aa,scale,noangles,
< amat,bmat,aamat,bbmat,amatinv,omtil)
USE m_constants
......@@ -15,6 +15,7 @@
!==> Arguments
REAL, INTENT (IN) :: aa
REAL, INTENT (IN) :: a1(3),a2(3),a3(3),scale(3)
LOGICAL, INTENT (IN) :: noangles
REAL, INTENT (OUT) :: amat(3,3),bmat(3,3),amatinv(3,3)
REAL, INTENT (OUT) :: aamat(3,3),bbmat(3,3)
REAL, INTENT (OUT) :: omtil
......@@ -45,6 +46,30 @@
omtil = (aa**3)*scale(1)*scale(2)*scale(3)*volume
! matrices of lattice vectors in full Cartesian units
IF (noangles) THEN ! we scale the coordinate system in the case of cP, cI, cF, tI etc.
DO i=1,3
amat(i,1) = aa*scale(i)*a1(i)
amat(i,2) = aa*scale(i)*a2(i)
amat(i,3) = aa*scale(i)*a3(i)
ENDDO
DO i=1,3
bmat(1,i) = (pi_const/(aa*scale(i))) * b1(i)
bmat(2,i) = (pi_const/(aa*scale(i))) * b2(i)
bmat(3,i) = (pi_const/(aa*scale(i))) * b3(i)
ENDDO
DO i=1,3
amatinv(1,i) = (1.0/(aa*scale(i))) * b1(i)
amatinv(2,i) = (1.0/(aa*scale(i))) * b2(i)
amatinv(3,i) = (1.0/(aa*scale(i))) * b3(i)
ENDDO
ELSE ! we scale the lattice vectors in the case of mP, mA, mB, aP
DO i=1,3
amat(i,1) = aa*scale(1)*a1(i)
amat(i,2) = aa*scale(2)*a2(i)
......@@ -63,6 +88,8 @@
amatinv(3,i) = (1.0/(aa*scale(3))) * b3(i)
ENDDO
ENDIF
!---> check that amat and amatinv consistent
! (amat*amatinv should be identity)
......@@ -84,9 +111,8 @@
+ ="setab")
ENDIF
aamat=matmul(transpose(amat),amat)
bbmat=matmul(transpose(bmat),bmat)
END SUBROUTINE setab
END MODULE m_setab
inpgen/struct_input.f
View file @ 3fcb97cc
......@@ -9,7 +9,7 @@
> natmax,nop48,
X nline,xl_buffer,buffer,
< title,film,cal_symm,checkinp,symor,
< cartesian,oldfleur,a1,a2,a3,dvac,aa,scale,
< cartesian,oldfleur,a1,a2,a3,dvac,aa,scale,noangles,
< factor,natin,atomid,atompos,ngen,mmrot,ttr,
< l_hyb,l_soc,l_ss,theta,phi,qss,inistop)
......@@ -26,7 +26,7 @@
CHARACTER(len=xl_buffer) :: buffer
LOGICAL :: cal_symm, checkinp, symor, film
LOGICAL :: cartesian,oldfleur,inistop
LOGICAL, INTENT (OUT) :: l_hyb,l_soc,l_ss
LOGICAL, INTENT (OUT) :: l_hyb,l_soc,l_ss,noangles
INTEGER, INTENT (OUT) :: natin
INTEGER, INTENT (OUT) :: ngen
REAL, INTENT (OUT) :: aa,theta,phi
......@@ -140,7 +140,7 @@
IF ( buffer(1:8)=='&lattice' ) THEN
CALL lattice2(
> buffer,xl_buffer,errfh,bfh,nline,
< a1,a2,a3,aa,scale,ios )
< a1,a2,a3,aa,scale,noangles,ios )
dvac = 0.00
IF ( ios.NE.0 ) THEN
WRITE (errfh,*)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment