$STORAGE:2
C    -------------PROGRAM SEPARATE--------------------------------------
C         This program separates records with different record numbers
C         within data files by creating separate files for each set of
C         occurring record numbers.
C         Records are assumed to be no longer than 80 chars.
C         By: Jim Groeneveld, NIPG-TNO, Leiden, 13 July '87
      PROGRAM SEPARATE
      CHARACTER INFIL(80),MSGFIL(80)
      LOGICAL RDOPEN,WROPEN,MSOPEN,CHECK
      RDOPEN = .FALSE.
      WROPEN = .FALSE.
      CALL HEAD
      CALL ASKPAR (INFIL,KFIRST,KLAST,LASTPD,CHECK)
      IF (KFIRST .EQ. 0) THEN
         NPASS = 0
 1       CALL PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
     1      RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
         GOTO 1
      ELSE
         CALL PASS1 (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
     1      RDOPEN,WROPEN,MSGFIL,MSOPEN)
         NPASS = 1
 2       CALL PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
     1      RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
         GOTO 2
      ENDIF
      END
C    --------------------SUBROUTINE HEAD--------------------------------
C     SUBROUTINE HEAD: Display program HEADing on screen.
      SUBROUTINE HEAD
      CHARACTER*80 TEXT
      LOGICAL ERROR
      CALL CLS
      TEXT = '===== Program SEPARATE by Jim Groeneveld, ====='
      CALL WRTXSI ('+',TEXT,ERROR)
      TEXT = '============ NIPG-TNO, 14 July 1987 ==========='
      CALL WRTXSI (' ',TEXT,ERROR)
      TEXT = ' '
      CALL WRTXSI (' ',TEXT,ERROR)
      IF (ERROR) STOP 'ERROR in HEAD'
      RETURN
      END
C    --------------------SUBROUTINE CLS---------------------------------
      SUBROUTINE CLS
      WRITE (*,*) CHAR(27),'[2J'
      RETURN
      END
C    --------------------SUBROUTINE ASKPAR------------------------------
C     SUBROUTINE ASKPAR: ASK for necessary PARameters.  
      SUBROUTINE ASKPAR (INFIL,KFIRST,KLAST,LASTPD,CHECK)
      CHARACTER INFIL(80),ANSWER(80),TEXT*80
      LOGICAL END,ERROR,FNCHCK,CHECK
 1    TEXT = 'Enter name of originating file:'
      CALL WRTXSE (' ',TEXT,ERROR)
      CALL RDCLNK (INFIL,END,ERROR)
      IF (END) GOTO 8
      IF (ERROR) GOTO 9
      ERROR = .NOT. FNCHCK(INFIL,LASTPD)
      IF (ERROR) THEN
         TEXT = '****** Error within extension of file name ******'
         CALL WRTXSI (' ',TEXT,ERROR)
         GOTO 1
      ENDIF
  2   TEXT = 'Enter starting position of record number per case on each'
      CALL WRTXSI (' ',TEXT,ERROR)
      TEXT = 'record (line) or enter a 0 (zero) if there is none:'
      CALL WRTXSE (' ',TEXT,ERROR)
      CALL RDCLNK (ANSWER,END,ERROR)
      IF (END) GOTO 8
      IF (ERROR) GOTO 9
      CALL LVALUE (ANSWER,RSTART,NUMVAL)
      IF (NUMVAL .NE. 0 .OR. RSTART .LT. 0 .OR. RSTART .GT. 80) THEN
         TEXT = '****** Illegal number, must be between 0 and 80 ******'
         CALL WRTXSI (' ',TEXT,ERROR)
         GOTO 2
      ENDIF
      KFIRST = INT(RSTART)
 3    IF (KFIRST .EQ. 0) THEN
         TEXT = 'Enter number of records per case:'
         CALL WRTXSE (' ',TEXT,ERROR)
         CALL RDCLNK (ANSWER,END,ERROR)
         IF (END) GOTO 8
         IF (ERROR) GOTO 9
         CALL LVALUE (ANSWER,RPOS,NUMVAL)
         IF (NUMVAL .NE. 0 .OR. RPOS .LT. 1) THEN
         TEXT = '****** Illegal number, must be positive ******'
            CALL WRTXSI (' ',TEXT,ERROR)
            GOTO 3
         ENDIF
         KLAST = INT(RPOS)
      ELSE
         TEXT = 'Enter number of positions of record number (max. 3):'
         CALL WRTXSE (' ',TEXT,ERROR)
         CALL RDCLNK (ANSWER,END,ERROR)
         IF (END) GOTO 8
         IF (ERROR) GOTO 9
         CALL LVALUE (ANSWER,RPOS,NUMVAL)
         IF (NUMVAL .NE. 0 .OR. RPOS .LT. 1 .OR. RPOS .GT. 3) THEN
         TEXT = '****** Illegal number, must be between 1 and 3 ******'
            CALL WRTXSI (' ',TEXT,ERROR)
            GOTO 3
         ENDIF
         KLAST = INT(RPOS) + KFIRST - 1
         IF (KLAST .GT. 80) THEN
            TEXT = '****** Illegal number, may not cause to exceed'
            CALL WRTXSI (' ',TEXT,ERROR)
            TEXT = '       position 80 ******'
            CALL WRTXSI (' ',TEXT,ERROR)
            GOTO 3
         ENDIF
      ENDIF
 4    TEXT = 'Do you want to check for matching record lengths? Yes/No:'
      CALL WRTXSE (' ',TEXT,ERROR)
      CALL RDCLNK (ANSWER,END,ERROR)
      IF (END) GOTO 8
      IF (ERROR) GOTO 9
      CALL TESTYN (ANSWER,CHECK,ERROR)
      IF (ERROR) GOTO 4
      RETURN
 8    STOP 'EOF in ASKPAR'
 9    STOP 'ERROR in ASKPAR'
      END
