program kadena
C  fmc 94/8
C  
C  To read a Chem3d(v2.3) output file and create 
C the "attached" and "chain" part of an MM2 input file.
C  Some particular atoms will probably have to be corrected by hand.
C
          parameter (maxatm=300, maxbon=8, maxcha=50, maxlen= 50)
C  Variable maxbon must also be consistent with format 10
          implicit real*8 (a-h,o-z)
          character*3 simb
          dimension ibond(maxatm,maxbon),kbond(maxatm)
          dimension iattch(maxatm),jattch(maxatm)
          dimension ichai(maxcha,maxlen),kchai(maxcha)
C
10        format(a3,i5,3f12.6,i5,8i5)
20        FORMAT(3F10.5,I5,5X,3F10.5,2I5)
C Initializations
          do 110 j=1,maxbon
            do 100 i=1,maxatm
C (initialization of ibond is probably not necessary)
              ibond(i,j)= 0
  100         continue
  110       continue
          do 150 i=1,maxatm
            kbond(i)= 0
  150       continue

          index= 0
          izero= 0
          zero= 0.
          read(5,*) natom
C
C Reads all data
C
          do 300 i=1,maxatm
            read(5,10,end=500) simb,nce1,x1,y1,z1,ncod1,
     1        (ibond(i,j),j=1,maxbon)
  300       continue
          write(6,*) ' MAXATM=',maxatm,'  ONLY!!'
          stop
C Fills kbond
  500     continue
          natoms= i - 1
          do 700 i=1,natoms
             kbond(i)= 0
             do 600 j=1,maxbon
               if(ibond(i,j).eq.0) goto 700
                 kbond(i)= kbond(i) + 1
  600          continue
  700        continue
C
C  Deals with attached atoms
C
           nattch= 0
           do 1000 i= 1,natoms
             if(kbond(i).eq.1) then
               nattch= nattch+1
               jattch(nattch)= i
               iattch(nattch)= ibond(i,1)
C  Deletes from jattch
               ibond(i,1)= 0
               kbond(i)= 0
C  Deletes from iattch
C  after placing jattch in the last place of iattch bond list.
               iatt= iattch(nattch)
               jatt= jattch(nattch)
               kbiatt= kbond(iatt)
               kbiat1= kbiatt-1
               do 800 j=1,kbiat1
                 if(ibond(iatt,j).eq.jatt) then
                   iaux= ibond(iatt,kbiatt)   
                   ibond(iatt,kbiatt)= ibond(iatt,j)
                   ibond(iatt,j)= iaux
                   goto 900
                   end if
  800            continue
  900          continue
               ibond(iatt,kbiatt)= 0  
               kbond(iatt)= kbond(iatt)-1
               end if
 1000        continue
C
C  Now the chain part
C
           ncha= 0
 1100      continue
           do 2000 i=1,natoms
             if(kbond(i).ne.0) then
               ncha= ncha+1
               if(ncha.gt.maxcha) then
                 write(6,*) ' MAXCHA= ',maxcha,'  TOO LARGE !!!'
                 stop
                 end if
               ichai(ncha,1)= i
               kbi= kbond(i)
               ito= ibond(i,kbi)
               ibond(i,kbi)= 0
               kbond(i)= kbond(i) - 1
               ifrom= i
               do 1500 incha=2,maxlen
                 ichai(ncha,incha)= ito
C Deletes the ifrom contribution to ito
                 kbito= kbond(ito)
                 kbit1= kbito - 1
                 do 1150 ind=1,kbit1
                   if(ibond(ito,ind).eq.ifrom) then
                     iaux= ibond(ito,kbito)
                     ibond(ito,kbito)= ibond(ito,ind)
                     ibond(ito,ind)= iaux
                     goto 1200
                     end if
 1150              continue
 1200            continue
                 ibond(ito,kbito)= 0
                 kbond(ito)= kbond(ito)-1
C If chain is finished, start new chain
                 if(kbond(ito).eq.0) then
                   kchai(ncha)= incha
                   goto 1100
                   end if
C If not, look for the new link
                 kbito= kbond(ito)
                 ifrom= ito
                 ito= ibond(ito,kbito)
                 ibond(ifrom,kbito)= 0
                 kbond(ifrom)= kbond(ifrom)-1
 1500            continue
C If it gets here, problem
               write(6,*) ' MAXLEN= ',maxlen,'  ONLY !!! '
               stop
             end if
 2000      continue
C Apparently finished with the chains
C
C Prints out
C
         write(6,2010) nattch
 2010    format(2x,'Attached atoms: ',/,i5)
         write(6,2020) (iattch(i),jattch(i),i=1,nattch)
 2020    format(16i5)
         write(6,2030) ncha
 2030    format(2x,'Chains: ',/,i5)
         do 2100 i= 1,ncha
           write(6,2020) (ichai(i,k),k=1,kchai(i))
 2100      continue
         end