******************************************************************************* program surflocus ******************************************************************************* c c c To compile non-graphics programs use : c f77 $(OPT) surflocus.f -o surflocus c real rx(3000) real ry(3000) real rz(3000) real rox(300) real roy(300) real roz(300) real ucell ,cx,cy,cz character*80 record(3000) character*80 recobj(300) character*80 rec character*80 aform character*80 bform character*40 fname character*40 gname character*4 aname character*20 right character*20 r1 character*5 left character*5 l1 character*1 at(3000) character*1 ao(300) integer i,ia,id,ih integer natom integer ndisp ,nobj integer j,itime integer ia(3000) real rdist c c print *,'Enter car file name: ' read(5,'(a40)') fname c print *,'Input the number of atoms:' read(5,*) natom c print *,'Enter molecule file name: ' read(5,'(a40)') gname c print *,'Input the number of atoms:' read(5,*) nobj c c print *,'Input the internuclear distance:' c read(5,*) rdist c for gold rdist=2.8837 c open(unit=7,file=fname,form='formatted', $ status='old',err=990) c open(unit=9,file=gname,form='formatted', $ status='old',err=990) c aform = "(a1,4x,3(2x,f13.9),a29)" bform = "(a5,3(f10.5),a29)" c do 210 i=1,nobj read(9,'(a80)',end=997,err=995) recobj(i) c write(6,'(a80)') recobj(i) read (recobj(i),aform,err=996) ao(i),rox(i), $ roy(i),roz(i),right print *,rox(i),roy(i),roz(i) 210 continue c read(7,'(a80)',end=997,err=995) record(1) read(7,'(a80)',end=997,err=995) record(2) read(7,'(a80)',end=997,err=995) record(3) read(7,'(a80)',end=997,err=995) record(4) read(7,'(a80)',end=997,err=995) record(5) write(6,'(a80)') record(5) read (record(5),bform,err=996) l1,cx,cy,cz,r1 do 200 i=1,natom read(7,'(a80)',end=997,err=995) record(i+5) c write(6,'(a80)') record(i+5) read (record(i+5),aform,err=996) at(i),rx(i), $ ry(i),rz(i),right print *,rx(i),ry(i),rz(i) if(at(i).eq.'H') ia(i)=1 if(at(i).eq.'C') ia(i)=6 if(at(i).eq.'N') ia(i)=7 if(at(i).eq.'O') ia(i)=8 if(at(i).eq.'Fe') ia(i)=26 if(at(i).eq.'S') ia(i)=16 if(at(i).eq.'Au') ia(i)=107 200 continue c close(7) c c print *,'Enter output string: ' read(5,'(a4)') aname c c output files for the fcc bridge position c call outfile(rdist,natom,nobj,rx,ry,rz,rox,roy,roz, $cx,cy,cz,record,recobj,at,ao,aname,1) c c output files for the top position c call outfile(rdist,natom,nobj,rx,ry,rz,rox,roy,roz, $cx,cy,cz,record,recobj,at,ao,aname,2) c c output files for the fcc position c call outfile(rdist,natom,nobj,rx,ry,rz,rox,roy,roz, $cx,cy,cz,record,recobj,at,ao,aname,3) c c output files for the hcp position c call outfile(rdist,natom,nobj,rx,ry,rz,rox,roy,roz, $cx,cy,cz,record,recobj,at,ao,aname,4) c goto 999 990 continue print *,'Error in input file' goto 999 995 continue print *,'Error in format' print *, record goto 999 996 continue print *,'Error parsing format' print *, record print *,left, rx(i), ry(i), rz(i),right goto 999 997 continue print *,'End of file detected' 999 continue c end c *************************************************************************** Subroutine int2char(i,tempchar1,tempchar2) *************************************************************************** ! To convert the integer data to character data Implicit None Integer i Character*1 tempchar1 Character*2 tempchar2 Character*4 record if(i.lt.10) then Write (record,'(i1)') i Read (record,'(a1)') tempchar1 else Write (record,'(i2)') i Read (record,'(a2)') tempchar2 endif Return End ************************************************************************** subroutine outfile(rd,na,no,rx,ry,rz,rox,roy,roz,cx,cy,cz, $record,recobj,at,ao,aname,itt) ************************************************************************** real rd integer na,no,itt character*4 aname character*1 at(3000) character*1 ao(300) real rx(3000) real ry(3000) real rz(3000) real rox(300) real roy(300) real roz(300) real cx,cy,cz character*80 record(3000) character*80 recobj(300) real nroy(300) real nroz(300) real ucell character*80 rec character*40 gname if(itt.eq.1) then c c fcc bridging site c gname=aname//'_fcb.car' r1y=0.25*rd r1z=0.25*sqrt(3.0)*rd r2y=1.75*rd r2z=0.75*sqrt(3.0)*rd else if(itt.eq.2) then c c top site c gname=aname//'_top.car' r1y=0.0 r1z=0.0 r2y=1.5*rd r2z=0.5*sqrt(3.0)*rd else if(itt.eq.3) then c c fcc site c gname=aname//'_fcc.car' r1y=0.5*rd r1z=sqrt(3.0)/6.0*rd r2y=2.0*rd r2z=2.0*sqrt(3.0)/3.0*rd else if(itt.eq.4) then c c hcp site c gname=aname//'_hcp.car' r1y=rd r1z=sqrt(3.0)/3.0*rd r2y=2.5*rd r2z=5.0*sqrt(3.0)/6.0*rd endif c open(unit=7,file=gname,form='formatted', $ status='new',err=990) ierror=0 junit=7 do 50 j=1,5 write(junit,'(a80)') record(j) 50 continue c c rec=record(5) c write (junit,10) rec(1:5),cx,cy,cz,rec(36:80) c rorigy=roy(1) rorigz=roz(1) do 110 j = 1,no rec=recobj(j) nroy(j)=roy(j)+r1y-rorigy nroz(j)=roz(j)+r1z-rorigz print *,rox(j),roy(j),roz(j) if(j.le.9) then write (junit,25) ao(j),j, $ rox(j),nroy(j),nroz(j),rec(51:80) else if(j.gt.9) then write (junit,27) ao(j),j, $ rox(j),nroy(j),nroz(j),rec(51:80) endif 110 continue do 120 j = 1,no rec=recobj(j) nroy(j)=roy(j)+r2y-rorigy nroz(j)=roz(j)+r2z-rorigz print *,rox(j),roy(j),roz(j) if(j.le.9) then write (junit,25) ao(j),j, $ rox(j),nroy(j),nroz(j),rec(51:80) else if(j.gt.9) then write (junit,27) ao(j),j, $ rox(j),nroy(j),nroz(j),rec(51:80) endif 120 continue do 100 j = 1,na rec=record(j+5) print *,rx(j),ry(j),rz(j) if(j.le.9) then write (junit,25) at(j),j, $ rx(j),ry(j),rz(j),rec(51:80) else if(j.gt.9) then write (junit,27) at(j),j, $ rx(j),ry(j),rz(j),rec(51:80) endif 100 continue do 150 j = 1,2 write(junit,'(a3)') 'end' 150 continue close(7) c 10 format(a5,3(f10.5),a45) 20 format(a8,f12.9,3x,f12.9,3x,f12.9,a30) 25 format(a1,i1,6x,f12.9,3x,f12.9,3x,f12.9,a30) 27 format(a1,i2,5x,f12.9,3x,f12.9,2x,f13.9,a30) c goto 999 990 continue print *,'Error in output file' goto 999 999 continue c Return End