C    -------------------SUBROUTINE TESTYN-------------------------------
      SUBROUTINE TESTYN (ANSWER,TEST,ERROR)
      CHARACTER ANSWER(80),TEXT*80
      LOGICAL TEST,ERROR
      ERROR = .FALSE.
      TEST = .FALSE.
      CALL SHLFT0 (ANSWER,LANSW)
      IF (ANSWER(1) .EQ. 'Y' .OR. ANSWER(1) .EQ. 'y') THEN
         TEST = .TRUE.
      ELSEIF (ANSWER(1) .EQ. 'N' .OR. ANSWER(1) .EQ. 'n') THEN
C        nothing
      ELSE
         TEXT = '****** Illegal answer, enter YES or NO ******'
         CALL WRTXSI (' ',TEXT,ERROR)
         ERROR = .TRUE.
      ENDIF
      RETURN
      END
C    -------------------LOGICAL FUNCTION FNCHCK-------------------------
C     LOGICAL FUNCTION FNCHCK CHeCKs FileName of INFILE for a three
C     characters long extension consisting only of digits, which is
C     not allowed, as it is reserved for output files.
      LOGICAL FUNCTION FNCHCK (FNAME,LASTPD)
      CHARACTER FNAME(80),MATCH(80)
      LOGICAL DIGIT(3)
C     Filename extensions are characters behind the last period
C     occurring in the filename. However, an extension may not be
C     given for the filename, while it may be for a specified path.
C     Thus it concerns only an eventual period behind the last
C     backslash. Search backwards for a backslash and a period:
      FNCHCK = .TRUE.
      DIGIT(1) = .FALSE.
      DIGIT(2) = .FALSE.
      DIGIT(3) = .FALSE.
      CALL SHLFT0 (FNAME,LFNAME)
      DO 1 J = 1 , LFNAME
         IF (FNAME(J) .EQ. ' ') THEN
            FNCHCK = .FALSE.
            RETURN
         ENDIF
1     CONTINUE
      CALL EMPTY (MATCH)
      MATCH(1) = '\'
      LASTBS = INCHAR (80,FNAME,MATCH)
      MATCH(1) = '.'
      LASTPD = INCHAR (80,FNAME,MATCH)
      IF (LASTPD .GT. LASTBS) THEN
C        FNAME contains a period indicating a possible extension.
C        Now look at the extension and search for digits.
C        Firstly, the eventual extension is within the characters
C        behind the period until the end of the name (the length).
         IF (LFNAME .EQ. LASTPD) THEN
C           no characters behind last period, OK
         ELSEIF (LFNAME .GT. LASTPD+3) THEN
C           extension too long: FNCHCK = .FALSE.
            FNCHCK = .FALSE.
         ELSEIF (LFNAME .LT. LASTPD+3) THEN
C           extension is less than 3 characters long, OK
         ELSE
