********************************************************************** * * * REAXFF Reactive force field program * * * * Developed and written by Adri van Duin, duin@wag.caltech.edu * * * * Copyright (c) 2001-2010 California Institute of Technology * * * * This is an open-source program. Feel free to modify its * * contents. Please keep me informed of any useful modification * * or addition that you made. Please do not distribute this * * program to others; if people are interested in obtaining * * a copy of this program let them contact me first. * * * ********************************************************************** ********************************************************************** subroutine ffinpt ********************************************************************** #include "cbka.blk" #include "cbkboncor.blk" #include "cbkconst.blk" #include "cbkcovbon.blk" #include "cbkff.blk" #include "cbkfftorang.blk" #include "cbknonbon.blk" #include "cbksrthb.blk" #include "cbktorsion.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "valang.blk" #include "cbksrtbon1.blk" #include "cbkchb.blk" dimension rcore2(nsort),ecore2(nsort),acore2(nsort) ********************************************************************** * * * Read in force field * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In ffinpt' c$$$ call timer(65) c$$$ close (65) c$$$ end if open (4,file='ffield.reax',status='old') rewind (4) iline=0 read (4,'(a40)',end=990,err=990)qffield iline=iline+1 ********************************************************************** * * * Read in general force field parameters * * * ********************************************************************** read (4,1100,end=990,err=990)npar iline=iline+1 do i1=1,npar read (4,1300,end=990,err=990)vpar(i1) iline=iline+1 end do cutoff=0.01*vpar(30) swa=vpar(12) if (abs(swa).gt.0.01) write (*,*) $'Warning: non-zero value for lower Taper-radius cutoff' swb=vpar(13) if (swb.lt.zero) stop $'Negative value for upper Taper-radius cutoff' if (swb.lt.5.0) write (*,*) $'Warning: very low value for upper Taper-radius cutoff:',swb ********************************************************************** * * * Read in atom type data * * * ********************************************************************** read (4,1100,end=990,err=990) nso iline=iline+1 read (4,*,end=990,err=990) iline=iline+1 read (4,*,end=990,err=990) iline=iline+1 read (4,*,end=990,err=990) iline=iline+1 if (nso.gt.nsort) stop 'Maximum number of atom types exceeded' do i1=1,nso read (4,1200,end=990,err=990)qas(i1),rat(i1),aval(i1),amas(i1), $rvdw(i1),eps(i1),gam(i1),rapt(i1),stlp(i1) iline=iline+1 read (4,1250,end=990,err=990)alf(i1),vop(i1),valf(i1), $valp1(i1),valp2(i1),chi(i1),eta(i1),vnphb iline=iline+1 read (4,1250,end=990,err=990)vnq(i1),vlp1(i1),vincr(i1), $bo131(i1),bo132(i1),bo133(i1),sigqeq(i1),default iline=iline+1 read (4,1250,end=990,err=990)vovun(i1),vval1(i1),vrom, $vval3(i1),vval4(i1),rcore2(i1),ecore2(i1),acore2(i1) iline=iline+1 idef(i1)=int(default) nphb(i1)=int(vnphb) end do ********************************************************************** * * * Calculate van der Waals and Coulomb pair-parameters * * * ********************************************************************** do i1=1,nso do i2=1,nso rcore(i1,i2)=sqrt(rcore2(i1)*rcore2(i2)) ecore(i1,i2)=sqrt(ecore2(i1)*ecore2(i2)) acore(i1,i2)=sqrt(acore2(i1)*acore2(i2)) p1co(i1,i2)=sqrt(4.0*rvdw(i1)*rvdw(i2)) p2co(i1,i2)=sqrt(eps(i1)*eps(i2)) p3co(i1,i2)=sqrt(alf(i1)*alf(i2)) gamwh=sqrt(vop(i1)*vop(i2)) gamwco(i1,i2)=1.0/gamwh**vpar(29) gamch=sqrt(gam(i1)*gam(i2)) gamcco(i1,i2)=1.0/gamch**3 rob1(i1,i2)=0.50*(rat(i1)+rat(i2)) rob2(i1,i2)=0.50*(rapt(i1)+rapt(i2)) rob3(i1,i2)=0.50*(vnq(i1)+vnq(i2)) end do end do ********************************************************************** * * * Read in bond type data * * * ********************************************************************** read (4,1100,end=990,err=990)nboty iline=iline+1 read (4,*,end=990,err=990) iline=iline+1 if (2*nboty.gt.nbotym) stop 'Maximum nr. of bond types exceeded' ih=0 do i1=1,nboty ih=ih+1 read (4,1400,end=990,err=990)nbs(ih,1),nbs(ih,2),de1(ih), $de2(ih),de3(ih),psi(ih),pdo(ih),v13cor(ih),popi(ih),vover(ih) iline=iline+1 read (4,1450,end=990,err=990)psp(ih),pdp(ih),ptp(ih), $bom(ih),bop1(ih),bop2(ih),ovc(ih),vuncor(ih) iline=iline+1 if (nbs(ih,1).ne.nbs(ih,2)) then ih=ih+1 nbs(ih,1)=nbs(ih-1,2) nbs(ih,2)=nbs(ih-1,1) de1(ih)=de1(ih-1) de2(ih)=de2(ih-1) de3(ih)=de3(ih-1) psi(ih)=psi(ih-1) pdo(ih)=pdo(ih-1) v13cor(ih)=v13cor(ih-1) vover(ih)=vover(ih-1) psp(ih)=psp(ih-1) pdp(ih)=pdp(ih-1) ptp(ih)=ptp(ih-1) bop1(ih)=bop1(ih-1) bop2(ih)=bop2(ih-1) * bop3(ih)=bop3(ih-1) * bop4(ih)=bop4(ih-1) bom(ih)=bom(ih-1) popi(ih)=popi(ih-1) ovc(ih)=ovc(ih-1) end if end do nboty2=ih ********************************************************************** * * * Read in off-diagonal parameters * * * ********************************************************************** read (4,1100,end=990,err=990)nodmty iline=iline+1 if (nodmty.gt.nodmtym) $stop 'Maximum nr. of off-diagonal Morse types exceeded' ih=0 do i1=1,nodmty ih=ih+1 read (4,1400,end=990,err=990)nodm1,nodm2,deodmh,rodmh,godmh, $rsig,rpi,rpi2 iline=iline+1 if (rsig.gt.zero) rob1(nodm1,nodm2)=rsig if (rsig.gt.zero) rob1(nodm2,nodm1)=rsig if (rpi.gt.zero) rob2(nodm1,nodm2)=rpi if (rpi.gt.zero) rob2(nodm2,nodm1)=rpi if (rpi2.gt.zero) rob3(nodm1,nodm2)=rpi2 if (rpi2.gt.zero) rob3(nodm2,nodm1)=rpi2 if (rodmh.gt.zero) p1co(nodm1,nodm2)=2.0*rodmh if (rodmh.gt.zero) p1co(nodm2,nodm1)=2.0*rodmh if (deodmh.gt.zero) p2co(nodm1,nodm2)=deodmh if (deodmh.gt.zero) p2co(nodm2,nodm1)=deodmh if (godmh.gt.zero) p3co(nodm1,nodm2)=godmh if (godmh.gt.zero) p3co(nodm2,nodm1)=godmh end do ********************************************************************** * * * Read in valency angle and conjugation type data * * * ********************************************************************** read (4,1100,end=990,err=990)nvaty iline=iline+1 if (nvaty.gt.nvatym) $stop 'Maximum nr. of valency angle types exceeded' do i1=1,nvaty read (4,1500,end=990,err=990)nvs(i1,1),nvs(i1,2), $nvs(i1,3),th0(i1),vka(i1),vka3(i1),vka8(i1),vkac(i1),vkap(i1), $vval2(i1) iline=iline+1 end do ********************************************************************** * * * Read in torsion angle type data * * * ********************************************************************** read (4,1100,end=990,err=990)ntoty iline=iline+1 if (ntoty.gt.ntotym) $stop 'Maximum nr. of torsion angle types exceeded' do i1=1,ntoty read (4,1600,end=990,err=990)nts(i1,1),nts(i1,2),nts(i1,3), $nts(i1,4),v1(i1), $v2(i1),v3(i1),v4(i1),vconj(i1),v2bo(i1),v3bo(i1) iline=iline+1 end do ********************************************************************** * * * Read in hydrogen bond type data * * * ********************************************************************** read (4,1100,end=990,err=990)nhbty iline=iline+1 if (nhbty.gt.nhbtym) $stop 'Maximum nr. of hydrogen bond types exceeded' do i1=1,nhbty read (4,1500,end=990,err=990)nhbs(i1,1),nhbs(i1,2), $nhbs(i1,3),rhb(i1),dehb(i1),vhb1(i1),vhb2(i1) iline=iline+1 end do ********************************************************************** * * * Calculate vdWaals interaction parameters * * * ********************************************************************** do i1=1,nso do i2=1,nso rr=(rvdw(i1)+rvdw(i2)) rr2=rr*rr eps2=sqrt(eps(i1)*eps(i2)) rr6=rr2*rr2*rr2 pvdw1(i1,i2)=eps2*rr6*rr6 pvdw1(i2,i1)=eps2*rr6*rr6 pvdw2(i1,i2)=2.0*eps2*rr6 pvdw2(i2,i1)=2.0*eps2*rr6 end do end do ********************************************************************** * * * Error part * * * ********************************************************************** goto 999 990 write (*,*)'Error or end-of-file reading unit 4 on line:',iline stop 999 continue close(4) ********************************************************************** * * * Format part * * * ********************************************************************** 1100 format (i3,2x,a2,3x,3d22.15) 1200 format (1x,a2,10f9.4) 1250 format (3x,10f9.4) 1300 format (f10.4) 1400 format (2i3,8f9.4) 1450 format (6x,8f9.4) 1500 format (3i3,7f9.4) 1600 format (4i3,7f9.4) return end ********************************************************************** *********************************************************************** subroutine mdsav(node) *********************************************************************** #include "cbka.blk" #include "cbkabo.blk" #include "cbkatomcoord.blk" #include "cbkbo.blk" #include "cbkc.blk" #include "cbkch.blk" #include "cbkconst.blk" #include "cbkdistan.blk" #include "cbkenergies.blk" #include "cbkia.blk" #include "cbkinit.blk" #include "cbklonpar.blk" #include "cbknubon2.blk" #include "cbkqa.blk" #include "cbktregime.blk" #include "cbksrtbon1.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "small.blk" dimension idum(mbond+3),bodum(mbond+3),qat2(2) character*25 qfileh character*33 qfile2 character*4 qext character*6 qmdfi character *7 var character *3 qat2,pepname character *1 qrtemp ************************************************************************ * * * Save coordinates, velocities and accelerations of MD-system * * * ************************************************************************ c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In mdsav' c$$$ call timer(65) c$$$ close (65) c$$$ end if ************************************************************************ c c This is just for test purposes c ************************************************************************ c$$$ write(6,*) '***************************' c$$$ write(6,*) 'mdsav node number is ',node c$$$ write(6,*) '***************************' return qfileh='Unknown' qmdfi='moldyn' pepname=' ' ipeptide=0 if (ni.eq.2) qmdfi='molsav' if (iopt.eq.0) then do i1=1,mbond+3 idum(i1)=nzero bodum(i1)=zero end do C if (napp.eq.1) C $open (7,file='fort.7',status='unknown',access='append') if (napp.ne.1) $open (7,file='fort.7',status='unknown') nsbmaxh=5*((nsbmax/5)+1) write (7,100)na,qmol,mdstep,nsbmaxh if (nbiolab.eq.1) write (67,101)na,qmol do i1=1,na bosum=0.0 do i3=1,nsbmax if (iag(i1,2+i3).gt.0) bosum=bosum+bo(nubon1(i1,i3)) end do if (nsbmax.lt.5) then write (7,200)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,5-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,5-iag(i1,2)),abo(i1),vlp(i1),ch(i1) if (nbiolab.eq.1) then !Delphi-connection table output write (67,201)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)) end if else if (nsbmax.lt.10) then write (7,210)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,10-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,10-iag(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbmax.lt.15) then write (7,220)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,15-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,15-iag(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbmax.lt.20) then write (7,230)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,20-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,20-iag(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbmax.lt.25) then write (7,240)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,25-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,25-iag(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbmax.gt.25) then write (7,250)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), $(idum(i2),i2=1,35-iag(i1,2)), $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), $(bodum(i2),i2=1,35-iag(i1,2)),abo(i1),vlp(i1),ch(i1) end if end do boss=zero vlps=0.0 C if (napp.eq.1) C $open (8,file='fort.8',status='unknown',access='append') if (napp.ne.1) $open (8,file='fort.8',status='unknown') nsbmaxh=5*((nsbma2/5)+1) write (8,100)na,qmol,mdstep,nsbmaxh chsum=0.0 do i1=1,na bosum=0.0 do i3=1,nsbma2 if (ia(i1,2+i3).gt.0) bosum=bosum+bo(nubon2(i1,i3)) end do if (nsbma2.lt.5) then write (8,200)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), $(idum(i2),i2=1,5-ia(i1,2)), $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), $(bodum(i2),i2=1,5-ia(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbma2.lt.10) then write (8,210)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), $(idum(i2),i2=1,10-ia(i1,2)), $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), $(bodum(i2),i2=1,10-ia(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbma2.lt.15) then write (8,220)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), $(idum(i2),i2=1,15-ia(i1,2)), $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), $(bodum(i2),i2=1,15-ia(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbma2.lt.20) then write (8,230)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), $(idum(i2),i2=1,20-ia(i1,2)), $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), $(bodum(i2),i2=1,20-ia(i1,2)),abo(i1),vlp(i1),ch(i1) else if (nsbma2.lt.25) then write (8,240)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), $(idum(i2),i2=1,25-ia(i1,2)), $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), $(bodum(i2),i2=1,25-ia(i1,2)),abo(i1),vlp(i1),ch(i1) end if boss=boss+bosum/2.0 vlps=vlps+vlp(i1) chsum=chsum+ch(i1) end do write (7,*)2.0*boss,vlps,2.0*boss+2.0*vlps,chsum close(8) close(7) end if if (noutpt.eq.0) then write (var,'(f7.4)')float(mdstep/nsav)/1d4 if (ni.eq.0) open (unit=67,file=qmdfi//var(3:7), $status='unknown') write (67,300)qmol do i1=1,na write (67,400)i1,qa(i1),(c(i1,i2),i2=1,3) end do write (67,*) close(67) end if if (noutpt.eq.2) then C open (88,file='moldyn.bgf',status='unknown',access='append') call writebgf(88) close (88) end if if ((ni.eq.1.and.iopt.eq.0).or.(ni.eq.1.and.iopt.eq.1.and. $iflga.eq.1)) then qrtemp=qr if (qr.eq.'I') qr='C' if (qfileh.eq.' ') then write (*,*)'Warning: no file name given; use Unknown' qfileh='Unknown' end if qfile2=qfileh if (imodfile.eq.0) then istart=1 qstrana1(1:25)=qfileh call stranal(istart,iend,vout,iout,1) qfile2=qfileh(istart:iend-1)//".geo" end if call writegeo(98) if (imodfile.eq.1.or.iopt.eq.0) then open (88,file=qfile2,status='unknown') call writegeo(88) close (88) end if qr=qrtemp if (iopt.eq.0) then do i1=1,na write (56,410) i1,ch(i1) write (55,410) i1,chgbgf(i1) end do ********************************************************************** * * * Write .pdb output file * * * ********************************************************************** open (unit=47,file='output.pdb',status='unknown') do i1=1,na write (47,412)'ATOM ',i1,qa(i1),pepname,ipeptide,c(i1,1), $c(i1,2),c(i1,3),1.0,2.2,qa(i1) end do write (47,*) 'TER' write (47,*) 'END' close (47) if (nsurp.eq.0) then if (kx.gt.0.or.ky.gt.0.or.kz.gt.0) then qrtemp=qr ********************************************************************** * * * Write crystal structure including periodic images * * * ********************************************************************** * mux=(1+kx+kx) * muy=(1+ky+ky) * muz=(1+kz+kz) * qr='F' * write (86,'(2x,a1,1x,a60)')qr,qmol * qr=qrtemp * write (86,'(3f10.4)')mux*axiss(1),muy*axiss(2),muz*axiss(3) * write (86,'(3f10.4)')angle(1),angle(2),angle(3) * do i1=1,na * write (86,'(i4,1x,a2,3x,3d22.15)')i1,qa(i1),(c(i1,i2),i2=1,3) * end do * nhulp=na+1 * do k1=-kx,kx * do k2=-ky,ky * do k3=-kz,kz * if (k1.ne.0.or.k2.ne.0.or.k3.ne.0) then * do i1=1,na * cx=c(i1,1)+k1*tm11 * cy=c(i1,2)+k1*tm21+k2*tm22 * cz=c(i1,3)+k1*tm31+k2*tm32+k3*tm33 * write (86,'(i4,1x,a2,3x,3d22.15)')nhulp,qa(i1),cx,cy,cz * nhulp=nhulp+1 * end do * end if * end do * end do * end do * write (86,*) ********************************************************************** * * * Write crystal structure with extra unit cells * * * ********************************************************************** mux=1+iexx muy=1+iexy muz=1+iexz qr='F' write (85,'(2x,a1,1x,a60)')qr,qmol qr=qrtemp write (85,'(3f10.4)')mux*axiss(1),muy*axiss(2),muz*axiss(3) write (85,'(3f10.4)')angle(1),angle(2),angle(3) do i1=1,na write (85,'(i4,1x,a2,3x,3d22.15)')i1,qa(i1),(c(i1,i2),i2=1,3) end do nhulp=na+1 do k1=0,iexx do k2=0,iexy do k3=0,iexz if (k1.ne.0.or.k2.ne.0.or.k3.ne.0) then do i1=1,na cx=c(i1,1)+k1*tm11 cy=c(i1,2)+k1*tm21+k2*tm22 cz=c(i1,3)+k1*tm31+k2*tm32+k3*tm33 write (85,'(i4,1x,a2,3x,3d22.15)')nhulp,qa(i1),cx,cy,cz nhulp=nhulp+1 end do end if end do end do end do write (85,*) end if end if end if end if if (ni.eq.0.or.ni.eq.2) then ********************************************************************** * * * Write ASCII trajectory file * * * ********************************************************************** if (ni.eq.0) open(unit=66,file=qmdfi//'.vel',status='unknown') if (ni.eq.2) then write (var,'(f7.4)')float(mdstep/nsav3)/1d4 open (unit=66,file=qmdfi//var(3:7),status='unknown') end if write (66,500)axis(1),axis(2),axis(3) write (66,550)angle(1),angle(2),angle(3) write (66,600)na,((c(i,j),j=1,3),qlabel(i),i=1,na) write (66,700)((vel(j,i),j=1,3),i=1,na) write (66,800)((accel(j,i),j=1,3),i=1,na) write (66,900)((aold(j,i),j=1,3),i=1,na) write (66,1000)tempmd write (66,1050) close (66) end if if (ni.ne.2.and.iopt.eq.0) then C open (unit=68,file='xmolout',status='unknown',access='append') write (68,1200)na write (68,1300)qmol,mdstep+nit+nprevrun,estrc, $axis(1),axis(2),axis(3),angle(1),angle(2),angle(3) do i1=1,na if (ixmolo.eq.0) write (68,1400)qa(i1),(c(i1,i2),i2=1,3) if (ixmolo.eq.1) write (68,1400)qa(i1),(c(i1,i2),i2=1,3), $(vel(i2,i1)/1e+10,i2=1,3),iag(i1,3+mbond) if (ixmolo.eq.2) write (68,1401)qa(i1),(c(i1,i2),i2=1,3), $iag(i1,3+mbond) end do close (68) if (itrout.ne.0) then C open (unit=69,file='xmolout2',status='unknown',access='append') write (69,1200)na write (69,1300)qmol,mdstep+nit+nprevrun,estrc, $axis(1),axis(2),axis(3),angle(1),angle(2),angle(3) do i1=1,na if (ixmolo.eq.0) write (69,1400)qa(i1),(cp(i1,i2),i2=1,3) if (ixmolo.eq.1) write (69,1400)qa(i1),(cp(i1,i2),i2=1,3), $(vel(i2,i1)/1e+10,i2=1,3),iag(i1,3+mbond) if (ixmolo.eq.2) write (68,1401)qa(i1),(c(i1,i2),i2=1,3), $iag(i1,3+mbond) end do close (69) end if call molanal end if ********************************************************************** * * * Generate BIOGRAF output-file * * * ********************************************************************** if ((ni.eq.1.and.iopt.eq.0).or.(ni.eq.1.and.iopt.eq.1.and. $iflga.eq.1)) then if (qfileh.eq.' ') then write (*,*)'Warning: no file name given; use Unknown' qfileh='Unknown' end if qfile2=qfileh if (imodfile.eq.0) then istart=1 qstrana1(1:25)=qfileh call stranal(istart,iend,vout,iout,1) qfile2=qfileh(istart:iend-1)//".bgf" end if call writebgf(90) if (imodfile.eq.1.or.iopt.eq.0) then open (88,file=qfile2,status='unknown') call writebgf(88) close (88) end if end if return ********************************************************************** * * * Format part * * * ********************************************************************** 100 format (i4,1x,a40,'Iteration:',i8,' #Bonds:',i4) 101 format (i3,2x,a40) 200 format (8i4,8f7.3) 201 format (8i3) 210 format (13i4,13f7.3) 220 format (18i4,18f7.3) 230 format (23i4,23f7.3) 240 format (28i4,28f7.3) 250 format (38i4,38f7.3) 300 format (2x,a1,1x,a60) 301 format (2x,a1,1x,f6.2,a60) 302 format (2x,a1,1x,2f6.2,a60) 310 format (2x,a1,1x,a60) 320 format (3f10.4) 400 format (i4,1x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) 410 format (i4,f12.6) 412 format(A6,I5,1x,A2,3x,A3,2x,i4,4x,3f8.3,f6.2,f6.2,4x,2x,A6) 500 format (1x,'Lattice parameters:',/(3f15.8)) 550 format (3f15.8) 600 format (i4,1x,'Atom coordinates (Angstrom):',/ $(3d24.15,1x,a5)) 700 format (1x,'Atom velocities (Angstrom/s):',/(3d24.15)) 800 format (1x,'Atom accelerations (Angstrom/s**2):',/(3d24.15)) 900 format (1x,'Previous atom accelerations:',/(3d24.15)) 1000 format (1x,'MD-temperature (K):',/(1d24.15)) 1050 format (1x,'Connections, bond orders and lone pairs:') 1100 format (8i3,8f8.4) 1200 format (i4) 1300 format (a40,i6,f12.4,6f7.2) 1400 format (a2,3f10.5,3f15.5,i6) 1401 format (a2,3f10.5,i6) 1500 format ('BIOGRF',i4) 1600 format ('XTLGRF',i4) 1700 format ('DESCRP ',a60) 1800 format ('REMARK ',a60) 1900 format ('FFIELD ',a40) 2000 format ('RUTYPE ',a40) 2100 format ('CRYSTX ',6f11.5) 2200 format ('CELLS ',6i5) 2300 format ('# At1 At2 R12 Force1 Force2 ', $'dR12/dIteration(MD only)') 2400 format ('BOND RESTRAINT ',2i4,f8.4,f8.2,f8.5,f10.7) 2500 format ('# At1 At2 At3 Angle Force1 Force2', $' dAngle/dIteration (MD only)') 2600 format ('ANGLE RESTRAINT ',3i4,2f8.2,f8.4,f9.6) 2700 format ('# At1 At2 At3 At3 Angle Force1 ', $'Force2 dAngle/dIteration (MD only)') 2800 format ('TORSION RESTRAINT ',4i4,2f8.2,f8.4,f9.6) 2900 format ('FORMAT ATOM (a6,1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,', $'3f10.5,1x,a5,i3,i2,1x,f8.5)') 3000 format ('HETATM',1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,3f10.5,1x, $a5,i3,i2,1x,f8.5) 3100 format ('FORMAT CONECT (a6,12i6)') 3200 format ('CONECT',12i6) 3300 format ('UNIT ENERGY kcal') 3400 format ('ENERGY',5x,f14.6) 3500 format ('END') end ************************************************************************ ************************************************************************ subroutine readc ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkcha.blk" #include "cbkconst.blk" #include "cbkdistan.blk" #include "cbkinit.blk" #include "cbktregime.blk" #include "control.blk" #include "opt.blk" #include "small.blk" character*6 qident character*20 qhulp * dimension qident(100) ************************************************************************ * * * Read control file * * * ************************************************************************ c$$$c if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$c write (65,*) 'In readc' c$$$c call timer(65) c$$$c close (65) c$$$c end if if (mdstep.gt.0.or.nit.gt.0) nmmsav=nmm ************************************************************************ * * * Set default values * * * ************************************************************************ nreac=0 axis1=200.0d0 axis2=200.0d0 axis3=200.0d0 cutof2=0.001d0 cutof3=0.300d0 tsetor=298.0d0 tset2=298.0d0 pset=0.0d0 tincr=0.0d0 tstep=0.5d0 * swa=0.0 !Moved to force field * swb=12.5 !Moved to force field taut=2.5d0 taut2=2.5d0 ndtau=50000 taup=500.0d0 vqnd=100.0d0 errnh=1.0d0 range=2.5d0 maxstp=1000 nequi=0 nmethod=3 ncha=3 ncha2=1 nchaud=1 nvlist=25 nrep1=5 nsav=50 icheck=0 ivels=0 itfix=0 ncontrol=25 noutpt=0 napp=0 nsurp=0 ncons=2 nrand=0 nmm=0 endpo=1.0d0 endpo2=1.0d0 nfc=50 nsav2=50 nmmax=50 i5758=0 parc1=1.0d0 parc2=0.001d0 icell=0 ingeo=1 ccpar=1.0005d0 icelo2=0 nrdd=0 nrddf=200000 nbiolab=0 c ngeofor=0 nincrop=0 accerr=2.50d0 vrange=2.50d0 vlbora=5.00d0 nsav3=1000 nhop2=25 nprevrun=0 ndebug=0 volcha=10.00d0 ixmolo=0 inpt=0 iconne=0 imolde=0 ianaly=0 icentr=0 itrans=0 itrout=0 tpnrad=300.0d0 ityrad=3 iexx=1 iexy=1 iexz=1 syscha=0.00d0 inmov1=0 inmov2=0 vfield=0.00d0 itstep=0 ifreq=0 isymm=1 icpres=0 delvib=0.0001d0 c shock variables shock_vel = 2.d0 ! impact velocity for shock simulations (nm/ps) shock_z_sep = 10.0d0 ! separation z value to apply initial velocities in shocks ishock_type = 0.0d0 ! shock type. 0: simple impact; 1: compressing c axis c Hugoniostat variables Hug_E0 = 0.d0 ! Reference energy Hug_P0 = 0.d0 ! Reference pressure Hug_V0 = 0.d0 ! Reference volume c Shear flow simulations for viscosity xImpVcm = 1.d0 ! velocity applied in shear simulations (in nm/ps), left half mover at -xImpVcm and right at +xImpVcm c$$$************************************************************************ c$$$* * c$$$* Read control-file * c$$$* * c$$$************************************************************************ c$$$ open (10,file='control',status='old') c$$$ 10 read (10,'(a20)',end=20,err=30)qhulp c$$$ if (qhulp(1:1).eq.'#') goto 10 c$$$ read (qhulp,*,err=30)vhulp c$$$ read (qhulp,'(8x,a6)',err=30)qident c$$$ if (qident.eq.'Hug_V0') Hug_P0=vhulp c$$$ if (qident.eq.'Hug_P0') Hug_V0=vhulp c$$$ if (qident.eq.'Hug_E0') Hug_E0=vhulp c$$$ if (qident.eq.'shea_v') xImpVcm=vhulp c$$$ if (qident.eq.'shok_t') ishock_type=int(vhulp) c$$$ if (qident.eq.'shok_z') shock_z_sep=vhulp c$$$ if (qident.eq.'shok_v') shock_vel=vhulp c$$$ if (qident.eq.'nreac') nreac=int(vhulp) c$$$ if (qident.eq.'axis1') axis1=vhulp c$$$ if (qident.eq.'axis2') axis2=vhulp c$$$ if (qident.eq.'axis3') axis3=vhulp c$$$ if (qident.eq.'cutof2') cutof2=vhulp c$$$ if (qident.eq.'cutof3') cutof3=vhulp c$$$ if (qident.eq.'mdtemp') tsetor=vhulp c$$$ if (qident.eq.'mdtem2') tset2=vhulp c$$$ if (qident.eq.'mdpres') pset=vhulp*0.001 c$$$ if (qident.eq.'tincr') tincr=vhulp c$$$ if (qident.eq.'tstep') tstep=vhulp c$$$* if (qident.eq.'lowtap') swa=vhulp !Moved to force field c$$$* if (qident.eq.'uptap') swb=vhulp !Moved to force field c$$$ if (qident.eq.'tdamp1') taut=vhulp c$$$ if (qident.eq.'tdamp2') taut2=vhulp c$$$ if (qident.eq.'ntdamp') ndtau=int(vhulp) c$$$ if (qident.eq.'pdamp1') taup=vhulp c$$$ if (qident.eq.'tdhoov') vqnd=vhulp c$$$ if (qident.eq.'achoov') errnh=vhulp/100.0 c$$$ if (qident.eq.'range') range=vhulp c$$$ if (qident.eq.'nmdit') maxstp=int(vhulp) c$$$ if (qident.eq.'nmdeqi') nequi=int(vhulp) c$$$ if (qident.eq.'imdmet') nmethod=int(vhulp) c$$$ if (qident.eq.'icharg') ncha=int(vhulp) nchaold=ncha c$$$ if (qident.eq.'ichaen') ncha2=int(vhulp) c$$$ if (qident.eq.'ichupd') nchaud=int(vhulp) c$$$ if (qident.eq.'iout1') nrep1=int(vhulp) c$$$ if (qident.eq.'iout2') nsav=int(vhulp) c$$$ if (qident.eq.'icheck') ntest=int(vhulp) c$$$ if (qident.eq.'ivels') nvel=int(vhulp) c$$$ if (qident.eq.'itfix') ntscale=int(vhulp) c$$$ if (qident.eq.'irecon') ncontrol=int(vhulp) c$$$ if (qident.eq.'iout3') noutpt=int(vhulp) c$$$ if (qident.eq.'iappen') napp=int(vhulp) c$$$ if (qident.eq.'isurpr') nsurp=int(vhulp) c$$$ if (qident.eq.'itdmet') ncons=int(vhulp) c$$$ if (qident.eq.'iravel') nrand=int(vhulp) c$$$ if (qident.eq.'imetho') nmm=int(vhulp) c$$$ if (qident.eq.'endmm') endpo=vhulp endpoold=endpo c$$$ if (qident.eq.'endmd') endpo2=vhulp c$$$ if (qident.eq.'imaxmo') nfc=int(vhulp) nfcold=nfc c$$$ if (qident.eq.'iout4') nsav2=int(vhulp) c$$$ if (qident.eq.'imaxit') nmmax=int(vhulp) nmmaxold=nmmax c$$$ if (qident.eq.'iout5') i5758=int(vhulp) c$$$ if (qident.eq.'parsca') parc1=vhulp c$$$ if (qident.eq.'parext') parc2=vhulp c$$$ if (qident.eq.'icelop') icell=int(vhulp) icellold=icell c$$$ if (qident.eq.'igeopt') ingeo=int(vhulp) c$$$ if (qident.eq.'celopt') ccpar=vhulp c$$$ if (qident.eq.'icelo2') icelo2=int(vhulp) icelo2old=icelo2 c$$$ if (qident.eq.'ideve1') nrdd=int(vhulp) c$$$ if (qident.eq.'ideve2') nrddf=int(vhulp) c$$$ if (qident.eq.'ibiola') nbiolab=int(vhulp) c$$$c if (qident.eq.'igeofo') ngeofor=int(vhulp) c$$$ if (qident.eq.'iincop') nincrop=int(vhulp) c$$$ if (qident.eq.'accerr') accincr=vhulp c$$$ if (qident.eq.'iout6') nsav3=int(vhulp) c$$$ if (qident.eq.'irten') nhop2=int(vhulp) c$$$ if (qident.eq.'npreit') nprevrun=int(vhulp) c$$$ if (qident.eq.'idebug') ndebug=int(vhulp) c$$$ if (qident.eq.'volcha') volcha=vhulp c$$$ if (qident.eq.'ixmolo') ixmolo=int(vhulp) c$$$ if (qident.eq.'inpt') inpt=int(vhulp) c$$$ if (qident.eq.'iconne') iconne=int(vhulp) c$$$ if (qident.eq.'imolde') imolde=int(vhulp) c$$$ if (qident.eq.'ianaly') ianaly=int(vhulp) c$$$ if (qident.eq.'icentr') icentr=int(vhulp) c$$$ if (qident.eq.'itrans') itrans=int(vhulp) c$$$ if (qident.eq.'itrout') itrout=int(vhulp) c$$$ if (qident.eq.'nvlist') nvlist=int(vhulp) c$$$ if (qident.eq.'vrange') vrange=vhulp c$$$ if (qident.eq.'vlbora') vlbora=vhulp c$$$ if (qident.eq.'tpnrad') tpnrad=vhulp c$$$ if (qident.eq.'ityrad') ityrad=int(vhulp) c$$$ if (qident.eq.'iexx') iexx=int(vhulp) c$$$ if (qident.eq.'iexy') iexy=int(vhulp) c$$$ if (qident.eq.'iexz') iexz=int(vhulp) c$$$ if (qident.eq.'syscha') syscha=vhulp c$$$ if (qident.eq.'inmov1') inmov1=int(vhulp) c$$$ if (qident.eq.'inmov2') inmov2=int(vhulp) c$$$ if (qident.eq.'itstep') itstep=int(vhulp) c$$$ if (qident.eq.'ifreq') ifreq=int(vhulp) c$$$ if (qident.eq.'isymm') isymm=int(vhulp) c$$$ if (qident.eq.'icpres') icpres=int(vhulp) c$$$ if (qident.eq.'delvib') delvib=vhulp c$$$ goto 10 c$$$ 20 continue close (10) axis(1)=axis1 axis(2)=axis2 axis(3)=axis3 if (axiss(1).gt.zero) then axis(1)=axiss(1) axis(2)=axiss(2) axis(3)=axiss(3) end if if (tincr.lt.0.0001.and.tincr.gt.-0.0001) tset=tsetor iequi=1 if (nequi.gt.0) iequi=0 if (iopt.eq.1.and.napp.eq.1) then stop 'No fort.7 and fort.8 append with iopt=1 !' end if if (mdstep.gt.0.or.nit.gt.0) nmm=nmmsav if (mdstep.gt.0.and.itstep.eq.1) then tstepmax=tstep tstep=tstep*(tsetor/tempmd) if (tstep.gt.tstepmax) tstep=tstepmax end if tstep=1.0d-15*tstep taus=taut taut=1.0d-15*taut taut2=1.0d-15*taut2 taup=1.0d-15*taup ts2=tstep/2.0 ts22=tstep*ts2 return 30 continue write (*,*)'Error reading control-file' stop 'Error reading control-file' ************************************************************************ * * * Format part * * * ************************************************************************ 1050 format (f7.3) 1055 format (f7.4) 1056 format (f9.4) 1060 format (i8) 1070 format (f7.5) end ************************************************************************ ************************************************************************ subroutine staint ************************************************************************ #include "cbka.blk" #include "cbkdcell.blk" #include "cbkqa.blk" #include "control.blk" #include "small.blk" #include "cbkc.blk" #include "cbkconst.blk" dimension bvt(nat,4) ************************************************************************ * * * Generate cartesian coordinates from internal coordinate input * * * ************************************************************************ c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In staint' c$$$ call timer(65) c$$$ close (65) c$$$ end if k=0 10 read (3,1200,end=20,err=20)(ijk(k+1,k1),k1=1,3),k2,qa(k+1), $bvt(k+1,3),bvt(k+1,2),bvt(k+1,1) qlabel(k+1)=qa(k+1) qresi1(k+1)=' ' qresi2(k+1)=' ' qresi3(k+1)=' ' qffty(k+1)=' ' if (k2.ne.k+1) then write (*,*)'Wrong order in internal coordinates at atom:',k2 goto 20 * stop 'Wrong order in internal coordinates' end if k=k+1 if (k.gt.nat) then write (*,*)na,nat stop 'Maximum number of atoms exceeded' end if goto 10 20 continue na=k ************************************************************************ * * * CALCULATION OF CARTESIAN COORDINATES FROM INTERNAL COORDINAATES * * * ************************************************************************ 12 C(1,1)=ZERO C(1,2)=ZERO C(1,3)=ZERO C(2,1)=BVT(2,1) C(2,2)=ZERO C(2,3)=ZERO HR=(BVT(3,2)-90.0D0)*DGRRDN C(3,1)=C(2,1)+BVT(3,1)*SIN(HR) C(3,2)=BVT(3,1)*COS(HR) C(3,3)=ZERO DO 32 K1=4,NA J=IJK(K1,2) KB=K1-1 XH=C(J,1) YH=C(J,2) ZH=C(J,3) DO 13 K2=1,KB C(K2,1)=C(K2,1)-XH C(K2,2)=C(K2,2)-YH C(K2,3)=C(K2,3)-ZH DO 13 K3=1,3 13 IF (ABS(C(K2,K3)).LT.1.0D-15) C(K2,K3)=1.0D-15 K=IJK(K1,3) P2=C(K,2)*C(K,2)+C(K,3)*C(K,3) IF (P2.NE.ZERO) THEN P=SQRT(P2) Q=SQRT(C(K,1)*C(K,1)+P2) SA=C(K,2)/P CA=C(K,3)/P SB=-C(K,1)/Q CB=P/Q ELSE SA=ZERO CA=ONE SB=ONE CB=ZERO ENDIF DO 16 K2=1,KB AZ=C(K2,1) BZ=C(K2,2) C(K2,1)=AZ*CB+BZ*SB*SA+C(K2,3)*SB*CA C(K2,2)=BZ*CA-C(K2,3)*SA 16 C(K2,3)=-AZ*SB+BZ*CB*SA+C(K2,3)*CB*CA IF (C(K,3).LE.ZERO) THEN DO 17 K2=1,KB 17 C(K2,3)=-C(K2,3) ENDIF I=IJK(K1,1) IF (1.0D5*ABS(C(I,1)).LE.ABS(C(I,2))) THEN T1=HALF*PI ELSE YX=ABS(C(I,2)/C(I,1)) T1=ATAN(YX) ENDIF IF (C(I,1).GE.ZERO.AND.C(I,2).LT.ZERO) T1=TWO*PI-T1 IF (C(I,1).LT.ZERO.AND.C(I,2).GE.ZERO) T1=PI-T1 IF (C(I,1).LT.ZERO.AND.C(I,2).LT.ZERO) T1=T1+PI DO 31 K2=1,KB IF (C(K2,1).EQ.ZERO.AND.C(K2,2).EQ.ZERO) GOTO 31 IF (1.0D5*ABS(C(K2,1)).LT.ABS(C(K2,2))) THEN T2=HALF*PI ELSE YX=ABS(C(K2,2)/C(K2,1)) T2=ATAN(YX) ENDIF IF (C(K2,1).GE.ZERO.AND.C(K2,2).LT.ZERO) T2=TWO*PI-T2 IF (C(K2,1).LT.ZERO.AND.C(K2,2).GE.ZERO) T2=PI-T2 IF (C(K2,1).LT.ZERO.AND.C(K2,2).LT.ZERO) T2=T2+PI T3=T2-T1 IF (T3.LT.ZERO)T3=T3+TWO*PI RZ=SQRT(C(K2,1)*C(K2,1)+C(K2,2)*C(K2,2)) C(K2,1)=RZ*COS(T3) C(K2,2)=RZ*SIN(T3) 31 CONTINUE HR=(BVT(K1,2)-90.0D0)*DGRRDN HT=BVT(K1,3)*DGRRDN CHR=COS(HR) C(K1,1)=BVT(K1,1)*CHR*COS(HT) C(K1,2)=BVT(K1,1)*CHR*SIN(HT) 32 C(K1,3)=C(IJK(K1,3),3)+BVT(K1,1)*SIN(HR) return 1200 FORMAT(4I3,1X,A2,3F10.5,4X,I1,F10.5) end ************************************************************************ ************************************************************************ subroutine outint ************************************************************************ #include "cbka.blk" #include "cbkabo.blk" #include "cbkbo.blk" #include "cbkconst.blk" #include "cbkia.blk" #include "cbkinit.blk" #include "cbknubon2.blk" #include "cbkqa.blk" #include "cbktregime.blk" #include "control.blk" #include "small.blk" #include "cbksrtbon1.blk" ************************************************************************ * * * Output internal coordinates * * * ************************************************************************ dimension dvdc(3,3),dargdc(3,3) c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In outint' c$$$ call timer(65) c$$$ close (65) c$$$ end if write (91,50)qmol open (82,file='output.MOP',status='unknown') write (82,*) write (82,'(a40)')qmol write (82,*) close (82) * IF (NMOLO.GT.1) THEN * WRITE(6,*)' OUTPUT INTERNAL COORDINATES NOT POSSIBLE FOR ', * $'CALCULATION ON MORE THAN ONE MOLECULE' * RETURN * END IF ************************************************************************ * * * Output of internal coordinates. * * First 3 atoms of other input file. * * * ************************************************************************ N1=1 N2=2 N3=3 C open (82,file='output.MOP',status='unknown',access='append') write(91,100)N1,qa(n1) write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n1), $zero,nzero,zero,nzero,zero,nzero,nzero,nzero,nzero call dista2(n1,n2,rr,dx,dy,dz) write(91,200)N1,N2,qa(n2),RR write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n2), $rr,none,zero,nzero,zero,nzero,n1,nzero,nzero close (82) call dista2(n2,n3,rr,dx,dy,dz) hv=zero call calvalres(n1,n2,n3,arg,hv,dvdc,dargdc) WRITE(91,300)N1,N2,N3,qa(n3),rdndgr*HV,RR C open (82,file='output.MOP',status='unknown',access='append') write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n3), $rr,none,rdndgr*hv,none,zero,nzero,n2,n1,nzero close (82) naih=3 do i1=naih+1,na bomax=zero j1=0 do i2=1,ia(i1,2) iob=ia(i1,2+i2) ncubo=nubon2(i1,i2) if (bo(ncubo).gt.bomax.and.iob.lt.i1) then bomax=bo(ncubo) j1=iob end if end do if (j1.eq.0) j1=i1-1 call dista2(j1,i1,rr,dx,dy,dz) bomax=zero j2=0 do i2=1,ia(j1,2) iob=ia(j2,2+i2) ncubo=nubon2(j1,i2) if (bo(ncubo).gt.bomax.and.iob.lt.i1.and. $abo(iob).gt.bo(ncubo)+0.2) then bomax=bo(ncubo) j2=iob end if end do if (j2.eq.0) j2=i1-2 if (j2.eq.j1) j2=j2+1 call calvalres(j2,j1,i1,arg,hh,dvdc,dargdc) bomax=zero j3=0 do i2=1,ia(j2,2) iob=ia(j2,2+i2) ncubo=nubon2(j2,i2) if (bo(ncubo).gt.bomax.and.iob.lt.i1.and.iob.ne.j1) then bomax=bo(ncubo) j3=iob end if end do if (j3.eq.0) j3=i1-3 if (j3.eq.j2.and.j3.ne.j1-1) j3=j3+1 if (j3.eq.j2.and.j3.ne.j1-2) j3=j3+2 if (j3.eq.j1.and.j3.ne.j2-1) j3=j3+1 if (j3.eq.j1.and.j3.ne.j2-2) j3=j3+2 call caltor(j3,j2,j1,i1,ht) write(91,400)j3,j2,j1,i1,qa(i1),ht,rdndgr*hh,rr C open (82,file='output.MOP',status='unknown',access='append') write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(i1), $rr,none,rdndgr*hh,none,ht,none,j1,j2,j3 close (82) end do close(82) return 50 format (' I',2x,a60) 100 FORMAT(9X,I3,1x,a2) 200 FORMAT(6X,2I3,1x,a2,20X,F10.5) 300 FORMAT(3X,3I3,1x,a2,10X,2F10.5) 400 FORMAT(4I3,1x,a2,3F10.5) end ************************************************************************ ************************************************************************ subroutine outres ************************************************************************ #include "cbka.blk" #include "cbkbo.blk" #include "cbkch.blk" #include "cbkd.blk" #include "cbkenergies.blk" #include "cbkh.blk" #include "cbkimove.blk" #include "cbkrbo.blk" #include "cbktorang.blk" #include "cbktorsion.blk" #include "cbktregime.blk" #include "cbkvalence.blk" #include "control.blk" #include "opt.blk" #include "small.blk" #include "cbkinit.blk" ************************************************************************ * * * Output molecular data * * * ************************************************************************ dimension isort(100),iad1(100),iad2(100),iad3(100),iad4(100) character*60 qm2 c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In outres' c$$$ call timer(65) c$$$ close (65) c$$$ end if read (9,100,end=50)idata,qm2 * if (qm2.ne.qmol) then * write (*,*)'Wrong molecule in outres-file' * write (*,*)qmol * write (*,*)qm2 * return * end if do 25 i1=1,idata read (9,200)isort(i1),iad1(i1),iad2(i1),iad3(i1),iad4(i1) ndata2=ndata2+1 if (isort(i1).eq.1) then * do i2=1,nbon * if (ib(i2,2).eq.iad1(i1).and.ib(i2,3).eq.iad2(i1)) then * if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),rbo(i2) * caldat(ndata2)=rbo(i2) * end if * end do call dista2(iad1(i1),iad2(i1),dish,dx,dy,dz) write (81,*)iad1(i1),iad2(i1),dish caldat(ndata2)=dish end if if (isort(i1).eq.2) then do i2=1,nval if (iv(i2,2).eq.iad1(i1).and.iv(i2,3).eq.iad2(i1).and. $iv(i2,4).eq.iad3(i1)) then if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1), $iad3(i1),h(i2)*rdndgr caldat(ndata2)=h(i2)*rdndgr end if end do end if if (isort(i1).eq.3) then do i2=1,ntor if (it(i2,2).eq.iad1(i1).and.it(i2,3).eq.iad2(i1).and. $it(i2,4).eq.iad3(i1).and.it(i2,5).eq.iad4(i1)) then if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),iad3(i1),iad4(i1), $abs(thg(i2)) caldat(ndata2)=abs(thg(i2)) end if end do end if if (isort(i1).eq.4) then if (iopt.ne.1) write (81,*)estrmin caldat(ndata2)=estrmin end if if (isort(i1).eq.5) then if (iopt.ne.1) write (81,*)estrmin caldat(ndata2)=estrmin end if if (isort(i1).eq.6) then if (iopt.ne.1) write (81,*)iad1(i1),axiss(iad1(i1)) caldat(ndata2)=axiss(iad1(i1)) end if if (isort(i1).eq.7) then if (iopt.ne.1) write (81,*)eco caldat(ndata2)=eco end if if (isort(i1).eq.8) then do i2=1,nbon if (ib(i2,2).eq.iad1(i1).and.ib(i2,3).eq.iad2(i1)) then if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),bo(i2) caldat(ndata2)=bo(i2) end if end do end if if (isort(i1).eq.9) then if (iopt.ne.1) write (81,*)ch(iad1(i1)) caldat(ndata2)=ch(iad1(i1)) end if if (isort(i1).eq.10) then rmsg=0.0 nmovh=0 do i2=1,na do i3=1,3 rmsg=rmsg+imove(i2)*d(i3,i2)*d(i3,i2) nmovh=nmovh+imove(i2) end do end do rmsg=sqrt(rmsg/float(nmovh*3)) if (iopt.ne.1) write (81,*)rmsg caldat(ndata2)=rmsg end if if (isort(i1).eq.11) then if (iopt.ne.1) write (81,*)1000.0*pressu caldat(ndata2)=1000.0*pressu end if 25 continue 50 return ************************************************************************ * * * Format part * * * ************************************************************************ 100 format (i3,a60) 200 format (5i3) end ************************************************************************ ************************************************************************ subroutine readgeo ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkconst.blk" #include "cbkdistan.blk" #include "cbkinit.blk" #include "cbkqa.blk" #include "cbksrtbon1.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "small.blk" character*80 qromb character*25 qfileh c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readgeo' c$$$ call timer(65) c$$$ close (65) c$$$ end if if (ngeofor.eq.-1) return ********************************************************************** * * * Read in system geometry * * * ********************************************************************** if (ngeofor.eq.0) then call readdelphi (qfileh,iend,naold) namov=na end if if (ngeofor.eq.1) then call readbgf(iend,naold) end if if (ngeofor.eq.2) then ********************************************************************** * * * Read in free format (xmol) geometry * * * ********************************************************************** qr='1' read (3,'(i6)')na namov=na read (3,'(a60)')qmol do i1=1,na read (3,'(a80)')qromb ifirstchar=80 do i2=1,80 if (qromb(i2:i2).ne.' '.and.i2.lt.ifirstchar) ifirstchar=i2 end do read (qromb(ifirstchar:80),'(a2)')qa(i1) read (qromb(ifirstchar+2:80),*)c(i1,1),c(i1,2),c(i1,3) qlabel(i1)=qa(i1) qresi1(i1)=' ' qresi2(i1)=' ' qresi3(i1)=' ' qffty(i1)=' ' end do ibity=1 axiss(1)=-1.0 end if if (ngeofor.eq.3) then ********************************************************************** * * * Read in ChemDraw CC1-file * * * ********************************************************************** qr='1' read (3,*)na namov=na read (3,'(a60)')qmol do i1=1,na read (3,'(2x,a2,5x,3f12.6)')qa(i1),c(i1,1),c(i1,2),c(i1,3) end do end if if (ngeofor.eq.4) then ********************************************************************** * * * Read in .pdb-format * * * ********************************************************************** qr='C' call readpdb(iendf) namov=na ibity=1 axiss(1)=-1.0 qfile(nprob)=qmol if (iendf.eq.1) stop 'End-of-file while reading in .pdb' end if ********************************************************************** * * * Set up periodic system * * * ********************************************************************** axis(1)=axiss(1) axis(2)=axiss(2) axis(3)=axiss(3) angle(1)=angles(1) angle(2)=angles(2) angle(3)=angles(3) if (axiss(1).lt.zero) then axis(1)=axis1 axis(2)=axis2 axis(3)=axis3 angle(1)=90.0 angle(2)=90.0 angle(3)=90.0 end if halfa=angle(1)*dgrrdn hbeta=angle(2)*dgrrdn hgamma=angle(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axis(1)*sinbet*sinphi tm21=axis(1)*sinbet*cosphi tm31=axis(1)*cosbet tm22=axis(2)*sinalf tm32=axis(2)*cosalf tm33=axis(3) return end ************************************************************************ ************************************************************************ subroutine readdelphi (qfileh,iend,naold) ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkconst.blk" #include "cbkd.blk" #include "cbkdcell.blk" #include "cbkdistan.blk" #include "cbkff.blk" #include "cbkh.blk" #include "cbkinit.blk" #include "cbkqa.blk" #include "cbkrestr.blk" #include "cbksrtbon1.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "small.blk" character*25 qfileh ********************************************************************** * * * Read in geometries in Delphi-format (xyz) * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readdelphi' c$$$ call timer(65) c$$$ close (65) c$$$ end if if (imodfile.eq.1) then open (3,file=qfileh,status='old') end if nmmax=nmmaxold nfc=nfcold ibity=1 iredo=1 endpo=endpoold icell=icellold icelo2=icelo2old iend=0 read (3,1000,end=900)qr,qmol ********************************************************************** * * * Read in restraint information (optional) * * * ********************************************************************** if (qr.eq.'R'.or.qr.eq.'P'.or.qr.eq.'X') then qmol=qmol(7:60) qmolset(nuge)=qmol read (18,1070,end=4,err=4) nrestra do i1=1,nrestra read (18,1090)irstra(i1,1),irstra(i1,2),rrstra(i1),vkrstr(i1), $vkrst2(i1),rrcha(i1) end do 4 continue end if ********************************************************************** * * * Read in torsion restraint information (optional) * * * ********************************************************************** if (qr.eq.'T'.or.qr.eq.'X') then if (qr.eq.'T') then qmol=qmol(7:60) qmolset(nuge)=qmol end if read (28,1070,end=6,err=6) nrestrat do i1=1,nrestrat read (28,1091)irstrat(i1,1),irstrat(i1,2),irstrat(i1,3), $irstrat(i1,4),trstra(i1),vkrt(i1),vkr2t(i1),rtcha(i1) end do 6 continue end if ********************************************************************** * * * Read in valency angle restraint information (optional) * * * ********************************************************************** if (qr.eq.'V') then qmol=qmol(7:60) qmolset(nuge)=qmol read (38,1070,end=7,err=7) nrestrav do i1=1,nrestrav read (38,1092)irstrav(i1,1),irstrav(i1,2),irstrav(i1,3), $vrstra(i1),vkrv(i1),vkr2v(i1) end do 7 continue end if ********************************************************************** * * * Read in geometry * * * ********************************************************************** ibh2=0 iequi=1 iexco=0 if (nequi.gt.0) iequi=0 axiss(1)=-1.0 if (qr.eq.'O'.or.qr.eq.'L') stop 'Not xyz-format' if (qr.eq.'I') then !Delphi internal coordinates if (nsurp.ge.2) stop 'Int.coordinates only with 1 gemetry' call staint goto 20 end if if (qr.eq.'B') then !Previous geometry with volume reduction read (3,*) vred=(1.0-0.01*volcha)**(0.33333) iexco=1 na=naold do i1=1,3 qmol=qmol axiss(i1)=vred*axis(i1) angles(i1)=angle(i1) do i2=1,na c(i2,i1)=vred*c(i2,i1) end do end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 goto 20 end if if (qr.eq.'S') then !Previous geometry with volume expansion read (3,*) vexp=(1.0+0.01*volcha)**(0.33333) na=naold iexco=1 do i1=1,3 qmol=qmol axiss(i1)=vexp*axis(i1) angles(i1)=angle(i1) do i2=1,na c(i2,i1)=vexp*c(i2,i1) end do end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 goto 20 end if if (qr.eq.'F'.or.qr.eq.'Y'.or.qr.eq.'3'.or.qr.eq.'5'. $or.qr.eq.'P') then kx=0 ky=0 kz=0 ibity=2 read(3,1005)axiss(1),axiss(2),axiss(3) read(3,1005)angles(1),angles(2),angles(3) halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) end if if (qr.eq.'M'.or.qr.eq.'A') then nmmsav=nmm nmm=2 end if if (qr.eq.'A') nmm=1 if (qr.eq.'D') then endpo=endpo/25 nmmax=nmmax*5 qruid='HIGH PRECISION' end if if (qr.eq.'H') then nmmax=nmmax/10 qruid='LOW PRECISION' end if if (qr.eq.'1'.or.qr.eq.'5') then nmm=1 nmmax=1 qruid='SINGLE POINT' end if if (qr.eq.'Y') then icell=0 qruid='NO CELL OPT' end if 10 read (3,1100,end=20,err=20)ir,qa(na+1),(c(na+1,i2),i2=1,3) qlabel(na+1)=qa(na+1) qresi1(na+1)=' ' qresi2(na+1)=' ' qresi3(na+1)=' ' qffty(na+1)=' ' if (ir.eq.0) goto 20 na=na+1 if (na.gt.nat) then write (*,*)'Maximum number of atom exceeded ',na,nat stop 'Maximum number of atoms exceeded' end if goto 10 20 continue if (imodfile.eq.1) close (3) return 900 iend=1 return 1000 format (2x,a1,1x,a60) 1005 format (3f10.4) 1070 format (i3) 1090 format (2i4,2f8.4,f8.6,f10.8) 1091 format (4i4,2f8.4,3f8.6) 1092 format (3i4,2f8.4,2f8.6) 1100 format (i4,1x,a2,3x,3d22.15,1x,a5,1x,i5) end ************************************************************************ ************************************************************************ subroutine readbgf(iendf,naold) ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkcha.blk" #include "cbkcharmol.blk" #include "cbkconst.blk" #include "cbkd.blk" #include "cbkdcell.blk" #include "cbkdistan.blk" #include "cbkenergies.blk" #include "cbkff.blk" #include "cbkh.blk" #include "cbkimove.blk" #include "cbkinit.blk" #include "cbkqa.blk" #include "cbkrestr.blk" #include "cbksrtbon1.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "small.blk" character*80 qromb character*2 qrom character*5 quen character*5 qlabhulp character*25 qfileh character*200 qhulp ********************************************************************** * * * Read in BIOGRAF-geometry * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readbgf' c$$$ call timer(65) c$$$ close (65) c$$$ end if iendf=0 ienread=0 iredo=0 qremark(1)=' ' enmol=zero formol=zero c$$$ if (imodfile.eq.1) then c$$$ open (3,file=qfileh,status='old') c$$$ end if open (3,file='fort.3',status='old') read (3,'(a40)',end=900)qromb ibity=0 if (qromb(1:6).eq.'BIOGRF') ibity=1 if (qromb(1:6).eq.'XTLGRF') ibity=2 if (ibity.eq.0) then write (*,*)qromb(1:6) stop 'Unknown Biograf-file' end if read (qromb,'(6x,i4)')ibgfversion if (ibity.eq.1) qr='C' if (ibity.eq.2) qr='F' iremark=0 iformat=0 iline=0 iexco=0 iruid=1 vvol=1.0 nmcharge=0 nmmax=nmmaxold nfc=nfcold ncha=nchaold endpo=endpoold icell=icellold icelo2=icelo2old axiss(1)=-1.0 30 read (3,'(a200)',end=46,err=40)qhulp qstrana1(1:200)=qhulp iline=iline+1 irecog=0 if (qhulp(1:6).eq.'DESCRP') then read (qhulp,'(7x,a40)',end=46,err=46)qmol irecog=1 end if if (qhulp(1:6).eq.'REMARK') then if (iremark.lt.20) iremark=iremark+1 read (qhulp,'(7x,a40)',end=46,err=46)qremark(iremark) irecog=1 end if if (qhulp(1:6).eq.'FORMAT') then if (iformat.lt.20) iformat=iformat+1 read(qhulp,'(7x,a40)',end=46,err=46)qformat(iformat) irecog=1 end if if (qhulp(1:7).eq.'VCHANGE') then read (qhulp(8:60),*)vvol vred=(1.0+(vvol-1.0))**(0.33333333) iexco=1 na=naold qmol=qmol do i1=1,3 axiss(i1)=vred*axis(i1) angles(i1)=angle(i1) do i2=1,na cglobal(i2,i1)=vred*cglobal(i2,i1) end do end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 irecog=1 end if if (qhulp(1:7).eq.'VCHANGX') then read (qhulp(8:60),*)vvol vred=vvol iexco=1 na=naold qmol=qmol do i1=1,3 axiss(i1)=axis(i1) angles(i1)=angle(i1) do i2=1,na cglobal(i2,i1)=cglobal(i2,i1) end do end do axiss(1)=vred*axiss(1) do i2=1,na cglobal(i2,1)=vred*cglobal(i2,1) end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 irecog=1 end if if (qhulp(1:7).eq.'VCHANGY') then read (qhulp(8:60),*)vvol vred=vvol iexco=1 na=naold qmol=qmol do i1=1,3 axiss(i1)=axis(i1) angles(i1)=angle(i1) do i2=1,na cglobal(i2,i1)=cglobal(i2,i1) end do end do axiss(2)=vred*axiss(2) do i2=1,na cglobal(i2,2)=vred*cglobal(i2,2) end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 irecog=1 end if if (qhulp(1:7).eq.'VCHANGZ') then read (qhulp(8:60),*)vvol vred=vvol iexco=1 na=naold qmol=qmol do i1=1,3 axiss(i1)=axis(i1) angles(i1)=angle(i1) do i2=1,na cglobal(i2,i1)=cglobal(i2,i1) end do end do axiss(3)=vred*axiss(3) do i2=1,na cglobal(i2,3)=vred*cglobal(i2,3) end do halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) ibity=2 irecog=1 end if if (qhulp(1:6).eq.'CRYSTX') then read (qhulp,'(8x,6f11.5)',end=46,err=46)axiss(1), $axiss(2),axiss(3),angles(1),angles(2),angles(3) kx=0 ky=0 kz=0 halfa=angles(1)*dgrrdn hbeta=angles(2)*dgrrdn hgamma=angles(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axiss(1)*sinbet*sinphi tm21=axiss(1)*sinbet*cosphi tm31=axiss(1)*cosbet tm22=axiss(2)*sinalf tm32=axiss(2)*cosalf tm33=axiss(3) kx=int(2.0*swb/tm11) ky=int(2.0*swb/tm22) kz=int(2.0*swb/tm33) qr='F' if (nmmax.eq.1.and.nmmaxold.gt.1) qr='5' if (icell.eq.0.and.icellold.gt.0) qr='Y' ibity=2 irecog=1 end if if (qhulp(1:6).eq.'PERIOD') then read (qhulp,'(7x,i3)',end=46,err=46)iperiod irecog=1 end if if (qhulp(1:4).eq.'AXES') then read (qhulp,'(7x,a3)',end=46,err=46)qbgfaxes irecog=1 end if if (qhulp(1:6).eq.'SGNAME') then read (qhulp,'(7x,a3)',end=46,err=46)qbgfsgn irecog=1 end if * if (qhulp(1:5).eq.'CELLS') then * read (qhulp,'(7x,*)',end=40,err=40)kx,ky,kz * irecog=1 * end if if (qhulp(1:6).eq.'HETATM') then if (ibgfversion.lt.400) then read (qhulp, $'(7x,i5,1x,a5,1x,a3,1x,a1,1x,a5,3f10.5,1x,a5,i3,i2,1x,f8.5)' $,end=40,err=40) $ir,qlabel(na+1),qresi1(na+1),qresi2(na+1),qresi3(na+1), $cglobal(na+1,1),cglobal(na+1,2), $cglobal(na+1,3),qffty(na+1),ibgr1(na+1),ibgr2(na+1), $chgglobal(na+1) else stop 'Unsupported Biograf-version' end if qlabhulp=qlabel(na+1) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:5) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:4) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:3) if (qlabhulp(1:1).eq.'C ') qa(na+1)='C ' if (qlabhulp(1:2).eq.'Ca') qa(na+1)='Ca' if (qlabhulp(1:2).eq.'Cl') qa(na+1)='Cl' if (qlabhulp(1:2).eq.'Cu') qa(na+1)='Cu' if (qlabhulp(1:2).eq.'Co') qa(na+1)='Co' if (qlabhulp(1:1).eq.'H ') qa(na+1)='H ' if (qlabhulp(1:2).eq.'He') qa(na+1)='He' if (qlabhulp(1:1).eq.'N ') qa(na+1)='N ' if (qlabhulp(1:2).eq.'Ni') qa(na+1)='Ni' if (qlabhulp(1:1).eq.'O ') qa(na+1)='O ' if (qlabhulp(1:1).eq.'B ') qa(na+1)='B ' if (qlabhulp(1:1).eq.'F ') qa(na+1)='F ' if (qlabhulp(1:2).eq.'Fe') qa(na+1)='Fe' if (qlabhulp(1:1).eq.'P ') qa(na+1)='P ' if (qlabhulp(1:1).eq.'S ') qa(na+1)='S ' if (qlabhulp(1:1).eq.'Y ') qa(na+1)='Y ' if (qlabhulp(1:2).eq.'Al ') qa(na+1)='Al' if (qlabhulp(1:2).eq.'Au ') qa(na+1)='Au' if (qlabhulp(1:2).eq.'Si') qa(na+1)='Si' if (qlabhulp(1:2).eq.'Pt') qa(na+1)='Pt' if (qlabhulp(1:2).eq.'Mo') qa(na+1)='Mo' if (qlabhulp(1:2).eq.'Mg') qa(na+1)='Mg' if (qlabhulp(1:2).eq.'Ar') qa(na+1)='Ar' if (qlabhulp(1:2).eq.'Zr') qa(na+1)='Zr' if (qlabhulp(1:2).eq.'Ti') qa(na+1)='Ti' if (qlabhulp(1:2).eq.'Ru') qa(na+1)='Ru' if (qlabhulp(1:2).eq.'Ba') qa(na+1)='Ba' if (qlabhulp(1:2).eq.'Bi') qa(na+1)='Bi' if (qlabhulp(1:2).eq.'Li') qa(na+1)='Li' if (qlabhulp(1:2).eq.'V ') qa(na+1)='V ' if (qlabhulp(1:2).eq.'X ') qa(na+1)='X ' na=na+1 if (na.gt.nattot) then write (*,*)'Number of atoms:read ',na write (*,*)'Maximum number of atoms: ',nattot stop $'Maximum number of atoms exceeded; increase nattot in cbka.blk' end if irecog=1 end if if (qhulp(1:6).eq.'RUTYPE') then !run-type identifiers irecrun=0 read (qhulp,'(7x,a40)',end=46,err=46)qruid if (qruid(1:10).eq.'NORMAL RUN') then iruid=0 irecrun=1 end if if (qruid(1:14).eq.'HIGH PRECISION') then endpo=endpo/25 nmmax=nmmax*5 qr='D' iruid=1 irecrun=1 end if if (qruid(1:13).eq.'LOW PRECISION') then nmmax=nmmax/10 qr='H' iruid=1 irecrun=1 end if if (qruid(1:12).eq.'SINGLE POINT') then iruid=1 nmmax=1 qr='1' if (ibity.eq.2) qr='5' irecrun=1 end if if (qruid(1:11).eq.'NO CELL OPT') then iruid=1 icell=0 if (ibity.eq.2) qr='Y' irecrun=1 end if if (qruid(1:8).eq.'CELL OPT') then iruid=1 icell=1 iexco=0 !Override from VCHANGE read (qruid,'(8x,i6)',end=46,err=46)ncellopt if (ncellopt.eq.2) icell=2 !cell optimisation during energy minimisation if (ncellopt.eq.3) icelo2=4 !c/a optimisation if (ncellopt.eq.4) icelo2=1 !only a optimisation if (ncellopt.eq.5) icelo2=2 !only b optimisation if (ncellopt.eq.6) icelo2=3 !only c optimisation if (ncellopt.eq.7) then icelo2=4 !c/a optimisation icell=2 !cell optimisation during energy minimisation end if if (ibity.eq.2) qr='F' irecrun=1 end if if (qruid(1:6).eq.'MAXMOV') then iruid=1 read (qruid,'(6x,i6)',end=46,err=46)nfc irecrun=1 end if if (qruid(1:4).eq.'REDO') then iruid=1 read (qruid,'(4x,i6)',end=46,err=46)iredo irecrun=1 end if if (qruid(1:5).eq.'MAXIT') then iruid=1 read (qruid,'(6x,i6)',end=46,err=46)nmmax if (qruid(14:18).eq.'ENDPO') then read (qruid,'(18x,f6.3)',end=46,err=46)endpo end if irecrun=1 end if if (qruid(1:5).eq.'ENDPO') then iruid=1 read (qruid,'(6x,f6.3)',end=46,err=46)endpo irecrun=1 end if if (qruid(1:9).eq.'CHARGEMET') then iruid=1 read (qruid,'(9x,i6)',end=46,err=46)ncha irecrun=1 end if if (irecrun.eq.0) then write (*,*)'Warning: ignored RUTYPE identifier ',qruid(1:12) end if irecog=1 end if if (qhulp(1:14).eq.'BOND RESTRAINT') then nrestra=nrestra+1 istart=15 call stranal(istart,iend,vout,iout,1) irstra(nrestra,1)=iout istart=iend call stranal(istart,iend,vout,iout,1) irstra(nrestra,2)=iout istart=iend call stranal(istart,iend,vout,iout,1) rrstra(nrestra)=vout istart=iend call stranal(istart,iend,vout,iout,1) vkrstr(nrestra)=vout istart=iend call stranal(istart,iend,vout,iout,1) vkrst2(nrestra)=vout istart=iend call stranal(istart,iend,vout,iout,1) rrcha(nrestra)=vout istart=iend call stranal(istart,iend,vout,iout,1) itstart(nrestra)=iout istart=iend call stranal(istart,iend,vout,iout,1) itend(nrestra)=iout istart=iend * read (qhulp,'(15x,2i4,f8.4,f8.2,f8.5,f10.7)',end=46,err=46) * $irstra(nrestra,1),irstra(nrestra,2),rrstra(nrestra), * $vkrstr(nrestra),vkrst2(nrestra),rrcha(nrestra) qr='R' irecog=1 end if if (qhulp(1:15).eq.'ANGLE RESTRAINT') then nrestrav=nrestrav+1 read (qhulp,'(16x,3i4,2f8.2,f8.4,f9.6)',end=46,err=46) $irstrav(nrestrav,1),irstrav(nrestrav,2),irstrav(nrestrav,3), $vrstra(nrestrav),vkrv(nrestrav),vkr2v(nrestrav), $rvcha(nrestrav) qr='V' irecog=1 end if if (qhulp(1:17).eq.'TORSION RESTRAINT') then nrestrat=nrestrat+1 read (qhulp,'(18x,4i4,2f8.2,f8.4,f9.6)',end=46,err=46) $irstrat(nrestrat,1),irstrat(nrestrat,2),irstrat(nrestrat,3), $irstrat(nrestrat,4),trstra(nrestrat),vkrt(nrestrat), $vkr2t(nrestrat),rtcha(nrestrat) qr='T' irecog=1 end if if (qhulp(1:16).eq.'MASCEN RESTRAINT') then nrestram=nrestram+1 istart=17 call stranal(istart,iend,vout,iout,1) istart=iend irstram(nrestram,1)=0 if (qstrana2.eq.'x') irstram(nrestram,1)=1 if (qstrana2.eq.'y') irstram(nrestram,1)=2 if (qstrana2.eq.'z') irstram(nrestram,1)=3 if (qstrana2.eq.'p') irstram(nrestram,1)=4 !fixed center of mass if (irstram(nrestram,1).eq.0) $stop 'Error in mass centre restraint' call stranal(istart,iend,vout,iout,1) istart=iend irstram(nrestram,2)=iout call stranal(istart,iend,vout,iout,1) istart=iend irstram(nrestram,3)=iout call stranal(istart,iend,vout,iout,1) istart=iend rmstra1(nrestram)=vout call stranal(istart,iend,vout,iout,1) istart=iend if (irstram(nrestram,1).le.3) irstram(nrestram,4)=iout if (irstram(nrestram,1).eq.4) rmstra2(nrestram)=vout call stranal(istart,iend,vout,iout,1) istart=iend if (irstram(nrestram,1).le.3) irstram(nrestram,5)=iout if (irstram(nrestram,1).eq.4) rmstra3(nrestram)=vout call stranal(istart,iend,vout,iout,1) istart=iend if (irstram(nrestram,1).le.3) rmstra2(nrestram)=vout call stranal(istart,iend,vout,iout,1) istart=iend if (irstram(nrestram,1).le.3) rmstra3(nrestram)=vout call stranal(istart,iend,vout,iout,1) istart=iend if (irstram(nrestram,1).le.3) rmcha(nrestram)=vout irecog=1 end if if (qhulp(1:9).eq.'MOLCHARGE') then nmcharge=nmcharge+1 istart=10 call stranal(istart,iend,vout,iout,1) istart=iend iat1mc(nmcharge)=iout call stranal(istart,iend,vout,iout,1) istart=iend iat2mc(nmcharge)=iout call stranal(istart,iend,vout,iout,1) istart=iend vmcha(nmcharge)=vout irecog=1 end if if (qhulp(1:8).eq.'FIXATOMS') then istart=9 call stranal(istart,iend,vout,iout,1) if1=iout istart=iend call stranal(istart,iend,vout,iout,1) if2=iout do i12=if1,if2 imove(i12)=0 end do irecog=1 end if if (qhulp(1:11).eq.'UNIT ENERGY') then eenconv=zero read (qhulp,'(14x,a5)',end=46,err=46)quen if (quen.eq.'eV') eenconv=23.0408 if (quen.eq.'EV') eenconv=23.0408 if (quen.eq.'ev') eenconv=23.0408 if (quen.eq.'h') eenconv=627.5 if (quen.eq.'H') eenconv=627.5 if (quen.eq.'kcal') eenconv=1.0 if (quen.eq.'kCal') eenconv=1.0 if (quen.eq.'KCAL') eenconv=1.0 if (eenconv.eq.zero) then write (*,*)quen,': unknown energy unit; assuming kcal/mol' eenconv=1.0 end if irecog=1 end if if (qhulp(1:6).eq.'ENERGY') then read (qhulp(7:80),*,end=46,err=46)enmol ienread=1 irecog=1 end if if (qhulp(1:6).eq.'GEOUPD') then icgeopt(nprob)=0 icgeo=0 irecog=1 end if if (qhulp(1:9).eq.'NO GEOUPD') then icgeopt(nprob)=1 icgeo=1 irecog=1 end if if (qhulp(1:9).eq.'FREQUENCY') then ifreqset(nprob)=1 ifreq=1 irecog=1 end if * if (qhulp(1:5).eq.'FORCE') then * read (qhulp(6:80),*,end=46,err=46)formol * ienread=1 * irecog=1 * end if if (qhulp(1:6).eq.'FFIELD') goto 30 if (qhulp(1:6).eq.'CONECT') goto 30 if (qhulp(1:5).eq.'ORDER') goto 30 if (qhulp(1:1).eq.'#') goto 30 if (qhulp(1:3).eq.'END') goto 45 if (irecog.eq.0) then write (*,*)'Warning: ignored line starting with: ',qhulp(1:10) end if goto 30 40 write (*,*)'Error on line ',iline+1,' of Biograf-input' stop 45 read (3,*,err=46,end=46) 46 continue if (ienread.eq.1) then if (eenconv.eq.zero) then write (*,*)'No energy unit given; assuming kcal/mol' eenconv=1.0 end if enmol=enmol*eenconv !Convert energies to kcal/mol end if namov=0 !calculate number of moving atoms do i1=1,na if (imove(i1).eq.1) namov=namov+1 end do if (imodfile.eq.1) close (3) return 900 iendf=1 return end ************************************************************************ ************************************************************************ subroutine readpdb (iendf) ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkqa.blk" #include "control.blk" #include "opt.blk" #include "small.blk" #include "cbksrtbon1.blk" character*200 qhulp ********************************************************************** * * * Read in .pdb-geometry * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readpdb' c$$$ call timer(65) c$$$ close (65) c$$$ end if iendf=1 qmol='pdb_in' 5 read (3,'(a200)',end=10,err=900) qhulp qstrana1(1:200)=qhulp istart=1 call stranal(istart,iend,vout,iout,1) istart=iend if (qstrana2(1:6).eq.'HEADER') then call stranal(istart,iend,vout,iout,1) istart=iend qmol=qstrana2(1:20) end if if (qstrana2(1:6).eq.'HETATM'.or.qstrana2(1:4).eq.'ATOM') then call stranal(istart,iend,vout,iout,1) istart=iend call stranal(istart,iend,vout,iout,1) istart=iend qa(na+1)=qstrana2(1:2) call stranal(istart,iend,vout,iout,1) istart=iend call stranal(istart,iend,vout,iout,1) istart=iend call stranal(istart,iend,vout,iout,1) istart=iend c(na+1,1)=vout call stranal(istart,iend,vout,iout,1) istart=iend c(na+1,2)=vout call stranal(istart,iend,vout,iout,1) istart=iend c(na+1,3)=vout na=na+1 end if if (qstrana2(1:3).eq.'END'.or.qstrana2(2:4).eq.'END') then iendf=0 goto 10 end if goto 5 10 continue return 900 write (*,*)'Error reading in .pdb-format' stop 'Error reading in .pdb-format' end ************************************************************************ ************************************************************************ subroutine readtreg ************************************************************************ #include "cbka.blk" #include "cbktregime.blk" #include "control.blk" #include "small.blk" dimension isumattreg(mtreg) character*200 qrom ********************************************************************** * * * Read in temperature regime * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readtreg' c$$$ call timer(65) c$$$ close (65) c$$$ end if ntrc=0 open (19,file='tregime.in',status='old',err=60) 10 read (19,'(a200)',end=50,err=900)qrom qstrana1(1:200)=qrom if (qrom(1:1).eq.'#') goto 10 istart=1 ntrc=ntrc+1 if (ntrc.gt.mtreg) then write (*,*)'Too many temperature regimes in tregime.in;', $' inrease mtreg in cbka.blk' stop 'Too many temperature regimes in tregime.in' end if call stranal(istart,iend,vout,iout,1) nittc(ntrc)=iout istart=iend if (ntrc.gt.1) then if (nittc(ntrc).lt.nittc(ntrc-1)) then ntrc=ntrc-1 write (*,*)'Warning: wrong order or empty line in tregime.in' write (*,*)'Ignored lines below iteration:',nittc(ntrc) goto 50 end if end if call stranal(istart,iend,vout,iout,1) nntreg(ntrc)=iout if (nntreg(ntrc).gt.mtzone) then write (*,*)'Too many temperature zones in tregime.in;', $' inrease mtzone in cbka.blk' stop 'Too many temperature zones in tregime.in' end if istart=iend isumattreg(ntrc)=0 do i1=1,nntreg(ntrc) call stranal(istart,iend,vout,iout,1) ia1treg(ntrc,i1)=iout istart=iend call stranal(istart,iend,vout,iout,1) ia2treg(ntrc,i1)=iout istart=iend isumattreg(ntrc)=isumattreg(ntrc)+1+ia2treg(ntrc,i1)- $ia1treg(ntrc,i1) call stranal(istart,iend,vout,iout,1) tsettreg(ntrc,i1)=vout istart=iend call stranal(istart,iend,vout,iout,1) tdamptreg(ntrc,i1)=vout istart=iend call stranal(istart,iend,vout,iout,1) dttreg(ntrc,i1)=vout istart=iend end do goto 10 50 continue close (19) 60 continue ********************************************************************** * * * Check consistency temperature programs in tregime.in * * * ********************************************************************** if (ntrc.gt.0) then do i1=1,ntrc if (isumattreg(i1).ne.na) then write (*,*)'Inconsistency in temperature regime nr.',i1 write (*,*)'Number of atoms defined in tregime.in:', $isumattreg(i1) write (*,*)'Number of atoms in system:',na stop 'Inconsistency in tregime.in' end if end do end if return 900 stop 'Error reading tregime.in' end ************************************************************************ ************************************************************************ subroutine readvreg ************************************************************************ #include "cbka.blk" #include "cbkc.blk" #include "cbkvregime.blk" #include "control.blk" character*200 qrom ********************************************************************** * * * Read in volume regime * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readvreg' c$$$ call timer(65) c$$$ close (65) c$$$ end if nvrc=0 open (19,file='vregime.in',status='old',err=60) 10 read (19,'(a200)',end=50,err=900)qrom qstrana1(1:200)=qrom if (qrom(1:1).eq.'#') goto 10 istart=1 nvrc=nvrc+1 if (nvrc.gt.mvreg) then write (*,*)'Too many volume regimes in vregime.in;', $' inrease mvreg in cbka.blk' stop 'Too many volume regimes in vregime.in' end if call stranal(istart,iend,vout,iout,1) nitvc(nvrc)=iout istart=iend if (nvrc.gt.1) then if (nitvc(nvrc).lt.nitvc(nvrc-1)) then nvrc=nvrc-1 write (*,*)'Warning: wrong order or empty line in vregime.in' write (*,*)'Ignored lines below iteration:',nitvc(nvrc) goto 50 end if end if call stranal(istart,iend,vout,iout,1) nnvreg(nvrc)=iout if (nnvreg(nvrc).gt.mvzone) then write (*,*)'Too many volume regimes in vregime.in;', $' inrease mvzone in cbka.blk' stop 'Too many volume zones in vregime.in' end if istart=iend do i1=1,nnvreg(nvrc) call stranal(istart,iend,vout,iout,1) if (qstrana2(1:1).ne.'a'.and.qstrana2(1:1).ne.'b'.and. $qstrana2(1:1).ne.'c'.and.qstrana2(1:4).ne.'alfa'.and. $qstrana2(1:4).ne.'beta'.and.qstrana2(1:5).ne.'gamma') then write (*,*)qstrana2 write (*,*)'Invalid cell parameter type in vregime.in ;', $' use a,b,c,alfa,beta or gamma' stop 'Invalid cell parameter type in vregime.in' end if qvtype(nvrc,i1)=qstrana2 istart=iend call stranal(istart,iend,vout,iout,1) dvvreg(nvrc,i1)=vout istart=iend call stranal(istart,iend,vout,iout,1) ivsca(nvrc,i1)=1 if (qstrana2(1:1).eq.'n') ivsca(nvrc,i1)=0 istart=iend end do goto 10 50 continue close (19) 60 continue return 900 stop 'Error reading vregime.in' end ************************************************************************ ************************************************************************ subroutine readereg ************************************************************************ #include "cbka.blk" #include "cbkeregime.blk" #include "control.blk" character*200 qrom ********************************************************************** * * * Read in electric field regime * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readereg' c$$$ call timer(65) c$$$ close (65) c$$$ end if nerc=0 open (19,file='eregime.in',status='old',err=60) 10 read (19,'(a200)',end=50,err=900)qrom qstrana1(1:200)=qrom if (qrom(1:1).eq.'#') goto 10 istart=1 nerc=nerc+1 if (nerc.gt.mereg) then write (*,*)'Too many electric field regimes in eregime.in;', $' inrease mereg in cbka.blk' stop 'Too many electric field regimes in eregime.in' end if call stranal(istart,iend,vout,iout,1) nitec(nerc)=iout if (nerc.gt.1) then if (nitec(nerc).lt.nitec(nerc-1)) then nerc=nerc-1 write (*,*)'Warning: wrong order or empty line in eregime.in' write (*,*)'Ignored lines below iteration:',nitec(nerc) goto 50 end if end if istart=iend call stranal(istart,iend,vout,iout,1) nnereg(nerc)=iout if (nnereg(nerc).gt.mezone) then write (*,*)'Too many electric field zones in eregime.in;', $' inrease mezone in cbka.blk' stop 'Too many electric field zones in vregime.in' end if istart=iend do i1=1,nnereg(nerc) call stranal(istart,iend,vout,iout,1) if (qstrana2(1:1).ne.'x'.and.qstrana2(1:1).ne.'y'.and. $qstrana2(1:1).ne.'z') then write (*,*)qstrana2 write (*,*)'Invalid field direction in eregime.in ;', $' use x,y or z' stop 'Invalid field direction in eregime.in' end if qetype(nerc,i1)=qstrana2 istart=iend call stranal(istart,iend,vout,iout,1) ereg(nerc,i1)=vout istart=iend end do goto 10 50 continue close (19) 60 continue return 900 stop 'Error reading vregime.in' end ************************************************************************ ************************************************************************ subroutine readaddmol ************************************************************************ #include "cbka.blk" #include "cbkatomcoord.blk" #include "cbkc.blk" #include "cbkff.blk" #include "cbkh.blk" #include "control.blk" character*80 qromb character*200 qhulp character*5 qlabhulp ********************************************************************** * * * Read in molecule coordinates. This molecule will be added to * * the system at regular intervals * * Accepts only .bgf-format * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readaddmol' c$$$ call timer(65) c$$$ close (65) c$$$ end if ********************************************************************** * * * Set default values * * * ********************************************************************** iaddfreq=-1 !frequency of molecule addition; <0: no addition xadd=-9000.0 !x-coordinate for added molecule; <-5000.0: random yadd=-9000.0 !y-coordinate for added molecule; <-5000.0: random zadd=-9000.0 !z-coordinate for added molecule; <-5000.0: random iveladd=1 !1: random initial velocities; 2: read in velocities !from addmol.vel addist=-1.00 !Minimum distance between added molecule and rest !of system. < 0.0: do not check nadattempt=10 !Number of attempts at adding the molecule taddmol=-1.0 !Temperature added molecule. <0.0: system temperature open (19,file='addmol.bgf',status='old',err=60) read (19,'(a40)',end=900,err=900)qromb if (qromb(1:6).ne.'BIOGRF') then write (*,*)'addmol.bgf should start with BIOGRF' stop 'addmol.bgf should start with BIOGRF' end if naa=0 iline=0 30 read (19,'(a200)',end=900,err=900)qhulp irecog=0 iline=iline+1 if (qhulp(1:6).eq.'DESCRP') then irecog=1 end if if (qhulp(1:6).eq.'FORMAT') then irecog=1 end if if (qhulp(1:6).eq.'REMARK') then irecog=1 end if if (qhulp(1:6).eq.'HETATM') then irecog=1 read (qhulp,'(7x,i5,1x,a5,1x,3x,1x,1x,1x,5x,3f10.5)' $,end=900,err=900) $ir,qlabhulp,cadd(naa+1,1),cadd(naa+1,2),cadd(naa+1,3) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:5) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:4) if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:3) if (qlabhulp(1:1).eq.'C ') qadd(naa+1)='C ' if (qlabhulp(1:2).eq.'Ca') qadd(naa+1)='Ca' if (qlabhulp(1:2).eq.'Cl') qadd(naa+1)='Cl' if (qlabhulp(1:2).eq.'Cu') qadd(naa+1)='Cu' if (qlabhulp(1:2).eq.'Co') qadd(naa+1)='Co' if (qlabhulp(1:1).eq.'H ') qadd(naa+1)='H ' if (qlabhulp(1:2).eq.'He') qadd(naa+1)='He' if (qlabhulp(1:1).eq.'N ') qadd(naa+1)='N ' if (qlabhulp(1:2).eq.'Ni') qadd(naa+1)='Ni' if (qlabhulp(1:1).eq.'O ') qadd(naa+1)='O ' if (qlabhulp(1:1).eq.'B ') qadd(naa+1)='B ' if (qlabhulp(1:1).eq.'F ') qadd(naa+1)='F ' if (qlabhulp(1:2).eq.'Fe') qadd(naa+1)='Fe' if (qlabhulp(1:1).eq.'P ') qadd(naa+1)='P ' if (qlabhulp(1:1).eq.'S ') qadd(naa+1)='S ' if (qlabhulp(1:1).eq.'Y ') qadd(naa+1)='Y ' if (qlabhulp(1:2).eq.'Al') qadd(naa+1)='Al' if (qlabhulp(1:2).eq.'Au') qadd(naa+1)='Au' if (qlabhulp(1:2).eq.'Si') qadd(naa+1)='Si' if (qlabhulp(1:2).eq.'Pt') qadd(naa+1)='Pt' if (qlabhulp(1:2).eq.'Mo') qadd(naa+1)='Mo' if (qlabhulp(1:2).eq.'Mg') qadd(naa+1)='Mg' if (qlabhulp(1:2).eq.'Ar') qadd(naa+1)='Ar' if (qlabhulp(1:2).eq.'Zr') qadd(naa+1)='Zr' if (qlabhulp(1:2).eq.'Ba') qadd(naa+1)='Ba' if (qlabhulp(1:2).eq.'X ') qadd(naa+1)='X ' ityadd(naa+1)=0 do i1=1,nso !Find force field type if (qadd(naa+1).eq.qas(i1)) ityadd(naa+1)=i1 end do if (ityadd(naa+1).eq.0) then write (*,*) 'Unknown atom type:',qadd(naa+1) stop 'Unknown atom type' end if naa=naa+1 end if if (qhulp(1:7).eq.'FREQADD') then irecog=1 read (qhulp,'(8x,i6)',end=900,err=900) iaddfreq end if if (qhulp(1:6).eq.'VELADD') then irecog=1 read (qhulp,'(8x,i6)',end=900,err=900) iveladd end if if (qhulp(1:6).eq.'STARTX') then irecog=1 read (qhulp,'(7x,f8.2)',end=900,err=900) xadd end if if (qhulp(1:6).eq.'STARTY') then irecog=1 read (qhulp,'(7x,f8.2)',end=900,err=900) yadd end if if (qhulp(1:6).eq.'STARTZ') then irecog=1 read (qhulp,'(7x,f8.2)',end=900,err=900) zadd end if if (qhulp(1:6).eq.'ADDIST') then irecog=1 read (qhulp,'(7x,f8.2)',end=900,err=900) addist end if if (qhulp(1:8).eq.'NATTEMPT') then irecog=1 read (qhulp,'(9x,i6)',end=900,err=900) nadattempt end if if (qhulp(1:7).eq.'TADDMOL') then irecog=1 read (qhulp,'(8x,f8.2)',end=900,err=900) taddmol end if if (qhulp(1:6).eq.'FFIELD') goto 30 if (qhulp(1:6).eq.'CONECT') goto 30 if (qhulp(1:5).eq.'ORDER') goto 30 if (qhulp(1:1).eq.'#') goto 30 if (qhulp(1:3).eq.'END') goto 45 if (irecog.eq.0) then write (*,*)'Warning: ignored line starting with: ',qhulp(1:10) end if goto 30 45 continue close (19) if (iveladd.eq.2) then open (19,file='addmol.vel',status='old',err=800) read (19,*) read (19,'(3d24.15)',err=850,end=850) $((veladd(j,i),j=1,3),i=1,naa) close (19) end if ************************************************************************ * * * Place molecule at origin * * * ************************************************************************ ccx=0.0 ccy=0.0 ccz=0.0 do i1=1,naa ccx=ccx+cadd(i1,1)/float(naa) ccy=ccy+cadd(i1,2)/float(naa) ccz=ccz+cadd(i1,3)/float(naa) end do do i1=1,naa cadd(i1,1)=cadd(i1,1)-ccx cadd(i1,2)=cadd(i1,2)-ccy cadd(i1,3)=cadd(i1,3)-ccz end do 60 continue return 800 stop 'Error opening addmol.vel' 850 stop 'Error or end of file reading addmol.vel' 900 write (*,*)'Error or end-of-file reading addmol.bgf on line:', $iline return end ************************************************************************ ********************************************************************** subroutine writegeo(nunit1) ********************************************************************** #include "cbka.blk" #include "cbkc.blk" #include "cbkconst.blk" #include "cbkqa.blk" #include "cbkrestr.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "small.blk" #include "cbksrtbon1.blk" #include "cbkinit.blk" ********************************************************************** * * * Copy new geometries to unit nunit1 * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In writegeo' c$$$ call timer(65) c$$$ close (65) c$$$ end if if (axiss(1).lt.zero) then if (nrestra.eq.0.and.nrestrat.eq.0.and. $nrestrav.eq.0) $write (nunit1,300)qr,qmol if (nrestra.gt.0) write (nunit1,301)qr, $rrstra(1),qmol if (nrestrav.gt.0) write (nunit1,301)qr, $vrstra(1),qmol if (nrestrat.gt.0) write (nunit1,301)qr, $trstra(1),qmol else write (nunit1,310)qr,qmol write (nunit1,320)axiss(1),axiss(2),axiss(3) write (nunit1,320)angles(1),angles(2),angles(3) end if do i1=1,na if (nbiolab.ne.1) write (nunit1,400)i1,qa(i1),(c(i1,i2),i2=1,3) if (nbiolab.eq.1) write (nunit1,401)i1,qa(i1),(c(i1,i2),i2=1,3) !Delphi-format end do if (nbiolab.ne.1) write (nunit1,*) return 300 format (2x,a1,1x,a60) 301 format (2x,a1,1x,f6.2,a60) 310 format (2x,a1,1x,a60) 320 format (3f10.4) 400 format (i4,1x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) 401 format (i3,2x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) end ********************************************************************** ********************************************************************** subroutine writebgf(nunit1) ********************************************************************** #include "cbka.blk" #include "cbkc.blk" #include "cbkcha.blk" #include "cbkcharmol.blk" #include "cbkconst.blk" #include "cbkenergies.blk" #include "cbkia.blk" #include "cbkimove.blk" #include "cbkinit.blk" #include "cbkqa.blk" #include "cbkrestr.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "opt.blk" #include "cbksrtbon1.blk" #include "small.blk" dimension qdir(3) character*2 qt character*1 qdir ********************************************************************** * * * Copy new Biograf-geometries to unit nunit1 * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In newbgf' c$$$ call timer(65) c$$$ close (65) c$$$ end if irom=1 qdir(1)='x' qdir(2)='y' qdir(3)='z' ibgfversion=200 if (ibity.eq.1) write (nunit1,1500)ibgfversion if (ibity.eq.2) write (nunit1,1600)ibgfversion * if (qr.ne.'F'.and.qr.ne.'5'.and.qr.ne.'Y') * $write (nunit1,1500)ibgfversion * if (qr.eq.'F'.or.qr.eq.'5'.or.qr.eq.'Y') * $write (nunit1,1600)ibgfversion write (nunit1,1700)qmol * write (nunit1,1700)qkeyw(nprob) do i1=1,iremark write (nunit1,1800)qremark(i1) end do qruid='NORMAL RUN' if (iruid.eq.0) then write (nunit1,2000) else if (abs(endpo-endpoold).gt.1e-5) write (nunit1,2010)endpo if (nmmax.ne.nmmaxold) write (nunit1,2020)nmmax if (nfc.ne.nfcold) write (nunit1,2030)nfc if (ncha.ne.nchaold) write (nunit1,2036)ncha if (iredo.gt.1) write (nunit1,2035)iredo if (icell.ne.icellold) then if (icell.eq.0) write (nunit1,2033) if (icell.gt.0) write (nunit1,2034)ncellopt end if end if if (iexco.ne.0.and.nsurp.gt.0) then write (nunit1,2040)vvol write (nunit1,3500) write (nunit1,*) return end if if (nmcharge.gt.0) then do i3=1,nmcharge write (nunit1,2050)iat1mc(i3),iat2mc(i3),vmcha(i3) end do end if ims=0 do i1=1,na if (ims.eq.0.and.imove(i1).eq.0) then if1=i1 ims=1 end if if (ims.eq.1.and.imove(i1).eq.1) then write (nunit1,2060)if1,i1-1 ims=0 end if end do if (ims.eq.1) then write (nunit1,2060)if1,na end if * if (qr.eq.'F'.or.qr.eq.'5'.or.qr.eq.'Y') if (ibity.eq.2) $write (nunit1,2100)axiss(1),axiss(2),axiss(3),angles(1), $angles(2),angles(3) if (nrestra.gt.0) write (nunit1,2300) do i2=1,nrestra write (nunit1,2400) $irstra(i2,1),irstra(i2,2),rrstra(i2), $vkrstr(i2),vkrst2(i2),rrcha(i2),itstart(i2),itend(i2) end do if (nrestrav.gt.0) write (nunit1,2500) do i2=1,nrestrav write (nunit1,2600) $irstrav(i2,1),irstrav(i2,2),irstrav(i2,3), $vrstra(i2),vkrv(i2),vkr2v(i2),zero end do if (nrestrat.gt.0) write (nunit1,2700) do i2=1,nrestrat write (nunit1,2800) $irstrat(i2,1),irstrat(i2,2),irstrat(i2,3), $irstrat(i2,4),trstra(i2),vkrt(i2), $vkr2t(i2),zero end do if (nrestram.gt.0) write (nunit1,2810) do i2=1,nrestram write (nunit1,2820) $qdir(irstram(i2,1)),irstram(i2,2),irstram(i2,3), $rmstra1(i2),irstram(i2,4),irstram(i2,5),rmstra2(i2), $rmstra3(i2),rmcha(i2) end do if (icgeo.eq.0.and.ingeo.eq.0) write (nunit1,2830) if (icgeo.eq.1.and.ingeo.eq.1) write (nunit1,2840) if (ifreq.eq.1) write (nunit1,2850) write (nunit1,2900) do i2=1,na write (nunit1,3000)i2,qa(i2),c(i2,1),c(i2,2),c(i2,3), $qa(i2),irom,irom,chgbgf(i2) end do write (nunit1,3100) if (nsurp.lt.2) then do i1=1,na write (nunit1,3200)i1,(iag(i1,2+i2),i2=1,iag(i1,2)) end do write (nunit1,3300) write (nunit1,3400)estrc end if write (nunit1,3500) write (nunit1,*) return 1500 format ('BIOGRF',i4) 1600 format ('XTLGRF',i4) 1700 format ('DESCRP ',a60) 1800 format ('REMARK ',a60) 1900 format ('FFIELD ',a40) 2000 format ('RUTYPE NORMAL RUN') 2010 format ('RUTYPE ENDPO',f6.3) 2020 format ('RUTYPE MAXIT',i6) 2030 format ('RUTYPE MAXMOV',i6) 2033 format ('RUTYPE NO CELL OPT') 2034 format ('RUTYPE CELL OPT',i6) 2035 format ('RUTYPE REDO',i6) 2036 format ('RUTYPE CHARGEMET',i6) 2040 format ('VCHANGE',f8.4) 2050 format ('MOLCHARGE',2i4,f6.2) 2060 format ('FIXATOMS',2i6) 2100 format ('CRYSTX ',6f11.5) 2200 format ('CELLS ',6i5) 2300 format ('# At1 At2 R12 Force1 Force2 ', $'dR12/dIter(MD) Start (MD) End (MD)') 2400 format ('BOND RESTRAINT ',2i4,f8.4,f8.2,f8.4,1x,f10.7,2i8) 2500 format ('# At1 At2 At3 Angle Force1 Force2', $' dAngle/dIteration (MD only)') 2600 format ('ANGLE RESTRAINT ',3i4,2f8.2,f8.4,f9.6) 2700 format ('# At1 At2 At3 At3 Angle Force1 ', $'Force2 dAngle/dIteration (MD only)') 2800 format ('TORSION RESTRAINT ',4i4,2f8.2,f8.4,f9.6) 2810 format ('# x/y/z At1 At2 R At3 At4 Force1', $' Force2 dR/dIteration (MD only)') 2820 format ('MASCEN RESTRAINT ',a1,1x,2i4,f8.2,2i4,2f8.2,f9.6) 2830 format ('GEOUPD') 2840 format ('NO GEOUPD') 2850 format ('FREQUENCY') 2900 format ('FORMAT ATOM (a6,1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,', $'3f10.5,1x,a5,i3,i2,1x,f8.5)') 3000 format ('HETATM',1x,i5,1x,a2,3x,1x,3x,1x,1x,1x,5x,3f10.5,1x, $a5,i3,i2,1x,f8.5) 3100 format ('FORMAT CONECT (a6,12i6)') 3200 format ('CONECT',12i6) 3300 format ('UNIT ENERGY kcal') 3400 format ('ENERGY',5x,f14.6) 3500 format ('END') end ********************************************************************** ********************************************************************** subroutine writeen(tottime,sum1,sdev,sdeva,sum12,sumt,sump, $sumtt,tmax,eaver,eav2,eav3,etot2,ediff) ********************************************************************** #include "cbka.blk" #include "cbkcha.blk" #include "cbkenergies.blk" #include "cbkrestr.blk" #include "cbktorang.blk" #include "cbktorsion.blk" #include "cbktregime.blk" #include "control.blk" #include "small.blk" dimension disres(mrestra) ********************************************************************** * * * Write out MD statistics to units 71,73 and 76 * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In writeen' c$$$ call timer(65) c$$$ close (65) c$$$ end if if (nrep1.gt.1) $sdev=sqrt((sum12-sum1*sum1/float(nrep1))/float(nrep1-1)) eavn=eaver/float(mdstep) if (mdstep.gt.1) $sdeva=sqrt((eav3-eav2*eav2/float(mdstep))/float(mdstep-1)) C open (71,file='fort.71',status='unknown',access='append') C open (73,file='fort.73',status='unknown',access='append') write (71,'(i8,2i4,1x,19(f10.2,1x))')mdstep+nprevrun,nmolo, $nmolo5,estrc,ekin,estrc+ekin,tempmd,sum1/float(nrep1),eavn, $sumt/float(nrep1),tmax,sump/float(nrep1),sdev,sdeva,tset, $tstep*1d+15,rmsg,tottime write (73,'(i8,1x,14(f10.2,1x))')mdstep+nprevrun,eb,ea,elp, $emol,ev,ecoa,ehb,et,eco,ew,ep,ech,efi close (71) close (73) if ((sumt/float(nrep1)).gt.tset) then if (invt.eq.0) write (*,*)'Switched to NVT in iteration',mdstep invt=1 end if C if (nrestra.gt.0.or.nrestrat.gt.0) C $open (76,file='fort.76',status='unknown',access='append') if (nrestra.gt.0) then do i2=1,nrestra call dista2(irstra(i2,1),irstra(i2,2),disres(i2),dx,dy,dz) end do C open (76,file='fort.76',status='unknown',access='append') write (76,'(i8,1x,40f12.4)')mdstep,eres,estrc, $(rrstra(i2),disres(i2),i2=1,nrestra) end if if (nrestrat.gt.0) then C open (76,file='fort.76',status='unknown',access='append') do i2=1,nrestrat do i3=1,ntor ih1=irstrat(i2,1) ih2=irstrat(i2,2) ih3=irstrat(i2,3) ih4=irstrat(i2,4) if (ih1.eq.it(i3,2).and.ih2.eq.it(i3,3).and.ih3.eq.it(i3,4) $.and.ih4.eq.it(i3,5)) ittr=i3 end do write (76,'(i8,1x,40f12.4)')mdstep,eres, $trstra(i2),thg(ittr) end do end if if (nrestra.gt.0.or.nrestrat.gt.0) close(76) if (nrestram.gt.0) then C open (76,file='fort.76',status='unknown',access='append') do i2=1,nrestram write (76,'(2i8,1x,20f12.4)')mdstep,i2,eres,rmstra1(i2), $dismacen(i2) end do close (76) end if return end ********************************************************************** ************************************************************************ subroutine molanal ************************************************************************ #include "cbka.blk" #include "cbkbo.blk" #include "cbkconst.blk" #include "cbkdcell.blk" #include "cbkff.blk" #include "cbkia.blk" #include "cbkrbo.blk" #include "control.blk" #include "opt.blk" #include "small.blk" #include "cbksrtbon1.blk" dimension iam(nat,mbond+3),nmolata(nmolmax,nat) dimension molfra(nmolmax,nsort),ndup(nmolmax) character*40 qmolan1 character*100 qmolan logical found ************************************************************************ * * * Analyse and output molecular fragments * * * ************************************************************************ c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In molanal' c$$$ call timer(65) c$$$ close (65) c$$$ end if do i1=1,nmolmax do i2=1,nsort molfra(i1,i2)=0 end do ndup(i1)=1 end do do i1=1,na do i2=1,mbond+3 iam(i1,i2)=0 end do end do ************************************************************************ * * * Create connection table based on corrected bond orders * * * ************************************************************************ do i1=1,nbon if (bo(i1).gt.cutof3) then j1=ib(i1,2) j2=ib(i1,3) iam(j1,2)=iam(j1,2)+1 iam(j1,2+iam(j1,2))=j2 iam(j2,2)=iam(j2,2)+1 iam(j2,2+iam(j2,2))=j1 end if end do ********************************************************************** * * * Find molecules * * * ********************************************************************** nmolo6=0 found=.FALSE. DO 61 k1=1,na IF (iam(K1,3+mbond).EQ.0) found=.TRUE. 61 IF (iam(K1,3+mbond).GT.nmolo6) nmolo6=iam(K1,3+mbond) IF (.NOT.FOUND) GOTO 62 ************************************************************************ * * * Molecule numbers are assigned. No restrictions are made for the * * sequence of the numbers in the connection table. * * * ************************************************************************ N3=1 64 N2=N3 nmolo6=nmolo6+1 if (nmolo6.gt.nmolmax) stop 'Too many molecules in system' iam(N2,3+mbond)=nmolo6 67 FOUND=.FALSE. DO 66 N1=N2+1,na IF (iam(N1,3+mbond).NE.0) GOTO 66 DO 65 L=1,mbond IF (iam(N1,l+2).EQ.0) GOTO 66 IF (iam(iam(N1,l+2),3+mbond).EQ.nmolo6) THEN FOUND=.TRUE. iam(N1,3+mbond)=nmolo6 GOTO 66 ENDIF 65 CONTINUE 66 CONTINUE IF (FOUND) GOTO 67 DO 63 N3=N2+1,NA 63 if (iam(N3,3+mbond).eq.0) goto 64 ************************************************************************ * * * The assigned or input molecule numbers are checked for their * * consistency. * * * ************************************************************************ 62 FOUND=.FALSE. DO 72 N1=1,NA DO 71 L=1,mbond IF (iam(N1,L+2).EQ.0) GOTO 72 IF (iam(iam(N1,L+2),3+mbond).NE.iam(N1,3+mbond)) THEN FOUND=.TRUE. ENDIF 71 CONTINUE 72 CONTINUE IF (FOUND) THEN write (7,'(i4,a40)')na,qmol do i1=1,na write (7,'(40i4)')i1,iam(i1,1),(iam(i1,2+i2),i2=1,nsbmax), $iam(i1,3+mbond) end do STOP' Mol.nrs. not consistent; maybe wrong cell parameters' ENDIF do i1=1,nmolo6 natmol=0 do i2=1,na if (iam(i2,3+mbond).eq.i1) then natmol=natmol+1 nmolata(i1,natmol+1)=i2 end if end do nmolata(i1,1)=natmol end do ************************************************************************ * * * Analyze molecules * * * ************************************************************************ do i1=1,nmolo6 do i2=1,nmolata(i1,1) i3=nmolata(i1,1+i2) ityp=ia(i3,1) molfra(i1,ityp)=molfra(i1,ityp)+1 end do end do do i1=1,nmolo6 isee=0 do i2=1,nmolo6 isee2=1 do i3=1,nso if (molfra(i1,i3).ne.molfra(i2,i3)) isee2=0 end do if (isee2.eq.1.and.i1.gt.i2.and.isee.eq.0) then !molecule type already exists ndup(i2)=ndup(i2)+1 ndup(i1)=0 isee=1 end if end do end do C open (45,file='molfra.out',status='unknown',access='append') if (mdstep.eq.0) write (45,100)cutof3 write (45,110) ntotmol=0 ntotat=0 vtotmass=zero do i1=1,nmolo6 if (ndup(i1).gt.0) then * write (45,110)i1,(molfra(i1,i2),i2=1,nso),ndup(i1) ntotmol=ntotmol+ndup(i1) qmolan=' ' qmolan1=' ' istart=-4 ihulp=0 vmass=zero do i2=1,nso vmass=vmass+molfra(i1,i2)*amas(i2) ntotat=ntotat+molfra(i1,i2)*ndup(i1) if (molfra(i1,i2).gt.0) then istart=istart+6 iend=istart+5 if (molfra(i1,i2).gt.1) then write (qmolan(istart:iend),'(a2,i3)')qas(i2),molfra(i1,i2) else write (qmolan(istart:iend-2),'(a2)')qas(i2) end if end if end do ihulp=1 do i2=1,iend if (qmolan(i2:i2).ne.' ') then qmolan1(ihulp:ihulp)=qmolan(i2:i2) ihulp=ihulp+1 end if end do * write (45,120)ndup(i1),qmolan(1:iend),vmass write (45,120)mdstep,ndup(i1),qmolan1,vmass vtotmass=vtotmass+ndup(i1)*vmass end if end do write (45,*)'Total number of molecules:',ntotmol write (45,*)'Total number of atoms:',ntotat write (45,*)'Total system mass:',vtotmass close (45) return 100 format('Bond order cutoff:',f6.4) 110 format('Iteration Freq. Molecular formula',15x,'Molecular mass') 120 format(i8,i4,' x ',a35,f10.4) end ************************************************************************ ************************************************************************ subroutine stranal(istart,iend,vout,iout,icheck) ************************************************************************ #include "cbka.blk" #include "cbkconst.blk" #include "opt.blk" character*1 qchar dimension qchar(5) ********************************************************************** * * * Analyze string for special characters; find words in string * * * ********************************************************************** qchar(1)=' ' qchar(2)='/' ifound1=0 do i1=istart,200 ifound2=0 do i2=1,icheck if (qstrana1(i1:i1).eq.qchar(i2)) then ifound2=1 if (ifound1.eq.1) then !End of word iend=i1 goto 10 end if end if end do if (ifound2.eq.0.and.ifound1.eq.0) then !Start of word istart2=i1 ifound1=1 end if end do 10 continue qstrana2=' ' vout=zero iout=0 if (ifound1.eq.1) then qstrana2=qstrana1(istart2:iend-1) istart=istart2 vout=zero read (qstrana2,*,end=20,err=20) vout 20 iout=int(vout) end if return end ************************************************************************ ********************************************************************** subroutine dipmom(naold,dpmm,xdip,ydip,zdip,xdir,ydir,zdir) ********************************************************************** #include "cbka.blk" #include "cbkc.blk" #include "cbkch.blk" #include "cbkconst.blk" #include "control.blk" #include "small.blk" ********************************************************************** * * * Calculate and output dipole moment * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In dipmom' c$$$ call timer(65) c$$$ close (65) c$$$ end if ************************************************************************ * * * CONVERSION FACTOR TO DEBYE UNITS IS CALCULATED * * THE CALCULATION IS INITIALIZED * * * ************************************************************************ ELCHG=1.60217733D-19 ! [C] = [As] CLIGHT=2.99792458D8 ! [m/s] DBCONV=ONE/(CLIGHT*ELCHG*1.0D11) CHCPX=ZERO CHCPY=ZERO CHCPZ=ZERO CHCMX=ZERO CHCMY=ZERO CHCMZ=ZERO XDIP=ZERO YDIP=ZERO ZDIP=ZERO XGRD=ZERO YGRD=ZERO ZGRD=ZERO ************************************************************************ * * * CALCULATION OF MAGNITUDE AND CENTRES OF POSITIVE AND NEGATIVE * * CHARGES * * * ************************************************************************ if (na.eq.0) na=naold CHRG=ZERO DO 4 K1=1,NA CHK1=CH(K1) IF (CHK1.EQ.ZERO) GOTO 4 IF (CHK1.LT.ZERO) GOTO 3 CHRG=CHRG+CHK1 CHCPX=CHCPX+CHK1*C(K1,1) CHCPY=CHCPY+CHK1*C(K1,2) CHCPZ=CHCPZ+CHK1*C(K1,3) GOTO 4 3 CHCMX=CHCMX-CHK1*C(K1,1) CHCMY=CHCMY-CHK1*C(K1,2) CHCMZ=CHCMZ-CHK1*C(K1,3) 4 CONTINUE ************************************************************************ * * * CALCULATION OF DISTANCE BETWEEN CENTRES AND OF DIPOLE MOMENT * * IN DEBIJE UNITS * * * ************************************************************************ CHDSTX=CHCPX-CHCMX CHDSTY=CHCPY-CHCMY CHDSTZ=CHCPZ-CHCMZ DPMM=SQRT(CHDSTX*CHDSTX+CHDSTY*CHDSTY+CHDSTZ*CHDSTZ)/DBCONV IF(DPMM.LT.1.0D-4)RETURN XDIP=HALF*(CHCPX+CHCMX)/CHRG YDIP=HALF*(CHCPY+CHCMY)/CHRG ZDIP=HALF*(CHCPZ+CHCMZ)/CHRG GRTST=MAX(CHDSTX,CHDSTY,CHDSTZ) XDIR=-CHDSTX/GRTST YDIR=-CHDSTY/GRTST ZDIR=-CHDSTZ/GRTST open (64,file='dipole.out',status='unknown') write (64,100)dpmm,xdip,ydip,zdip,xdir,ydir,zdir close (64) 100 format ('Dipole moment (Debye):',f12.4,' Location:',3f12.4, $' Direction (-side):',3f12.4) return end ************************************************************************ ********************************************************************** subroutine readtraj(ivels) ********************************************************************** #include "cbka.blk" #include "cbkatomcoord.blk" #include "cbkc.blk" #include "cbkconst.blk" #include "cbkdistan.blk" #include "cbktregime.blk" #include "cellcoord.blk" #include "control.blk" #include "small.blk" #include "cbkinit.blk" ********************************************************************** * * * Read in trajectory file * * * ********************************************************************** c$$$ if (ndebug.eq.1) then c$$$C open (65,file='fort.65',status='unknown',access='append') c$$$ write (65,*) 'In readtraj' c$$$ call timer(65) c$$$ close (65) c$$$ end if open(unit=66,file='moldyn.vel',status='old',err=10) ivels=1 read (66,*) read (66,100)aaxis,baxis,caxis read (66,100)angles(1),angles(2),angles(3) if (qr.eq.'F'.or.qr.eq.'P'.or.ngeofor.eq.1) then axis(1)=aaxis axis(2)=baxis axis(3)=caxis axiss(1)=axis(1) axiss(2)=axis(2) axiss(3)=axis(3) angle(1)=angles(1) angle(2)=angles(2) angle(3)=angles(3) halfa=angle(1)*dgrrdn hbeta=angle(2)*dgrrdn hgamma=angle(3)*dgrrdn sinalf=sin(halfa) cosalf=cos(halfa) sinbet=sin(hbeta) cosbet=cos(hbeta) cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) if (cosphi.gt.1.0) cosphi=1.0 sinphi=sqrt(one-cosphi*cosphi) tm11=axis(1)*sinbet*sinphi tm21=axis(1)*sinbet*cosphi tm31=axis(1)*cosbet tm22=axis(2)*sinalf tm32=axis(2)*cosalf tm33=axis(3) end if if (aaxis.ne.axis(1).or.baxis.ne.axis(2).or.caxis.ne.axis(3)) $stop 'Wrong cell parameters in moldyn.vel' read (66,200)nan if (nan.ne.na) stop 'Wrong number of atoms in moldyn.vel-file' if (nbiolab.eq.1) write (*,*)'Warning: using labels in vels-file' read (66,250)((c(i,j),j=1,3),qlabel(i),i=1,na) read (66,*) read (66,300)((vel(j,i),j=1,3),i=1,na) read (66,*) read (66,300)((accel(j,i),j=1,3),i=1,na) read (66,*) read (66,300,end=10,err=10)((aold(j,i),j=1,3),i=1,na) read (66,*) read (66,300,end=10,err=10)tempmd read (66,*) read (66,350,end=10,err=10)nsbma2 10 continue ********************************************************************** * * * Format part * * * ********************************************************************** 100 format(3d15.8) 200 format(i4) 250 format(3d24.15,1x,a5) 300 format(3d24.15) 350 format(i3) 400 format (8i3,8f8.4) return end **********************************************************************