home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / statstcs / separate.arc / SEPARATE.FOR < prev    next >
Encoding:
Text File  |  1987-07-20  |  26.4 KB  |  725 lines
  1. $STORAGE:2
  2. C    -------------PROGRAM SEPARATE--------------------------------------
  3. C         This program separates records with different record numbers
  4. C         within data files by creating separate files for each set of
  5. C         occurring record numbers.
  6. C         Records are assumed to be no longer than 80 chars.
  7. C         By: Jim Groeneveld, NIPG-TNO, Leiden, 13 July '87
  8.       PROGRAM SEPARATE
  9.       CHARACTER INFIL(80),MSGFIL(80)
  10.       LOGICAL RDOPEN,WROPEN,MSOPEN,CHECK
  11.       RDOPEN = .FALSE.
  12.       WROPEN = .FALSE.
  13.       CALL HEAD
  14.       CALL ASKPAR (INFIL,KFIRST,KLAST,LASTPD,CHECK)
  15.       IF (KFIRST .EQ. 0) THEN
  16.          NPASS = 0
  17.  1       CALL PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
  18.      1      RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
  19.          GOTO 1
  20.       ELSE
  21.          CALL PASS1 (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
  22.      1      RDOPEN,WROPEN,MSGFIL,MSOPEN)
  23.          NPASS = 1
  24.  2       CALL PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,MIN,CHECK,
  25.      1      RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
  26.          GOTO 2
  27.       ENDIF
  28.       END
  29. C    --------------------SUBROUTINE HEAD--------------------------------
  30. C     SUBROUTINE HEAD: Display program HEADing on screen.
  31.       SUBROUTINE HEAD
  32.       CHARACTER*80 TEXT
  33.       LOGICAL ERROR
  34.       CALL CLS
  35.       TEXT = '===== Program SEPARATE by Jim Groeneveld, ====='
  36.       CALL WRTXSI ('+',TEXT,ERROR)
  37.       TEXT = '============ NIPG-TNO, 14 July 1987 ==========='
  38.       CALL WRTXSI (' ',TEXT,ERROR)
  39.       TEXT = ' '
  40.       CALL WRTXSI (' ',TEXT,ERROR)
  41.       IF (ERROR) STOP 'ERROR in HEAD'
  42.       RETURN
  43.       END
  44. C    --------------------SUBROUTINE CLS---------------------------------
  45.       SUBROUTINE CLS
  46.       WRITE (*,*) CHAR(27),'[2J'
  47.       RETURN
  48.       END
  49. C    --------------------SUBROUTINE ASKPAR------------------------------
  50. C     SUBROUTINE ASKPAR: ASK for necessary PARameters.  
  51.       SUBROUTINE ASKPAR (INFIL,KFIRST,KLAST,LASTPD,CHECK)
  52.       CHARACTER INFIL(80),ANSWER(80),TEXT*80
  53.       LOGICAL END,ERROR,FNCHCK,CHECK
  54.  1    TEXT = 'Enter name of originating file:'
  55.       CALL WRTXSE (' ',TEXT,ERROR)
  56.       CALL RDCLNK (INFIL,END,ERROR)
  57.       IF (END) GOTO 8
  58.       IF (ERROR) GOTO 9
  59.       ERROR = .NOT. FNCHCK(INFIL,LASTPD)
  60.       IF (ERROR) THEN
  61.          TEXT = '****** Error within extension of file name ******'
  62.          CALL WRTXSI (' ',TEXT,ERROR)
  63.          GOTO 1
  64.       ENDIF
  65.   2   TEXT = 'Enter starting position of record number per case on each'
  66.       CALL WRTXSI (' ',TEXT,ERROR)
  67.       TEXT = 'record (line) or enter a 0 (zero) if there is none:'
  68.       CALL WRTXSE (' ',TEXT,ERROR)
  69.       CALL RDCLNK (ANSWER,END,ERROR)
  70.       IF (END) GOTO 8
  71.       IF (ERROR) GOTO 9
  72.       CALL LVALUE (ANSWER,RSTART,NUMVAL)
  73.       IF (NUMVAL .NE. 0 .OR. RSTART .LT. 0 .OR. RSTART .GT. 80) THEN
  74.          TEXT = '****** Illegal number, must be between 0 and 80 ******'
  75.          CALL WRTXSI (' ',TEXT,ERROR)
  76.          GOTO 2
  77.       ENDIF
  78.       KFIRST = INT(RSTART)
  79.  3    IF (KFIRST .EQ. 0) THEN
  80.          TEXT = 'Enter number of records per case:'
  81.          CALL WRTXSE (' ',TEXT,ERROR)
  82.          CALL RDCLNK (ANSWER,END,ERROR)
  83.          IF (END) GOTO 8
  84.          IF (ERROR) GOTO 9
  85.          CALL LVALUE (ANSWER,RPOS,NUMVAL)
  86.          IF (NUMVAL .NE. 0 .OR. RPOS .LT. 1) THEN
  87.          TEXT = '****** Illegal number, must be positive ******'
  88.             CALL WRTXSI (' ',TEXT,ERROR)
  89.             GOTO 3
  90.          ENDIF
  91.          KLAST = INT(RPOS)
  92.       ELSE
  93.          TEXT = 'Enter number of positions of record number (max. 3):'
  94.          CALL WRTXSE (' ',TEXT,ERROR)
  95.          CALL RDCLNK (ANSWER,END,ERROR)
  96.          IF (END) GOTO 8
  97.          IF (ERROR) GOTO 9
  98.          CALL LVALUE (ANSWER,RPOS,NUMVAL)
  99.          IF (NUMVAL .NE. 0 .OR. RPOS .LT. 1 .OR. RPOS .GT. 3) THEN
  100.          TEXT = '****** Illegal number, must be between 1 and 3 ******'
  101.             CALL WRTXSI (' ',TEXT,ERROR)
  102.             GOTO 3
  103.          ENDIF
  104.          KLAST = INT(RPOS) + KFIRST - 1
  105.          IF (KLAST .GT. 80) THEN
  106.             TEXT = '****** Illegal number, may not cause to exceed'
  107.             CALL WRTXSI (' ',TEXT,ERROR)
  108.             TEXT = '       position 80 ******'
  109.             CALL WRTXSI (' ',TEXT,ERROR)
  110.             GOTO 3
  111.          ENDIF
  112.       ENDIF
  113.  4    TEXT = 'Do you want to check for matching record lengths? Yes/No:'
  114.       CALL WRTXSE (' ',TEXT,ERROR)
  115.       CALL RDCLNK (ANSWER,END,ERROR)
  116.       IF (END) GOTO 8
  117.       IF (ERROR) GOTO 9
  118.       CALL TESTYN (ANSWER,CHECK,ERROR)
  119.       IF (ERROR) GOTO 4
  120.       RETURN
  121.  8    STOP 'EOF in ASKPAR'
  122.  9    STOP 'ERROR in ASKPAR'
  123.       END
  124. C    -------------------SUBROUTINE TESTYN-------------------------------
  125.       SUBROUTINE TESTYN (ANSWER,TEST,ERROR)
  126.       CHARACTER ANSWER(80),TEXT*80
  127.       LOGICAL TEST,ERROR
  128.       ERROR = .FALSE.
  129.       TEST = .FALSE.
  130.       CALL SHLFT0 (ANSWER,LANSW)
  131.       IF (ANSWER(1) .EQ. 'Y' .OR. ANSWER(1) .EQ. 'y') THEN
  132.          TEST = .TRUE.
  133.       ELSEIF (ANSWER(1) .EQ. 'N' .OR. ANSWER(1) .EQ. 'n') THEN
  134. C        nothing
  135.       ELSE
  136.          TEXT = '****** Illegal answer, enter YES or NO ******'
  137.          CALL WRTXSI (' ',TEXT,ERROR)
  138.          ERROR = .TRUE.
  139.       ENDIF
  140.       RETURN
  141.       END
  142. C    -------------------LOGICAL FUNCTION FNCHCK-------------------------
  143. C     LOGICAL FUNCTION FNCHCK CHeCKs FileName of INFILE for a three
  144. C     characters long extension consisting only of digits, which is
  145. C     not allowed, as it is reserved for output files.
  146.       LOGICAL FUNCTION FNCHCK (FNAME,LASTPD)
  147.       CHARACTER FNAME(80),MATCH(80)
  148.       LOGICAL DIGIT(3)
  149. C     Filename extensions are characters behind the last period
  150. C     occurring in the filename. However, an extension may not be
  151. C     given for the filename, while it may be for a specified path.
  152. C     Thus it concerns only an eventual period behind the last
  153. C     backslash. Search backwards for a backslash and a period:
  154.       FNCHCK = .TRUE.
  155.       DIGIT(1) = .FALSE.
  156.       DIGIT(2) = .FALSE.
  157.       DIGIT(3) = .FALSE.
  158.       CALL SHLFT0 (FNAME,LFNAME)
  159.       DO 1 J = 1 , LFNAME
  160.          IF (FNAME(J) .EQ. ' ') THEN
  161.             FNCHCK = .FALSE.
  162.             RETURN
  163.          ENDIF
  164. 1     CONTINUE
  165.       CALL EMPTY (MATCH)
  166.       MATCH(1) = '\'
  167.       LASTBS = INCHAR (80,FNAME,MATCH)
  168.       MATCH(1) = '.'
  169.       LASTPD = INCHAR (80,FNAME,MATCH)
  170.       IF (LASTPD .GT. LASTBS) THEN
  171. C        FNAME contains a period indicating a possible extension.
  172. C        Now look at the extension and search for digits.
  173. C        Firstly, the eventual extension is within the characters
  174. C        behind the period until the end of the name (the length).
  175.          IF (LFNAME .EQ. LASTPD) THEN
  176. C           no characters behind last period, OK
  177.          ELSEIF (LFNAME .GT. LASTPD+3) THEN
  178. C           extension too long: FNCHCK = .FALSE.
  179.             FNCHCK = .FALSE.
  180.          ELSEIF (LFNAME .LT. LASTPD+3) THEN
  181. C           extension is less than 3 characters long, OK
  182.          ELSE
  183. C           extension is exactly 3 characters long
  184.             DO 3 J = LASTPD+1 , LFNAME
  185.                IF (ICHAR(FNAME(J)) .GE. 48 .AND.
  186.      1             ICHAR(FNAME(J)) .LE. 57)
  187.      2             DIGIT(J-LASTPD) = .TRUE.
  188.  3          CONTINUE
  189.             IF (FNAME(LASTPD+1) .EQ. '-') DIGIT(1) = .TRUE.
  190.             IF (DIGIT(1) .AND. DIGIT(2) .AND. DIGIT(3)) FNCHCK = .FALSE.
  191.             IF ((FNAME(LASTPD+1) .EQ. 'M' .OR.
  192.      1           FNAME(LASTPD+1) .EQ. 'm') .AND.
  193.      2          (FNAME(LASTPD+2) .EQ. 'S' .OR.
  194.      3           FNAME(LASTPD+2) .EQ. 's') .AND.
  195.      4          (FNAME(LASTPD+3) .EQ. 'G' .OR.
  196.      5           FNAME(LASTPD+3) .EQ. 'g')) FNCHCK = .FALSE.
  197.          ENDIF
  198.       ELSE
  199. C        indicate that the eventual period is not in the file name
  200. C        but in the path name, which is not of interest
  201.          LASTPD = 0
  202.       ENDIF
  203.       IF ((LASTPD .EQ. 0 .AND. LFNAME .GT. 76) .OR.
  204.      1     LASTPD .GT. 77) FNCHCK = .FALSE.
  205.       RETURN
  206.       END
  207. C    -------------------SUBROUTINE RDCLNK-------------------------------
  208. C     SUBROUTINE RDCLNK: ReaD Character LiNe from Keyboard.
  209.       SUBROUTINE RDCLNK (LINE,END,ERROR)
  210.       CHARACTER LINE(80)
  211.       LOGICAL END,ERROR
  212.       END = .FALSE.
  213.       ERROR = .FALSE.
  214.       READ (*,'(80A1)',END=8,ERR=9) LINE
  215.       RETURN
  216.  8    END = .TRUE.
  217.       RETURN
  218.  9    ERROR = .TRUE.
  219.       RETURN
  220.       END
  221. C    --------------------SUBROUTINE WRTXSI------------------------------
  222. C     SUBROUTINE WRTXSI: WRite TeXt to Screen (Incl. EOL).
  223.       SUBROUTINE WRTXSI (CCC,TEXT,ERROR)
  224.       CHARACTER TEXT*80,CCC,ATEXT(80)
  225.       LOGICAL ERROR
  226.       ERROR = .FALSE.
  227.       CALL CHTOAR (TEXT,ATEXT)
  228.       LTEXT = LENCH(ATEXT)
  229.       WRITE (*,'(A1,80A1)',ERR=9) CCC,(ATEXT(L),L=1,LTEXT)
  230.       RETURN
  231.  9    ERROR = .TRUE.
  232.       RETURN
  233.       END
  234. C    -------------------SUBROUTINE WRTXSE-------------------------------
  235. C     SUBROUTINE WRTXSE: WRite TeXt to Screen (Excl. EOL).
  236.       SUBROUTINE WRTXSE (CCC,TEXT,ERROR)
  237.       CHARACTER TEXT*80,CCC,ATEXT(80),FMT*15
  238.       LOGICAL ERROR
  239.       ERROR = .FALSE.
  240.       CALL CHTOAR (TEXT,ATEXT)
  241.       LTEXT = LENCH(ATEXT)
  242.       WRITE (FMT,7) LTEXT
  243.  7    FORMAT ('(A1,',I2,'A1,'' '',\)')
  244.       WRITE (*,FMT,ERR=9) CCC,(ATEXT(L),L=1,LTEXT)
  245.       RETURN
  246.  9    ERROR = .TRUE.
  247.       RETURN
  248.       END
  249. C    --------------------SUBROUTINE WRCLSI------------------------------
  250. C     SUBROUTINE WRCLSI: WRite Character Line to Screen (Incl. EOL).
  251.       SUBROUTINE WRCLSI (CCC,LINE,ERROR)
  252.       CHARACTER LINE(80),CCC
  253.       LOGICAL ERROR
  254.       ERROR = .FALSE.
  255.       LLINE = LENCH(LINE)
  256.       WRITE (*,'(A1,80A1)',ERR=9) CCC,(LINE(J),J=1,LLINE)
  257.       RETURN
  258.  9    ERROR = .TRUE.
  259.       RETURN
  260.       END
  261. C    -------------------SUBROUTINE WRCLSE-------------------------------
  262. C     SUBROUTINE WRCLSE: WRite Character Line to Screen (Excl. EOL).
  263.       SUBROUTINE WRCLSE (CCC,LINE,ERROR)
  264.       CHARACTER LINE(80),CCC
  265.       LOGICAL ERROR
  266.       ERROR = .FALSE.
  267.       WRITE (*,'(A1,80A1,'' '',\)',ERR=9) CCC,LINE
  268.       RETURN
  269.  9    ERROR = .TRUE.
  270.       RETURN
  271.       END
  272. C    --------------------SUBROUTINE RDCLNF------------------------------
  273. C     SUBROUTINE RDCLNF: ReaD Character LiNe from File with unitnr.
  274.       SUBROUTINE RDCLNF (NRUNIT,LINE,END,ERROR)
  275.       CHARACTER LINE(80)
  276.       LOGICAL END,ERROR
  277.       END = .FALSE.
  278.       ERROR = .FALSE.
  279.       READ (NRUNIT,'(80A1)',END=8,ERR=9) LINE
  280.       RETURN
  281.  8    END = .TRUE.
  282.       RETURN
  283.  9    ERROR = .TRUE.
  284.       RETURN
  285.       END
  286. C    --------------------SUBROUTINE WRCLNF------------------------------
  287. C     SUBROUTINE WRCLNF: WRite Character LiNe to File with unitnr.
  288.       SUBROUTINE WRCLNF (NRUNIT,LINE,LLINE,ERROR)
  289.       CHARACTER LINE(80)
  290.       LOGICAL ERROR
  291.       ERROR = .FALSE.
  292.       LLINE = LENCH(LINE)
  293.       WRITE (NRUNIT,'(80A1)',ERR=9) (LINE(J),J=1,LLINE)
  294.       RETURN
  295.  9    ERROR = .TRUE.
  296.       RETURN
  297.       END
  298. C    -------------------SUBROUTINE OPENRD------------------------------
  299. C     SUBROUTINE OPENRD: OPEN file for ReaD.
  300.       SUBROUTINE OPENRD (NRUNIT,RDFILE,OPENED)
  301.       CHARACTER RDFILE(80),FILERD*80
  302.       LOGICAL OPENED
  303.       IF (.NOT. OPENED) THEN
  304.          CALL ARTOCH (RDFILE,FILERD)
  305.          OPEN (NRUNIT,FILE=FILERD)
  306.          OPENED = .TRUE.
  307.       ENDIF
  308.       RETURN
  309.       END
  310. C    ----------------------SUBROUTINE OPENWR----------------------------
  311. C     SUBROUTINE OPENWR: OPEN file for WRite.
  312.       SUBROUTINE OPENWR (NRUNIT,WRFILE,OPENED)
  313.       CHARACTER WRFILE(80),FILEWR*80
  314.       LOGICAL OPENED
  315.       IF (.NOT. OPENED) THEN
  316.          CALL ARTOCH (WRFILE,FILEWR)
  317.          OPEN (NRUNIT,FILE=FILEWR,STATUS='NEW')
  318.          OPENED = .TRUE.
  319.       ENDIF
  320.       RETURN
  321.       END
  322. C    ------------------SUBROUTINE OUTEXT--------------------------------
  323.       SUBROUTINE OUTEXT (INFIL,LASTPD,NRREC,OUTFIL)
  324.       CHARACTER INFIL(80),OUTFIL(80),EXT(80),TEMP*80
  325.       CALL ARTOCH (INFIL,TEMP)
  326.       CALL CHTOAR (TEMP,OUTFIL)
  327.       IF (LASTPD .EQ. 0) LASTCH = LENCH(INFIL)
  328.       IF (LASTPD .GT. 0) LASTCH = LASTPD - 1
  329.       IF (NRREC .NE. 1000) THEN
  330.          WRITE (TEMP,'(I3)') IABS(NRREC)
  331.       ELSE
  332.          TEMP = '-00'
  333.       ENDIF
  334.       CALL CHTOAR (TEMP,EXT)
  335.       OUTFIL(LASTCH+1) = '.'
  336.       IF (NRREC .LT. 0) OUTFIL(LASTCH+2) = '-'
  337.       DO 3 J = 1 , 3
  338.          IF (EXT(J) .EQ. ' ') EXT(J) = '0'
  339.          OUTFIL(LASTCH+1+J) = EXT(J)
  340.  3    CONTINUE
  341.       RETURN
  342.       END
  343. C    ------------------SUBROUTINE TXTEXT--------------------------------
  344.       SUBROUTINE TXTEXT (INFIL,LASTPD,TXT,TXTFIL)
  345.       CHARACTER INFIL(80),TXTFIL(80),EXT(80),TEMP*80,TXT*3
  346.       CALL ARTOCH (INFIL,TEMP)
  347.       CALL CHTOAR (TEMP,TXTFIL)
  348.       IF (LASTPD .EQ. 0) LASTCH = LENCH(INFIL)
  349.       IF (LASTPD .GT. 0) LASTCH = LASTPD - 1
  350.       TEMP = TXT
  351.       CALL CHTOAR (TEMP,EXT)
  352.       TXTFIL(LASTCH+1) = '.'
  353.       DO 3 J = 1 , 3
  354.          TXTFIL(LASTCH+1+J) = EXT(J)
  355.  3    CONTINUE
  356.       RETURN
  357.       END
  358. C    ------------------SUBROUTINE PASS1---------------------------------
  359. C     SUBROUTINE PASS1 reads originating file for the first time and
  360. C     writes the first separated file based on the first record number
  361. C     encountered.
  362.       SUBROUTINE PASS1 (INFIL,KFIRST,KLAST,LASTPD,NFIRST,
  363.      1   MIN,CHECK,RDOPEN,WROPEN,MSGFIL,MSOPEN)
  364.       CHARACTER INFIL(80),OUTFIL(80),RDFILE*80,WRFILE*80,RECNR(80),
  365.      1   TEXT*80,ATEXT(80),LINE(80),MSGFIL(80)
  366.       LOGICAL RDOPEN,WROPEN,MSOPEN,END,ERROR,CHECK
  367.       TEXT = '---------------------------------------- Pass  1'
  368.       CALL WRTXSI (' ',TEXT,ERROR)
  369.       CALL OPENRD (1,INFIL,RDOPEN)
  370.       NLNSRD = 0
  371.       NLNSWR = 0
  372.  1    CALL RDCLNF (1,LINE,END,ERROR)
  373.       IF (ERROR) STOP 'ERROR in PASS1 after RDCLNF'
  374.       IF (.NOT. END) THEN
  375.          NLNSRD = NLNSRD + 1
  376.          CALL RRECNR (LINE,KFIRST,KLAST,NR)
  377.          IF (NLNSRD .EQ. 1) THEN
  378.             MIN = 1001
  379.             NRWR = NR
  380.             NFIRST = NR
  381.             CALL OUTEXT (INFIL,LASTPD,NRWR,OUTFIL)
  382.             CALL OPENWR (2,OUTFIL,WROPEN)
  383.             TEXT = '   Output file opened:'
  384.             CALL WRTXSE (' ',TEXT,ERROR)
  385.             CALL WRCLSI (' ',OUTFIL,ERROR)
  386.             TEXT = '   Current record number:'
  387.             CALL WRTXSE (' ',TEXT,ERROR)
  388.             CALL CVALUE (NRWR,ATEXT,L)
  389.             CALL WRCLSI (' ',ATEXT,ERROR)
  390.             TEXT = ' '
  391.             CALL WRTXSI (' ',TEXT,ERROR)
  392.          ELSE
  393.             IF (NR .LT. MIN .AND. NR .NE. NFIRST)
  394.      1         MIN = NR
  395.          ENDIF
  396.          IF (MOD(NLNSRD,100) .EQ. 1) THEN
  397.             TEXT = 'Processing from line:'
  398.             CALL WRTXSE ('+',TEXT,ERROR)
  399.             CALL CVALUE (NLNSRD,ATEXT,L)
  400.             CALL WRCLSI (' ',ATEXT,ERROR)
  401.          ENDIF
  402.          IF (NR .EQ. NRWR) THEN
  403.             CALL WRCLNF (2,LINE,LLINE,ERROR)
  404.             NLNSWR = NLNSWR + 1
  405.             IF (CHECK) CALL RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,
  406.      1         1,MSOPEN,INFIL,LASTPD,MSGFIL)
  407.          ENDIF
  408.          GOTO 1
  409.       ELSE
  410.          IF (WROPEN) CLOSE (2)
  411.          CLOSE (1)
  412.          RDOPEN = .FALSE.
  413.          WROPEN = .FALSE.
  414.          TEXT = '     Number of lines read:'
  415.          CALL WRTXSE ('+',TEXT,ERROR)
  416.          CALL CVALUE (NLNSRD,ATEXT,L)
  417.          CALL WRCLSI (' ',ATEXT,ERROR)
  418.          TEXT = '     Number of lines written:'
  419.          CALL WRTXSE (' ',TEXT,ERROR)
  420.          CALL CVALUE (NLNSWR,ATEXT,L)
  421.          CALL WRCLSI (' ',ATEXT,ERROR)
  422.          IF (MIN .EQ. 1001 .OR. NLNSRD .EQ. 0)
  423.      1      CALL FINISH (1,MSGFIL,MSOPEN)
  424.       ENDIF
  425.       RETURN
  426.       END
  427. C    ------------------SUBROUTINE PASSN---------------------------------
  428. C     SUBROUTINE PASSN reads originating file for the next times and
  429. C     writes the next separated file based on the relative minimum 
  430. C     record number encountered.
  431. C     Without a recordnumber to interprete this subroutine reads the
  432. C     originating file repeatedly and writes succeeding separated files
  433. C     based on the the number of the pass.
  434.       SUBROUTINE PASSN (INFIL,KFIRST,KLAST,LASTPD,NFIRST,
  435.      1   MIN,CHECK,RDOPEN,WROPEN,MSGFIL,MSOPEN,NPASS)
  436.       CHARACTER INFIL(80),OUTFIL(80),RDFILE*80,WRFILE*80,RECNR(80),
  437.      1   TEXT*80,ATEXT(80),LINE(80),MSGFIL(80)
  438.       LOGICAL RDOPEN,WROPEN,MSOPEN,END,ERROR,CHECK
  439.       NPASS = NPASS + 1
  440.       TEXT = '---------------------------------------- Pass'
  441.       CALL WRTXSE (' ',TEXT,ERROR)
  442.       CALL CVALUE (NPASS,ATEXT,L)
  443.       CALL WRCLSI (' ',ATEXT,ERROR)
  444.       CALL OPENRD (1,INFIL,RDOPEN)
  445.       NLNSRD = 0
  446.       NLNSWR = 0
  447.       IF (KFIRST .NE. 0) NRWR = MIN
  448.       IF (KFIRST .EQ. 0) NRWR = NPASS
  449.       MIN = 1001
  450.  1    CALL RDCLNF (1,LINE,END,ERROR)
  451.       IF (ERROR) STOP 'ERROR in PASSN after RDCLNF'
  452.       IF (.NOT. END) THEN
  453.          NLNSRD = NLNSRD + 1
  454.          IF (KFIRST .NE. 0) CALL RRECNR (LINE,KFIRST,KLAST,NR)
  455.          IF (NLNSRD .EQ. 1) THEN
  456.             CALL OUTEXT (INFIL,LASTPD,NRWR,OUTFIL)
  457.             CALL OPENWR (2,OUTFIL,WROPEN)
  458.             TEXT = '   Output file opened:'
  459.             CALL WRTXSE (' ',TEXT,ERROR)
  460.             CALL WRCLSI (' ',OUTFIL,ERROR)
  461.             TEXT = '   Current record number:'
  462.             CALL WRTXSE (' ',TEXT,ERROR)
  463.             CALL CVALUE (NRWR,ATEXT,L)
  464.             CALL WRCLSI (' ',ATEXT,ERROR)
  465.             TEXT = ' '
  466.             CALL WRTXSI (' ',TEXT,ERROR)
  467.          ENDIF
  468.          IF (MOD(NLNSRD,100) .EQ. 1) THEN
  469.             TEXT = 'Processing from line:'
  470.             CALL WRTXSE ('+',TEXT,ERROR)
  471.             CALL CVALUE (NLNSRD,ATEXT,L)
  472.             CALL WRCLSI (' ',ATEXT,ERROR)
  473.          ENDIF
  474.          IF (NR .LT. MIN .AND. NR .NE. NFIRST .AND. NR .GT. NRWR .AND.
  475.      1       KFIRST .NE. 0) MIN = NR
  476.          IF ((NR .EQ. NRWR .AND. KFIRST .NE. 0) .OR. (KFIRST .EQ. 0
  477.      1      .AND. MOD(NRWR,KLAST) .EQ. MOD(NLNSRD,KLAST))) THEN
  478.             CALL WRCLNF (2,LINE,LLINE,ERROR)
  479.             NLNSWR = NLNSWR + 1
  480.             IF (CHECK) CALL RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,
  481.      1         NPASS,MSOPEN,INFIL,LASTPD,MSGFIL)
  482.          ENDIF
  483.          GOTO 1
  484.       ELSE
  485.          IF (WROPEN) CLOSE (2)
  486.          CLOSE (1)
  487.          RDOPEN = .FALSE.
  488.          WROPEN = .FALSE.
  489.          TEXT = '     Number of lines read:'
  490.          CALL WRTXSE ('+',TEXT,ERROR)
  491.          CALL CVALUE (NLNSRD,ATEXT,L)
  492.          CALL WRCLSI (' ',ATEXT,ERROR)
  493.          TEXT = '     Number of lines written:'
  494.          CALL WRTXSE (' ',TEXT,ERROR)
  495.          CALL CVALUE (NLNSWR,ATEXT,L)
  496.          CALL WRCLSI (' ',ATEXT,ERROR)
  497.          IF ((KFIRST .NE. 0 .AND. MIN .EQ. 1001) .OR. (KFIRST .EQ. 0
  498.      1      .AND. NRWR .EQ. KLAST) .OR. NLNSRD .EQ. 0)
  499.      2      CALL FINISH (NPASS,MSGFIL,MSOPEN)
  500.       ENDIF
  501.       RETURN
  502.       END
  503. C    --------------------SUBROUTINE FINISH------------------------------
  504.       SUBROUTINE FINISH (NPASS,MSGFIL,MSOPEN)
  505.       CHARACTER TEXT*80,ATEXT(80),MSGFIL(80)
  506.       LOGICAL ERROR,MSOPEN
  507.       TEXT = '---------------------------------------- End of run'
  508.       CALL WRTXSI (' ',TEXT,ERROR)
  509.       TEXT = '     Number of passes ((maximum) records per case):'
  510.       CALL WRTXSE (' ',TEXT,ERROR)
  511.       CALL CVALUE (NPASS,ATEXT,L)
  512.       CALL WRCLSI (' ',ATEXT,ERROR)
  513.       IF (MSOPEN) THEN
  514.          CLOSE (3)
  515.          TEXT = '   The following file contains a report of'
  516.          CALL WRTXSI (' ',TEXT,ERROR)
  517.          TEXT = '   inconsistencies found with matching'
  518.          CALL WRTXSI (' ',TEXT,ERROR)
  519.          TEXT = '   record lengths:'
  520.          CALL WRTXSE (' ',TEXT,ERROR)
  521.          CALL WRCLSI (' ',MSGFIL,ERROR)
  522.       ENDIF
  523.       STOP 'Normal termination of program SEPARATE'
  524.       END
  525. C    --------------------SUBROUTINE RRECNR------------------------------
  526.       SUBROUTINE RRECNR (LINE,KFIRST,KLAST,NR)
  527.       CHARACTER LINE(80),RECNR(80)
  528.       CALL EMPTY (RECNR)
  529.       DO 2 J = KFIRST , KLAST
  530.          RECNR(J-KFIRST+1) = LINE(J)
  531.  2    CONTINUE
  532.       LRECNR = LENCH(RECNR)
  533.       IF (LRECNR .EQ. 0) THEN
  534.          NUMVAL = 2
  535.       ELSE
  536.          CALL LVALUE (RECNR,RVALUE,NUMVAL)
  537.       ENDIF
  538.       IF (NUMVAL .EQ. 1 .OR. NUMVAL .EQ. 2) THEN
  539.          NR = 1000
  540.       ELSE 
  541.          NR = INT(RVALUE)
  542.       ENDIF
  543.       RETURN
  544.       END
  545. C    ------------------SUBROUTINE RLCHCK--------------------------------
  546.       SUBROUTINE RLCHCK (LREC,LLINE,NRWR,NLNSRD,NLNSWR,NPASS,MSOPEN,
  547.      1   INFIL,LASTPD,MSGFIL)
  548.       CHARACTER INFIL(80),MSGFIL(80),TEXT*80,ATEXT(80)
  549.       LOGICAL MSOPEN,ERROR
  550.       IF (NLNSWR .EQ. 1) THEN
  551.          LREC = LLINE
  552.       ELSEIF (LLINE .NE. LREC) THEN
  553.          IF (.NOT. MSOPEN) THEN
  554.             CALL TXTEXT (INFIL,LASTPD,'MSG',MSGFIL)
  555.             CALL OPENWR (3,MSGFIL,MSOPEN)
  556.             TEXT = 'The lengths of the following records do not match:'
  557.             CALL CHTOAR (TEXT,ATEXT)
  558.             CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
  559.             TEXT = ' '
  560.             CALL CHTOAR (TEXT,ATEXT)
  561.             CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
  562.             TEXT = 'Pass Rec LineRd LineWr Len Lln'
  563.             CALL CHTOAR (TEXT,ATEXT)
  564.             CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
  565.             TEXT = '------------------------------'
  566.             CALL CHTOAR (TEXT,ATEXT)
  567.             CALL WRCLNF (3,ATEXT,LATEXT,ERROR)
  568.          ENDIF
  569.          WRITE (3,3) NPASS,NRWR,NLNSRD,NLNSWR,LREC,LLINE
  570.  3       FORMAT (I4,1X,I3,1X,I6,1X,I6,1X,I3,1X,I3)
  571.       ENDIF
  572.       RETURN
  573.       END
  574. C    ------------------SUBROUTINE SHLFT0--------------------------------
  575. C     SUBROUTINE SHLFT0 SHIFTS NON-BLANK CHARACTERS TO THE MOST LEFT
  576. C    *   POSITION OF THE CHARACTER VARIABLE (OMITS PRECEDING BLANKS) AND
  577. C    *   DETERMINES THE REMAINING LENGTH (TILL CLOSING BLANKS) FROM CHVAR
  578.       SUBROUTINE SHLFT0 (CHVAR,LENVAR)
  579.       CHARACTER CHVAR(80)
  580.       LENVAR = LENCH(CHVAR)
  581.       IF (LENVAR .EQ. 0 .OR. LENVAR .EQ. 1) RETURN
  582.       IF (CHVAR(1) .NE. ' ') RETURN
  583.       DO 3 I = 1 , LENVAR
  584.          IF (CHVAR(I) .NE. ' ') GO TO 4
  585.  3    CONTINUE
  586. C     CHVAR ONLY CONSISTS OF BLANKS: NO SHIFT
  587. *     LENVAR = 0
  588.       RETURN
  589.  4    DO 5 J = I , LENVAR
  590.          CHVAR(J-I+1) = CHVAR(J)
  591.  5    CONTINUE
  592.       DO 6 J = LENVAR-I+2 , LENVAR
  593.          CHVAR(J) = ' '
  594.  6    CONTINUE
  595.       LENVAR = LENVAR + 1 - I
  596.       RETURN
  597.       END
  598. C    -----------------------SUBROUTINE SHLFT1---------------------------
  599. C     SUBROUTINE SHLFT1 SHIFTS NON-BLANK CHARACTERS TO THE MOST LEFT
  600. C    *   POSITION OF THE CHARACTER VARIABLE (OMITS PRECEDING BLANKS)
  601. C    *   FROM WHICH THE LENGTH (TILL CLOSING BLANKS) IS KNOWN: "LENVAR".
  602. C    *   RETURNS THE REMAINING LENGTH AFTER SHIFTING LEFT: "LENVAR".
  603.       SUBROUTINE SHLFT1 (CHVAR,LENVAR)
  604.       CHARACTER CHVAR(80)
  605.       DO 3 I = 1 , LENVAR
  606.          IF (CHVAR(I) .NE. ' ') GO TO 4
  607.  3    CONTINUE
  608. C     CHVAR ONLY CONSISTS OF BLANKS: NO SHIFT
  609.       LENVAR = 0
  610.       RETURN
  611.  4    DO 5 J = I , LENVAR
  612.          CHVAR(J-I+1) = CHVAR(J)
  613.  5    CONTINUE
  614.       DO 6 J = LENVAR-I+1 , LENVAR
  615.          CHVAR(J) = ' '
  616.  6    CONTINUE
  617.       LENVAR = LENVAR + 1 - I
  618.       RETURN
  619.       END
  620. C    -----------------------------FUNCTION LENCH------------------------
  621. C     FUNCTION LENCH DETERMINES LENGTH OF CHVAR WITHOUT CLOSING
  622. C    *                  BLANKS
  623.       FUNCTION LENCH (CHVAR)
  624.       CHARACTER CHVAR(80)
  625.       DO 7 LENCH = LENGTH(CHVAR) , 1 , -1
  626.          IF (CHVAR(LENCH) .NE. ' ') GO TO 8
  627.  7    CONTINUE
  628.       LENCH = 0
  629.  8    RETURN
  630.       END
  631. C    -------------------------SUBROUTINE CVALUE-------------------------
  632. C     SUBROUTINE CVALUE CONVERTS INTEGER VARIABLE TO CHARACTER VARIABLE
  633. C    *   SHIFTED LEFT
  634.       SUBROUTINE CVALUE (INTVAR,CHINT,L)
  635.       CHARACTER CHINT(80),CHFILE*80
  636.       WRITE (CHFILE,'(I5)') INTVAR
  637.       READ (CHFILE,'(80A1)') CHINT
  638.       CALL SHLFT0 (CHINT,L)
  639.       RETURN
  640.       END
  641. C    ------------------------------- FUNCTION INCHAR ------------------
  642. C     FUNCTION INCHAR searches backwards IN characterstring TEXT for
  643. C     (last) position of occurrence of CHARacterstring STRING in TEXT
  644. C     up to position LPOS
  645.       FUNCTION INCHAR (LPOS,TEXT,STRING)
  646. C    *   no use of eventually known STRING and TEXT length
  647.       CHARACTER STRING(80),TEXT(80),STRVAR*80,TXTVAR*80
  648.       WRITE (STRVAR,'(80A1)') STRING
  649.       LS = LENCH(STRING)
  650.       LT = LENCH(TEXT)
  651.       IF (LT .GT. LPOS) LT = LPOS
  652.       DO 10 I = LT-LS+1 , 1 , -1
  653.          WRITE (TXTVAR,'(80A1)') (TEXT(J),J=I,I+LS-1)
  654.          IF (TXTVAR .EQ. STRVAR) GO TO 11
  655.  10   CONTINUE
  656. C    *   NO STRING FOUND, INCHAR WILL BE 0
  657.       INCHAR = 0
  658.       RETURN
  659. C    *   STRING FOUND, INCHAR WILL GET POSITION NUMBER OF MATCH
  660.  11   INCHAR = I
  661.       RETURN
  662.       END
  663. C    -----------------SUBROUTINE LVALUE---------------------------------
  664. C     SUBROUTINE LVALUE READS NUMBER (REAL OR INTEGER VALUE) WITHIN CHVAR
  665. C    -NUMVAL=0 : INTEGER VALUE
  666. C    -NUMVAL=1 : REAL OR EXPONENTIAL VALUE
  667. C    -NUMVAL=2 : NON-NUMERICAL CONTENT OF CHVAR
  668.       SUBROUTINE LVALUE (CHVAR,RVALUE,NUMVAL)
  669.       CHARACTER CHVAR(80), FMT*7, CHFILE*80
  670.       CALL SHLFT0 (CHVAR,LENVAR)
  671. *     CALL APTAIL (CHVAR(:LENVAR),LENVAR,*9)
  672.       NUMVAL = 0
  673.       WRITE (FMT,3) LENVAR
  674.  3    FORMAT ('(G',I2,'.0)')
  675.       WRITE (CHFILE,'(80A1)') CHVAR
  676.       READ (CHFILE,FMT,ERR=9) RVALUE
  677.       IF (RVALUE-FLOAT(INT(RVALUE)) .NE. 0.) NUMVAL = 1
  678.       RETURN
  679. C     IF CHVAR = ' ' --> LENVAR = 0 AND FMT = 'G0.0' --> ERROR
  680.  9    NUMVAL = 2
  681.       RETURN
  682.       END
  683. C    ----------------------  SUBROUTINE APTAIL  -------------------------
  684. C     SUBROUTINE APTAIL DETECTS THE PRESENCE OF @ IN CHVAR;
  685. C     CHAR: @ MAY NOT BE READ WITH G-FORMAT DUE TO SYSTEM ERROR.......
  686. *     SUBROUTINE APTAIL (CHVAR,LENVAR,*)
  687. *     CHARACTER CHVAR(80)
  688. *     DO 804 N = 1, LENVAR
  689. *        IF (CHVAR(N) .EQ. '@') RETURN 1
  690. *804  CONTINUE
  691. *     RETURN
  692. *     END
  693. C    ----------------------- FUNCTION LENGTH ---------------------------
  694.       FUNCTION LENGTH (CHVAR)
  695.       CHARACTER CHVAR(80)
  696.       DO 3 LENGTH = 80 , 1 , -1
  697.          IF (CHVAR(LENGTH) .NE. ' ') RETURN
  698.  3    CONTINUE
  699.       LENGTH = 0
  700.       RETURN
  701.       END
  702. C    ------------------- SUBROUTINE ARTOCH -----------------------------
  703. C     SUBROUTINE ARTOCH converts a character ARray TO a CHaracter var.
  704.       SUBROUTINE ARTOCH (CARRAY,CHVAR)
  705.       CHARACTER CARRAY(80),CHVAR*80
  706.       WRITE (CHVAR,'(80A1)') CARRAY
  707.       RETURN
  708.       END
  709. C    ------------------- SUBROUTINE CHTOAR -----------------------------
  710. C     SUBROUTINE CHTOAR converts a CHaracter var. TO a character ARray
  711.       SUBROUTINE CHTOAR (CHVAR,CARRAY)
  712.       CHARACTER CARRAY(80),CHVAR*80
  713.       READ (CHVAR,'(80A1)',ERR=9) CARRAY
  714.       RETURN
  715.  9    STOP 'ERROR in CHTOAR'
  716.       END
  717. C    ------------------- SUBROUTINE EMPTY ------------------------------
  718.       SUBROUTINE EMPTY (CHARR)
  719.       CHARACTER CHARR(80)
  720.       DO 1 I = 1 , 80
  721.          CHARR(I) = ' '
  722.  1    CONTINUE
  723.       RETURN
  724.       END
  725.