      subroutine packdb (idx,ndx,dbasef,indexf,icomp)                   PACK001
c ----------------------------------------------------------------------PACK002
c     packs the database DBNAME                                         PACK003
c ----------------------------------------------------------------------PACK004
c     This program module is part of the PhysiSoft X-ray Library        PACK005
c     and may not be sold or reproduced for commercial purposes.        PACK006
c     Although it has been tested carefully, there is no warranty       PACK007
c     regarding accuracy or freedom from side-effects.                  PACK008
c                   (C) 1986-1990 Bernhard Rupp                         PACK009
c ----------------------------------------------------------------------PACK010
                                                                        PACK011
      parameter (iat=20,iidx=3200)                                      PACK012
                                                                        PACK013
      character ili*60,icomp*4,answ                                     PACK014
      character indexf*25,dbasef*25                                     PACK015
      integer idx(iidx),iix(iidx),ixx(iidx)                             PACK016
      dimension ili(iat+5)                                              PACK017
                                                                        PACK018
   22 format (a60)                                                      PACK019
      ipr=6                                                             PACK020
      ilines=0                                                          PACK021
      ifi=0                                                             PACK022
      open (7,file='sexiedbf.bak',form='formatted',access='direct',     PACK023
     & recl=60, status='unknown')                                       PACK024
      open (8,file='index.bak',form='formatted',access='direct',        PACK025
     & recl=6, status='unknown')                                        PACK026
                                                                        PACK027
      call clrscr (icomp)                                               PACK028
      write(ipr,'(/a)')'  Backing up data base ......'                  PACK029
      ieof=0                                                            PACK030
      istart=0                                                          PACK031
      do 0003 i=1,32000                                                 PACK032
         do 2003 j=1,5+iat                                              PACK033
            irec=istart+j                                               PACK034
 2003       read(1,22,rec=irec,err=9003) ili(j)                         PACK035
          goto 9001                                                     PACK036
 9003    ieof=1                                                         PACK037
 9001    iend=j-1                                                       PACK038
         do 3003 j=1,iend                                               PACK039
            irec=j+istart                                               PACK040
 3003       write (7,22,rec=irec) ili(j)                                PACK041
         istart=istart+j-1                                              PACK042
         if (ieof.eq.1) goto 9004                                       PACK043
 0003 continue                                                          PACK044
 9004 write(ipr,'(i6,a)') irec,' records backed up.....'                PACK045
      write(ipr,'(a)')'  Saving index file .........'                   PACK046
      do 4003 i=1,ndx                                                   PACK047
         write (8,'(i6)',rec=i) idx(i)                                  PACK048
 4003 continue                                                          PACK049
      write(ipr,'(a,i4)')'  Number of indexed entries ',ndx             PACK050
                                                                        PACK051
c --- rearrange index file --                                           PACK052
      write(ipr,'(a)')'  Rearranging index file.....'                   PACK053
                                                                        PACK054
      do 1004 i=1,ndx                                                   PACK055
         if (i.eq.ndx) then                                             PACK056
            ixx(i)=irec-iabs(idx(i))+1                                  PACK057
         else                                                           PACK058
            ixx(i)=iabs(idx(i+1))-iabs(idx(i))                          PACK059
         end if                                                         PACK060
 1004 continue                                                          PACK061
      idel=0                                                            PACK062
      inew=0                                                            PACK063
      do 0005 i=1,ndx                                                   PACK064
         if (idx(i).lt.0) then                                          PACK065
            idel=idel+1                                                 PACK066
            goto 0005                                                   PACK067
         end if                                                         PACK068
         inew=inew+1                                                    PACK069
         iix(inew)=idx(i)                                               PACK070
         ixx(inew)=ixx(i)                                               PACK071
 0005 continue                                                          PACK072
      iptr=iabs(idx(1))                                                 PACK073
      idx(1)=iptr                                                       PACK074
      do 1005 i=2,iidx                                                  PACK075
         if (iix(i).eq.0) goto 9105                                     PACK076
         iptr=iptr+ixx(i-1)                                             PACK077
         idx(i)=iptr                                                    PACK078
 1005 continue                                                          PACK079
 9105 continue                                                          PACK080
                                                                        PACK081
c --- abandon current files --                                          PACK082
      close(1,status='delete')                                          PACK083
      close(2,status='delete')                                          PACK084
                                                                        PACK085
c --- write new files                                                   PACK086
      open(unit=2,file=indexf, form='formatted', recl=6,                PACK087
     & access='direct', status='new')                                   PACK088
      open(unit=1,file=dbasef, form='formatted', recl=60,               PACK089
     & access='direct', status='new')                                   PACK090
                                                                        PACK091
      write(ipr,'(a)')'  Writing new index file.....'                   PACK092
      do 0008 i=1,ndx-idel                                              PACK093
         write (2,'(i6)',rec=i) idx(i)                                  PACK094
 0008 continue                                                          PACK095
      write(ipr,'(a,i4)')'  Number of updated entries ',ndx-idel        PACK096
      write(ipr,'(a)')'  Writing new data base file '                   PACK097
      istart=0                                                          PACK098
c --- transfer header --                                                PACK099
      do 0010 i=1,idx(1)-1                                              PACK100
 0010    read(7,22,rec=i) ili(i)                                        PACK101
      do 0011 i=1,idx(1)-1                                              PACK102
 0011    write(1,22,rec=i) ili(i)                                       PACK103
                                                                        PACK104
c --- transfer files --                                                 PACK105
      iblk=ndx-idel                                                     PACK106
      if (iblk.eq.0) then                                               PACK107
         write(ipr,'(a)')'  Data base is empty - no records to update'  PACK108
         return                                                         PACK109
      end if                                                            PACK110
      i=1                                                               PACK111
 0014 continue                                                          PACK112
      ist=iix(i)                                                        PACK113
      ied=iix(i)+ixx(i)-1                                               PACK114
      ibuf=0                                                            PACK115
      do 0012 j=ist,ied                                                 PACK116
         ibuf=ibuf+1                                                    PACK117
         read(7,22,rec=j,err=9012) ili(ibuf)                            PACK118
 0012 continue                                                          PACK119
      goto 9013                                                         PACK120
 9012 ied2=j-1                                                          PACK121
      goto 9014                                                         PACK122
 9013 ied2=idx(i)+ixx(i)-1                                              PACK123
 9014 ist2=idx(i)                                                       PACK124
      ibuf=0                                                            PACK125
      do 0013 j=ist2,ied2                                               PACK126
         ibuf=ibuf+1                                                    PACK127
         write(1,22,rec=j) ili(ibuf)                                    PACK128
 0013 continue                                                          PACK129
      i=i+1                                                             PACK130
      if (i.le.iblk) goto 0014                                          PACK131
      write(ipr,'(a)')'  Update finished'                               PACK132
      write(ipr,'(a)')'  Hit enter to return to data base menu'         PACK133
      call inkey (answ)                                                 PACK134
      return                                                            PACK135
      end                                                               PACK136
