c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  program archive  --  create or extract from an archive  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "archive" is a utility program for coordinate files which
c     concatenates multiple coordinate sets into a single archive
c     file, or extracts individual coordinate sets from an archive
c
c
      program archive
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      integer i,iarc,ixyz,start,stop,step
      integer lext,freeunit,trimtext,current
      integer lines,last,leng1,leng2,nold
      character*1 letter,answer
      character*4 output
      character*7 ext
      character*8 mode
      character*60 arcfile,coordfile
      character*80 record,string
      logical exist,query
c
c
c     get the name to use for the coordinate archive file
c
      call initial
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Enter Name of the Coordinate Archive File :  ',$)
         read (input,20)  filename
   20    format (a60)
      end if
      call basefile (filename)
      iarc = freeunit ()
c
c     decide whether to compress or extract files
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,30)
   30    format (/,' Create (C) or Extract (E) from an Archive',
     &              ' [C] :  ',$)
         read (input,40)  answer
   40    format (a1)
      end if
      call upcase (answer)
      if (answer .eq. 'E') then
         mode = 'extract '
      else
         mode = 'compress'
      end if
c
c     make separate files into a single concatenated file
c
      if (mode .eq. 'compress') then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,50)
   50       format (/,' Use TINKER (T), XMOL (X) or BIOSYM (B)',
     &                 ' Format [T] :  ',$)
            read (input,60)  answer
   60       format (a1)
         end if
         call upcase (answer)
         last = leng
         do i = 1, leng
            letter = filename(i:i)
            if (letter .eq. '/')  last = leng
c           if (letter .eq. '\')  last = leng
            if (ichar(letter) .eq. 92)  last = leng
            if (letter .eq. ']')  last = leng
            if (letter .eq. ':')  last = leng
            if (letter .eq. '~')  last = leng
            if (letter .eq. '.')  last = i - 1
         end do
         leng = min(leng,last)
         if (answer .eq. 'X') then
            output = 'xmol'
            arcfile = filename(1:leng)//'.xmol'
         else if (answer .eq. 'B') then
            output = 'bios'
            arcfile = filename(1:leng)//'.bios'
         else
            output = 'xyz '
            arcfile = filename(1:leng)
            call suffix (arcfile,'arc')
         end if
         start = 0
         stop = 0
         step = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=70,end=70)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=70,end=70)  stop
         call nextarg (string,exist)
         if (exist)  read (string,*,err=70,end=70)  step
   70    continue
         if (query) then
            write (iout,80)
   80       format (/,' Numbers of First & Last File and Step',
     &                 ' Increment :  ',$)
            read (input,90)  record
   90       format (a80)
            read (record,*,err=100,end=100)  start,stop,step
  100       continue
         end if
         if (stop .eq. 0)  stop = start
         if (step .eq. 0)  step = 1
         call version (arcfile,'new')
         open (unit=iarc,file=arcfile,status='new')
c
c     cycle over the user specified coordinate files
c
         nold = 0
         i = start
         dowhile (i.ge.start .and. i.le.stop)
            ixyz = freeunit ()
            lext = 3
            call numeral (i,ext,lext)
            coordfile = filename(1:leng)//'.'//ext(1:lext)
            call version (coordfile,'old')
            inquire (file=coordfile,exist=exist)
            if (.not.exist .and. i.lt.100) then
               lext = 2
               call numeral (i,ext,lext)
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'old')
               inquire (file=coordfile,exist=exist)
            end if
            if (.not.exist .and. i.lt.10) then
               lext = 1
               call numeral (i,ext,lext)
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'old')
               inquire (file=coordfile,exist=exist)
            end if
            if (exist) then
               open (unit=ixyz,file=coordfile,status='old')
               rewind (unit=ixyz)
               call readxyz (ixyz)
               close (unit=ixyz)
               if (output .eq. 'xmol') then
                  if (n .ne. nold)  call active
                  call prtxmol (iarc)
               else if (output .eq. 'bios') then
                  if (n .ne. nold)  call active
                  call prtbios (iarc)
               else
                  call prtxyz (iarc)
               end if
            end if
            i = i + step
            nold = n
         end do