C           extension is exactly 3 characters long
            DO 3 J = LASTPD+1 , LFNAME
               IF (ICHAR(FNAME(J)) .GE. 48 .AND.
     1             ICHAR(FNAME(J)) .LE. 57)
     2             DIGIT(J-LASTPD) = .TRUE.
 3          CONTINUE
            IF (FNAME(LASTPD+1) .EQ. '-') DIGIT(1) = .TRUE.
            IF (DIGIT(1) .AND. DIGIT(2) .AND. DIGIT(3)) FNCHCK = .FALSE.
            IF ((FNAME(LASTPD+1) .EQ. 'M' .OR.
     1           FNAME(LASTPD+1) .EQ. 'm') .AND.
     2          (FNAME(LASTPD+2) .EQ. 'S' .OR.
     3           FNAME(LASTPD+2) .EQ. 's') .AND.
     4          (FNAME(LASTPD+3) .EQ. 'G' .OR.
     5           FNAME(LASTPD+3) .EQ. 'g')) FNCHCK = .FALSE.
         ENDIF
      ELSE
C        indicate that the eventual period is not in the file name
C        but in the path name, which is not of interest
         LASTPD = 0
      ENDIF
      IF ((LASTPD .EQ. 0 .AND. LFNAME .GT. 76) .OR.
     1     LASTPD .GT. 77) FNCHCK = .FALSE.
      RETURN
      END
C    -------------------SUBROUTINE RDCLNK-------------------------------
C     SUBROUTINE RDCLNK: ReaD Character LiNe from Keyboard.
      SUBROUTINE RDCLNK (LINE,END,ERROR)
      CHARACTER LINE(80)
      LOGICAL END,ERROR
      END = .FALSE.
      ERROR = .FALSE.
      READ (*,'(80A1)',END=8,ERR=9) LINE
      RETURN
 8    END = .TRUE.
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    --------------------SUBROUTINE WRTXSI------------------------------
C     SUBROUTINE WRTXSI: WRite TeXt to Screen (Incl. EOL).
      SUBROUTINE WRTXSI (CCC,TEXT,ERROR)
      CHARACTER TEXT*80,CCC,ATEXT(80)
      LOGICAL ERROR
      ERROR = .FALSE.
      CALL CHTOAR (TEXT,ATEXT)
      LTEXT = LENCH(ATEXT)
      WRITE (*,'(A1,80A1)',ERR=9) CCC,(ATEXT(L),L=1,LTEXT)
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    -------------------SUBROUTINE WRTXSE-------------------------------
C     SUBROUTINE WRTXSE: WRite TeXt to Screen (Excl. EOL).
      SUBROUTINE WRTXSE (CCC,TEXT,ERROR)
      CHARACTER TEXT*80,CCC,ATEXT(80),FMT*15
      LOGICAL ERROR
      ERROR = .FALSE.
      CALL CHTOAR (TEXT,ATEXT)
      LTEXT = LENCH(ATEXT)
      WRITE (FMT,7) LTEXT
 7    FORMAT ('(A1,',I2,'A1,'' '',\)')
      WRITE (*,FMT,ERR=9) CCC,(ATEXT(L),L=1,LTEXT)
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    --------------------SUBROUTINE WRCLSI------------------------------
C     SUBROUTINE WRCLSI: WRite Character Line to Screen (Incl. EOL).
      SUBROUTINE WRCLSI (CCC,LINE,ERROR)
      CHARACTER LINE(80),CCC
      LOGICAL ERROR
      ERROR = .FALSE.
      LLINE = LENCH(LINE)
      WRITE (*,'(A1,80A1)',ERR=9) CCC,(LINE(J),J=1,LLINE)
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    -------------------SUBROUTINE WRCLSE-------------------------------
C     SUBROUTINE WRCLSE: WRite Character Line to Screen (Excl. EOL).
      SUBROUTINE WRCLSE (CCC,LINE,ERROR)
      CHARACTER LINE(80),CCC
      LOGICAL ERROR
      ERROR = .FALSE.
      WRITE (*,'(A1,80A1,'' '',\)',ERR=9) CCC,LINE
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    --------------------SUBROUTINE RDCLNF------------------------------
C     SUBROUTINE RDCLNF: ReaD Character LiNe from File with unitnr.
      SUBROUTINE RDCLNF (NRUNIT,LINE,END,ERROR)
      CHARACTER LINE(80)
      LOGICAL END,ERROR
      END = .FALSE.
      ERROR = .FALSE.
      READ (NRUNIT,'(80A1)',END=8,ERR=9) LINE
      RETURN
 8    END = .TRUE.
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    --------------------SUBROUTINE WRCLNF------------------------------
C     SUBROUTINE WRCLNF: WRite Character LiNe to File with unitnr.
      SUBROUTINE WRCLNF (NRUNIT,LINE,LLINE,ERROR)
      CHARACTER LINE(80)
      LOGICAL ERROR
      ERROR = .FALSE.
      LLINE = LENCH(LINE)
      WRITE (NRUNIT,'(80A1)',ERR=9) (LINE(J),J=1,LLINE)
      RETURN
 9    ERROR = .TRUE.
      RETURN
      END
