LOCAL INCLUDE 'RESOU.INC'
C                                       Local include for RESOU
      INCLUDE 'INCS:ZPBUFSZ.INC'
      HOLLERITH XNAMEI(3), XCLAIN(2), XNAMOU(3), XCLAOU(2)
      REAL      XSIN, XDISIN, XSOUT, XDISO, FPARM(30), RPARM(30)
      REAL       BUFF1(UVBFSS), BUFF2(UVBFSS)
      INTEGER   SEQIN, SEQOUT, DISKIN, DISKO, JBUFSZ, ILOCWT,
     *   CATOLD(256), INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO, LRECI,
     *   LRECO, NRPRMI, NRPRMO, OLDCNO, NEWCNO, NUMSOU, INSOU(30),
     *   OUSOU(30)
      LOGICAL   ISCOMP
      CHARACTER NAMEIN*12, CLAIN*6, NAMOUT*12, CLAOUT*6
      COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XNAMOU, XCLAOU,
     *   XSOUT, XDISO, FPARM, RPARM
      COMMON /TPARMS/ CATOLD, SEQIN, SEQOUT, DISKIN, DISKO, ILOCWT,
     *   INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO, LRECI, LRECO,
     *   NRPRMI, NRPRMO, ISCOMP, OLDCNO, NEWCNO, NUMSOU, INSOU,
     *   OUSOU
      COMMON /CHARPM/ NAMEIN, CLAIN, NAMOUT, CLAOUT
      COMMON /BUFRS/ BUFF1, BUFF2, JBUFSZ
C                                       End local include for RESOU
LOCAL END
      PROGRAM RESOU
C-----------------------------------------------------------------------
C! Renumbers sources
C# Utility UV UV-util VLA VLB
C-----------------------------------------------------------------------
C;  Copyright (C) 2025
C;  Associated Universities, Inc. Washington DC, USA.
C;
C;  This program is free software; you can redistribute it and/or
C;  modify it under the terms of the GNU General Public License as
C;  published by the Free Software Foundation; either version 2 of
C;  the License, or (at your option) any later version.
C;
C;  This program is distributed in the hope that it will be useful,
C;  but WITHOUT ANY WARRANTY; without even the implied warranty of
C;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C;  GNU General Public License for more details.
C;
C;  You should have received a copy of the GNU General Public
C;  License along with this program; if not, write to the Free
C;  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C;  MA 02139, USA.
C;
C;  Correspondence concerning AIPS should be addressed as follows:
C;         Internet email: aipsmail@nrao.edu.
C;         Postal address: AIPS Project Office
C;                         National Radio Astronomy Observatory
C;                         520 Edgemont Road
C;                         Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C   RESOU copies a data set renumbering sources
C   Inputs:
C      AIPS adverb  Prg. name.          Description.
C      INNAME         NAMEIN        Name of input UV data.
C      INCLASS        CLAIN         Class of input UV data.
C      INSEQ          SEQIN         Seq. of input UV data.
C      INDISK         DISKIN        Disk number of input VU data.
C      OUTNAME        NAMOUT        Name of the output uv file.
C                                   Default output is input file.
C      OUTCLASS       CLAOUT        Class of the output uv file.
C      OUTSEQ         SEQOUT        Seq. number of output uv data.
C      OUTDISK        DISKO         Disk number of the output file.
C      FPARM(30)      INSOU         Input source numbers
C      RPARM(30)      OUSOU         Output source numbers
C-----------------------------------------------------------------------
      CHARACTER PRGM*6
      INTEGER  IRET
      INCLUDE 'RESOU.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA PRGM /'RESOU '/
C-----------------------------------------------------------------------
C                                       Get input parameters and
C                                       create output file if nec.
      CALL RESOIN (PRGM, IRET)
      IF (IRET.NE.0) GO TO 990
C                                       Call routine that sends data
C                                       to the user routine.
      CALL RESOUV (IRET)
      IF (IRET.NE.0) GO TO 990
      CALL RESOHI