c
c     extract coordinates from a concatenated file
c
      else if (mode .eq. 'extract ') then
  110    continue
         arcfile = filename(1:leng)
         call suffix (arcfile,'arc')
         call version (arcfile,'old')
         inquire (file=arcfile,exist=exist)
         if (exist) then
            open (unit=iarc,file=arcfile,status='old')
         else
            write (iout,120)
  120       format (/,' Enter Name of the Coordinate Archive File',
     &                 ' :  ',$)
            read (input,130)  filename
  130       format (a60)
            leng = trimtext (filename)
            goto 110
         end if
         rewind (unit=iarc)
         call readxyz (iarc)
         rewind (unit=iarc)
         current = 1
         leng1 = 1
         leng2 = leng
         do i = 1, leng
            if (filename(i:i) .eq. '/')  leng1 = i+1
            if (filename(i:i) .eq. ']')  leng1 = i+1
            if (filename(i:i) .eq. ':')  leng1 = i+1
         end do
         do i = leng, leng1, -1
            if (filename(i:i) .eq. '.')  leng2 = i-1
         end do
         leng = leng2 - leng1 + 1
         filename(1:leng) = filename(leng1:leng2)
         start = 0
         stop = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=140,end=140)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=140,end=140)  stop
  140    continue
         if (query) then
            write (iout,150)
  150       format (/,' Numbers of First & Last File to Extract',
     &                 ' [<CR>=Exit] :  ',$)
            read (input,160)  record
  160       format (a80)
            read (record,*,err=170,end=170)  start,stop
  170       continue
         end if
         if (stop .eq. 0)  stop = start
         dowhile (start .ne. 0)
            if (start .le. current) then
               current = 1
               rewind (unit=iarc)
            end if
            lines = (start-current) * (n+1)
            do i = 1, lines
               read (iarc,180)
  180          format ()
            end do
            do i = start, stop
               lext = 3
               call numeral (i,ext,lext)
               call readxyz (iarc)
               ixyz = freeunit ()
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'new')
               open (unit=ixyz,file=coordfile,status='new')
               call prtxyz (ixyz)
               close (unit=ixyz)
            end do
            current = stop
            start = 0
            stop = 0
            query = .true.
            call nextarg (string,exist)
            if (exist) then
               read (string,*,err=190,end=190)  start
               query = .false.
            end if
            call nextarg (string,exist)
            if (exist)  read (string,*,err=190,end=190)  stop
  190       continue
            if (query) then
               write (iout,200)
  200          format (/,' Numbers of First & Last File to Extract',
     &                    ' [<CR>=Exit] :  ',$)
               read (input,210)  record
  210          format (a80)
               read (record,*,err=220,end=220)  start,stop
  220          continue
            end if
            if (stop .eq. 0)  stop = start
         end do
      end if
      close (unit=iarc)
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine prtxmol  --  output of XMOL coordinate file  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtxmol" writes out a set of Cartesian coordinates for
c     all active atoms in the XMOL program's generic XYZ format
c
c
      subroutine prtxmol (ixmol)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'titles.i'
      include 'usage.i'
      integer i,j,ixmol
      character*3 atmnam
      character*60 coordfile
      logical opened
c
c
c     open output unit if not already done
c
      inquire (unit=ixmol,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.xmol'
         call version (coordfile,'new')
         open (unit=ixmol,file=coordfile,status='new')
      end if
c
c     write out the number of active atoms and the title
c
      if (ltitle .eq. 0) then
         write (ixmol,10)  nuse
   10    format (i6,/)
      else
         write (ixmol,20)  nuse,title(1:ltitle)
   20    format (i6,2x,a,/)
      end if
c
c     write the atom name and coordinates for each active atom
c
      do i = 1, n
         if (use(i)) then
            atmnam = name(i)
            do j = 1, 3
               if ((atmnam(j:j).lt.'a'.or.atmnam(j:j).gt.'z') .and.
     &             (atmnam(j:j).lt.'A'.or.atmnam(j:j).gt.'Z'))
     &            atmnam(j:j) = ' '
            end do
            if (atmnam(1:1) .eq. 'H')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'C')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'N')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'O')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'S')  atmnam(2:3) = '  '
            write (ixmol,30)  atmnam,x(i),y(i),z(i)
   30       format (5x,a3,2x,3f12.6)
         end if
      end do
      if (.not. opened)  close (unit=ixmol)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine prtbios  --  output of BIOSYM archive file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "prtbios" writes out a set of Cartesian coordinates for
c     all active atoms in the Biosym Insight II archive format
c
c
      subroutine prtbios (ibios)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'titles.i'
      include 'usage.i'
      integer i,k,ibios
      character*60 coordfile
      logical opened
c
c
c     open output unit if not already done
c
      inquire (unit=ibios,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.bios'
         call version (coordfile,'new')
         open (unit=ibios,file=coordfile,status='new')
      end if
c
c     write out the title and the date/time line
c
      if (ltitle .eq. 0) then
         write (ibios,10)
   10    format (/,'date:')
      else
         write (ibios,20)  title(1:ltitle)
   20    format (a,/,'date:')
      end if
c
c     write the coordinates for each active atom
c
      k = 0
      do i = 1, n
         if (use(i)) then
            k = k + 1
            write (ibios,30)  name(i),x(i),y(i),z(i),k
   30       format (a3,2x,3f15.6,4x,i6)
         end if
      end do
c
c     finally, write the end lines for this frame
c
      write (ibios,40)
   40 format ('end',/,'end')
      if (.not. opened)  close (unit=ibios)
      return
      end