C    -------------------SUBROUTINE OPENRD------------------------------
C     SUBROUTINE OPENRD: OPEN file for ReaD.
      SUBROUTINE OPENRD (NRUNIT,RDFILE,OPENED)
      CHARACTER RDFILE(80),FILERD*80
      LOGICAL OPENED
      IF (.NOT. OPENED) THEN
         CALL ARTOCH (RDFILE,FILERD)
         OPEN (NRUNIT,FILE=FILERD)
         OPENED = .TRUE.
      ENDIF
      RETURN
      END
C    ----------------------SUBROUTINE OPENWR----------------------------
C     SUBROUTINE OPENWR: OPEN file for WRite.
      SUBROUTINE OPENWR (NRUNIT,WRFILE,OPENED)
      CHARACTER WRFILE(80),FILEWR*80
      LOGICAL OPENED
      IF (.NOT. OPENED) THEN
         CALL ARTOCH (WRFILE,FILEWR)
         OPEN (NRUNIT,FILE=FILEWR,STATUS='NEW')
         OPENED = .TRUE.
      ENDIF
      RETURN
      END
C    ------------------SUBROUTINE OUTEXT--------------------------------
      SUBROUTINE OUTEXT (INFIL,LASTPD,NRREC,OUTFIL)
      CHARACTER INFIL(80),OUTFIL(80),EXT(80),TEMP*80
      CALL ARTOCH (INFIL,TEMP)
      CALL CHTOAR (TEMP,OUTFIL)
      IF (LASTPD .EQ. 0) LASTCH = LENCH(INFIL)
      IF (LASTPD .GT. 0) LASTCH = LASTPD - 1
      IF (NRREC .NE. 1000) THEN
         WRITE (TEMP,'(I3)') IABS(NRREC)
      ELSE
         TEMP = '-00'
      ENDIF
      CALL CHTOAR (TEMP,EXT)
      OUTFIL(LASTCH+1) = '.'
      IF (NRREC .LT. 0) OUTFIL(LASTCH+2) = '-'
      DO 3 J = 1 , 3
         IF (EXT(J) .EQ. ' ') EXT(J) = '0'
         OUTFIL(LASTCH+1+J) = EXT(J)
 3    CONTINUE
      RETURN
      END
C    ------------------SUBROUTINE TXTEXT--------------------------------
      SUBROUTINE TXTEXT (INFIL,LASTPD,TXT,TXTFIL)
      CHARACTER INFIL(80),TXTFIL(80),EXT(80),TEMP*80,TXT*3
      CALL ARTOCH (INFIL,TEMP)
      CALL CHTOAR (TEMP,TXTFIL)
      IF (LASTPD .EQ. 0) LASTCH = LENCH(INFIL)
      IF (LASTPD .GT. 0) LASTCH = LASTPD - 1
      TEMP = TXT
      CALL CHTOAR (TEMP,EXT)
      TXTFIL(LASTCH+1) = '.'
      DO 3 J = 1 , 3
         TXTFIL(LASTCH+1+J) = EXT(J)
 3    CONTINUE
      RETURN
      END