C                                       Close down files, etc.
 990  CALL DIE (IRET, BUFF1)
C
 999  STOP
      END
      SUBROUTINE RESOIN (PRGN, JERR)
C-----------------------------------------------------------------------
C   RESOIN gets input parameters for RESOU and creates an output file
C   if necessary.
C   Inputs:
C      PRGN    C*6  Program name
C   Output:
C      JERR    I    Error code: 0 => ok
C                                5 => catalog troubles
C                                8 => can't start
C   Output in common:
C      LRECI   I  Input file record length
C      NRPRMI  I  Input number of random parameters.
C      INCSI   I  Input Stokes' increment in vis.
C      INCFI   I  Input frequency increment in vis.
C      INCIFI  I  Input IF increment in vis.
C      LRECO   I  Output file record length
C      NRPRMO  I  Output number of random parameters.
C      INCSO   I  Output Stokes' increment in vis.
C      INCFO   I  Output frequency increment in vis.
C      INCIFO  I  Output IF increment in vis.
C      ISCOMP  L  If true data is compressed
C   Commons: /INPARM/ all input adverbs in order given by INPUTS
C                     file
C            /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
      INTEGER   JERR
      CHARACTER PRGN*6
C
      CHARACTER STAT*4, BLANK*6, PTYPE*2
      INTEGER   IROUND, NPARM, IERR, INCX, I, J
      LOGICAL   T, F
      INCLUDE 'RESOU.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DCAT.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DUVH.INC'
      DATA BLANK  /'      '/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Init for AIPS, disks, ...
      CALL ZDCHIN (T)
      CALL VHDRIN
      JBUFSZ = UVBFSS * 2
C                                       Initialize /CFILES/
      NSCR = 0
      NCFILE = 0
      JERR = 0
C                                       Get input parameters.
      NPARM = 74
      CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         RQUICK = .TRUE.
         JERR = 8
         IF (IERR.EQ.1) GO TO 999
            WRITE (MSGTXT,1000) IERR
            CALL MSGWRT (8)
         END IF
C                                       Restart AIPS
      IF (RQUICK) CALL RELPOP (JERR, BUFF1, IERR)
      IF (JERR.NE.0) GO TO 999
      JERR = 5
C                                       Crunch input parameters.
      CALL H2CHR (12, 1, XNAMEI, NAMEIN)
      CALL H2CHR (6, 1, XCLAIN, CLAIN)
      CALL H2CHR (12, 1, XNAMOU, NAMOUT)
      CALL H2CHR (6, 1, XCLAOU, CLAOUT)
      SEQIN = IROUND (XSIN)
      SEQOUT = IROUND (XSOUT)
      DISKIN = IROUND (XDISIN)
      DISKO = IROUND (XDISO)
C                                       Get antenna list
      NUMSOU = 0
      DO 20 I = 1,30
         INSOU(I) = IROUND (FPARM(I))
         OUSOU(I) = IROUND (RPARM(I))
         IF ((INSOU(I).LE.0) .OR. (OUSOU(I).LE.0)) GO TO 30
         DO 10 J = 1,NUMSOU
            IF (INSOU(J).EQ.INSOU(I)) THEN
               MSGTXT = 'SOURCE NUMBERS REPEATED IN FPARM'
               GO TO 990
               END IF
 10         CONTINUE
         NUMSOU = NUMSOU + 1
 20      CONTINUE
C                                       Create new file.
C                                       Get CATBLK from old file.
 30   IF (NUMSOU.LE.0) THEN
         MSGTXT = 'NO SOURCE NUMBERS SPECIFIED'
         GO TO 990
         END IF
      OLDCNO = 1
      PTYPE = 'UV'
      CALL CATDIR ('SRCH', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, STAT, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1030) IERR, NAMEIN, CLAIN, SEQIN, DISKIN,
     *      NLUSER
         GO TO 990
         END IF
      CALL CATIO ('READ', DISKIN, OLDCNO, CATBLK, 'REST', BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1040) IERR
         GO TO 990
         END IF
