c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  program superpose  --  optimal coordinate superposition  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "superpose" takes two input structures and superimposes them
c     in the optimal least squares sense; it will attempt to match
c     up all pairs of atoms or just those specified by the user
c
c
      program superpose
      implicit none
      include 'sizes.i'
      include 'align.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,i1,i2,n1,n2,ixyz
      integer range(4),delta
      integer option,start,stop,freeunit
      integer atomic1(maxatm),atomic2(maxatm)
      real*8 dist12,cutoff,rmsvalue
      real*8 x1(maxatm),y1(maxatm),z1(maxatm)
      real*8 x2(maxatm),y2(maxatm),z2(maxatm)
      real*8 mass1(maxatm),mass2(maxatm)
      character*1 answer
      character*3 name1(maxatm),name2(maxatm)
      character*60 file1,file2,title1,title2
      character*60 coordfile
      character*80 record
      logical skip
c
c
c     get the atomic coordinates for the first structure
c
      call initial
      call getxyz
      call field
      call katom
      file1 = filename
      title1 = title
      n1 = n
      do i = 1, n1
         x1(i) = x(i)
         y1(i) = y(i)
         z1(i) = z(i)
         name1(i) = name(i)
         atomic1(i) = atomic(i)
         mass1(i) = mass(i)
      end do
c
c     get the atomic coordinates for the second structure
c
      call getxyz
      call field
      call katom
      file2 = filename
      title2 = title
      n2 = n
      do i = 1, n2
         x2(i) = x(i)
         y2(i) = y(i)
         z2(i) = z(i)
         name2(i) = name(i)
         atomic2(i) = atomic(i)
         mass2(i) = mass(i)
      end do
c
c     determine which pairs of atoms are to be superimposed
c
      write (iout,10)
   10 format (/,' Two Options are Available :  (1) Fit atoms "M"',
     &           ' through "N" from structure 1',
     &        /,' to the corresponding atoms of structure 2. Enter',
     &           ' "1,M,N" to use this option.',
     &        /,' If "N" is omitted, the fit uses atoms 1 through',
     &           ' "M". If both "M" and "N" are',
     &        /,' omitted, the fit uses all atoms; or (2) Individual',
     &           ' entry of atom range pairs',
     &        /,' to be used in the fitting procedure.')
      option = 0
      start = 0
      stop = 0
      write (iout,20)
   20 format (/,' Enter an Option (either 1,M,N or 2',
     &           ' [<CR>=1,0,0]) :  ',$)
      read (input,30)  record
   30 format (a80)
      read (record,*,err=40,end=40)  option,start,stop
   40 continue
      if (option .eq. 0) then
         option = 1
         start = 0
         stop = 0
      end if
c
c     automatic superposition of corresponding sets of atoms
c
      if (option .eq. 1) then
         if (n1.ne.n2 .and. start.eq.0) then
            write (iout,50)
   50       format (/,' SUPERPOSE  --  The Molecules contain',
     &                 ' Different Numbers of Atoms')
         end if
         write (iout,60)
   60    format (/,' Include Hydrogens Atoms in the Fitting [Y] :  ',$)
         read (input,70)  answer
         call upcase (answer)
   70    format (a1)
         if (start.eq.0 .and. stop.eq.0) then
            start = 1
            stop = min(n1,n2)
         else if (start.ne.0 .and. stop.eq.0) then
            stop = min(n1,n2,start)
            start = 1
         else if (start.ne.0 .and. stop.ne.0) then
            start = max(1,start)
            stop = min(n1,n2,stop)
         end if
         nfit = 0
         do i = start, stop
            skip = .false.
            if (answer .eq. 'N') then
               if (atomic1(i).le.1 .or. atomic2(i).le.1) then
                  skip = .true.
               end if
            end if
            if (.not. skip) then
               nfit = nfit + 1
               ifit(1,nfit) = i
               ifit(2,nfit) = i
            end if
         end do