C    ------------------SUBROUTINE PASS1---------------------------------
C     SUBROUTINE PASS1 reads originating file for the first time and
C     writes the first separated file based on the first record number
C     encountered.
      SUBROUTINE PASS1 (INFIL,KFIRST,KLAST,LASTPD,NFIRST,
     1   MIN,CHECK,RDOPEN,WROPEN,MSGFIL,MSOPEN)
      CHARACTER INFIL(80),OUTFIL(80),RDFILE*80,WRFILE*80,RECNR(80),
     1   TEXT*80,ATEXT(80),LINE(80),MSGFIL(80)
      LOGICAL RDOPEN,WROPEN,MSOPEN,END,ERROR,CHECK
      TEXT = '---------------------------------------- Pass  1'
      CALL WRTXSI (' ',TEXT,ERROR)
      CALL OPENRD (1,INFIL,RDOPEN)
      NLNSRD = 0
      NLNSWR = 0
 1    CALL RDCLNF (1,LINE,END,ERROR)
      IF (ERROR) STOP 'ERROR in PASS1 after RDCLNF'
      IF (.NOT. END) THEN
         NLNSRD = NLNSRD + 1
         CALL RRECNR (LINE,KFIRST,KLAST,NR)
         IF (NLNSRD .EQ. 1) THEN
            MIN = 1001
            NRWR = NR
            NFIRST = NR
            CALL OUTEXT (INFIL,LASTPD,NRWR,OUTFIL)
            CALL OPENWR (2,OUTFIL,WROPEN)
            TEXT = '   Output file opened:'
            CALL WRTXSE (' ',TEXT,ERROR)
            CALL WRCLSI (' ',OUTFIL,ERROR)
            TEXT = '   Current record number:'
            CALL WRTXSE (' ',TEXT,ERROR)
            CALL CVALUE (NRWR,ATEXT,L)
            CALL WRCLSI (' ',ATEXT,ERROR)
            TEXT = ' '
            CALL WRTXSI (' ',TEXT,ERROR)
         ELSE
            IF (NR .LT. MIN .AND. NR .NE. NFIRST)
     1         MIN = NR
         ENDIF
         IF (MOD(NLNSRD,100) .EQ. 1) THEN
            TEXT = 'Processing from line:'
            CALL WRTXSE ('+',TEXT,ERROR)
            CALL CVALUE (NLNSRD,ATEXT,L)
            CALL WRCLSI (' ',ATEXT,ERROR)
         ENDIF
         IF (NR .EQ. NRWR) THEN
            CALL WRCLNF (2,LINE,LLINE,ERROR)
            NLNSWR = NLNSWR + 1
            IF (CHECK) CALL RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,
     1         1,MSOPEN,INFIL,LASTPD,MSGFIL)
         ENDIF
         GOTO 1
      ELSE
         IF (WROPEN) CLOSE (2)
         CLOSE (1)
         RDOPEN = .FALSE.
         WROPEN = .FALSE.
         TEXT = '     Number of lines read:'
         CALL WRTXSE ('+',TEXT,ERROR)
         CALL CVALUE (NLNSRD,ATEXT,L)
         CALL WRCLSI (' ',ATEXT,ERROR)
         TEXT = '     Number of lines written:'
         CALL WRTXSE (' ',TEXT,ERROR)
         CALL CVALUE (NLNSWR,ATEXT,L)
         CALL WRCLSI (' ',ATEXT,ERROR)
         IF (MIN .EQ. 1001 .OR. NLNSRD .EQ. 0)
     1      CALL FINISH (1,MSGFIL,MSOPEN)
      ENDIF
      RETURN
      END