C                                       Save input CATBLK
      CALL COPY (256, CATBLK, CATOLD)
C                                       Compressed data?
      ISCOMP = CATBLK(KINAX).EQ.1
C                                       Find weight and scale.
      IF (ISCOMP) THEN
         CALL AXEFND (8, 'WEIGHT  ', CATBLK(KIPCN), CATH(KHPTP), ILOCWT,
     *      JERR)
         IF (JERR.NE.0) THEN
            MSGTXT = 'ERROR FINDING WEIGHT FOR COMPRESSED DATA'
            JERR = 9
            GO TO 990
            END IF
         END IF
C                                       Get uv header info.
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
C                                       Save input file info
      INCX = CATBLK(KINAX)
      LRECI = LREC
      NRPRMI = NRPARM
      INCSI = INCS / INCX
      INCFI = INCF / INCX
      INCIFI = INCIF / INCX
C                                       Put new values in CATBLK.
      CALL MAKOUT (NAMEIN, CLAIN, SEQIN, BLANK, NAMOUT, CLAOUT, SEQOUT)
      CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
      CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC))
      CATBLK(KIIMS) = SEQOUT
C                                       Create output file.
      NEWCNO = 1
      FRW(NCFILE+1) = 3
      JERR = 4
      CALL UVCREA (DISKO, NEWCNO, BUFF1, IERR)
      IF (IERR.NE.0) THEN
         WRITE (MSGTXT,1050) IERR
         GO TO 990
         END IF
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKO
      FCNO(NCFILE) = NEWCNO
      FRW(NCFILE) = FRW(NCFILE) - 1
C                                       Save output file info
      CALL UVPGET (JERR)
      IF (JERR.NE.0) GO TO 999
      IF (ILOCSU.LT.0) THEN
         MSGTXT = 'MULTI-SOURCE DATA SET REQUIRED'
         GO TO 990
         END IF
      INCX = CATBLK(KINAX)
      LRECO = LREC
      NRPRMO = NRPARM
      INCSO = INCS / INCX
      INCFO = INCF / INCX
      INCIFO = INCIF / INCX
C                                        Put input file in READ
      PTYPE = 'UV'
      CALL CATDIR ('CSTA', DISKIN, OLDCNO, NAMEIN, CLAIN, SEQIN,
     *   PTYPE, NLUSER, 'READ', BUFF1, IERR)
      NCFILE = NCFILE + 1
      FVOL(NCFILE) = DISKIN
      FCNO(NCFILE) = OLDCNO
      FRW(NCFILE) = 0
      JERR = 0
      SEQOUT = CATBLK(KIIMS)
      GO TO 999
C
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RESOIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
 1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
     *   I3,' USID=',I5)
 1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
 1050 FORMAT ('ERROR',I3,' CREATING OUTPUT FILE')
      END
      SUBROUTINE RESOUV (IRET)
C-----------------------------------------------------------------------
C   RESOUV sends uv data one point at a time to the user supplied
C   routine and then writes the modified data if requested.
C   Input in common:
C      LRECI   I  Input file record length
C      NRPRMI  I  Input number of random parameters.
C      INCSI   I  Input Stokes increment in vis.
C      INCFI   I  Input frequency increment in vis.
C      INCIFI  I  Input IF increment in vis.
C      LRECO   I  Output file record length
C      NRPRMO  I  Output number of random parameters.
C      INCSO   I  Output Stokes' increment in vis.
C      INCFO   I  Output frequency increment in vis.
C      INCIFO  I  Output IF increment in vis.
C      ISCOMP  L  If true data is compressed
C   Output:
C      IRET    I  Return code, 0 => OK, otherwise abort.
C-----------------------------------------------------------------------
      INTEGER   IRET
