program makea implicit integer*4 (i-n) character*80 fn parameter (nat0=100000) character*2 sy(nat0) character*20 s20 character*1 ok integer*4 gf,wg logical lpbc,lsep real r(3*nat0),p(3) write(6,*)'Exctracts Amber geometry' write(6,*)'Atomic types: TXT' write(6,*)'Geometry: GEO' write(6,701) 701 format(' Geometry frequency (1,2...; 0 for all,', 1' negative for separate files): ',$) read(5,*)gf if(gf.lt.0)then gf=-gf lsep=.true. else lsep=.false. endif if(gf.eq.0)gf=1 write(6,700) 700 format(' Correct PBC (y/n)? ',$) read(5,'(a)')ok lpbc=ok.eq.'y'.or.ok.eq.'Y' nat=0 open(2,file='TXT') if(.not.lsep)open(3,file='FILE.X') 1 read(2,200,end=500,err=500)fn 200 format(a80) if(fn(2:14).eq.'FLAG POINTERS')then read(2,*) read(2,*)nat write(6,*)nat,' atoms' if(nat.gt.nat0)then write(6,*)'Too many atoms' stop endif endif if(fn(2:15).eq.'FLAG ATOM_NAME')then read(2,*) read(2,4000)(sy(i),i=1,nat) 4000 format(20(a2,2x)) write(6,*)'types read' goto 2 endif goto 1 500 write(6,*)' atoms not defined' stop 2 close(2) ig=0 wg=0 open(2,file='GEO') read(2,*,end=900,err=900) 4 read(2,2001,end=900,err=900)(r(i),i=1,3*nat) 2001 format(10F8.3) ig=ig+1 read(2,*)p(1),p(2),p(3) if(ig.eq.1)write(6,600)p(1),p(2),p(3) 600 format('Box:',3f8.3) c c correct PBC: if(lpbc)then do 5 ix=1,3 do 5 ia=1,nat ii=ix+(ia-1)*3 6 if(r(ii).lt.p(ix)/2.)then r(ii)=r(ii)+p(ix) goto 6 endif 7 if(r(ii).gt.p(ix)/2.)then r(ii)=r(ii)-p(ix) goto 7 endif 5 continue if(ig.eq.1)write(6,*)'PBC fixed' endif if((ig/gf)*gf.eq.ig)then wg=wg+1 if(lsep)then write(s20,2000)ig 2000 format(i20) do 101 istart=1,len(s20) 101 if(s20(istart:istart).ne.' ')goto 102 102 do 103 iend=len(s20),1,-1 103 if(s20(iend:iend).ne.' ')goto 104 104 open(3,file=s20(istart:iend)//'.x') endif write(3,*)'amber',ig,'geometry' write(3,*)nat do 3 ia=1,nat iz=0 if(sy(ia)(1:1).eq.'H')iz=1 if(sy(ia).eq.'He')iz=2 if(sy(ia).eq.'Li')iz=3 if(sy(ia).eq.'Be')iz=4 if(sy(ia).eq.'B')iz=5 if(sy(ia)(1:1).eq.'C')iz=6 if(sy(ia)(1:1).eq.'N')iz=7 if(sy(ia)(1:1).eq.'O')iz=8 if(sy(ia)(1:1).eq.'F')iz=9 if(sy(ia).eq.'Na')iz=11 if(sy(ia).eq.'Mg')iz=12 if(sy(ia)(1:1).eq.'P')iz=15 if(sy(ia)(1:1).eq.'S')iz=16 if(sy(ia).eq.'Cl')iz=17 if(sy(ia)(1:1).eq.'K')iz=19 if(sy(ia).eq.'Ca')iz=20 if(sy(ia).eq.'Br')iz=35 if(sy(ia)(1:1).eq.'I')iz=53 if(iz.eq.0)write(6,*)iz,sy(ia),' unknown atom' 3 write(3,300)iz,(r(ix+(ia-1)*3),ix=1,3) 300 format(i3,3f12.6) if(lsep)close(3) endif goto 4 900 close(2) if(.not.lsep)close(3) write(6,*)ig,' geometries' if(lsep)then write(6,*)wg,' files' else write(6,*)wg,' written to FILE.X' endif stop end