C    ------------------SUBROUTINE PASSN---------------------------------
C     SUBROUTINE PASSN reads originating file for the next times and
C     writes the next separated file based on the relative minimum 
C     record number encountered.
C     Without a recordnumber to interprete this subroutine reads the
C     originating file repeatedly and writes succeeding separated files
C     based on the the number of the pass.
      SUBROUTINE PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,
     1   MIN,CHECK,RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
      CHARACTER INFIL(80),OUTFIL(80),RDFILE*80,WRFILE*80,RECNR(80),
     1   TEXT*80,ATEXT(80),LINE(80),MSGFIL(80)
      LOGICAL RDOPEN,WROPEN,MSOPEN,END,ERROR,CHECK
      NPASS = NPASS + 1
      TEXT = '---------------------------------------- Pass'
      CALL WRTXSE (' ',TEXT,ERROR)
      CALL CVALUE (NPASS,ATEXT,L)
      CALL WRCLSI (' ',ATEXT,ERROR)
      CALL OPENRD (1,INFIL,RDOPEN)
      NLNSRD = 0
      NLNSWR = 0
      IF (KFIRST .NE. 0) NRWR = MIN
      IF (KFIRST .EQ. 0) NRWR = NPASS
      MIN = 1001
 1    CALL RDCLNF (1,LINE,END,ERROR)
      IF (ERROR) STOP 'ERROR in PASSN after RDCLNF'
      IF (.NOT. END) THEN
         NLNSRD = NLNSRD + 1
         IF (KFIRST .NE. 0) CALL RRECNR (LINE,KFIRST,KLAST,NR)
         IF (NLNSRD .EQ. 1) THEN
            CALL OUTEXT (INFIL,LASTPD,NRWR,OUTFIL)
            CALL OPENWR (2,OUTFIL,WROPEN)
            TEXT = '   Output file opened:'
            CALL WRTXSE (' ',TEXT,ERROR)
            CALL WRCLSI (' ',OUTFIL,ERROR)
            TEXT = '   Current record number:'
            CALL WRTXSE (' ',TEXT,ERROR)
            CALL CVALUE (NRWR,ATEXT,L)
            CALL WRCLSI (' ',ATEXT,ERROR)
            TEXT = ' '
            CALL WRTXSI (' ',TEXT,ERROR)
         ENDIF
         IF (MOD(NLNSRD,100) .EQ. 1) THEN
            TEXT = 'Processing from line:'
            CALL WRTXSE ('+',TEXT,ERROR)
            CALL CVALUE (NLNSRD,ATEXT,L)
            CALL WRCLSI (' ',ATEXT,ERROR)
         ENDIF
         IF (NR .LT. MIN .AND. NR .NE. NFIRST .AND. NR .GT. NRWR .AND.
     1       KFIRST .NE. 0) MIN = NR
         IF ((NR .EQ. NRWR .AND. KFIRST .NE. 0) .OR. (KFIRST .EQ. 0
     1      .AND. MOD(NRWR,KLAST) .EQ. MOD(NLNSRD,KLAST))) THEN
            CALL WRCLNF (2,LINE,LLINE,ERROR)
            NLNSWR = NLNSWR + 1
            IF (CHECK) CALL RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,
     1         NPASS,MSOPEN,INFIL,LASTPD,MSGFIL)
         ENDIF
         GOTO 1
      ELSE
         IF (WROPEN) CLOSE (2)
         CLOSE (1)
         RDOPEN = .FALSE.
         WROPEN = .FALSE.
         TEXT = '     Number of lines read:'
         CALL WRTXSE ('+',TEXT,ERROR)
         CALL CVALUE (NLNSRD,ATEXT,L)
         CALL WRCLSI (' ',ATEXT,ERROR)
         TEXT = '     Number of lines written:'
         CALL WRTXSE (' ',TEXT,ERROR)
         CALL CVALUE (NLNSWR,ATEXT,L)
         CALL WRCLSI (' ',ATEXT,ERROR)
         IF ((KFIRST .NE. 0 .AND. MIN .EQ. 1001) .OR. (KFIRST .EQ. 0
     1      .AND. NRWR .EQ. KLAST) .OR. NLNSRD .EQ. 0)
     2      CALL FINISH (NPASS,MSGFIL,MSOPEN)
      ENDIF
      RETURN
      END
C    --------------------SUBROUTINE FINISH------------------------------
      SUBROUTINE FINISH (NPASS,MSGFIL,MSOPEN)
      CHARACTER TEXT*80,ATEXT(80),MSGFIL(80)
      LOGICAL ERROR,MSOPEN
      TEXT = '---------------------------------------- End of run'
      CALL WRTXSI (' ',TEXT,ERROR)
      TEXT = '     Number of passes ((maximum) records per case):'
      CALL WRTXSE (' ',TEXT,ERROR)
      CALL CVALUE (NPASS,ATEXT,L)
      CALL WRCLSI (' ',ATEXT,ERROR)
      IF (MSOPEN) THEN
         CLOSE (3)
         TEXT = '   The following file contains a report of'
         CALL WRTXSI (' ',TEXT,ERROR)
         TEXT = '   inconsistencies found with matching'
         CALL WRTXSI (' ',TEXT,ERROR)
         TEXT = '   record lengths:'
         CALL WRTXSE (' ',TEXT,ERROR)
         CALL WRCLSI (' ',MSGFIL,ERROR)
      ENDIF
      STOP 'Normal termination of program SEPARATE'
      END
C    --------------------SUBROUTINE RRECNR------------------------------
      SUBROUTINE RRECNR (LINE,KFIRST,KLAST,NR)
      CHARACTER LINE(80),RECNR(80)
      CALL EMPTY (RECNR)
      DO 2 J = KFIRST , KLAST
         RECNR(J-KFIRST+1) = LINE(J)
 2    CONTINUE
      LRECNR = LENCH(RECNR)
      IF (LRECNR .EQ. 0) THEN
         NUMVAL = 2
      ELSE
         CALL LVALUE (RECNR,RVALUE,NUMVAL)
      ENDIF
      IF (NUMVAL .EQ. 1 .OR. NUMVAL .EQ. 2) THEN
         NR = 1000
      ELSE 
         NR = INT(RVALUE)
      ENDIF
      RETURN
      END