C
      CHARACTER OFILE*48, IFILE*48
      INTEGER   INIO, IPTRI, IPTRO, LUNI, LUNO, INDI, INDO, ILENBU,
     *   KBIND, NIOUT, NIOLIM, IBIND, I, INCX, BO, VO, J, NUMVIS,
     *   XCOUNT, NCORI, NCORO, NCOPY, RNXRET, VISINC, VISMSG
      LOGICAL   T, F
      INCLUDE 'RESOU.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DUVH.INC'
      INCLUDE 'INCS:DHDR.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUNI, LUNO /16, 17/
      DATA VO, BO /0, 1/
      DATA T, F /.TRUE.,.FALSE./
C-----------------------------------------------------------------------
C                                       Dimension of complex axis
      INCX = CATBLK(KINAX)
      IF (ISCOMP) INCX = 3
      VISINC = CATBLK(KIGCN) / 20
      VISMSG = CATBLK(KIGCN) / 10
      VISINC = MAX (20000, MIN (200000,VISINC))
      VISMSG = (VISMSG / VISINC) * VISINC
      IF (VISMSG.LT.VISINC) VISMSG = 100 * VISINC
C                                       Number of visibilities in input
C                                       and output files.
      NCORI = (LRECI - NRPRMI) / CATOLD(KINAX)
      NCORO = (LRECO - NRPRMO) / CATBLK(KINAX)
      NCOPY = LRECO
C                                       Open and init for read
C                                       visibility file
      CALL ZPHFIL ('UV', DISKIN, FCNO(NCFILE), 1, IFILE, IRET)
      CALL ZOPEN (LUNI, INDI, DISKIN, IFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1000) IRET
         GO TO 990
         END IF
C                                       Open vis file for write
      CALL ZPHFIL ('UV', DISKO, NEWCNO, 1, OFILE, IRET)
      CALL ZOPEN (LUNO, INDO, DISKO, OFILE, T, F, F, IRET)
      IF (IRET.GT.0) THEN
         WRITE (MSGTXT,1010) IRET
         GO TO 990
         END IF
C                                       Init vis file for write
      ILENBU = 0
      CALL UVINIT ('WRIT', LUNO, INDO, NVIS, VO, LRECO, ILENBU, JBUFSZ,
     *   BUFF2, BO, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1020) IRET
         GO TO 990
         END IF
      IPTRO = KBIND
      NIOUT = 0
      NIOLIM = ILENBU
C                                       Init vis file for read.
      ILENBU = 0
      CALL UVINIT ('READ', LUNI, INDI, NVIS, VO, LRECI, ILENBU, JBUFSZ,
     *   BUFF1, BO, IBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1030) IRET
         GO TO 990
         END IF
      NUMVIS = 0
      XCOUNT = 0
C                                       make an index table
      CALL RNXGET (DISKIN, OLDCNO, CATOLD)
      CALL RNXINI (DISKO, NEWCNO, CATBLK, RNXRET)
C                                       Loop
 100  CONTINUE
C                                       Read vis. record.
         CALL UVDISK ('READ', LUNI, INDI, BUFF1, INIO, IBIND, IRET)
         IF (IRET.NE.0) THEN
            WRITE (MSGTXT,1100) IRET
            GO TO 990
            END IF
         IPTRI = IBIND
C                                       Out of data?
         IF (INIO.LE.0) GO TO 200
C                                       Loop over buffer
         DO 190 I = 1,INIO
            NUMVIS = NUMVIS + 1
            IF (MOD(NUMVIS-1,VISMSG).EQ.0) THEN
               WRITE (MSGTXT,1105) NUMVIS
               CALL MSGWRT (2)
            ELSE IF (MOD(NUMVIS-1,VISINC).EQ.0) THEN
               WRITE (MSGTXT,1105) NUMVIS
               CALL MSGWRT (1)
               END IF
