mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-16 03:38:05 +01:00
253 lines
7.9 KiB
Fortran
Executable File
253 lines
7.9 KiB
Fortran
Executable File
************************************************************************
|
|
subroutine zmattocart(coord,natwdummy,atsymbol)
|
|
************************************************************************
|
|
* Construct Cartesian coordinates from Z-matrix
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natwdummy,iatoms,j
|
|
real*8 coord(3,natwdummy),src(3)
|
|
character*2 atsymbol(*)
|
|
logical log
|
|
C
|
|
|
|
call zconvdesc(iatoms,coord,natwdummy,atsymbol)
|
|
|
|
c do iatoms=1,natwdummy
|
|
c write(6,"(20f10.6)") (coord(j,iatoms),j=1,3)
|
|
c enddo
|
|
C Shift dummys to the end
|
|
do iatoms=1,natwdummy
|
|
if(atsymbol(iatoms).eq.'x ') atsymbol(iatoms)='X '
|
|
enddo
|
|
log=.true.
|
|
do while(log)
|
|
log=.false.
|
|
do iatoms=1,natwdummy-1
|
|
if(atsymbol(iatoms).eq.'X '.and.atsymbol(iatoms+1).ne.'X ')
|
|
$then
|
|
log=.true.
|
|
do j=1,3
|
|
src(j)=coord(j,iatoms)
|
|
enddo
|
|
do j=1,3
|
|
coord(j,iatoms)=coord(j,iatoms+1)
|
|
enddo
|
|
atsymbol(iatoms)=atsymbol(iatoms+1)
|
|
do j=1,3
|
|
coord(j,iatoms+1)=src(j)
|
|
enddo
|
|
atsymbol(iatoms+1)='X '
|
|
endif
|
|
enddo
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
************************************************************************
|
|
subroutine readminp(iatoms,natwdummy,ats,b,
|
|
$ bondl,c,ang,d,dang,label,val,npar)
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natwdummy,iatoms,a,b,c,d,i,n,npar
|
|
character*2 ats
|
|
character*1 gval(500)
|
|
character*10 chbondl,chang,chdang
|
|
real*8 bondl,ang,dang,val(*),getval
|
|
character*10 lab,label(*)
|
|
C
|
|
read(minpfile,*)ats,b,chbondl,c,chang,d,chdang
|
|
bondl=getval(chbondl,label,val,npar)
|
|
ang=getval(chang,label,val,npar)*pi/180.d0
|
|
dang=getval(chdang,label,val,npar)*pi/180.d0
|
|
C
|
|
return
|
|
end
|
|
c
|
|
************************************************************************
|
|
subroutine zconvdesc(iatoms,coord,natwdummy,atsymbol)
|
|
************************************************************************
|
|
* Computes 4th atom coordinates if prev. 3 ones are known
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer natwdummy,iatoms,i,j,b,c,d,npar
|
|
real*8 coord(3,natwdummy),absrbc,getval,
|
|
$ amatrix(3),lmn(3,3),rcb(3),rdc(3),rdccrcb(3),ncl(3),
|
|
$ n(3),l(3),absrdccrcb,ang,dang,bondl,val(natwdummy*3)
|
|
character*4 uval
|
|
character*2 atsymbol(*)
|
|
character*10 chbondl,chang,label(natwdummy*3),lab1
|
|
character*1 line(512),lab(10)
|
|
character*512 line1
|
|
equivalence(line,line1)
|
|
equivalence(lab,lab1)
|
|
C Read the values for geometrical parameters
|
|
do iatoms=1,natwdummy+1
|
|
read(minpfile,*)
|
|
enddo
|
|
npar=0
|
|
do
|
|
read(minpfile,'(512a1)',end=1000) line
|
|
if(line(1).eq.' ') exit
|
|
npar=npar+1
|
|
call lowercase(line,line,512)
|
|
j=1
|
|
do while(line(j).ne.'='.and.line(j).ne.' ')
|
|
j=j+1
|
|
enddo
|
|
do i=1,512
|
|
if(line(i).eq.'=') line(i)=' '
|
|
enddo
|
|
lab1=' '
|
|
do i=1,j-1
|
|
lab(i)=line(i)
|
|
line(i)=' '
|
|
enddo
|
|
label(npar)=lab1
|
|
line1=trim(line1)
|
|
read(line1,*) val(npar)
|
|
enddo
|
|
1000 continue
|
|
call getkeym('geom',4,uval,4)
|
|
C First atom
|
|
read(minpfile,*) atsymbol(1)
|
|
coord(1,1)=0.d0
|
|
coord(2,1)=0.d0
|
|
coord(3,1)=0.d0
|
|
C Second atom
|
|
if(natwdummy.ge.2) then
|
|
read(minpfile,*) atsymbol(2),i,chbondl
|
|
bondl=getval(chbondl,label,val,npar)
|
|
coord(1,2)=bondl
|
|
coord(2,2)=0.d0
|
|
coord(3,2)=0.d0
|
|
endif
|
|
C Third atom
|
|
if(natwdummy.ge.3) then
|
|
read(minpfile,*) atsymbol(3),i,chbondl,j,chang
|
|
bondl=getval(chbondl,label,val,npar)
|
|
ang=getval(chang,label,val,npar)*pi/180.d0
|
|
if(i.eq.1) then
|
|
coord(1,3)=bondl*dcos(ang)
|
|
else
|
|
coord(1,3)=coord(1,i)-bondl*dcos(ang)
|
|
endif
|
|
coord(2,3)=bondl*dsin(ang)
|
|
coord(3,3)=0.d0
|
|
endif
|
|
C Other atoms
|
|
do iatoms=4,natwdummy
|
|
call readminp(iatoms,natwdummy,atsymbol(iatoms),b,bondl,c,ang,d,
|
|
$dang,label,val,npar)
|
|
|
|
rcb(1)=coord(1,b)-coord(1,c)
|
|
rcb(2)=coord(2,b)-coord(2,c)
|
|
rcb(3)=coord(3,b)-coord(3,c)
|
|
rdc(1)=coord(1,c)-coord(1,d)
|
|
rdc(2)=coord(2,c)-coord(2,d)
|
|
rdc(3)=coord(3,c)-coord(3,d)
|
|
|
|
absrbc=dsqrt(rcb(1)**2+rcb(2)**2+rcb(3)**2)
|
|
lmn(1,1)=rcb(1)/absrbc
|
|
lmn(1,2)=rcb(2)/absrbc
|
|
lmn(1,3)=rcb(3)/absrbc
|
|
|
|
call crproduct(rdc,rcb,rdccrcb)
|
|
absrdccrcb=dsqrt(rdccrcb(1)**2+rdccrcb(2)**2+rdccrcb(3)**2)
|
|
lmn(3,1)=rdccrcb(1)/absrdccrcb
|
|
lmn(3,2)=rdccrcb(2)/absrdccrcb
|
|
lmn(3,3)=rdccrcb(3)/absrdccrcb
|
|
|
|
n(1)=lmn(3,1)
|
|
n(2)=lmn(3,2)
|
|
n(3)=lmn(3,3)
|
|
l(1)=lmn(1,1)
|
|
l(2)=lmn(1,2)
|
|
l(3)=lmn(1,3)
|
|
call crproduct(n,l,ncl)
|
|
lmn(2,1)=ncl(1)
|
|
lmn(2,2)=ncl(2)
|
|
lmn(2,3)=ncl(3)
|
|
|
|
amatrix(1)=-bondl*dcos(ang)
|
|
amatrix(2)=bondl*dcos(dang)*dsin(ang)
|
|
amatrix(3)=bondl*dsin(dang)*dsin(ang)
|
|
c
|
|
coord(1,iatoms)=coord(1,b)+amatrix(1)*lmn(1,1)
|
|
$ +amatrix(2)*lmn(2,1)+amatrix(3)*lmn(3,1)
|
|
coord(2,iatoms)=coord(2,b)+amatrix(1)*lmn(1,2)+
|
|
$ amatrix(2)*lmn(2,2)+amatrix(3)*lmn(3,2)
|
|
coord(3,iatoms)=coord(3,b)+amatrix(1)*lmn(1,3)+
|
|
$ amatrix(2)*lmn(2,3)+amatrix(3)*lmn(3,3)
|
|
enddo
|
|
C
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
subroutine crproduct(a,b,acb)
|
|
************************************************************************
|
|
* Computes cross product of a,b in 3 dimensions
|
|
************************************************************************
|
|
real*8 a(3),b(3),acb(3)
|
|
C
|
|
acb(1)=a(2)*b(3)-a(3)*b(2)
|
|
acb(2)=a(3)*b(1)-a(1)*b(3)
|
|
acb(3)=a(1)*b(2)-a(2)*b(1)
|
|
return
|
|
end
|
|
C
|
|
************************************************************************
|
|
real*8 function getval(lab,label,val,npar)
|
|
************************************************************************
|
|
* Get the value of a geometric parameter in Z-matrix
|
|
************************************************************************
|
|
#include "MRCCCOMMON"
|
|
integer n,npar
|
|
character*10 lab,label(*)
|
|
real*8 val(*)
|
|
C
|
|
call lowercase(lab,lab,10)
|
|
n=1
|
|
do while(label(n).ne.lab)
|
|
n=n+1
|
|
if(n.gt.npar) then
|
|
write(iout,*) 'Undefined variable in Z-matrix!'
|
|
call mrccend(1)
|
|
endif
|
|
enddo
|
|
getval=val(n)
|
|
C
|
|
return
|
|
end
|
|
C
|
|
***********************************************************************
|
|
subroutine buildinertial(natoms,coord,atmass,ten,gtol,etol)
|
|
***********************************************************************
|
|
* Construct moment of inertia tensor
|
|
***********************************************************************
|
|
implicit none
|
|
integer i,natoms
|
|
real*8 ten(3,3),coord(3,natoms),atmass(natoms),gtol,etol
|
|
C
|
|
ten=0.d0
|
|
etol=0.d0
|
|
do i=1,natoms
|
|
ten(1,1)=ten(1,1)+atmass(i)*(coord(2,i)**2+coord(3,i)**2)
|
|
ten(2,2)=ten(2,2)+atmass(i)*(coord(1,i)**2+coord(3,i)**2)
|
|
ten(3,3)=ten(3,3)+atmass(i)*(coord(1,i)**2+coord(2,i)**2)
|
|
ten(3,2)=ten(3,2)-atmass(i)*coord(2,i)*coord(3,i)
|
|
ten(1,2)=ten(1,2)-atmass(i)*coord(1,i)*coord(2,i)
|
|
ten(1,3)=ten(1,3)-atmass(i)*coord(1,i)*coord(3,i)
|
|
etol=etol+(4.d0*gtol*atmass(i)*coord(1,i))**2+
|
|
$ (4.d0*gtol*atmass(i)*coord(2,i))**2+
|
|
$ (4.d0*gtol*atmass(i)*coord(3,i))**2
|
|
enddo
|
|
etol=dsqrt(etol)!/100.d0
|
|
ten(2,3)=ten(3,2)
|
|
ten(2,1)=ten(1,2)
|
|
ten(3,1)=ten(1,3)
|
|
C
|
|
return
|
|
end
|
|
C
|