C    ------------------SUBROUTINE RLCHCK--------------------------------
      SUBROUTINE RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,NPASS,MSOPEN,
     1   INFIL,LASTPD,MSGFIL)
      CHARACTER INFIL(80),MSGFIL(80),TEXT*80,ATEXT(80)
      LOGICAL MSOPEN,ERROR
      IF (NLNSWR .EQ. 1) THEN
         LREC = LLINE
      ELSEIF (LLINE .NE. LREC) THEN
         IF (.NOT. MSOPEN) THEN
            CALL TXTEXT (INFIL,LASTPD,'MSG',MSGFIL)
            CALL OPENWR (3,MSGFIL,MSOPEN)
            TEXT = 'The lengths of the following records do not match:'
            CALL CHTOAR (TEXT,ATEXT)
            CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
            TEXT = ' '
            CALL CHTOAR (TEXT,ATEXT)
            CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
            TEXT = 'Pass Rec LineRd LineWr Len Lln'
            CALL CHTOAR (TEXT,ATEXT)
            CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
            TEXT = '------------------------------'
            CALL CHTOAR (TEXT,ATEXT)
            CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
         ENDIF
         WRITE (3,3) NPASS,NRWR,NLNSRD,NLNSWR,LREC,LLINE
 3       FORMAT (I4,1X,I3,1X,I6,1X,I6,1X,I3,1X,I3)
      ENDIF
      RETURN
      END
C    ------------------SUBROUTINE SHLFT0--------------------------------
C     SUBROUTINE SHLFT0 SHIFTS NON-BLANK CHARACTERS TO THE MOST LEFT
C    *   POSITION OF THE CHARACTER VARIABLE (OMITS PRECEDING BLANKS) AND
C    *   DETERMINES THE REMAINING LENGTH (TILL CLOSING BLANKS) FROM CHVAR
      SUBROUTINE SHLFT0 (CHVAR,LENVAR)
      CHARACTER CHVAR(80)
      LENVAR = LENCH(CHVAR)
      IF (LENVAR .EQ. 0 .OR. LENVAR .EQ. 1) RETURN
      IF (CHVAR(1) .NE. ' ') RETURN
      DO 3 I = 1 , LENVAR
         IF (CHVAR(I) .NE. ' ') GO TO 4
 3    CONTINUE
C     CHVAR ONLY CONSISTS OF BLANKS: NO SHIFT
*     LENVAR = 0
      RETURN
 4    DO 5 J = I , LENVAR
         CHVAR(J-I+1) = CHVAR(J)
 5    CONTINUE
      DO 6 J = LENVAR-I+2 , LENVAR
         CHVAR(J) = ' '
 6    CONTINUE
      LENVAR = LENVAR + 1 - I
      RETURN
      END
C    -----------------------SUBROUTINE SHLFT1---------------------------
C     SUBROUTINE SHLFT1 SHIFTS NON-BLANK CHARACTERS TO THE MOST LEFT
C    *   POSITION OF THE CHARACTER VARIABLE (OMITS PRECEDING BLANKS)
C    *   FROM WHICH THE LENGTH (TILL CLOSING BLANKS) IS KNOWN: "LENVAR".
C    *   RETURNS THE REMAINING LENGTH AFTER SHIFTING LEFT: "LENVAR".
      SUBROUTINE SHLFT1 (CHVAR,LENVAR)
      CHARACTER CHVAR(80)
      DO 3 I = 1 , LENVAR
         IF (CHVAR(I) .NE. ' ') GO TO 4
 3    CONTINUE
C     CHVAR ONLY CONSISTS OF BLANKS: NO SHIFT
      LENVAR = 0
      RETURN
 4    DO 5 J = I , LENVAR
         CHVAR(J-I+1) = CHVAR(J)
 5    CONTINUE
      DO 6 J = LENVAR-I+1 , LENVAR
         CHVAR(J) = ' '
 6    CONTINUE
      LENVAR = LENVAR + 1 - I
      RETURN
      END
C    -----------------------------FUNCTION LENCH------------------------
C     FUNCTION LENCH DETERMINES LENGTH OF CHVAR WITHOUT CLOSING
C    *                  BLANKS
      FUNCTION LENCH (CHVAR)
      CHARACTER CHVAR(80)
      DO 7 LENCH = LENGTH(CHVAR) , 1 , -1
         IF (CHVAR(LENCH) .NE. ' ') GO TO 8
 7    CONTINUE
      LENCH = 0
 8    RETURN
      END
C    -------------------------SUBROUTINE CVALUE-------------------------
C     SUBROUTINE CVALUE CONVERTS INTEGER VARIABLE TO CHARACTER VARIABLE
C    *   SHIFTED LEFT
      SUBROUTINE CVALUE (INTVAR,CHINT,L)
      CHARACTER CHINT(80),CHFILE*80
      WRITE (CHFILE,'(I5)') INTVAR
      READ (CHFILE,'(80A1)') CHINT
      CALL SHLFT0 (CHINT,L)
      RETURN
      END