c
c     manual input of the pairs of atom ranges to superimpose
c
      else
         write (iout,80)
   80    format (/,' On successive lines below, enter atom pairs or',
     &              ' pairs of atom ranges to use',
     &           /,' during fitting. Entering "4,7" will fit atom 4',
     &              ' of structure 1 to atom 7 of',
     &           /,' structure 2, while the entry "4,7,9,12" will',
     &              ' match atoms 4 through 7 from',
     &           /,' structure 1 with atoms 9 through 12 of structure',
     &              ' 2. Hit <RET> to end entry',
     &           /,' of the list of pairs.')
         nfit = 0
         dowhile (.true.)
            do i = 1, 4
               range(i) = 0
            end do
            write (iout,90)
   90       format (/,' Enter a Pair of Atoms or Ranges :  ',$)
            read (input,100)  record
  100       format (a80)
            read (record,*,err=110,end=110)  (range(i),i=1,4)
  110       continue
            if (range(1) .eq. 0) then
               goto 120
            else if (range(2) .eq. 0) then
               nfit = nfit + 1
               ifit(1,nfit) = range(1)
               ifit(2,nfit) = range(1)
            else if (range(3) .eq. 0) then
               nfit = nfit + 1
               ifit(1,nfit) = range(1)
               ifit(2,nfit) = range(2)
            else
               delta = range(3) - range(1)
               do i = range(1), range(2)
                  nfit = nfit + 1
                  ifit(1,nfit) = i
                  ifit(2,nfit) = i + delta
               end do
            end if
         end do
  120    continue
      end if
c
c     decide on the weighting to use for the coordinates
c
      write (iout,130)
  130 format (/,' Use Mass- or Unit-Weighted Coordinates',
     &           ' (M or [U]) :  ',$)
      read (input,140)  answer
  140 format (a1)
      call upcase (answer)
      if (answer .eq. 'M') then
         do i = 1, nfit
            wfit(i) = 0.5d0 * (mass1(ifit(1,i)) + mass2(ifit(2,i)))
         end do
      else
         do i = 1, nfit
            wfit(i) = 1.0d0
         end do
      end if
c
c     decide which options to perform during superposition
c
      write (iout,150)
  150 format (/,' Write Best-Fit Coordinates of 2nd Molecule [N] :  ',$)
      read (input,160)  answer
  160 format (a1)
      call upcase (answer)
      cutoff = 0.0d0
      write (iout,170)
  170 format (/,' Cutoff Value for listing RMS Deviations [0.0] :  ',$)
      read (input,180)  cutoff
  180 format (f20.0)
c
c     perform the least squares superposition
c
      write (iout,190)
  190 format (/,' Summary of Root Mean Square Interatomic Distances :')
      verbose = .true.
      call impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue)
      write (iout,200)  rmsvalue
  200 format (/,' Final Root Mean Square Distance :',5x,f15.6)
c
c     write out the results of the superposition
c
      write (iout,210)  file1,title1
  210 format (/,' Structure 1 :  ',a,/,5x,a)
      write (iout,220)  file2,title2
  220 format (/,' Structure 2 :  ',a,/,5x,a)
      write (iout,230)
  230 format (/,'   Atom in the',9x,'Atom in the',12x,'Distance',
     &           10x,'Weight'
     &        /,' First Structure',5x,'Second Structure',
     &           8x,'Separated',10x,'in Fit'/)
      do i = 1, nfit
         i1 = ifit(1,i)
         i2 = ifit(2,i)
         dist12 = sqrt((x1(i1)-x2(i2))**2 + (y1(i1)-y2(i2))**2
     &                       + (z1(i1)-z2(i2))**2)
         if (dist12 .ge. cutoff) then
            write (iout,240)  i1,name1(i1),i2,name2(i2),dist12,wfit(i)
  240       format (5x,i5,'-',a3,11x,i5,'-',a3,7x,f13.6,4x,f12.4)
         end if
      end do
      write (iout,250)  rmsvalue
  250 format (/,' Final Root Mean Square Distance :',5x,f15.6)
c
c     create output file for superimposed second structure
c
      if (answer .eq. 'Y') then
         do i = 1, n
            x(i) = x2(i)
            y(i) = y2(i)
            z(i) = z2(i)
         end do
         ixyz = freeunit ()
         coordfile = file2(1:leng)//'.xyz'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end if
      end
