      program CODECO  
c
c     Urs Kradolfer, 17.1.90, revised: 4. August 1990, 21. April 1991
c                    major revision: 4. September 1991
c                    revised 28.1.92 and tested on HP-UX, SUN and VMS
c
c     Karl Koch, 10.5.95, added GSE2.0 support
c
c     Some format-stuff modified and channel-ID in gse1to2 modified. 18.5.95/uk
c     Bug in subr. gse2to2 removed. 6.7.95 / uk
c
c     Bug in GSE2.0 format removed (hang and vang were wrong for some channels)
c                                                              11.11.95 / uk
c     Format of CHK2 (checksum GSE2.0) corrected.  16.11.95 / uk
c
c     14.2.2017 (Using gfortran on Linux):
c     - Modified subroutine gse1to2 - see there.
c     - 'readonly' removed at open(3,... - not acceptet by gfortran compiler!
c     - Subr. INTAND: On Linux, call IAND instead of JIAND
c
c------------------------------------------------------------------------------
c
c     Program to convert GSE-datafiles into other formats.
c
c     NOTE: This version now supports both the 'old' GSE-format and
c           the 'new' GSE2.0 format 
c
c     NOTE: the 'old' GSE-format and the new GSE2.0 format do not contain the
c           same information on the header-lines. Therefore some information
c           may get lost if converting from old to new GSE-format or
c           vice versa.
c
c
c     Current array-dimensions:
c                               Signal (IY):     11000 samples
c                               Character-array: 66000 (6 times larger)
c
c     This program (or its subroutines) may be used to decompress
c     data files which are compressed with the GSE-algorithms.
c     The Swiss Seismological Service uses these algorithms as well.
c
c --> See the remarks below on authorship of the compression/decompression
c     routines!
c
      implicit none
c
      integer isignalsize, ibufsize
      integer iformat_in, iformat_out
      integer*4 MODULO_VALUE
c
cuk      parameter (isignalsize = 100000,
cuk     &           ibufsize    = 600000)
      parameter (isignalsize =  200000,
     &           ibufsize    = 1200000)
      parameter (MODULO_VALUE = 100 000 000)
c
      integer*4 iy(isignalsize),icomp, i,j, ierror, iy1,modulo,
     &          numout, nmax, nchar, idiff, ii, ichecksum,nchecksum,
     &          trimlen, ilin, idiffout, iwaveform
c
      character*1 cbuf(ibufsize)
      character infile*80,outfile*80, line*132,
     &          format_in*4, format_out*4, fmt*6
      character*132 lin(100)
c
chp      write(6,'(a,nn)')'Enter name of inputfile: '
cvms     write(6,'(a)')'$Enter name of inputfile: '
      write(6,*)'Enter name of inputfile: '
      read(5,'(a)') infile
c
chp      write(6,'(a,nn)')'Enter name of outputfile: '
cvms     write(6,'(a)')'$Enter name of outputfile: '
      write(6,*)'Enter name of outputfile: '
      read(5,'(a)') outfile
      open(4,file=outfile,status='unknown')
      write(6,*)'Possible output formats are:'
      write(6,*)'INTn  (n=1,...,9)  '
      write(6,*)'INTV  integer variable (`free-format`)'
      write(6,*)'INT   GSE2.0 integer format'
      write(6,*)'CMPn  (n=6, 7, or 8 bit compression)'
      write(6,*)'CMn   (n=6, or 8 bit compression) in GSE2.0 format'
chp      write(6,'(a,nn)')'Enter desired output format: '
cvms     write(6,'(a)')'$Enter desired output format: '
      write(6,*)'Enter desired output format: '
      read(5,'(a)') format_out
      call CASEFOLD(format_out)
      if (format_out(4:4).eq.' ') then
	 iformat_out=2
	 idiffout=0
         if (format_out(1:2).eq.'CM') idiffout=2
      else
chp         write(6,'(a,nn)')'Enter # of differences (0, 1 or 2): '
cvms        write(6,'(a)')'$Enter # of differences (0, 1 or 2): '
         write(6,*)'Enter # of differences (0, 1 or 2): '
         read(5,*) idiffout
	 iformat_out=1
      endif
c
c     This is the input part of CODECO
c
cuk2017      open(3,file=infile,status='old',readonly)
      open(3,file=infile,status='old')
      iwaveform=0
c
 1    read(3,'(a)',end=999) line
      if(line(1:4).ne.'WID1' .and. line(1:4).ne.'WID2')then
         write(4,'(a)') line(1:trimlen(line))
         goto 1
      else
         if(line(1:4).eq.'WID1') iformat_in=1
         if(line(1:4).eq.'WID2') iformat_in=2
      endif
c
      if (iformat_in.eq.2) goto 20
c
c     input data are in GSE1.0 format
c
      write(6,*) 'Reading GSE1.0 format data'
      read(line(28:35),'(i8)') nmax
      read(line(75:80),'(a4,x,i1)') format_in, idiff
      lin(1)=line
      ilin=1
 2    read(3,'(a)') line
      if(line(1:4).ne.'DAT1')then
         ilin=ilin+1
         lin(ilin)=line
         goto 2
      else
         ilin=ilin+1
         lin(ilin)=line
      endif
c
c     Now read in data according to the format:
c
      if(format_in.eq.'INTV')then
         read(3,*) (iy(i),i=1,nmax)
         read(3,'(4x,6x,i15)') ichecksum
      endif
      if(format_in(1:3).eq.'INT'.and.format_in.ne.'INTV')then
         read(format_in(4:4),*) ii
         read(3,'(a)') line
         i=(trimlen(line)+ii-1)/ii
         write(fmt,'(''('',i2.2,''i'',i1.1,'')'')') i,ii
         backspace(3)
         read(3,fmt) (iy(i),i=1,nmax)
         read(3,'(4x,6x,i15)') ichecksum
      endif
c
      if(format_in(1:3).eq.'CMP')then
         read(format_in(4:4),*) icomp 
         j=0
  10     read(3,'(a)') line
         if(line(1:4).eq.'CHK1') goto 11
         j=j+1
         do i=1,80
            cbuf(80*(j-1)+i)=line(i:i)
         enddo
         goto 10
  11     continue
         read(line(5:),*) ichecksum
         nchar=j*80
         numout=isignalsize   ! on input, give max. size of array iout (=iy)
         if(icomp.eq.6) call DCOMP6(nchar,cbuf,numout,iy,ierror)
         if(icomp.eq.7) call DCOMP7(nchar,cbuf,numout,iy,ierror)
         if(icomp.eq.8) call DCOMP8(nchar,cbuf,numout,iy,ierror)
         if(ierror.eq.-1) write(6,*)'Integer*4 array not large enough !'
         if(numout.ne.nmax)then
            write(6,*)'Error in retrieving correct number of samples !'
            write(6,*)'Expected ',nmax,', received ',numout
         endif
      endif
c
c     remove first or second differences if necessary
c
      do i=1,idiff
ccc         write(6,*)'removing 1st differences...'
         call REMDIF1(iy,nmax)
      enddo
      nchecksum=0
      do i=1,nmax
         nchecksum=nchecksum+iy(i)
      enddo
      if (iformat_in.eq.1) goto 50
      write(6,*) 'There is good news and bad news at this point:'
      write(6,*) 'First the good news: no more CPU time will be used!!!'
      write(6,*) 'and now the bad news: You have screwed up !!!'
      stop
c
c     The input data are GSE2.0
c
20    write(6,*) 'Reading GSE2.0 format data'
      read(line(49:56),'(i8)') nmax
      read(line(45:47),'(a3)') format_in
      idiff=2
      lin(1)=line
      ilin=1
22    read(3,'(a)') line
      if(line(1:4).ne.'DAT2')then
         ilin=ilin+1
         lin(ilin)=line
         goto 22
      else
         ilin=ilin+1
         lin(ilin)=line
      endif
c
c     Now read in data according to the format:
c
      if(format_in.eq.'INT') then
         read(3,*) (iy(i),i=1,nmax)
  30     read(3,'(a)') line
         if(line(1:4).eq.'CHK2') goto 31
         goto 30
  31     read(line(5:),*) ichecksum
      endif
c
      if(format_in(1:2).eq.'CM')then
         read(format_in(3:3),*) icomp 
         j=0
  32     read(3,'(a)') line
         if(line(1:4).eq.'CHK2') goto 34
         j=j+1
         do i=1,80
            cbuf(80*(j-1)+i)=line(i:i)
         enddo
         goto 32
  34     continue
         read(line(5:),*) ichecksum
         nchar=j*80
         numout=isignalsize   ! on input, give max. size of array iout (=iy)
         if(icomp.eq.6) call DCOMP6(nchar,cbuf,numout,iy,ierror)
         if(icomp.eq.7) call DCOMP7(nchar,cbuf,numout,iy,ierror)
         if(icomp.eq.8) call DCOMP8(nchar,cbuf,numout,iy,ierror)
         if(ierror.eq.-1) write(6,*)'Integer*4 array not large enough !'
         if(numout.ne.nmax)then
            write(6,*)'Error in retrieving correct number of samples !'
            write(6,*)'Expected ',nmax,', received ',numout
         endif
      endif
c
c     remove first or second differences
c
ccc         write(6,*)'removing 1st differences...'
      call REMDIF1(iy,nmax)
ccc         write(6,*)'removing 2nd differences...'
      call REMDIF1(iy,nmax)
c
      nchecksum=0
      modulo=MODULO_VALUE
      do i=1,nmax
	 iy1=iy(i)
	 if (abs(iy1).ge.modulo) iy1=iy1-(iy1/modulo)*modulo
         nchecksum=nchecksum+iy1
	 if (abs(nchecksum).ge.modulo)
     &      nchecksum=nchecksum-(nchecksum/modulo)*modulo
      enddo
      nchecksum=abs(nchecksum)
c
c     Done with the input !!!!!
c
50    continue
c
ccc      write(6,*)'Signal now available in decompressed form.'
c
      if(nchecksum.ne.ichecksum)then
         write(6,*)'Error in checksum in waveform number',iwaveform+1
         write(6,'(a)') lin(1)(1:trimlen(lin(1)))
         write(6,*)'Read checksum       =',ichecksum
         write(6,*)'Calculated checksum =',nchecksum
         write(6,*)
         ichecksum=nchecksum  ! ... use the correct checksum  !!!
      endif
c
c     Here the output is generated!!!
c
      if (iformat_in.eq.iformat_out) then
	 if (iformat_in.eq.1) then
             write(lin(1)(75:80),'(a4,x,i1)') format_out, idiffout
	 endif
	 if (iformat_in.eq.2) then
             write(lin(1)(45:47),'(a3)') format_out
	 endif
      else
         if (iformat_out.eq.2)  then
            write(6,*) 'Converting from GSE 1.0 to GSE 2.0 format'
	    call gse1to2(ilin,lin,format_out,idiffout)
            nchecksum=0
            modulo=MODULO_VALUE
            do i=1,nmax
	       iy1=iy(i)
	       if (abs(iy1).ge.modulo) iy1=iy1-(iy1/modulo)*modulo
               nchecksum=nchecksum+iy1
	       if (abs(nchecksum).ge.modulo)
     &            nchecksum=nchecksum-(nchecksum/modulo)*modulo
            enddo
            ichecksum=abs(nchecksum)
         else
            write(6,*) 'Converting from GSE 2.0 to GSE 1.0 format'
	    call gse2to1(ilin,lin,format_out,idiffout)
            nchecksum=0
            do i=1,nmax
               nchecksum=nchecksum+iy(i)
            enddo
            ichecksum=nchecksum
         endif
      endif
c
      do i=1,idiffout
         call DIF1(iy,nmax)
      enddo
      do i=1,ilin
         line=lin(i)
         write(4,'(a)') line(1:trimlen(line))
      enddo
      if(format_out(1:2).eq.'CM')then
         if (iformat_out.eq.1) read(format_out(4:4),*) icomp
         if (iformat_out.eq.2) read(format_out(3:3),*) icomp
         nchar=ibufsize ! on input, give max. size of array cbuf
         if(icomp.eq.6) call CMPRS6(nmax,iy,nchar,cbuf,ierror)
         if(icomp.eq.7) call CMPRS7(nmax,iy,nchar,cbuf,ierror)
         if(icomp.eq.8) call CMPRS8(nmax,iy,nchar,cbuf,ierror)
         if(ierror.eq.-1) write(6,*)'Character array not large enough !'
C        TEST FOR MULTIPLE OF 80 CHARACTERS
         if(nchar-((nchar/80)*80).ne.0)then
            write(6,*)'Not a multiple of 80 characters !'
         endif
         do i=1,nchar/80
            do j=1,80
               line(j:j)=cbuf(80*(i-1)+j)
            enddo
cccc            write(4,'(a)') line
            if(line.ne.' ') write(4,'(a)') line(1:80)  ! kradi, 28.11.90
         enddo
      endif
      if(format_out(1:3).eq.'INT')then
         if(format_out(4:4).eq.'V' .or. format_out(4:4).eq.' ') then
             write(4,*) (iy(i),i=1,nmax)
         else
             read(format_out(4:4),*) ii
cc             i=(trimlen(line)+ii-1)/ii
             i=(80+ii-1)/ii
             write(fmt,'(''('',i2.2,''i'',i1.1,'')'')') i,ii
             write(4,fmt) (iy(i),i=1,nmax)
         endif
      endif
c
      if (iformat_out.eq.1) then
          line='CHK1'
          write(line(10:24),'(i15)') ichecksum
      endif
      if (iformat_out.eq.2) then
          line='CHK2'
          write(line(6:13),'(i8)') ichecksum
      endif
      write(4,'(a)') line(1:trimlen(line))
c
      iwaveform=iwaveform+1
      goto 1
c
 999  close(4)
      close(3)
      write(6,*)'Number of waveforms processed:',iwaveform
c
      end ! of program codeco2
c
      subroutine CASEFOLD(cn) ! Urs Kradolfer, 20. Feb. 1990
c
c Input : character-string of any length
c Output: same character-string, but all letters are CAPITAL now
c         (other characters are not changed)
c
c   --> this subroutine needs the function TRIMLEN !
c
c Call  : call CASEFOLD(charstring)
c
      implicit none
      character cn*(*)
      integer i, trimlen,ilen, ival
      ilen=trimlen(cn)
      do i=1,ilen
         ival=ICHAR(cn(i:i))
         if(ival.ge.97.and.ival.le.122)then
            cn(i:i)=CHAR(ival-32)
         endif
      enddo
      RETURN
      end ! of subroutine casefold
c
      integer function TRIMLEN(t)   ! Urs Kradolfer, June 1986
c
c     Call:    nc=TRIMLEN(char)
c
c          --> nc says, how many characters the input-string has
c              (ignoring trailing blanks!).
c
      implicit none
      character t*(*)
      do 1 trimlen=LEN(t),1,-1
    1    if(t(trimlen:trimlen).ne.' ')RETURN
      trimlen=1
      end ! of integer function trimlen
c
c***************************************************************************
c
      subroutine DIF1(iy,nmax)
c
c     Do Data-compression (first differences)
c
c     Urs Kradolfer, January 1990
c
      implicit none
      integer nmax, iy(nmax), k, xim1, xtemp
c
      xim1=iy(1)
      do k=2,nmax
         xtemp=iy(k)
         iy(k)=xtemp-xim1
         xim1=xtemp
      enddo
c
      RETURN
      end ! of subroutine dif1
c
c***************************************************************************
c
      subroutine REMDIF1(iy,nmax)
c
c     Remove Data-compression (first differences)
c
c     Urs Kradolfer, January 1990
c
      implicit none
      integer nmax, iy(nmax), k
c
      do k=2,nmax
         iy(k)=iy(k)+iy(k-1)
      enddo
c
      RETURN
      end ! of subroutine remdif1
c
      subroutine gse1to2(ilin,lin,format_out,idiffout)
c
c     Convert header lines from GSE1.0 to GSE2.0
c
c     Karl Koch, May 1995
c
c     Modified call of 'ifix' to 'INT'. Urs Kradolfer, 14Feb2017
c
      character*(*) lin(*)
      character*(*) format_out
      integer*4 ilin
      integer*4 idiffout
      character sta*6,cmp*3,auxid*4,chid*8,instyp*6,frmt*4
      integer hh,mm,ss,nnn,nsamp,mnths(12),day,mnth
      integer yydoy,year,doy
      real sampr,amp,per,sec,hang,vang
      data mnths/31,28,31,30,31,30,31,31,30,31,30,31/
	    
100   format(i8,3(1x,i2),1x,i3,1x,i8,1x,a6,1x,a8,1x,
     &  a2,1x,f11.7,1x,a6,1x,a4,1x,i1)
101   format(f9.6,a1,f7.4,1x,4(f9.4,1x),2(f7.2,1x),f6.1,1x,f6.1)
      read(lin(1)(6:),100) yydoy,hh,mm,ss,nnn,nsamp,sta,chid,cmp,
     &  sampr,instyp,frmt,idiff
      read(lin(2),101) amp,units,per,lat,lon,elev,dep,baz,bslo,hang
c
      year=yydoy/1000
      doy=yydoy-year*1000
cuk2017      if(ifix(year/4)*4.eq.year) mnths(2)=29
      if(INT(year/4)*4.eq.year) mnths(2)=29
      mnth=0
      do i=1,12
	 mnth=mnth+mnths(i)
	 if (mnth.ge.doy) goto 60
      enddo
60    mnth=mnth-mnths(i)
      day=doy-mnth
      mnth=i
      sec=ss+nnn/1000
c
      cmp=cmp(1:1)//'H'//cmp(2:2)  ! old GSE: 'SZ'; GSE2.0: 'SHZ'
c                                     (we do not know if SHZ of SLZ or...?)
c     --> so we implicitly assume High gain channel here.....
      if(cmp(3:3).eq.'S') cmp(3:3)='Z' ! this is here for the Swiss NDC only
c      auxid='    '
      auxid=chid
c
      hang=-1.0
      if(cmp(3:3).eq.'N') hang=0.0
      if(cmp(3:3).eq.'E') hang=90.0
      vang=0.0
      if(cmp(3:3).eq.'N'.or.cmp(3:3).eq.'E') vang=90.0
c
      lin(1)(1:4)='WID2'
200   format(i4,2(1h/,i2.2),1x,2(i2.2,1h:),f6.3,1x,a5,1x,a3,1x,
     &  a4,1x,a3,1x,i8,1x,f11.6,1x,e10.2,1x,f7.3,1x,a6,1x,f5.1,1x,f4.1)
       write(lin(1)(6:),200)
     2  year,mnth,day,hh,mm,sec,sta,cmp,auxid,format_out,nsamp,sampr,
     3  amp,per,instyp,hang,vang
      lin(2)='DAT2'
      ilin=2
cuk      write(6,*) (lin(i),i=1,ilin)
      return
      end
c 
      subroutine gse2to1(ilin,lin,format_out,idiffout)
c
c     Convert header lines from GSE2.0 to GSE1.0
c
c     Karl Koch, May 1995
      character*(*) lin(*)
      character*(*) format_out
      integer*4 ilin, n
      integer*4 idiffout
      character sta*6,cmp*3,auxid*4,chid*8,instyp*6,frmt*4, fmt*80
      integer hh,mm,ss,nnn,nsamp,mnths(12),day,mnth
      integer yydoy,year,doy,units
      real sampr,amp,per,sec,hang,vang
      real lat,lon,dep,elev,baz,bslo
      data mnths/31,28,31,30,31,30,31,31,30,31,30,31/
	    
200   format(i4,1x,i2,1x,i2,1x,i2,1x,i2,1x,f6.3,1x,a5,1x,a3,1x,
     &  a4,1x,a3,1x,i8,1x,f11.6,1x,e10.2,1x,f7.3,1x,a6,1x,f5.1,1x,f4.1)
      read(lin(1)(6:),200) year,mnth,day,hh,mm,sec,sta,cmp,auxid,
     1  frmt,nsamp,sampr,amp,per,instyp,hang,vang
c
      doy=0
      do i=1,mnth-1
          doy=doy+mnths(i)
      enddo
      doy=doy+day
      yydoy=doy+1000*year
      ss=sec
      nnn=1000.*(sec-ss)
      chid='????????'
cuk      print *,year,mnth,day,yydoy,hh,mm,ss,nnn,sec
      cmp(2:2)=cmp(3:3)
      units=0
      lat=-999
      lon=-999
      elev=-999
      dep=-999
      baz=-1
      bslo=-1
c
      lin(1)(1:4)='WID1'
100   format(i8,3(1x,i2.2),1x,i3.3,1x,i8,1x,a6,1x,a8,1x,
     &  a2,1x,f11.7,1x,a6,1x,a4,1x,i1)
c101   format(f9.6,i1,f7.4,1x,4(f9.4,1x),2(f7.2,1x),f6.1,1x,f6.1)
c     if amp >= 100 format 9.6 problems; define format according to 'amp':
      fmt='(f9.6,i1,f7.4,1x,4(f9.4,1x),2(f7.2,1x),f6.1,1x,f6.1)'
cuk      n=9-(log10(amp)+2)  ! produces wrong output if amp=0.0771 !
      n=9-(log10(amp)+3)
      write(fmt(5:5),'(i1)') n
      write(lin(1)(6:),100) yydoy,hh,mm,ss,nnn,nsamp,sta,auxid,cmp(1:2),
     &   sampr,instyp,format_out,idiffout
c      write(lin(2),101) amp,units,per,lat,lon,elev,dep,baz,bslo,hang
      write(lin(2),fmt) amp,units,per,lat,lon,elev,dep,baz,bslo,hang
      lin(3)='DAT1'
      ilin=3
cuk      write(6,*) (lin(i),i=1,ilin)
      return
      end
c
C******************************************************************************
c#    The following data compression and decompression routines have
c#    been developped by Dr. Shane Ingate and Dr. Ken Muirhead, at the
c#    Australian Seismological Centre, Bureau of Mineral Resources,
c#    Canberra, Australia.
c#    They provided me with these routines in March 1989 during the
c#    session of the Group of Scientific Experts (GSE) in Geneva.
c#    These compression/decompression algorithms are used by all members
c#    of the GSE during the large-scale data exchange experiment GSETT-2,
c#    carried out from 1989 to 1991.
c#    It is recommended to use second differences and the six-bit compression.
c#    The second differences can be computed by two subsequent calls of
c#    subroutine DIF1 (see above).
c#    These routines are already running on many different machines.
c#    Because the AND function is not standard FORTRAN 77, this operation
c#    has been moved to a separate subroutine INTAND. All users of these
c#    routines will have to modify INTAND so that it performs correctly on
c#    their computers.
c#                                 Urs Kradolfer, Swiss Seismological Service
c#
C******************************************************************************
C                                                                       *
C     SUBROUTINE CMPRS6(LX,IX,LC,CBUFF,IERROR)                          *
C                                                                       *
C     ROUTINE TO COMPRESS INTEGER DATA INTO PRINTABLE ASCII CHARACTERS. *
C     INPUTS ARE INTEGER*4 ARRAY IX OF LENGTH LX.                       *
C     LC SHOULD CONTAIN THE DIMENSION OF THE ARRAY CBUFF.               *
C     OUTPUTS ARE CHARACTER*1 ARRAY CBUFF CONTAINING LC CHARACTERS.     * 
C     IF THE ARRAY CBUFF IS NOT LARGE ENOUGH TO CONTAIN ALL OF THE DATA *
C     IERROR IS SET TO -1, OTHERWISE IT IS SET TO ZERO.                 *
C     OUTPUT IS PADDED TO A MULTIPLE OF 80 CHARACTERS USING SPACES.     *
C                                                                       *
C     METHOD OF COMPRESSION IS TO USE THE 6 LEAST SIGNIFICANT SIX BITS  *
C     OF AN EIGHT BIT BYTE SO THAT ALL DATA CAN BE TRANSMITTED AS ASCII *
C     CHARACTERS.                                                       *
C     OF THESE SIX BITS, THE MOST SIGNIFICANT IS USED AS A CONTINUATION *
C     BIT. IF IT IS SET TO ONE THE FOLLOWING BYTE ALSO FORMS PART OF    *
C     THE PRESENT SAMPLE. IF ZERO, THIS IS THE LAST BYTE IN THE SAMPLE. *
C     THE SECOND LEAST SIGNIFICANT BIT IS USED AS A SIGN BIT IN THE     *
C     FIRST BYTE AND FOR DATA IN SUBSEQUENT BYTES (ORIGINAL DATA IS     *
C     FIRST CONVERTED TO SIGN AND MAGNITUDE). ALL OTHER BITS OF FIRST   *
C     AND SUBSEQUENT BYTES FORM THE MAGNITUDE OF THE NUMBER.            *
C                                                                       *
C     TO ENABLE TRANSMISSION OVER AS MANY LINKS AS POSSIBLE DATA IS     *
C     FURTHER TRANSFORMED TO THE CHARACTERS +,-,0 - 9,A - Z, a - z      *
C     USING A LOOKUP TABLE.                                             *
C                                                                       *
C     SUBROUTINES CALLED INTAND (THIS SUBROUTINE IS MACHINE SPECIFIC)   *
C                                                                       *
C     DATA MAY BE DECOMPRESSED USING SUBROUTINE DCOMP6.                 *
C                                                                       *
C************************************************************************ 
C
      SUBROUTINE CMPRS6(LX,IX,LC,CBUFF,IERROR)
      IMPLICIT INTEGER*4 (I-N)
cuk      CHARACTER *1 CBUFF(4),TEMP(4),TEST(4),ACHAR(64),BLANK
cuu91      CHARACTER *1 CBUFF(1),TEMP(4),TEST(4),ACHAR(64),BLANK
      CHARACTER *1 CBUFF(lc),TEMP(4),TEST(4),ACHAR(64),BLANK
cuu91      INTEGER *4 IX(1)
      INTEGER *4 IX(lx)
      EQUIVALENCE (J,TEMP(1)),(TEST,ITEST)
      DATA TEST/'1','2','3','4'/
      DATA ACHAR / '+','-','0','1','2','3','4','5','6','7','8','9','A',
     1 'B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q',
     2 'R','S','T','U','V','W','X','Y','Z','a','b','c','d','e','f','g',
     3 'h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w',
     4 'x','y','z'/
      DATA BLANK /' '/
      DATA N4/16/, N5/32/, N5M1/31/, N6/64/, N9/512/, N10/1024/, 
     1 N10M1/1023/, N14/16384/, N15/32768/, N15M1/32767/, N19/524288/, 
     2 N20/1048576/, N20M1/1048575/, N24/16777216/, N25/33554432/, 
     3 N25M1/33554431/, N28/134217728/, N28M1/134217727/
      IERROR = 0
      IMAX = LC
      MFLAG = N5
      IOFF = 0
      DO 60 I = 1,LX
        JN = IX(I)
C       SET NFLAG TO 1 TO POINT TO FIRST ELEMENT IN LOOKUP TABLE
        NFLAG = 1
C
C       SEE IF NUMBER IS -VE IF SO CONVERT TO SIGN AND MAGNITUDE.
C
        IF(JN .LT. 0) THEN
           NFLAG = NFLAG + N4
           JN = -JN
        END IF
        IF(JN .LT. N4) GO TO 50
C        IF HERE, DATA REQUIRES MORE THAN 1 BYTE
         IF(JN .LT. N9) GO TO 40
C         IF HERE, DATA REQUIRES MORE THAN 2 BYTES
          IF(JN .LT. N14) GO TO 30
C          IF HERE, DATA REQUIRES MORE THAN 3 BYTES.
           IF(JN. LT. N19) GO TO 20
C           IF HERE, DATA REQUIRES MORE THAN 4 BYTES.
            IF(JN. LT. N24) GO TO 10
C            IF HERE, DATA REQUIRES MORE THAN 5 BYTES.
             IF(JN .GT. N28M1) JN=N28M1
C            FILL A BYTE IF HERE NUMBER WILL REQUIRE SIX BYTES
             J = JN/N25 + NFLAG + MFLAG
             IOFF = IOFF + 1
             CBUFF(IOFF) = ACHAR(J)
             CALL INTAND(JN,N25M1,JN)
             NFLAG = 1
   10       CONTINUE
C           FIVE CHARACTERS TO GO
            J = JN/N20 + NFLAG + MFLAG
            IOFF = IOFF + 1
            IF (IOFF .GT. IMAX) GO TO 80
            CBUFF(IOFF) = ACHAR(J)
            CALL INTAND(JN,N20M1,JN)
            NFLAG = 1
   20      CONTINUE
C          FOUR CHARACTERS TO GO
           J = JN/N15 + NFLAG + MFLAG
           IOFF = IOFF + 1
           IF (IOFF .GT. IMAX) GO TO 80
           CBUFF(IOFF) = ACHAR(J)
           CALL INTAND(JN,N15M1,JN)
           NFLAG = 1
   30     CONTINUE
C         THREE CHARACTERS TO GO
          J = JN/N10 + NFLAG + MFLAG
          IOFF = IOFF + 1
          IF (IOFF .GT. IMAX) GO TO 80
          CBUFF(IOFF) = ACHAR(J)
          CALL INTAND(JN,N10M1,JN)
          NFLAG = 1
   40    CONTINUE
C        TWO CHARACTERS TO GO
         J = JN/N5 + NFLAG + MFLAG
         IOFF = IOFF + 1
         IF (IOFF .GT. IMAX) GO TO 80
         CBUFF(IOFF) = ACHAR(J)
         CALL INTAND(JN,N5M1,JN)
         NFLAG = 1
   50   CONTINUE
C       ONE CHARACTER TO GO
        J = JN + NFLAG
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 80
        CBUFF(IOFF) = ACHAR(J)
   60 CONTINUE
C     NOW MAKE OUTPUT BUFFER UP TO A MULTIPLE OF 80 CHARACTERS
C     WITH BLANKS
      K = 80 - (IOFF - ((IOFF/80) * 80))
      IF (K .LT. 2) K = K + 80
C     PUT IN AT LEAST TWO ADJACENT SPACE CHARACTERS TO ASSIST IN
C     DECODING
      DO 70 I = 1, K
         IOFF = IOFF + 1
         IF (IOFF .GT. IMAX) GO TO 80
         CBUFF(IOFF) = BLANK
   70 CONTINUE
   80 CONTINUE
      LC = IOFF
      IF (IOFF .GT. IMAX) THEN
         LC = IMAX
         IERROR = -1
      ENDIF
      RETURN
      END
C******************************************************************
C                                                                 *
C     SUBROUTINE CMPRS7(LX,IX,LC,CBUFF,IERROR)                    *
C                                                                 *
C     ROUTINE TO WORD-COMPRESS DATA INTO 7 BIT BYTES.             *
C     INPUTS ARE INTEGER*4 ARRAY IX CONTAINING LX VALUES TO BE    *
C     COMPRESSED INTO 7 BIT BYTES. THE MOST SIGNIFICANT BIT OF    *
C     EACH BYTE IS NOT USED.                                      *
C     ON ENTRY LC SHOULD CONTAIN DIMENSIONED LENGTH OF CBUFF.     *
C     OUTPUTS ARE CHARACTER*1 ARRAY CBUFF WITH LC MODIFIED TO     * 
C     REFLECT THE NUMBER OF BYTES WHICH HAVE BEEN PUT INTO CBUFF. *
C     LC IS MADE A MULTIPLE OF 80 USING UNIQUE FILL CHARACTERS.   *
C     IF CBUFF IS TOO SMALL TO CONTAIN ALL COMPRESSED DATA        *
C     IERROR WILL CONTAIN -1 OTHERWISE IT WILL BE SET TO ZERO.    *
C     METHODOLOGY IS THAT THE MOST SIGNIFICANT BIT OF EACH BYTE   *
C     IS SET TO ONE IF NEXT BYTE CONTAINS INFORMATION PERTAINING  *
C     TO THE SAME SAMPLE. IN THE FIRST BYTE PERTAINING TO EACH    *
C     SAMPLE, THE SECOND MOST SIGNIFICANT BIT IS USED AS A SIGN   *
C     BIT. THE LEAST SIGNIFICANT 5 BITS OF THE FIRST BYTE AND     *
C     THE LEAST SIGNIFICANT SIX BITS OF ANY SUBSEQUENT BYTE       *
C     PERTAINING TO THE SAME SAMPLE ARE COMPRESSED TOGETHER ON    *
C     DECODING TO GIVE THE MAGNITUDE OF THE SAMPLE.               * 
C     USING THIS COMPRESSION SCHEME THE CODES                     *
C     1000000  1000000  AND 1000000  0000001 WOULD NOT NORMALLY BE*
C     TRANSMITTED (AKIN TO NOT TRANSMITTING LEADING ZEROS).       *
C     THESE TWO PATTERNS ARE USED AS CONTROL PATTERNS.            *
C     THE PATTERN 1000000 1000000 SIGNIFIES THE END OF THE DATA   *
C     AND IS USED TO FILL UP TO A MULTIPLE OF EIGHTY CHARACTERS.  *
C     THE PATTERN 1000000  0000001 INDICATES THAT 32 SHOULD BE    *
C     SUBTRACTED FROM THE PREVIOUS SAMPLE. USING THIS METHODOLOGY,*
C     ANY CONTROL CHARACTER WITH INTEGER VALUE LESS THAN 32       *
C     WHICH A COMMUNICATION LINK WONT ACCEPT CAN BE MODIFIED BY   *
C     ADDING 32 TO IT. THE 32 WILL BE SUBTRACTED ON DECOMPRESSION.*
C     DATA MAY BE DECOMPRESSED USING SUBROUTINE DCOMP7.           *
C                                                                 *
C     SUBROUTINES CALLED   ---   INTAND   ---   CHEKBT   ---      * 
C                                                                 *
C******************************************************************
C
      SUBROUTINE CMPRS7(LX,IX,LC,CBUFF,IERROR)
      IMPLICIT INTEGER*4 (I-N)
cuk      CHARACTER*1 CBUFF(4),TEMP(4),TEST(4),NCNTRL
cuu91      CHARACTER*1 CBUFF(1),TEMP(4),TEST(4),NCNTRL
      CHARACTER*1 CBUFF(lc),TEMP(4),TEST(4),NCNTRL
cuu91      INTEGER *4 IX(*)
      INTEGER *4 IX(lx)
      EQUIVALENCE (J,TEMP),(TEST,ITEST)
      DATA TEST/'1','2','3','4'/
      DATA N5/32/,
     *     N6/64/,        N6M1/63/,
     *     N11/2048/,
     *     N12/4096/,     N12M1/4095/,
     *     N17/131072/,
     *     N18/262144/,   N18M1/262143/,
     *     N23/8388608/,
     *     N24/16777216/, N24M1/16777215/,
     *     N27/134217728/,N27M1/134217727/
C
C     WORK OUT WHICH WAY BYTES ARE STORED IN A COMPUTER WORD
      IBYTE = 4
      IF(ITEST.EQ.(((52*256+51)*256+50)*256+49)) IBYTE = 1
C
      NCNTRL = CHAR(64)
C     NCNTRL IS A 7 BIT BYTE WITH BIT PATTERN 1000000
      MFLAG = N6
      IMAX = LC
      IERROR = 0
      IOFF = 0
      DO 100 II = 1,LX
        IONLY = 0
        JN = IX(II)
C
C       GET SIGN AND MAGNITUDE OF SAMPLE
C
        NFLAG = 0
        IF(JN .LT. 0) THEN
           NFLAG = N5
           JN = -JN
        END IF
        IF(JN .LT. N5) GO TO 40
         IONLY = 1
C        IF HERE, DATA REQUIRES MORE THAN 1 BYTE
         IF(JN .LT. N11) GO TO 30
C         IF HERE, DATA REQUIRES MORE THAN 2 BYTES
          IF(JN. LT. N17) GO TO 20
C          IF HERE, DATA REQUIRES MORE THAN 3 BYTES.
           IF(JN. LT. N23) GO TO 15
C           IF HERE, DATA REQUIRES MORE THAN 4 BYTES.
            IF(JN. GT. N27M1) JN=N27M1
C           FILL A BYTE
            J = JN/N24 + NFLAG + MFLAG
            IOFF = IOFF + 1
            IF (IOFF .GT. IMAX) GO TO 120
            CBUFF(IOFF) = TEMP(IBYTE)
            CALL INTAND(JN,N24M1,JN)
            NFLAG = 0
   15      CONTINUE
C          FOUR MORE BYTES TO GO
           J = JN/N18 + NFLAG + MFLAG
           IOFF = IOFF + 1
           IF (IOFF .GT. IMAX) GO TO 120
           CBUFF(IOFF) = TEMP(IBYTE)
           CALL INTAND(JN,N18M1,JN)
           NFLAG = 0
   20     CONTINUE
C         THREE MORE BYTES TO GO
          J = JN/N12 + NFLAG + MFLAG
          IOFF = IOFF + 1
          IF (IOFF .GT. IMAX) GO TO 120
          CBUFF(IOFF) = TEMP(IBYTE)
          CALL INTAND(JN,N12M1,JN)
          NFLAG = 0
   30    CONTINUE
C        TWO MORE BYTES TO GO
         J = JN/N6 + NFLAG + MFLAG
         IOFF = IOFF + 1
         IF (IOFF .GT. IMAX) GO TO 120
         CBUFF(IOFF) = TEMP(IBYTE)
         CALL INTAND(JN,N6M1,JN)
         NFLAG = 0
   40   CONTINUE
C       ONE MORE BYTE TO GO
        J = JN + NFLAG
C       CHECK AND MODIFY BYTE IF IT CANNOT BE TRANSMITTED
        CALL CHEKBT(TEMP(IBYTE),NSTAT,IBYTE)
C       IF CHARACTER HAS BEEN MODIFIED AND ONLY ONE CHARACTER IN WORD
C       NEED A CHARACTER WITH A CONTINUE BIT - CHECK AND PUT IN IF
C       REQUIRED
        IF (NSTAT .NE. 0) THEN
          IF(IONLY .EQ. 0) THEN
             IOFF = IOFF + 1
             IF (IOFF .GT. IMAX) GO TO 120
             CBUFF(IOFF) = CHAR(64)
          ENDIF
        ENDIF
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = TEMP(IBYTE)
        IF (NSTAT .EQ. 0) GO TO 100
C       CHARACTER WAS MODIFIED PUT OUT THE CODE 1000000 0000001 TO
C       INDICATE THAT IT WAS
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = NCNTRL
        J = 1
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = TEMP(IBYTE)
  100 CONTINUE
C     FINISHED COMPRESSING NOW MAKE UP TO A MULTIPLE OF 80 CHARACTERS
C     FIND OUT HOW MANY CHARACTERS TO PUT IN
      K = 80 - (IOFF - ((IOFF/80) * 80))
      IF (K .LT. 2) K = K + 80
C     FILL TO A MULTIPLE OF 80 CHARACTERS WITH REPEATS OF 
C     THE BIT PATTERN 1000000
      DO 110 I = 1,K
         IOFF = IOFF + 1
         IF(IOFF .GT. IMAX) GO TO 120
         CBUFF(IOFF) = NCNTRL
  110 CONTINUE
  120 CONTINUE
      LC = IOFF
      IF (IOFF .GT. IMAX) THEN
         LC = IMAX
         IERROR = -1
      ENDIF
      RETURN
      END
C******************************************************************
C                                                                 *
C     SUBROUTINE CMPRS8(LX,IX,LC,CBUFF,IERROR)                    *
C                                                                 *
C     ROUTINE TO WORD-COMPRESS DATA INTO 8 BIT BYTES.             *
C     INPUTS ARE INTEGER*4 ARRAY IX CONTAINING LX VALUES TO BE    *
C     COMPRESSED INTO 8 BIT BYTES.                                *
C     ON ENTRY LC SHOULD CONTAIN DIMENSIONED LENGTH OF CBUFF.     *
C     OUTPUTS ARE CHARACTER*1 ARRAY CBUFF WITH LC MODIFIED TO     * 
C     REFLECT THE NUMBER OF BYTES WHICH HAVE BEEN PUT INTO CBUFF. *
C     LC IS MADE A MULTIPLE OF 80 USING UNIQUE FILL CHARACTERS.   *
C     IF CBUFF IS TOO SMALL TO CONTAIN ALL COMPRESSED DATA        *
C     IERROR WILL CONTAIN -1 OTHERWISE IT WILL BE SET TO ZERO.    *
C     METHODOLOGY IS THAT THE MOST SIGNIFICANT BIT OF EACH BYTE   *
C     IS SET TO ONE IF NEXT BYTE CONTAINS INFORMATION PERTAINING  *
C     TO THE SAME SAMPLE. IN THE FIRST BYTE PERTAINING TO EACH    *
C     SAMPLE, THE SECOND MOST SIGNIFICANT BIT IS USED AS A SIGN   *
C     BIT. THE LEAST SIGNIFICANT 6 BITS OF THE FIRST BYTE AND     *
C     THE LEAST SIGNIFICANT SEVEN BITS OF ANY SUBSEQUENT BYTE     *
C     PERTAINING TO THE SAME SAMPLE ARE COMPRESSED TOGETHER ON    *
C     DECODING TO GIVE THE MAGNITUDE OF THE SAMPLE.               * 
C     USING THIS COMPRESSION SCHEME THE CODES                     *
C     10000000 10000000 AND 10000000 00000001 WOULD NOT NORMALLY  *
C     BE TRANSMITTED (AKIN TO NOT TRANSMITTING LEADING ZEROS)     *
C     THESE TWO PATTERNS ARE USED AS CONTROL PATTERNS.            *
C     THE PATTERN 10000000 10000000 SIGNIFIES THE END OF THE DATA *
C     AND IS USED TO FILL UP TO A MULTIPLE OF EIGHTY CHARACTERS.  *
C     THE PATTERN 10000000 0000001 INDICATES THAT 32 SHOULD BE    *
C     SUBTRACTED FROM THE PREVIOUS SAMPLE. USING THIS METHODOLOGY *
C     ANY CONTROL CHARACTER WHICH A COMMUNICATION LINK WONT ACCEPT*
C     CAN BE MODIFIED BY ADDING 32 TO IT. THE 32 WILL BE SUB-     *
C     TRACTED ON DECOMPRESSION                                    *
C     DATA MAY BE DECOMPRESSED USING SUBROUTINE DCOMP8            *
C                                                                 *
C     SUBROUTINES CALLED   ---   INTAND   ---   CHEKBT   ---      * 
C                                                                 *
C******************************************************************
C
      SUBROUTINE CMPRS8(LX,IX,LC,CBUFF,IERROR)
      IMPLICIT INTEGER *4 (I-N)
cuk      CHARACTER *1 CBUFF(4),TEMP(4),TEST(4),NCNTRL
cuu91      CHARACTER *1 CBUFF(1),TEMP(4),TEST(4),NCNTRL
      CHARACTER *1 CBUFF(lc),TEMP(4),TEST(4),NCNTRL
cuu91      INTEGER *4 IX(*)
      INTEGER *4 IX(lx)
      EQUIVALENCE (J,TEMP),(TEST,ITEST)
      DATA TEST/'1','2','3','4'/
      DATA N5/32/,
     *     N6/64/,
     *     N7/128/,       N7M1/127/,
     *     N12/4096/,
     *     N13/8192/,
     *     N14/16384/,    N14M1/16383/,
     *     N19/524288/,
     *     N20/1048576/,
     *     N21/2097152/,  N21M1/2097151/,
     *     N26/67108864/, N28M1/268435455/
      IBYTE = 4
C     WORK OUT WHICH WAY BYTES ARE STORED IN COMPUTER
      IF(ITEST .EQ. (((52*256+51)*256+50)*256+49)) IBYTE = 1
      J = N7 
      NCNTRL = TEMP(IBYTE)
C     NCNTRL IS AN EIGHT BIT BYTE WITH BIT PATTERN 10000000
C
      MFLAG = N7
      IOFF = 0
      IMAX = LC
      IERROR = 0 
      DO 100 II = 1,LX
        IFIX = 0
        JN = IX(II)
C
C       SEE IF NUMBER IS -VE.
C
        NFLAG = 0
        IF(JN .LT. 0) THEN
           NFLAG = N6
           JN = -JN
        END IF
        IF(JN .LT. N6) GO TO 40
C        IF HERE, DATA REQUIRES MORE THAN 1 BYTE
         IF(JN. LT. N13) GO TO 30
C         IF HERE, DATA REQUIRES MORE THAN 2 BYTES
          IF(JN. LT. N20) GO TO 20
C          IF HERE, DATA REQUIRES MORE THAN THREE BYTES
           IF(JN. GT. N28M1) JN = N28M1
C          FILL A BYTE
           J = JN/N21 + NFLAG + MFLAG
           IOFF = IOFF + 1
           IF (IOFF .GT. IMAX) GO TO 120
           CBUFF(IOFF) = TEMP(IBYTE)
           CALL INTAND(JN,N21M1,JN)
           NFLAG = 0
   20     CONTINUE
C         IF HERE, DATA REQUIRES THREE MORE BYTES
          J = JN/N14 + NFLAG + MFLAG
          IOFF = IOFF + 1
          IF (IOFF .GT. IMAX) GO TO 120
          CBUFF(IOFF) = TEMP(IBYTE)
          CALL INTAND(JN,N14M1,JN)
          NFLAG = 0
   30    CONTINUE
C        IF HERE, DATA REQUIRES TWO MORE BYTES
         J = JN/N7 + NFLAG + MFLAG
         IOFF = IOFF + 1
         IF (IOFF .GT. IMAX) GO TO 120
         CBUFF(IOFF) = TEMP(IBYTE)
         CALL INTAND(JN,N7M1,JN)
         NFLAG = 0
   40   CONTINUE
C       FILL IN LAST REMAINING BYTE
        J = JN + NFLAG
C       CHECK AND MODIFY BYTE IF IT CANNOT BE TRANSMITTED
        CALL CHEKBT(TEMP(IBYTE),NSTAT,IBYTE)
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = TEMP(IBYTE)
        IF(NSTAT .EQ. 0) GO TO 100
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = NCNTRL
        J = 1
        IOFF = IOFF + 1
        IF (IOFF .GT. IMAX) GO TO 120
        CBUFF(IOFF) = TEMP(IBYTE)
  100 CONTINUE
C     FINISHED COMPRESSING NOW MAKE UP TO A MULTIPLE OF 80 CHARACTERS
C     FIND HOW MANY CHARACTERS TO PUT IN
      K = 80 - (IOFF - ((IOFF/80) * 80))
      IF (K .LE. 2) K = K + 80
C     NEED AT LEAST TWO NCNTRL CHARACTERS TOGETHER FOR UNIQUENESS
      DO 110 I = 1,K
         IOFF = IOFF + 1
         IF (IOFF .GT. IMAX) GO TO 120
         CBUFF(IOFF) = NCNTRL
  110 CONTINUE
  120 CONTINUE
      LC = IOFF 
      IF ( IOFF .GT. IMAX) THEN
        LC = IMAX
        IERROR = -1
      ENDIF
      RETURN
      END
C***********************************************************************
C                                                                      *
C     SUBROUTINE DCOMP6(LB,IBUF,LOUT,IOUT,IERROR)                      *
C                                                                      *
C     SUBROUTINE DECOMPRESS INTEGER DATA THAT HAS BEEN COMPRESSED      *
C     INTO ASCII CHARACTERS AND RETURNS VALUES IN INTEGER *4 FORMAT    *
C     SEE SUBROUTINE CMPRS6 FOR COMPRESSION FORMAT                     *
C     INPUT - IBUF AN ARRAY OF CONTAINING  LB CHARACTERS.              *
C     LOUT SHOULD CONTAIN THE DIMENSION OF THE INTEGER *4 ARRAY IOUT.  * 
C     ON RETURN ARRAY LOUT WILL BE SET TO CONTAIN THE NUMBER OF INTEGER*
C     VALUES WHICH HAVE BEEN PUT IN THE ARRAY IOUT.                    *
C     IF THE ARRAY IOUT IS NOT LARGE ENOUGH TO CONTAIN ALL OF THE      *
C     DECOMPRESSED VALUES IERROR WILL BE SET TO -1 OTHERWISE IT WILL   *
C     SET TO ZERO                                                      *
C***********************************************************************
C
      SUBROUTINE DCOMP6(LB,IBUF,LOUT,IOUT,IERROR)
      IMPLICIT INTEGER *4 (I-N)
cuk      INTEGER *4 IOUT(*),ICHAR(128)
cuu91      INTEGER *4 IOUT(1),ICHAR(128)
      INTEGER *4 IOUT(lout),ICHAR(128)
cuu91      CHARACTER *1 IBUF(1), ACHAR(4), TEST(4)
      CHARACTER *1 IBUF(lb), ACHAR(4), TEST(4)
      CHARACTER *1 ASPACE,LFEED,CRETN
      EQUIVALENCE (INN,ACHAR),(ITEST,TEST)
      DATA TEST/'1','2','3','4'/
      data ichar/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     1 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     2 0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,2,
     3 3,4,5,6,7,8,9,10,11,0,0,0,0,0,0,0,
     4 12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,
     5 28,29,30,31,32,33,34,35,36,37,0,0,0,0,0,0,
     6 38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,
     7 54,55,56,57,58,59,60,61,62,63,0,0,0,0,0,0/
      IERROR = 0
      CRETN = CHAR(13)
      LFEED = CHAR(10)
      ASPACE = CHAR(32)
      IMAX = LOUT
      ISIGN = 16
      IOFLOW = 32
      MASK1 = 15
      MASK2 = 31
C     WORK OUT WHICH WAY BYTES ARE STORED IN COMPUTER
      IBYTE = 4
      IF (ITEST.EQ.(((52*256+51)*256+50)*256+49)) IBYTE = 1
      ICOUNT = 0
      I = 0
      J = 0
C     START OF DECODING
   1  CONTINUE
        I = I + 1
        ACHAR(IBYTE) = IBUF(I)
C       IF A CARRIAGE OR LINE FEED IGNORE, IF A SPACE THEN END OF DATA
        IF (ACHAR(IBYTE) .EQ. CRETN) GO TO 1 
        IF (ACHAR(IBYTE) .EQ. LFEED) GO TO 1 
        IF (ACHAR(IBYTE) .EQ. ASPACE) GO TO 5
        ICOUNT = ICOUNT + 1
C       STRIP OFF ANY HIGHER ORDER BITS
        CALL INTAND(INN,127,K)
C       GET NUMBER REPRESENTION OF INPUT CHARACTER
        INN = ICHAR(K)
C       GET SIGN BIT
        CALL INTAND(INN,ISIGN,JSIGN)
C       GET CONTINUATION BIT (IF ANY)
        CALL INTAND(INN,IOFLOW,JOFLOW)
C       REMOVE BITS WE DONT WANT
        CALL INTAND(INN,MASK1,ITEMP)
   2    CONTINUE
          IF(JOFLOW.EQ.0) GO TO 4
C         THERE IS ANOTHER BYTE IN THIS SAMPLE
          ITEMP = ITEMP * 32
   3        CONTINUE
            I = I + 1
            ACHAR(IBYTE) = IBUF(I)
          IF (ACHAR(IBYTE) .EQ. CRETN) GO TO 3 
          IF (ACHAR(IBYTE) .EQ. LFEED) GO TO 3 
          ICOUNT = ICOUNT + 1
C         STRIP OFF ANY HIGHER ORDER BITS
          CALL INTAND(INN,127,K)
          INN = ICHAR(K)
C         GET CONTINUATION BIT (IF ANY)
          CALL INTAND(INN,IOFLOW,JOFLOW)
          CALL INTAND(INN,MASK2,K)
          ITEMP = ITEMP + K
        GO TO 2
   4    CONTINUE
        IF (JSIGN.NE.0) ITEMP = -ITEMP
        J = J +1
        IF (J .GT. IMAX) GO TO 5
        IOUT(J) = ITEMP
      IF(ICOUNT.LT.LB) GO TO 1
   5  CONTINUE
      LOUT = J
      IF (J .GT. IMAX) THEN
         LOUT = IMAX
         IERROR = -1
      ENDIF
      RETURN
      END
C************************************************************************
C                                                                       *
C     SUBROUTINE DCOMP7(LB,IBUF,LOUT,IOUT,IERROR)                       *
C                                                                       *
C     SUBROUTINE DECOMPRESS INTEGER DATA THAT HAS BEEN COMPRESSED       *
C     INTO 7 BIT CHARACTERS AND RETURNS VALUES IN INTEGER *4 FORMAT.    *
C     SEE SUBROUTINE CMPRS7 FOR COMPRESSION FORMAT.                     *
C     INPUT - IBUF AN ARRAY OF CHARACTERS OF LENGTH LB.                 *
C     LOUT SHOULD CONTAIN THE LENGTH OF THE INTEGER *4 OUTPUT ARRAY IOUT*
C     ON RETURN ARRAY IOUT WILL CONTAIN LOUT INTEGER VALUES.            *
C     IF THE ARRAY IOUT WAS LARGE ENOUGH TO CONTAIN ALL CONVERTED       *
C     VALUES, IERROR WILL CONTAIN ZERO. IF NOT IT WILL BE SET TO -1     *
C                                                                       *
C************************************************************************
C
      SUBROUTINE DCOMP7(LB,IBUF,LOUT,IOUT,IERROR)
      IMPLICIT INTEGER *4 (I-N)
cuk      INTEGER *4 IOUT(*)
cuu91      INTEGER *4 IOUT(1)
      INTEGER *4 IOUT(lout)
cuu91      CHARACTER *1 IBUF(1),ACHAR(4),TEST(4)
      CHARACTER *1 IBUF(lb),ACHAR(4),TEST(4)
      EQUIVALENCE (INN,ACHAR),(ITEST,TEST)
      DATA TEST/'1','2','3','4'/
      DATA ISIGN/32/, IOFLOW/64/, MASK1/31/, MASK2/63/
      DATA ICORR/32/, MASK3/127/, NCNTRL/64/
C     WORK OUT WHICH WAY BYTES ARE STORED IN COMPUTER
      IBYTE = 4
      IF (ITEST.EQ.(((52*256+51)*256+50)*256+49)) IBYTE = 1
      I = 0
      J = 0
      IMAX = LOUT
C     START OF DECODING
   1  CONTINUE
        IEND = 0
        I = I + 1
        ACHAR(IBYTE) = IBUF(I)
C       REMOVE MOST SIGNIFICANT BIT - NOT USED
        CALL INTAND(INN,MASK3,INN)
C       TEST IF CHARACTER IS EQUAL TO NCNTRL
        IF (INN .EQ. NCNTRL) IEND =  1
C       GET SIGN BIT
        CALL INTAND(INN,ISIGN,JSIGN)
C       GET CONTINUATION BIT
        CALL INTAND(INN,IOFLOW,JOFLOW)
C       REMOVE SIGN AND CONTINUATION BITS
        CALL INTAND(INN,MASK1,ITEMP)
   2    CONTINUE
        IF(JOFLOW .EQ. 0) GO TO 3
C       THERE IS ANOTHER BYTE IN THIS SAMPLE
        I = I + 1
        ACHAR(IBYTE) = IBUF(I)
C       REMOVE MOST SIGNIFICANT BIT - NOT USED
        CALL INTAND(INN,MASK3,INN)
C       TEST IF CHARACTER IS EQUAL TO NCNTRL 
        IF (IEND .EQ. 1) THEN
           IF (INN .EQ. NCNTRL) GO TO 4
C          BIT PATTERN 1000000 FOLLOWED BY 1000000 MEANS END OF DATA
C          SEE IF PREVIOUS SAMPLE HAS TO BE MODIFIED
            IF (INN .LT. 16) THEN
               ITEMP = ICORR
C              SUBTRACT CORRECTION FROM PREVIOUS SAMPLE
               IF (IOUT(J) .LT. 0) ITEMP = -ITEMP
               IOUT(J) = IOUT(J) - ITEMP
               GO TO 1
           ENDIF
      ENDIF
      IEND = 0
C     GET CONTINUATION BIT
      CALL INTAND(INN,IOFLOW,JOFLOW)
      CALL INTAND(INN,MASK2,K)
C     SHIFT WHAT WE HAVE 6 BITS LEFT AND ADD IN NEW BITS
      ITEMP = ITEMP * 64 + K
      GO TO 2
   3  CONTINUE
      IF(JSIGN .NE. 0) ITEMP = -ITEMP
      J = J + 1
      IF (J .GT. IMAX) GO TO 4
      IOUT(J) = ITEMP
      IF(I. LT. LB) GO TO 1
   4  CONTINUE
      LOUT = J
      IF (J .GT. IMAX) THEN
         LOUT = IMAX
         IERROR = -1
      ENDIF
      RETURN
      END
C************************************************************************
C     SUBROUTINE DCOMP8(LB,IBUF,LOUT,IOUT,IERROR)                       *
C     SUBROUTINE DECOMPRESS INTEGER DATA THAT HAS BEEN COMPRESSED       * 
C     INTO 8 BIT CHARACTERS AND RETURNS VALUES IN INTEGER *4 FORMAT.    *
C     SEE SUBROUTINE CMPRS8 FOR COMPRESSION FORMAT.                     *
C     INPUT - IBUF AN ARRAY OF CHARACTERS OF LENGTH LB.                 *
C     LOUT SHOULD CONTAIN THE LENGTH OF THE INTEGER *4 OUTPUT ARRAY IOUT*
C     ON RETURN ARRAY IOUT WILL CONTAIN LOUT INTEGER VALUES.            *
C     IF THE ARRAY IOUT WAS LARGE ENOUGH TO CONTAIN ALL CONVERTED       *
C     VALUES IERROR WILL CONTAIN ZERO. IF NOT IT WILL BE SET TO -1      *
C************************************************************************
      SUBROUTINE DCOMP8(LB,IBUF,LOUT,IOUT,IERROR)
      IMPLICIT INTEGER *4 (I-N)
cuk      INTEGER *4 IOUT(*)
cuu91      INTEGER *4 IOUT(1)
      INTEGER *4 IOUT(lout)
cuu91      CHARACTER *1 IBUF(1),ACHAR(4),TEST(4)
      CHARACTER *1 IBUF(lb),ACHAR(4),TEST(4)
      EQUIVALENCE (INN,ACHAR),(ITEST,TEST)
      DATA TEST/'1','2','3','4'/
      DATA N5/32/,N12/4096/,N19/524288/,N26/67108864/
      DATA ISIGN/64/,IOFLOW/128/,MASK1/63/,MASK2/127/
      DATA NCNTRL/128/,ICORR/32/
C     WORK OUT WHICH WAY BYTES ARE STORED IN COMPUTER
      IBYTE = 4
      IF (ITEST.EQ.(((52*256+51)*256+50)*256+49)) IBYTE = 1
      I = 0
      J = 0
      IERROR = 0
      IMAX = LOUT
C     START OF DECODING
   1  CONTINUE
        IEND = 0
        ISUB = 0
        I = I + 1
        ACHAR(IBYTE) = IBUF(I)
C       TEST IF CHARACTER IS EQUAL TO NCNTRL (100000000)
        IF(INN.EQ.NCNTRL) IEND = 1
C       GET SIGN BIT
        CALL INTAND(INN,ISIGN,JSIGN)
C       GET CONTINUATION BIT
        CALL INTAND(INN,IOFLOW,JOFLOW)
C       REMOVE SIGN AND CONTINUATION BITS
        CALL INTAND(INN,MASK1,ITEMP)
   2    CONTINUE
          IF(JOFLOW.EQ.0) GO TO 3
C         THERE IS ANOTHER BYTE IN THIS SAMPLE
          I = I + 1
          ACHAR(IBYTE) = IBUF(I)
C         TEST IF CHARACTER IS EQUAL TO NCNTRL 
          IF (IEND.EQ.1) THEN
             IF (INN .EQ. NCNTRL) GO TO 100
C            IF TWO CONTROL CHARACTERS IN A ROW THEN END OF DATA
C            SEE IF PREVIOUS SAMPLE HAS TO BE MODIFIED
             IF (INN.LT.16) THEN
                ITEMP = ICORR
C               NOW SUBTRACT CORRECTION FROM PREVIOUS SAMPLE
                IF (IOUT(J).LT.0) ITEMP = - ITEMP 
                IOUT(J) = IOUT(J) - ITEMP
              GO TO 1
             ENDIF 
          ENDIF 
          IEND = 0
          ISUB = 0
C         GET CONTINUATION BIT
          CALL INTAND(INN,IOFLOW,JOFLOW)
C         MASK OFF CONTINUATION BIT
          CALL INTAND(INN,MASK2,K)
C         SHIFT WHAT WE HAVE SO FAR 7 BITS LEFT AND ADD IN NEXT BITS
          ITEMP = ITEMP * 128 + K
        GO TO 2
   3    CONTINUE
        IF(JSIGN.NE.0) ITEMP = -ITEMP
        J = J + 1
        IF (J .GT. IMAX) GO TO 100
        IOUT(J) = ITEMP
      IF(I. LT. LB) GO TO 1
  100 CONTINUE
      LOUT = J
      IF (J .GT. IMAX) THEN
        LOUT = IMAX
        IERROR = -1
      ENDIF
      RETURN
      END
C**********************************************************************
C                                                                     *
C      SUBROUTINE INTAND(I1,I2,I3)                                    *
C                                                                     *
C      SUBROUTINE BITWISE "ANDS" THE INTEGERS IN I1 AND I2            *
C      AND RETURNS THE RESULT IN INTEGER I3                           *
C      FOR EXAMPLE                                                    *
C      IF THE 32 BITS IN I1 ARE 11001100 1110001110 11110000 11111111 *
C      AND IN I2 ARE            10101010 1100110011 00110011 00110011 *
C      I3 WILL BECOME           10001000 1100000010 00110000 00110011 *
C                                                                     *
C      NOTE "AND" IS NOT STANDARD FORTRAN 77 FUNCTION SO THIS IS A    *
C      MACHINE DEPENDANT SUBROUTINE                                   *
C**********************************************************************
C
       SUBROUTINE INTAND(I1,I2,I3) 
       INTEGER *4 I1,I2,I3
C##SUN## REMOVE COMMENT FROM NEXT LINE FOR SUN COMPUTERS
cuk       I3 = AND(I1,I2)
C##DEC## REMOVE COMMENT FROM NEXT LINE FOR PDP AND VAX COMPUTERS and HP's
C       I3 = JIAND(I1,I2)
C##IBM## REMOVE COMMENT FROM NEXT LINE FOR IBM PC'S (I THINK)
      I3 = IAND(I1,I2)
       RETURN
       END
C************************************************************************
C                                                                       *
C     SUBROUTINE CHEKBT(ACHAR,NSTAT,IBYTE)                              *
C                                                                       *
C     SUBROUTINE CHECKS WHETHER THE CHARACTER ACHAR IS ONE WHICH CANNOT *
C     BE TRANSMITTED OVER A COMMUNICATIONS LINK. IF THE CHARACTER       *
C     CAN BE TRANSMITTED NSTAT IS SET TO 0 OTHERWISE IT IS SET TO 1.    *
C     IF NSTART IS SET TO ONE A ONE BIT IS ADDED INTO THE SIXTH MOST    *
C     SIGNIFICANT BIT OF ACHAR. THIS IS REMOVED IN THE DECODING PROGRAM *
C     THE SUBROUTINE HAS BEEN INITIALLY SET UP TO STOP CONTROL Z,       *
C     CONTROL C, CONTROL P AND CONTROL D CHARACTERS FROM BEING          *   
C     TRANSMITTED. THESE MAY HAVE TO BE CHANGED, DELETED OR ADDED TO    *
C     DEPENDING ON THE PARTICULAR CIRCUIT AND COMPUTERS.                *
C     FOR A FULL BINARY LINK, NO CONTROL CHARACTERS NEED BE STOPPED     *
C     AND THIS SUBROUTINE WILL BECOME REDUNDANT.                        * 
C     TO ADD ANOTHER CONTROL CHARACTER DEFINE IT, SPECIFY IT AND TEST   *
C     FOR IT.                                                           *
C     IBYTE = 1 FOR COMPUTERS WHICH STORE A CHARACTER IN THE MOST       *
C     SIGNIFICANT BITS OF AN INTEGER  *4 WORD. IBYTE = 4 FOR            *
C     COMPUTERS WHICH STORE A CHARACTER IN THE LEAST SIGNIFICANT        *
C     BYTE OF A COMPUTER WORD.                                          *
C     NOTE THIS SUBROUTINE WILL NOT WORK FOR CHARACTERS WHOSE 8 BIT     *
C     INTEGER REPRESENTATION IS GREATER THAN 31                         *
C     MODIFIED 28TH NOVEMBER 1988 BECAUSE OF ERRORS ON VAX COMPUTERS    *
C************************************************************************
C
      SUBROUTINE CHEKBT(ACHAR,NSTAT,IBYTE)
      IMPLICIT INTEGER *4 (I-N)
      CHARACTER *1 ACHAR,CNTRLZ,CNTRLC,CNTRLP,CNTRLD
      CHARACTER *1 OVRLAY,CHAR32
      INTEGER *4 ITEMP,ITEMP1
      EQUIVALENCE (ITEMP,OVRLAY),(ITEMP1,CHAR32)
      ITEMP = 0
      ITEMP1 = 0
      CHAR32 = CHAR(32)
C     DEFINE CONTROL CHARACTERS WHICH SHOULD NOT BE TRANSMITTED
C     THESE WILL VARY FOR DIFFERENT CIRCUITS AND COMPUTERS AND MAY HAVE
C     TO BE FOUND BY TRIAL AND ERROR.
      CNTRLZ = CHAR(26)
      CNTRLC = CHAR(3)
      CNTRLP = CHAR(16)
      CNTRLD = CHAR(4)
      NSTAT = 0
      IF(ACHAR.EQ.CNTRLZ) NSTAT = 1
      IF(ACHAR.EQ.CNTRLC) NSTAT = 1
      IF(ACHAR.EQ.CNTRLP) NSTAT = 1
      IF(ACHAR.EQ.CNTRLD) NSTAT = 1
      IF(NSTAT.EQ.1) THEN
         OVRLAY = ACHAR
         ITEMP = ITEMP + ITEMP1
         ACHAR = OVRLAY
      ENDIF
      RETURN
      END
c