C    ------------------------------- FUNCTION INCHAR ------------------
C     FUNCTION INCHAR searches backwards IN characterstring TEXT for
C     (last) position of occurrence of CHARacterstring STRING in TEXT
C     up to position LPOS
      FUNCTION INCHAR (LPOS,TEXT,STRING)
C    *   no use of eventually known STRING and TEXT length
      CHARACTER STRING(80),TEXT(80),STRVAR*80,TXTVAR*80
      WRITE (STRVAR,'(80A1)') STRING
      LS = LENCH(STRING)
      LT = LENCH(TEXT)
      IF (LT .GT. LPOS) LT = LPOS
      DO 10 I = LT-LS+1 , 1 , -1
         WRITE (TXTVAR,'(80A1)') (TEXT(J),J=I,I+LS-1)
         IF (TXTVAR .EQ. STRVAR) GO TO 11
 10   CONTINUE
C    *   NO STRING FOUND, INCHAR WILL BE 0
      INCHAR = 0
      RETURN
C    *   STRING FOUND, INCHAR WILL GET POSITION NUMBER OF MATCH
 11   INCHAR = I
      RETURN
      END
C    -----------------SUBROUTINE LVALUE---------------------------------
C     SUBROUTINE LVALUE READS NUMBER (REAL OR INTEGER VALUE) WITHIN CHVAR
C    -NUMVAL=0 : INTEGER VALUE
C    -NUMVAL=1 : REAL OR EXPONENTIAL VALUE
C    -NUMVAL=2 : NON-NUMERICAL CONTENT OF CHVAR
      SUBROUTINE LVALUE (CHVAR,RVALUE,NUMVAL)
      CHARACTER CHVAR(80), FMT*7, CHFILE*80
      CALL SHLFT0 (CHVAR,LENVAR)
*     CALL APTAIL (CHVAR(:LENVAR),LENVAR,*9)
      NUMVAL = 0
      WRITE (FMT,3) LENVAR
 3    FORMAT ('(G',I2,'.0)')
      WRITE (CHFILE,'(80A1)') CHVAR
      READ (CHFILE,FMT,ERR=9) RVALUE
      IF (RVALUE-FLOAT(INT(RVALUE)) .NE. 0.) NUMVAL = 1
      RETURN
C     IF CHVAR = ' ' --> LENVAR = 0 AND FMT = 'G0.0' --> ERROR
 9    NUMVAL = 2
      RETURN
      END
C    ----------------------  SUBROUTINE APTAIL  -------------------------
C     SUBROUTINE APTAIL DETECTS THE PRESENCE OF @ IN CHVAR;
C     CHAR: @ MAY NOT BE READ WITH G-FORMAT DUE TO SYSTEM ERROR.......
*     SUBROUTINE APTAIL (CHVAR,LENVAR,*)
*     CHARACTER CHVAR(80)
*     DO 804 N = 1, LENVAR
*        IF (CHVAR(N) .EQ. '@') RETURN 1
*804  CONTINUE
*     RETURN
*     END
C    ----------------------- FUNCTION LENGTH ---------------------------
      FUNCTION LENGTH (CHVAR)
      CHARACTER CHVAR(80)
      DO 3 LENGTH = 80 , 1 , -1
         IF (CHVAR(LENGTH) .NE. ' ') RETURN
 3    CONTINUE
      LENGTH = 0
      RETURN
      END
C    ------------------- SUBROUTINE ARTOCH -----------------------------
C     SUBROUTINE ARTOCH converts a character ARray TO a CHaracter var.
      SUBROUTINE ARTOCH (CARRAY,CHVAR)
      CHARACTER CARRAY(80),CHVAR*80
      WRITE (CHVAR,'(80A1)') CARRAY
      RETURN
      END
C    ------------------- SUBROUTINE CHTOAR -----------------------------
C     SUBROUTINE CHTOAR converts a CHaracter var. TO a character ARray
      SUBROUTINE CHTOAR (CHVAR,CARRAY)
      CHARACTER CARRAY(80),CHVAR*80
      READ (CHVAR,'(80A1)',ERR=9) CARRAY
      RETURN
 9    STOP 'ERROR in CHTOAR'
      END
C    ------------------- SUBROUTINE EMPTY ------------------------------
      SUBROUTINE EMPTY (CHARR)
      CHARACTER CHARR(80)
      DO 1 I = 1 , 80
         CHARR(I) = ' '
 1    CONTINUE
      RETURN
      END