C                                      Call uv routine.
            J = BUFF1(IPTRI+ILOCSU) + 0.1
            CALL NEWSOU (J)
            BUFF1(IPTRI+ILOCSU) = J
            XCOUNT = XCOUNT + 1.0D0
            CALL RCOPY (NCOPY, BUFF1(IPTRI), BUFF2(IPTRO))
C                                       update NX table
            CALL RNXUPD (BUFF1(IPTRI), RNXRET)
            IPTRO = IPTRO + LRECO
            NIOUT = NIOUT + 1
C                                       OK, but no output please
            IPTRI = IPTRI + LRECI
C                                       Write vis record.
            IF (NIOUT.GE.NIOLIM) THEN
               CALL UVDISK ('WRIT', LUNO, INDO, BUFF2, NIOLIM, KBIND,
     *            IRET)
               IF (IRET.NE.0) THEN
                  WRITE (MSGTXT,1150) IRET
                  GO TO 990
                  END IF
               IPTRO = KBIND
               NIOUT = 0
               END IF
 190        CONTINUE
C                                       Read next buffer.
         GO TO 100
C                                       Finish write
 200  NIOUT = - NIOUT
      CALL UVDISK ('FLSH', LUNO, INDO, BUFF2, NIOUT, KBIND, IRET)
      IF (IRET.NE.0) THEN
         WRITE (MSGTXT,1150) IRET
         GO TO 990
         END IF
C                                       Compress output file.
      NVIS = XCOUNT
      CALL UCMPRS (NVIS, DISKO, NEWCNO, LUNO, CATBLK, IRET)
C                                       Close files
      CALL ZCLOSE (LUNI, INDI, IRET)
      CALL ZCLOSE (LUNO, INDO, IRET)
      IRET = 0
      CALL RNXCLS (RNXRET)
      IF (RNXRET.NE.0) THEN
         MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE'
         GO TO 990
         END IF
      GO TO 999
C                                       Error
 990  CALL MSGWRT (8)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RESOUV: ERROR',I3,' OPEN-FOR-READ VIS FILE')
 1010 FORMAT ('RESOUV: ERROR',I3,' OPEN-FOR-WRITE VIS FILE')
 1020 FORMAT ('RESOUV: ERROR',I3,' INIT-FOR-WRITE VIS FILE')
 1030 FORMAT ('RESOUV: ERROR',I3,' INIT-FOR-READ VIS FILE')
 1100 FORMAT ('RESOUV: ERROR',I3,' READING VIS FILE')
 1105 FORMAT ('RESOUV: at visibility record',I10)
 1150 FORMAT ('RESOUV: ERROR',I3,' WRITING VIS FILE')
      END
      SUBROUTINE NEWSOU (SOUNUM)
C-----------------------------------------------------------------------
C   NEWSOU converts the source number
C   In/out
C      SOUNUM   I   Source number
C-----------------------------------------------------------------------
      INTEGER   SOUNUM
C
      INCLUDE 'RESOU.INC'
C
      INTEGER   I
C-----------------------------------------------------------------------
      DO 20 I = 1,NUMSOU
         IF (SOUNUM.EQ.INSOU(I)) THEN
            SOUNUM = OUSOU(I)
            GO TO 999
            END IF
 20      CONTINUE
C
 999  RETURN
      END
      SUBROUTINE RESOHI
C-----------------------------------------------------------------------
C   RESOHI copies and updates history file.  It also copies any tables.
C-----------------------------------------------------------------------
      CHARACTER NOTTYP*2, HILINE*72
      INTEGER   LUN1, LUN2, IERR, I, NONOT, I1, I2, JTRIM
      LOGICAL   T, F
      INCLUDE 'RESOU.INC'
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DHIS.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA LUN1, LUN2 /27,28/
      DATA T, F /.TRUE.,.FALSE./
      DATA NONOT /0/
      DATA NOTTYP /'  '/
C-----------------------------------------------------------------------
C                                       Write History.
      CALL HIINIT (3)
C                                       Copy/open history file.
      CALL HISCOP (LUN1, LUN2, DISKIN, DISKO, FCNO(NCFILE),
     *   FCNO(NCFILE-1), CATBLK, BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1000) IERR
         CALL MSGWRT (6)
         GO TO 200
         END IF
C                                       New history
      CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, SEQOUT, DISKO, LUN2, BUFF2,
     *   IERR)
      IF (IERR.NE.0) GO TO 200
      HILINE = TSKNAM // '/ Input source numbers'
      CALL HIADD (LUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      I2 = 0
 10   I1 = I2 + 1
      IF (I1.LE.NUMSOU) THEN
         I2 = MIN (NUMSOU, I1+9)
         WRITE (HILINE,1010) TSKNAM, 'F', (INSOU(I), I=I1,I2)
         IF (I1.GT.1) HILINE(7:13) = ' '
         IF (I2.EQ.NUMSOU) HILINE(JTRIM(HILINE):) = ' '
         CALL HIADD (LUN2, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         GO TO 10
         END IF
      HILINE = TSKNAM // '/ Output source numbers'
      CALL HIADD (LUN2, HILINE, BUFF2, IERR)
      IF (IERR.NE.0) GO TO 200
      I2 = 0
 20   I1 = I2 + 1
      IF (I1.LE.NUMSOU) THEN
         I2 = MIN (NUMSOU, I1+9)
         WRITE (HILINE,1010) TSKNAM, 'R', (OUSOU(I), I=I1,I2)
         IF (I1.GT.1) HILINE(7:13) = ' '
         IF (I2.EQ.NUMSOU) HILINE(JTRIM(HILINE):) = ' '
         CALL HIADD (LUN2, HILINE, BUFF2, IERR)
         IF (IERR.NE.0) GO TO 200
         GO TO 20
         END IF
C                                       Close HI file
 200  CALL HICLOS (LUN2, T, BUFF2, IERR)
C                                        Copy non-source tables
      CALL ALLTAB (NONOT, NOTTYP, LUN1, LUN2, DISKIN, DISKO,
     *   FCNO(2), FCNO(1), CATBLK, BUFF1, BUFF2, IERR)
      IF (IERR.GT.2) THEN
         WRITE (MSGTXT,1200)
         CALL MSGWRT (6)
         END IF
      CALL RESTAB (IERR)
C                                        Update CATBLK.
      CALL CATIO ('UPDT', DISKO, FCNO(NCFILE-1), CATBLK, 'REST',
     *   BUFF1, IERR)
C
 999  RETURN
C-----------------------------------------------------------------------
 1000 FORMAT ('RESOHI: ERROR',I3,' COPY/OPEN HISTORY FILE')
 1010 FORMAT (A6,A1,'PARM =',10(I4,','))
 1200 FORMAT ('RESOHI: ERROR COPYING TABLES')
      END
      SUBROUTINE RESTAB (IERR)
C-----------------------------------------------------------------------
C   Since there are so many tables that need operating on this will
C   do it in a generic sense.  Changes source ID column only
C   Output:
C      IERR   I   Error code, 0 => OK
C-----------------------------------------------------------------------
      INTEGER   IERR
C
      INCLUDE 'RESOU.INC'
      INTEGER   TABDO, MAXIFV, MAXKEY, MAXTWO, MAXIDC, MAXTIM
      PARAMETER (TABDO = 28, MAXIFV = 16, MAXKEY = 50)
      PARAMETER (MAXTWO = 10, MAXIDC = 6)
      PARAMETER (MAXTIM = 4)
C
      CHARACTER DOTYP(TABDO)*2
      INTEGER   II, VER, LUNIN, NKEY, NREC, NCOL, DATP(256), NROWS,
     *   BUFFER(512), IDUM, LVER, NVER, BIGBUF(100000), IRNO, SKOL,
     *   SOUNUM, IPTR
      INCLUDE 'INCS:DMSG.INC'
      INCLUDE 'INCS:DFIL.INC'
      INCLUDE 'INCS:DDCH.INC'
      INCLUDE 'INCS:DCAT.INC'
      DATA DOTYP /'FO', 'PO', 'SU', 'TE', 'BC', 'BD', 'BL', 'BP',
     *   'BS', 'BT', 'CA', 'CL', 'CM', 'CP', 'FG', 'FL', 'GA', 'IM',
     *   'MC', 'OF', 'OT', 'PC', 'PH', 'SN', 'SO',  'SY', 'TS', 'TY'/
C-----------------------------------------------------------------------
C                                       Loop over file types
      DO 100 II = 1,TABDO
         CALL FNDEXT (DOTYP(II), CATBLK, NVER)
C                                       Loop over version
         DO 90 LVER = 1,NVER
            WRITE (MSGTXT,1005) DOTYP(II), LVER
            CALL MSGWRT (2)
            VER = LVER
            LUNIN = 41
            CALL TABINI ('READ', DOTYP(II), DISKO, NEWCNO, VER, CATBLK,
     *         LUNIN, NKEY, NREC, NCOL, DATP, BUFFER, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) DOTYP(II), VER, IERR,
     *            'OPENING TABLE FILE'
               CALL MSGWRT (7)
               GO TO 90
               END IF
            CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
            CALL TABINI ('WRIT', DOTYP(II), DISKO, NEWCNO, VER, CATBLK,
     *         LUNIN, NKEY, NREC, NCOL, DATP, BUFFER, IERR)
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) DOTYP(II), VER, IERR,
     *            'OPENING TABLE FILE'
               CALL MSGWRT (7)
               GO TO 90
               END IF
C                                       # rows in table
            NROWS = BUFFER(5)
C                                       Find column
            CALL FNDCOL (1, 'ID. NO. ', 8, .TRUE., BUFFER, SKOL, IERR)
            IF (IERR.GT.10) THEN
               CALL FNDCOL (1, 'SOURCE_ID', 9, .TRUE., BUFFER, SKOL,
     *            IERR)
               IF (IERR.GT.10) THEN
                  CALL FNDCOL (1, 'SOURCE ID', 9, .TRUE., BUFFER, SKOL,
     *               IERR)
                  IF ((IERR.GT.10) .AND. (DOTYP(II).EQ.'FG')) THEN
                     CALL FNDCOL (1, 'SOURCE', 6, .TRUE., BUFFER, SKOL,
     *                  IERR)
                     END IF
                  END IF
               END IF
            IF (IERR.NE.0) THEN
               WRITE (MSGTXT,1010) DOTYP(II), VER, IERR,
     *            'FINDING COLUMN'
               GO TO 80
               END IF
            IPTR = DATP(SKOL)
            DO 20 IRNO = 1,NROWS
               CALL TABIO ('READ', 0, IRNO, BIGBUF, BUFFER, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1010) DOTYP(II), VER, IERR,
     *               'READING SOURCE NUMBER'
                  GO TO 80
               END IF
               SOUNUM = BIGBUF(IPTR)
               CALL NEWSOU (SOUNUM)
               BIGBUF(IPTR) = SOUNUM
               CALL TABIO ('WRIT', 0, IRNO, BIGBUF, BUFFER, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (MSGTXT,1010) DOTYP(II), VER, IERR,
     *               'WRITING SOURCE NUMBER'
                  GO TO 80
                  END IF
 20            CONTINUE
            IDUM = 0
            CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
            GO TO 90
C
 80         CALL MSGWRT (8)
            CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
 90         CONTINUE
 100     CONTINUE
      IERR = 0
C
  999 RETURN
C-----------------------------------------------------------------------
 1005 FORMAT ('RESTAB processing table ',A2,' version',I4)
 1010 FORMAT ('RESTAB 'A,' TABLE VERSION',I4,' ERROR',I4,' ON ',A)
      END
