C     PROGRAM-ID.      FILESCAN1.
C     AUTHORS.         RUTH DROZIN.
C                      JON ESCHINGER.
C
C     DATE-WRITTEN.    APRIL-JULY, 1978.
C     PURPOSE.         DETERMINE THE NATURE OF DISC FILES
C                      AT A SITE.
C
C     INPUT OPTIONS:
C
C     +SITEXXXXNAME OF SITE
C          WHERE XXXX = SITE ID
C     +COUNT
C          TELLS FILESCAN1 TO LOOK AT EVERY RECORD
C     +OUTPUTFID
C          WHERE FID = FILE IDENTIFIER FOR OUTPUT FILE
C          DEFAULT = DC/SCANDATA.:SYS
C     +ACCOUNTXXXXXXXX
C          WHERE XXXXXXXX = ACCOUNT TO BE SCANNED
C     +RANGEXXX,YYY
C          WHERE XXX = STARTING ACCOUNT TO BE SCANNED
C                YYY = ENDING ACCOUNT TO BE SCANNED
C     +PACKSN.ACCT
C          WHERE SN = NAME OF PRIVATE VOLUME TO SCAN
C                ACCT = ACCOUNT OF PRIVATE VOLUME
C
C
C     OUTPUT RECORD LAYOUT:
C
C     BYTES        FORMAT         DESCRIPTION
C     -----        ------         -----------
C
C     1-4          A4             SITE ID
C     5-8          A4             PRIVATE VOLUME SN
C     9-16         2A4            ACCOUNT
C     17-47        7A4,A3         FILENAME
C     48-49        A2             MAJOR FILE TYPE
C     50-51        A2             MINOR FILE TYPE
C     52-57        I6             # GRANULES
C     58           A1             ORGANIZATION
C     59-64        A4,A2          CREATE DATE
C     65-70        A4,A2          MODIFY DATE
C     71-76        A4,A2          LAST ACCESS DATE
C     77-78        I2             KEYMAX
C     80           A1             HAS JCL? (Y/N)
C     81           A1             VARIABLE KEY SIZE? (Y/N)
C     82           A1             BINARY, EBCDIC, BOTH
C     83           A1             VARIABLE RECORD SIZE? (Y/N)
C     84-88        I5             MAX RECORD SIZE
C     89-95        I7             # RECORDS
C     96-111       8A2            MULTIPLE FILE TYPES
C     112          A1             RECORD COUNT ACCURATE? (Y/N)
C
C
C
C     GLOSSARY OF VARIABLES:
C**************************************************
C     REMENBER TO ALPHA SORT LATER!!
C**************************************************
C
C     KEYBUF(8)    BUFFER TO HOLD RECORD KEY
C     NAMBUF(12)   FILE NAME(8),ACCT(2),PASS(2)
C     INBUF(33)    RECORD CONTENTS
C     IOUTFD(12)   OUTPUT FILE ID
C     INSN         PRIVATE VOLUME TO SCAN
C     IOUTSN       PRIVATE VOLUME/TAPE OUTPUT SERIAL NUMBER
C     ICMNDS(7)    POSSIBLE INPUT COMMANDS
C     NUMS(42,3)   COUNTERS (42 MINOR FILE TYPES)
C                     1ST COL = MAJOR/MINOR FILETYPE KEY
C                     2ND COL = # FILES OF THAT TYPE
C                     3RD COL = # GRANULES FOR THAT TYPE
C     ICOMM(20)    INPUT COMMAND BUFFER
C     IOUTBF(28)   OUTPUT RECORD BUFFER
C     INSTNM(18)   NAME OF SITE
C     ISTART       WILL = 1 IF AT LEAST ONE +ACCOUNT,
C                     +PACK OR +RANGE HAS BEEN ENCOUNTERED
C     INDCNT       WILL = 1 IF +COUNT ENCOUNTERED
C     INDFID       WILL = 1 IF +OUTPUT ENCOUNTERED
C     IOPT         WILL = 1 IF OUTPUT FID = DC
C                       = 2 IF OUTPUT FID = DP
C                       = 3 IF OUTPUT FID = LT
C     IENDAC(2)    ENDING ACCOUNT
C     INDPAC       WILL = 1 IF WORKING ON +PACK
C     INDRAN       WILL = 1 IF WORKING ON +RANGE
C     INDDEF       WILL = 1 IF DEFAULT FILESCAN RUN
C     IUNIT        F:102 = OUTPUT FID
C     IUNIT2       F:103 = KEYED FILE OF FILETYPE NAMES
C
C
C
       INTEGER     COPYRITE(14)
     *  /'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979'/
        GLOBAL COPYRITE
C     DIMENSION STATEMENT
      DIMENSION NNUMS(42,3),NCMNDS(7)
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     INITIALIZE THE VARIABLES
C
      DATA NNUMS/126*0/
      DATA NCMNDS/'+SIT+COU+OUT+ACC+RAN+PAC+END'/
      DATA IBLANK/'    '/
      DATA (NNUMS(K,1),K=1,42)/'0101010201030104010501060107',
     1  '010801090110011101120113011401150116021703180419',
     2  '042004210422042304240425052606270628072908300931',
     3  '09320933093410351036103710381039104011411242'/
      DO 1 K = 1,27
      IOUTBF(K)=IBLANK
 1    CONTINUE
      IOUTBF(28)=4H   N
      DO 2 K = 1,8
      KEYBUF(K)=IBLANK
 2    CONTINUE
      DO 3 K = 1,12
      NAMBUF(K)=IBLANK
 3    CONTINUE
      DO 4 K = 1,33
      INBUF(K) = IBLANK
 4    CONTINUE
      DO 5 K = 1,12
      IOUTFD(K) = IBLANK
 5    CONTINUE
      ISTART = INDCNT = INDST = INDFID = 0
      IOPT = 1
      IOUTFD(1) = 4HSCAN
      IOUTFD(2) = 4HDATA
      IOUTFD(9) = 4H:SYS
      DO 6 K = 1,7
      ICMNDS(K) = NCMNDS(K)
 6    CONTINUE
      DO 8 K = 1,42
      DO 7 L = 1,3
      NUMS(K,L) = NNUMS(K,L)
 7    CONTINUE
 8    CONTINUE
      DO 9 K = 1,18
      INSTNM(K)=4H
 9    CONTINUE
      IUNIT=102
      IUNIT2=103
C
C     MAIN PROGRAM
C     PURPOSE: GET INPUT COMMANDS
C
C
      CALL GETCOM
      END
C
C     SUBROUTINE GETCOM
C
C     PURPOSE: GET AND VALIDATE INPUT OPTIONS
C
      SUBROUTINE GETCOM
C
C     GLOBAL THE VARIABLES
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
10    CONTINUE
C
C     CALL ROUTINE TO READ COMMAND
C
      CALL RDCOM(ICOMM,IERROR)
C
C     IERROR = 5 = END OF COMMAND STREAM
C
      IF(IERROR.EQ.5)CALL CHKDEF
C
C     IERROR = ANYTHING ELSE, PRINT IT AND EXIT
C
      IF(IERROR.NE.0)WRITE(108,1001) IERROR;STOP 'ERROR IN GETCOM'
C
C     IDENTIFY COMMAND
C
      DO 20 I = 1,7
      IF(ICOMM(1).EQ.ICMNDS(I))K=I;GO TO 30
 20   CONTINUE
C
C     INVALID COMMAND
C
      WRITE(108,1000)ICOMM
     1 I)
      GO TO 10
 30   CONTINUE
C
C     CALL APPROPRIATE SUBROUTINE DEPENDING ON COMMAND
C
      IF(K.EQ.1)CALL SITE;GO TO 10
      IF(K.EQ.2)CALL COUNT;GO TO 10
      IF(K.EQ.3)CALL OUTPUT;GO TO 10
      IF(K.EQ.4)CALL AKOUNT;GO TO 10
      IF(K.EQ.5)CALL RANGE;GO TO 10
      IF ( K.EQ.6 ) CALL PACK; GO TO 10
      IF(K.EQ.7)CALL CHKDEF;GO TO 10
 1000 FORMAT(' INVALID COMMAND: ',20A4)
      END
C
C     SUBROUTINE SITE
C
C     PURPOSE: FILL IN SITE ID AND NAME
C
      SUBROUTINE SITE
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     CHECK FOR FIRST +SITE
C
      IF (INDST.EQ.1)WRITE(108,1000)ICOMM;RETURN
      INDST=1
C
C     CHECK IF RUN HAS STARTED
C
      IF(ISTART.EQ.1)WRITE(108,1000)ICOMM;RETURN
C
C     GET THE SITE ID
C
      ICHK=4H
      DO 10 K = 6,80
      CALL CBS(ICOMM,K,ICHK,1,1,IRES)
      IF(IRES.NE.0)I=K;GO TO 20
 10   CONTINUE
C
C     NEVER FOUND A NON-BLANK CHARACTER
C
      RETURN
 20   CONTINUE
C
C     MOVE SITE ID INTO IOUTBF
C
      CALL MBS(ICOMM,I,IOUTBF,1,4)
C
C
      L=80-(I+3)
C
C     MOVE NAME
C
      CALL MBS(ICOMM,I+4,INSTNM,1,L)
      RETURN
 1000 FORMAT('  INVALID +SITE IGNORED: ',20A4)
      END
C
C     SUBROUTINE COUNT
C
C     PURPOSE: SET BYTE 112 + 'Y" AND INDCNT = 1
C
      SUBROUTINE COUNT
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     CHECK TO SEE IF THIS IS THE FIRST +COUNT
C
      IF(INDCNT.EQ.1)WRITE(108,1000)ICOMM;RETURN
C
C     HAS RUN STARTED?
C
      IF(ISTART.EQ.1)WRITE(108,1000)ICOMM;RETURN
      INDCNT=1
      IY=4HY
      CALL MBS(IY,1,IOUTBF,112,1)
      RETURN
 1000 FORMAT(' INVALID +COUNT IGNORED: ',20A4)
      END
C
C     SUBROUTINE OUTPUT
C
C     PURPOSE: SET NAME OF OUTPUT FILE FOR FILE OPENER
C
      SUBROUTINE OUTPUT
      DATA IBLANK/'    '/
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     FIRST TIME +OUTPUT ENCOUNTERED?
C
      IF(INDFID.EQ.1)WRITE(108,1000)ICOMM;RETURN
C
C     PROCESSING ALREADY STARTED?
C
      INDFID=1
      IF(ISTART.EQ.1)WRITE(108,1000)ICOMM;RETURN
      IOPT=1
      IDC=4HDC/
      IDP=4HDP#
      ILT=4HLT#
C     BLANK OUT THE DEFAULT OUTPUT FILE NAME
C
C
      IOUTFD(1)=IOUTFD(2)=IOUTFD(9)=4H
C
C     CHECK OUTPUT TYPE ADN SET OPTION
C
C     I=START OF FID; J=START OF SN
C
      DO 10 K = 8,80
      CALL CBS(ICOMM,K,IDC,1,3,IRES)
      IF(IRES.EQ.0)I=K+3;GO TO 30
      CALL CBS(ICOMM,K,IDP,1,3,IRES)
      IF(IRES.EQ.0)J=K+3;GO TO 20
      CALL CBS(ICOMM,K,ILT,1,3,IRES)
      IF(IRES.EQ.0)J=K+3;GO TO 20
 10   CONTINUE
C
C     ASSUME AN IMPLIED DC/
C
      I=8
      GO TO 30
C
C     GET THE SERIAL NUMBER OF DP OR LT
C
 20   CONTINUE
      ISLASH=4H/
      DO 25 K=J,80
      CALL CBS(ICOMM,K,ISLASH,1,1,IRES)
      IF(IRES.EQ.0)I=K+1;GO TO 27
 25   CONTINUE
C
C     FELL THRU LOOP - NO / MAKES INVALID +OUTPUT
C
 26   CONTINUE
      WRITE(108,1000)ICOMM
      GO TO 100
C
C     CHECK LENGTH OF SERIAL NUMBER
C
 27   CONTINUE
      L=I-J-1
      IF(L.GT.4)WRITE(108,1000)ICOMM;GO TO 100
C
C     MOVE IN THE SN
C
      CALL MBS(ICOMM,J,IOUTSN,1,L)
 30   CONTINUE
C
C     GET THE NAME.ACCOUNT.PASSWORD
C
C     END OF NAME IF A DOT
C     END OF WHOLE THING IF A BLANK
C
      IDOT=4H.
      IBLANK=4H
C
C     GET START OF NAME
C
      DO 31 JJ=I,80
      CALL CBS(IBLANK,1,ICOMM,JJ,1,IRES)
      IF(IRES.NE.0)I=JJ;GO TO 33
 31   CONTINUE
C
C     NO NONE-BLANKS;INVALID +OUTPUT
C
      WRITE(108,1000)ICOMM
      GO TO 100
 33   CONTINUE
      DO 35 N = I,80
      CALL CBS(IBLANK,1,ICOMM,N,1,IRES)
C
C     NO NAME CHECK
C
      IF(IRES.EQ.0)L=N-I;IEND=1;GO TO 40
      CALL CBS(IDOT,1,ICOMM,N,1,IRES)
C     NO NAME CHECK
C
      IF(IRES.EQ.0.AND.N.EQ.I)WRITE(108,1000)ICOMM;GO TO 100
      IF(IRES.EQ.0)L=N-I;IEND=0;IA=N+1;GO TO 40
 35   CONTINUE
      IEND=1
      L=81-I
 40   CONTINUE
      IF(L.GT.31)WRITE(108,1000)ICOMM;GO TO 100
C
C     MOVE IN NAME
C
      CALL MBS(ICOMM,I,IOUTFD,1,L)
      IF(IEND.EQ.1)RETURN
C
C     GET ACCOUNT
C
      DO 45 K=IA+1,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.EQ.0.AND.K.EQ.IA)RETURN
      IF(IRES.EQ.0)L=K-IA;IEND=1;GO TO 50
      CALL CBS(IDOT,1,ICOMM,K,1,IRES)
C
C     CHECK ..
C
      IF(IRES.EQ.0.AND.K.EQ.IA)J=K+1;GO TO 60
      IF(IRES.EQ.0)L=K-IA;IEND=0;J=K+1;GO TO 50
 45   CONTINUE
      IEND=1
      L=81-IA
 50   CONTINUE
      IF(L.GT.8)WRITE(108,1000)ICOMM;GO TO 100
C
C     MOVE IN PASSWORD
      CALL MBS(ICOMM,IA,IOUTFD,33,L)
      IF(IEND.EQ.1)RETURN
C
C     GET THE PASSWORD
C
 60   CONTINUE
      DO 65 I=J,80
      CALL CBS(IBLANK,1,ICOMM,I,1,IRES)
      IF(IRES.EQ.0.AND.I.EQ.J)RETURN
      IF(IRES.EQ.0)L=I-J;GO TO 70
 65   CONTINUE
      L=81-J
 70   CONTINUE
      IF(L.GT.8)WRITE(108,1000)ICOMM;GO TO 100
      RETURN
 100  CONTINUE
C
C     REESTABLISH DEFAULT FID
C
      INDFID=0
      DO 101 K = 1,12
      IOUTFD(K)=4H
 101  CONTINUE
      IOUTFD(1)=4HSCAN
      IOUTFD(2)=4HDATA
      IOUTFD(9)=4H:SYS
      IOUTSN=4H
      RETURN
 1000 FORMAT('  INVALID +OUTPUT IGNORED: ',20A4)
      END
C
C     SUBROUTINE START
C
C     PURPOSE: SET 'THE RUN HAS STARTED INDICATOR' AND
C              OPEN THE OUTPUT FID
C
      SUBROUTINE START
C
C     GLOBAL THE VARUABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
      IF(ISTART.EQ.1)RETURN
      ISTART=1
C     THE FOLLOWING CALL HAS THESE         ARGUMENTS:
C     IUNIT,IOPT,IOUTFD,IOUTSN,IERROR,KEY
C
      IOPT=4
      IF(IOUTSN.NE.4H    )GO TO 10
      CALL KOPEN(IUNIT,IOPT,IOUTFD,IERROR,KEY)
      GO TO 20
 10   CONTINUE
      CALL KOPEN(IUNIT,IOPT,IOUTFD,IOUTSN,IERROR,KEY)
 20   CONTINUE
      IF(IERROR.NE.0)WRITE(108,1000)IERROR;STOP'OPEN OUTPUT FID'
      WRITE(108,1001)
      RETURN
 1001 FORMAT(1H1,35X,'FILESCAN1  VERS A02  12/27/78')
 1000 FORMAT(' ERROR OPENING OUTPUT FILE IS ',Z8)
      END
C
C     SUBROUTINE AKOUNT
C
C     PURPOSE: SEND AN ACCOUNT TO BE SCANNED TO OPEN NEXT
C
      SUBROUTINE AKOUNT
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C     CHECK TO SEE IF OUTPUT FID HAS BEEN OPENED
C
      CALL START
      DO 20 K=1,12
      NAMBUF(K)=4H
 20   CONTINUE
      INSN=4H
C
C     GET THE ACCOUNT
C
      IBLANK=4H
      DO 30 K=9,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.NE.0)I=K;GO TO 40
 30   CONTINUE
C
C     NO NON-BLANKS;NO ACCOUNT
C
      WRITE(108,1000)ICOMM
      RETURN
C
C     I IS THE START OF THE ACCOUNT
C
 40   CONTINUE
      DO 50 K = I,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.EQ.0)L=K-I;GO TO 70
 50   CONTINUE
      L=81-I
 70   CONTINUE
      IF(L.GT.8)WRITE(108,1000)ICOMM;RETURN
C     MOVE IN THE ACCOUNT
C
      CALL MBS(ICOMM,I,NAMBUF,33,L)
      IENDAC(1)=4H
      IENDAC(2)=4H
      INDPAC=INDRAN=INDDEF=0
      INDACT=1
      CALL GTFILE
      RETURN
 1000 FORMAT('  INVALID +ACCOUNT IGNORED: ',20A4)
      END
C
C     SUBROUTINE RANGE
C
C     PURPOSE: ESTABLISH THE RANGE OF ACCOUNTS
C
      SUBROUTINE RANGE
C
C     GLOBAL THE VARIABLES
C
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     HAS OUTPUT FID BEEN OPENED?
C
      CALL START
C
C     GET START ACCOUNT OF THE RANGE
C
C
C     A COMMA IS THE DELIMITER BETWEEN ACCOUNTS
C
      ICOMMA=4H,
      IBLANK=4H
      DO 10 K=7,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.NE.0)M=K;GO TO 20
 10   CONTINUE
C
C     FELL THRU LOOP - NO NON-BLANK CHARACTERS
C
      WRITE(108,1000)
      RETURN
 20   CONTINUE
      DO 30 I=M,80
      CALL CBS(ICOMMA,1,ICOMM,I,1,IRES)
      IF(IRES.EQ.0)L=I-M;N=I+1;GO TO 40
 30   CONTINUE
C
C     FELL THRU LOOP - NO COMMA
C
      WRITE(108,1000)ICOMM
      RETURN
 40   CONTINUE
C
C     CHECK LENGTH
C
      IF(L.GT.8)WRITE(108,1000)ICOMM;RETURN
C
C     BLANK OUT INPUT FID BUFFER
C
      DO 50 K=1,12
      NAMBUF(K)=4H
 50   CONTINUE
      INSN=4H
      CALL MBS(ICOMM,M,NAMBUF,33,L)
C
C     GET ENDING ACCOUNT OF RANGE
C
      DO 60 J=N,80
      CALL CBS(IBLANK,1,ICOMM,J,1,IRES)
      IF(IRES.EQ.0)L=J-N;GO TO 70
 60   CONTINUE
C
C     FELL THRU LOOP - GET MAX LENGTH
C
      L=81-N
 70   CONTINUE
      IF(L.GT.8)WRITE(108,1000)ICOMM;RETURN
C
C     BLANK OUT ENDING ACCT BUFFER
C
      IENDAC(1)=IENDAC(2)=4H
C
C     MOVE IN ENDING ACCOUNT
C
      CALL MBS(ICOMM,N,IENDAC,1,L)
      INDDEF=INDACT=INDPAC=0
      INDRAN=1
      CALL GTFILE
      RETURN
 1000 FORMAT('  INVALID +RANGE IGNORED: ',20A4)
      END
C
C     SUBROUTINE PACK
C
C     PURPOSE: SET UP NAME AND ACCOUNT FOR PRIVATE VOLUME SCAN
C
      SUBROUTINE PACK
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     HAS RUN STARTED?
C
      CALL START
C
C     GET SN; DOT IS DELIMITER FOR DIFFERENT ACCOUNT AND
C     BLANK IS FOR RUNNING ACCOUNT
C
      IBLANK=4H
      IDOT=4H.
      DO 10 K=6,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.NE.0)GO TO 20
 10   CONTINUE
C
C     FELL THRU LOOP - NO SN
C
      WRITE(108,1000)ICOMM
      RETURN
 20   CONTINUE
      DO 30 I=K,80
      CALL CBS(IBLANK,1,ICOMM,I,1,IRES)
      IF(IRES.EQ.0)IND=0;L=I-K;GO TO 50
      CALL CBS(IDOT,1,ICOMM,I,1,IRES)
      IF(IRES.EQ.0)IND=1;L=I-K;J=I+1;GO TO 50
 30   CONTINUE
      L=81-K
      IND=0
C
C     CHECK LENGTH
C
 50   CONTINUE
      IF(L.GT.4)WRITE(108,1000)ICOMM;RETURN
      INSN=4H
      CALL MBS(ICOMM,K,INSN,1,L)
      IF(IND.EQ.0)GO TO 100
 60   CONTINUE
C     CHECK FOR ACCOUNT
C
      DO 70 K=J,80
      CALL CBS(IBLANK,1,ICOMM,K,1,IRES)
      IF(IRES.EQ.0)L=K-J;GO TO 80
 70   CONTINUE
      L=81-K
 80   CONTINUE
C
C     CHECK MAX LENGTH
C
      IF(L.GT.8)WRITE(108,1000)ICOMM;RETURN
 100  CONTINUE
      DO 110 K=1,12
      NAMBUF(K)=4H
 110  CONTINUE
      INDPAC=1
      INDRAN=INDACT=INDDEF=0
      IENDAC(1)=IENDAC(2)=4H
      IF(IND.EQ.0)GO TO 120
      CALL MBS(ICOMM,J,NAMBUF,33,L)
 120  CONTINUE
      CALL GTFILE
      RETURN
 1000 FORMAT('  INVALID +PACK IGNORED: ',20A4)
      END
C
C     SUBROUTINE CHKDEF
C
C     PURPOSE: CHECK IF THIS IS A DEFAULT RUN
C
      SUBROUTINE CHKDEF
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C
C     CHECK TO SEE IF THE RUN HAS STARTED
C
      IF(ISTART.EQ.1)CALL ENDIT
C
C     THIS IS A DEFAULT RUN
C
      INDDEF=1
      INDRAN=INDACT=INDPAC=0
      DO 12 K=1,12
      NAMBUF(K)=4H
 12   CONTINUE
      INSN=4H
      CALL START
      CALL GTFILE
      CALL ENDIT
      END
C
C     SUBROUTINE ENDIT
C
C     PURPOSE: PRINT SUMMARY OF RUN
C              CLOSE/SAVE SCANDATA (OR +OUTPUT FID)
C
      SUBROUTINE ENDIT
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
      DIMENSION IBREAK(12),NAME(6)
C
      DATA IBREAK/16,17,18,25,26,28,29,30,34,40,41,42/
      DATA ITOTF/0/
      DATA ISTOTF/0/
      DATA ITOTG/0/
      DATA ISTOTG/0/
C
      WRITE(108,1000)INSTNM
C
C
C     CLOSE AND SAVE OUTPUT FID
C
C     THE FOLLOWING HAS THESE IMPLIED ARGUMENTS
C     IUNIT,IOUTFD,IOUTSN,IOPT,IERROR
C
      CALL KCLOSES(IUNIT,IERROR)
      IF(IERROR.NE.0)WRITE(108,1003)IERROR;CALL FREEPG;
     1STOP' CLOSE OUTPUT FILE'
C     OPEN KEYED FILETYPE NAMES FILE
C
C     THE FOLLOWING CALL HAS THESE IMPLIED ARGUMENTS:
C     IUNIT2,IERROR
C
      CALL KOPENIO(IUNIT2,IERROR)
      IF(IERROR.NE.0)WRITE(108,1007)IERROR;CALL FREEPG;
     1STOP' OPEN I/O ERROR'
C
C     PRINT THE SUMMARY
C
      DO 200 K=1,42
C
C     DON'T PRINT IT IF NO FILES OF THIS TYPE
C
      IF(NUMS(K,2).EQ.0)GO TO 150
C
C
C     PRINT LINE OF SUMMARY
C
      KEY=4H
      CALL MBS(NUMS(K,1),3,KEY,3,2)
      IF(IERROR.NE.0)WRITE(108,1004)IERROR;CALL FREEPG;
     1STOP' KEYED READ ERROR'
      WRITE(108,1001)(NAME(L),L=1,5),NUMS(K,2),NUMS(K,3)
C
C     ADD INTO SUBTOTAL COUNTER
C
      ISTOTF=ISTOTF+NUMS(K,2)
      ISTOTG=ISTOTG+NUMS(K,3)
C
 150  CONTINUE
C
C     CHECK IF SUBTOTALS LINE IS NECESSARY
C
      DO 100 I = 1,12
      IF(K.EQ.IBREAK(I))GO TO 110
 100  CONTINUE
C
C     NO SUBTOTALS NECESSARY
C
      GO TO 200
C
C     NEED TO PRINT SUBTOTALS
C
 110  CONTINUE
      KEY=4H
      CALL MBS(NUMS(K,1),1,KEY,1,2)
C
C     GET MAJOR FILETYPE NAME
C
      CALL KREAD(IUNIT2,KEY,4,NAME,24,IERROR)
      IF(IERROR.NE.0)WRITE(108,1004)IERROR;CALL FREEPG;
     1STOP' KEYED READ ERROR'
      IF(ISTOTF.EQ.0)GO TO 120
      WRITE(108,1002)(NAME(L),L=1,5),ISTOTF,ISTOTG
      ITOTF=ITOTF+ISTOTF
      ITOTG=ITOTG+ISTOTG
      ISTOTF=ISTOTG=0
 120  CONTINUE
 200  CONTINUE
C     WRITE GRAND TOTALS
C
      WRITE(108,1005)ITOTF,ITOTG
      WRITE(108,1006)
C
C     CLOSE AND SAVE FILETYPE NAME FILE
C     THIS HAS THE IMPLIED ARGUMENTS IUNIT2,IERROR
      CALL KCLOSES(IUNIT2,IERROR)
      IF(IERROR .NE.0)WRITE(108,1008)IERROR;CALL FREEPG;
     1STOP' CLOSE I/O FILE'
C
C     THIS IS THE END OF THE RUN
C
C
C     FREE THE PAGES
C
      CALL FREEPG
      STOP'END OF RUN'
 1000 FORMAT(1H1,25X,'FILESCAN  VERS A02   12/27/78',//,
     1    25X,'SUMMARY OF RUN AT SITE: ',18A4,//,
     2    15X,'FILETYPE',16X,'# FILES',4X,'# GRANULES',//)
 1001 FORMAT(15X,5A4,4X,I7,7X,I7)
 1002 FORMAT(6X,'** TOTAL ',5A4,4X,I7,6X,I8,//)
 1003 FORMAT(///,5X,'ERROR CLOSING OUTPUT FID ',Z8,///)
 1004 FORMAT(///,5X,'ERROR READING KEYED FILE',Z8,///)
 1005 FORMAT(////,'     GRAND TOTALS OF RUN',14X,I7,6X,I8)
 1006 FORMAT(1H1)
 1007 FORMAT(///,5X,'ERROR OPENING KEYED IO FILE ',Z8,///)
 1008 FORMAT(///,5X,'ERROR CLOSING KEYED IO FILE ',Z8,///)
      END
C
C     SUBROUTINE RDCOM(COMMAND-BUFFER,READ-ERROR)
C
C     PURPOSE - READ INPUT OPTIONS FROM THE CARD READER
C     (F:105) AND RETURN THE BUFFER. ALSO WILL PROCESS
C     END-OF-FILE AND ANY OTHER ERROR.
C
      SUBROUTINE RDCOM(ICMD,IER)
      DIMENSION ICMD(20)
      IUNIT=105
      READ(IUNIT,100,END=10,ERR=20)ICMD
       IER=0
      RETURN
 10   CONTINUE
      IER=5
      RETURN
 20   CONTINUE
      IER=1
      RETURN
 100  FORMAT(20A4)
      END
C
C     SUBROUTINE GTFILE
C
C     PURPOSE: CALL THE ROUTINES TO OPEN THE NEXT FILE, READ
C     THE FILE AND DETERMINE THE FILE TYPE
C
C
      SUBROUTINE GTFILE
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
      DIMENSION NCOMP(2),MNAME(2)
      DATA NPACK/'DP#'/
      DATA NCOPY /'C   '/
      DATA NOVER/'OVER'/
      DATA IDOT/'.'/
      DATA IBLANK/'    '/
      DATA NCOMP/'(C,1-50)'/
      DATA NSLASH/'/'/
      DATA MNAME(1)/'X-$'/
      IHOLD(1)=NAMBUF(9)
      IHOLD(2)=NAMBUF(10)
      IBL=4H
      INO=4HN
      IYES=4HY
C
C     FREE THE PAGES
C
      CALL FREEPG
C
C      SEND STARTING ACCOUNT AND PRIVATE VOLUME SERIAL
C     NUMBER TO SET UP THE DCB - IMPLIED ARGUMENTS ARE
C     IHOLD AND INSN
C
      CALL STARTUP
      KBYTE1=0
      INDOCM=0
 10   CONTINUE
C
C     BLANK OUT OUTPUT BUFFER EXCEPT FOR SITE-ID, PRIV VOL SN,
C     AND ACCURATE RECORD COUNT AND SET COMPRESSED BYTE TO 'N'
C
      DO 20 K=3,27
      IOUTBF(K)=4H
 20   CONTINUE
      CALL MBS(IBL,1,IOUTBF,109,3)
      CALL MBS(INO,1,IOUTBF,79,1)
C
C     BLANK OUT IERROR
C
      IERROR=0
C
C     OPEN THE NEXT FILE - IMPLIED ARGUMENTS ARE IOUTBF,
C     ISYNON,IERROR,IGRAN
C
      ISYNON=IGRAN=0
      CALL NEXT
C
C     CHECK TO SEE IF THE NEXT FILE IS BUSY (LOOK FOR IERROR=14)
C
      IF(IERROR.EQ.2Z14)WRITE(108,1001)(IOUTBF(MJ),MJ=5,12),
     1   (IOUTBF(MK),MK=3,4),IOUTBF(2);GO TO 10
C
C     CHECK FOR END OF ACCOUNT DIRECTORY
C
      IF(IERROR .EQ.2)RETURN
C
C     CHECK FOR CHANGE OF ACCOUNT - IF IT'S A DEFAULT RUN,
C     DON'T BOTHER
C
      IF(INDDEF.EQ.1)GO TO 50
      IF(IHOLD(1).EQ.IOUTBF(3).AND.IHOLD(2).EQ.IOUTBF(4))GO TO 50
C
C     ACCOUNT HAS CHANGED - WAS IT A +ACCOUNT OPTION?
C
      IF(INDACT.EQ.1)CALL CLOS;RETURN
C
C     MUST HAVE BEEN A +RANGE - ARE WE PAST ENDING ACCOUNT?
C
      CALL CBS(IOUTBF,9,IENDAC,1,8,IRES)
C
C     CURRENT ACCOUNT IS LESS/EQUAL ENDING ACCOUNT
C
      IHOLD(1)=IOUTBF(3)
      IHOLD(2)=IOUTBF(4)
 50   CONTINUE
C
C     CHECK FOR SYNONOMOUS FILE
C
      IF(ISYNON.NE.1)GO TO 60
C
C     FILETYPE IS SYNONOMOUS
C
      IFTYPE=4H0830
      CALL MBS(IFTYPE,1,IOUTBF,48,4)
C
C     ADD TO COUNTER
C
      NUMS(30,2)=NUMS(30,2)+1
      NUMS(30,3)=NUMS(30,3)+IGRAN
C
C     WRITE THE RECORD
C
      CALL WRTIT
C
C     GO GET ANOTHER FILE
C
      GO TO 10
 60   CONTINUE
C
C     NEED TO READ AT LEASE ONE RECORD - IMPLIED ARGUMENTS ARE
C     IBYTE, IERROR
C
      CALL RDFRST
C
C     IF IERROR = 6 ON FIRST READ IT'S A NULL FILE - FORGET IT
C
      IF(IERROR.EQ.6)CALL CLOS;GO TO 10
C
C     ANY OTHER ERROR, PRINT A FEW THINGS AND GET ANOTHER
C
      IF(IERROR.NE.0)WRITE(108,1000)IERROR,(IOUTBF(K),K=3,12);
     1   CALL CLOS;GO TO 10
C
C
C     ALL TEST CALLS HAVE IMPLIED ARGUMENT OF IANS
C
C
C     DBTEST CALLED IF IBYTE  = 2048   RESULTS ARE:
C     1 = DATABASE
C     2 = SCHEMA, SUBSCHEMA, JOURNAL
C     3 = APL WORKSPACE
C     4 = SAVEME/GETME
C     0 = NOME OF ABOVE
C
      IANS=0
      IF(IBYTE.NE.2048)GO  TO 80
      CALL DBTEST
      IF(IANS.LT.0.OR.IANS.GT.4)OUTPUT ' IANS WRONG AT DBTEST ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 80
      IF(IANS.EQ.1)IFTYPE=4H0627;KLMN=27
      IF(IANS.EQ.2)IFTYPE=4H0628;KLMN=28
      IF(IANS.EQ.4)IFTYPE=4H0526;KLMN=26
      CALL MOVEIN
      GO TO 10
 80   CONTINUE
C
C     SPSS WORKSPACE TEST IF IBYTE  = 800
C
C     RESULTS
C     1 = SPSS WS
C     0 = NOT
C
      IF(IBYTE.NE.800)GO  TO 100
      CALL SPSS
      IF(IANS.LT.0.OR.IANS.GT.1)OUTPUT ' IANS WRONG AT SPSS   ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 100
      IFTYPE=4H0423
      KLMN=23
      CALL MOVEIN
      GO TO 10
 100  CONTINUE
C
C     SOME LIBRARIES TEST IF IBYTE  = 12 AND ORG = KEYED
C     ALSO IF THE NAME IS :LIB
C     RESULTS:
C     1 = :DIC/:LIB
C     2 = LEMUR
C     0 = NEITHER
C
      IF(IOUTBF(5).EQ.4H:LIB)GO TO 105
      IF(IBYTE.NE.12)GO  TO 110
      KK=4HK
      CALL CBS(KK,1,IOUTBF,58,1,IRES)
      IF(IRES.NE.0)GO TO 110
 105  CONTINUE
      CALL LIBTST
      IF(IANS.LT.0.OR.IANS.GT.2)OUTPUT ' IANS WRONG AT LIBTST ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 110
      IF(IANS.EQ.1)IFTYPE=4H0931;KLMN=31
      IF(IANS.EQ.2)IFTYPE=4H0933;KLMN=33
      CALL MOVEIN
      GO TO 10
 110  CONTINUE
C
C     TEST FOR FORTRAN BINARIES - FIRST BYTE MUST BE X'1C' OR X'3C'
C     RESULT
C     1 = FORTRAN BINARY
C     0 = NOT
C
      IF(KBYTE1.NE.2Z1C.AND.KBYTE1.NE.2Z3C)GO TO 130
      CALL FRTBIN
      IF(IANS.LT.0.OR.IANS.GT.1)OUTPUT ' IANS WRONG AT FRTBIN ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
      IF(IANS.EQ.0)GO TO 130
      IFTYPE=4H0729
      KLMN=29
      CALL MOVEIN
      GO TO 10
 130  CONTINUE
C
C     CONSECUTIVE FILES WITH BYTES = 108,120 OR 80
C
C     RESULTS:
C     1 = ROM
C     2 = :BLIB
C     3 = SYSTEM
C     4 = COMPRESSED
C     5 = LOCCT
C     6 = BMD W/S
C     7 = OSIRIS W/S
C     0 = NONE OF THE ABOVE
C
      KK=4HC
      CALL CBS(KK,1,IOUTBF,58,1,IRES)
      IF(IRES.NE.0)GO TO 120
      IF(KBYTE1.EQ.2Z1C)GO TO 114
      IF(IBYTE.NE.108.AND.IBYTE.NE.120.AND.IBYTE.NE.80)GO    TO 120
 114  CONTINUE
      CALL ROMETC
      IF(IANS.LT.0.OR.IANS.GT.7)OUTPUT ' IANS WRONG AT ROMETC ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 120
      IF(IANS.EQ.1)IFTYPE=4H0217;KLMN=17;GO TO 115
      IF(IANS.EQ.2)IFTYPE=4H0932;KLMN=32;GO TO 115
      IF(IANS.EQ.3)IFTYPE=4H0934;KLMN=34;GO TO 115
C
C     IANS EQUAL TO 4 IS A COMPRESSED FILE - HAVE TO UNCOMPRESS
C     AND THEN FIND OUT WHAT IT IS
C
      IF(IANS.EQ.4)CALL MBS(IYES,1,IOUTBF,79,1);GO TO 300
C
      IF(IANS.EQ.5)IFTYPE=4H1040;KLMN=40;GO TO 115
      IF(IANS.EQ.6)IFTYPE=4H1037;KLMN=37;GO TO 115
      IF(IANS.EQ.7)IFTYPE=4H0422;KLMN=22
 115  CONTINUE
      CALL MOVEIN
      GO TO 10
 120  CONTINUE
C
C     HERE IS THE TEST FOR SHARED LIBRARIES - MUST BE KEYED AND
C     THE FIRST BYTE MUST BE X'04'
C     RESULT
C     1 = SHARED LIBRARY
C     0 = NOT
C
      IF(KBYTE1.NE.2Z04)GO TO 133
      KK=4HK
      CALL CBS(KK,1,IOUTBF,58,1,IRES)
      CALL SHARED
      IF(IANS.NE.0.AND.IANS.NE.1)OUTPUT ' IANS WRONG IN SHARED ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 133
      KLMN=34
      IFTYPE=4H0934
      CALL MOVEIN
      GO TO 10
 133  CONTINUE
C
C     NOW NEED TO READ MORE THAN ONE RECORD - NEXT TEST
C     IS FOR LOAD MODULES, TEXT, ETC.
C     RESULT
C     1 = LOAD MODULE
C     2 = TEXT-REGULAR
C     3 = TEXT-COMPRESSED
C     4 = TEXT-EDIT
C     5 = MINITAB W/S
C     6 = MANAGE DICT
C     0 = NONE OF ABOVE
C
      KK = 4HR
      CALL CBS(KK,1,IOUTBF,58,1,IRES)
      IF ( IRES.EQ.0 ) GO TO 400
      CALL LMNTXT
      IF(IANS.LT.0.OR.IANS.GT.6)OUTPUT ' IANS WRONG AT LMNTXT ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 400
      IF(IANS.EQ.1)IFTYPE=4H0318;KLMN=18;GO TO 135
      IF(IANS.EQ.2)IFTYPE=4H0419;KLMN=19;GO TO 135
      IF(IANS.EQ.3)IFTYPE=4H0420;KLMN=20;GO TO 135
      IF(IANS.EQ.4)IFTYPE=4H0421;KLMN=21;GO TO 135
      IF(IANS.EQ.5)IFTYPE=4H0425;KLMN=25;GO TO 135
      IF(IANS.EQ.6)IFTYPE=4H1035;KLMN=35
 135  CONTINUE
      CALL MOVEIN
      GO TO 10
 300  CONTINUE
C
C     HERE WE HAVE TO UNCOMPRESS FILES AND FIND THE PROCESSORS
C
C
C     UNCOMPRESS THE FILE
C
C     BRANCH TO PCL TO UNCOMPRESS THE FIRST 50  RECORDS
C
C
C     SET UP THE COMMAND LINE FOR PROCLINK
C
      DO 301 K = 1,20
      NPROC(K)=4H
 301  CONTINUE
      DO 302 K = 16,9,-1
      IF(IRES.NE.0)NR=K-8;GO TO 303
 302  CONTINUE
      NR=1
 303  CONTINUE
      DO 310 K = 47,17,-1
      CALL CBS(IBLANK,1,IOUTBF,K,1,IRES)
      IF(IRES.NE.0)J=K-16;GO TO 320
 310  CONTINUE
      J=31
 320  CONTINUE
      DO 330 K = 1,20
      NPROC(K)=4H
 330  CONTINUE
      L=3
      CALL MBS(NCOPY,1,NPROC,1,1)
      IF(IOUTBF(2).EQ.4H    )GO TO 340
      CALL MBS(NPACK,1,NPROC,L,3)
      L=L+3
      CALL MBS(IOUTBF,5,NPROC,L,4)
      L=L+4
      CALL MBS(NSLASH,1,NPROC,L,1)
      L=L+1
 340  CONTINUE
      CALL MBS(IOUTBF,17,NPROC,L,J)
      CALL MBS(IDOT,1,NPROC,J+L,1)
      CALL MBS(IOUTBF,9,NPROC,J+L+1,NR)
      CALL MBS(NCOMP,1,NPROC,J+L+NR+1,8)
      CALL MBS(NOVER,1,NPROC,J+L+NR+10,4)
      IF(IOUTBF(2).EQ.4H    )GO TO 350
      CALL MBS(NPACK,1,NPROC,J+L+NR+15,3)
      L=L+3
      CALL MBS(IOUTBF,5,NPROC,J+L+NR+15,4)
      L=L+4
      CALL MBS(NSLASH,1,NPROC,J+L+NR+15,1)
      L=L+1
 350  CONTINUE
      CALL MBS(MNAME,1,NPROC,J+L+NR+15,3)
      CALL MBS(IDOT,1,NPROC,J+L+NR+15+3,1)
      CALL MBS(IOUTBF,9,NPROC,J+L+NR+16+3,NR)
      NOPT=2
      DO 360 K = 80,1,-1
      CALL CBS(IBLANK,1,NPROC,K,1,IRES)
      IF(IRES.NE.0)JH=K;GO TO 365
 360  CONTINUE
 365  CONTINUE
      IF (JH.GT.64)WRITE(108,1003)(IOUTBF(MJ),MJ=5,12),
     1    IOUTBF(3),IOUTBF(4),IOUTBF(2);GO TO 500
      CALL PROCLINK(NOPT,NPROC)
      CALL CLOS
      INDOCM=1
      GO TO 405
 400  CONTINUE
      INDOCM=0
 401  CONTINUE
C
C     CALL PROCS ROUTINE TO GET PROPER PROCESSOR INPUT
C
C
C     0 = NONE OF THE BELOW
C     1 = FORTRAN
C     2 = COBOL
C     3 = BASIC
C     4 = METASYMBOL/AP
C     5 = PASCAL
C     6 = RPG
C     7 = ALGOL
C     8 = LISP
C     9 = MIX
C    10 = SNOBOL
C    11 = PL/1
C    12 = SL1
C    13 = GPDS
C    14 = CIRC (AC,DC,TR)
C    15 = XPL
C    16 = ECAP
C     17 = MANAGE COMMANDS
C     18 = BIOMED COMMANDS
C     19 = SPSS COMMANDS
C     20 = MORE THAN ONE FILE TYPE
C
C     IF NUMBER OF BYTES IS > 80 CAN'T BE PROCESSOR INPUT
C
C     BYPASS BYTE CHECK FOR COMPRESSED FILES
C
      IF(IBYTE.GT.80)GO TO 500
 405  CONTINUE
      CALL PROCS
      IF(IANS.LT.0.OR.IANS.GT.20)OUTPUT ' IANS WRONG AT PROCS  ';
     1WRITE(108,1002)IANS, (IOUTBF(L),L=5,12),IOUTBF(3),
     2IOUTBF(4),IOUTBF(2);CALL CLOS;GO TO 10
      IF(IANS.EQ.0)GO TO 500
      IF(IANS.EQ.1)IFTYPE=4H0101;KLMN=1;GO TO 450
      IF(IANS.EQ.2)IFTYPE=4H0102;KLMN=2;GO TO 450
      IF(IANS.EQ.3)IFTYPE=4H0103;KLMN=3;GO TO 450
      IF(IANS.EQ.4)IFTYPE=4H0104;KLMN=4;GO TO 450
      IF(IANS.EQ.5)IFTYPE=4H0105;KLMN=5;GO TO 450
      IF(IANS.EQ.6)IFTYPE=4H0106;KLMN=6;GO TO 450
      IF(IANS.EQ.7)IFTYPE=4H0107;KLMN=7;GO TO 450
      IF(IANS.EQ.8)IFTYPE=4H0108;KLMN=8;GO TO 450
      IF(IANS.EQ.9)IFTYPE=4H0109;KLMN=9;GO TO 450
      IF(IANS.EQ.10)IFTYPE=4H0110;KLMN=10;GO TO 450
      IF(IANS.EQ.11)IFTYPE=4H0111;KLMN=11;GO TO 450
      IF(IANS.EQ.12)IFTYPE=4H0112;KLMN=12;GO TO 450
      IF(IANS.EQ.13)IFTYPE=4H0113;KLMN=13;GO TO 450
      IF(IANS.EQ.14)IFTYPE=4H0114;KLMN=14;GO TO 450
      IF(IANS.EQ.15)IFTYPE=4H0115;KLMN=15;GO TO 450
      IF(IANS.EQ.17)IFTYPE=4H1036;KLMN=36;GO TO 450
      IF(IANS.EQ.18)IFTYPE=4H1038;KLMN=38;GO TO 450
      IF(IANS.EQ.19)IFTYPE=4H1039;KLMN=39;GO TO 450
      IF(IANS.EQ.20)IFTYPE=4H1141;KLMN=41;GO TO 450
 450  CONTINUE
      CALL MOVEIN
      GO TO 10
 500  CONTINUE
C
C     HERE WE HAVE REACHED THE END OF THE TESTS - ALL FILES
C     COMING TO THIS POINT ARE UNIDENTIFIABLE
C
      IFTYPE=4H1242
      KLMN=42
      CALL MOVEIN
      GO TO 10
 1000 FORMAT(///,' ERROR = ',Z8,' READING FIRST RECORD OF ',/,
     1   ' ACCOUNT IS ' 2A4,'  NAME IS ',7A4,A3,///)
 1001 FORMAT(2X,'**** FILE BUSY **** NAME IS: ',7A4,A3,' ACCOUNT: ',
     1  2A4,' PRIV VOL SN: ',A4)
 1002 FORMAT(' IANS IS ' ,I, ' FILE NAME IS ' ,7A4,A3,' ACCOUNT: ',
     1  2A4,' PRIV VOL SN: ',A4)
 1003 FORMAT(2X,'CANNOT UNCOMPRESS   NAME IS: ',7A4,A3,' ACCOUNT: ',
     1  2A4,' PRIV VOL SN: ',A4)
      END
C
C     SUBROUTINE WRTIT
C
C     PURPOSE - ADD ONE TO THE KEY AND WRITE A RECORD OF SCANDATA
C
      SUBROUTINE WRTIT
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     ADD ONE TO THE KEY
C
      KEY=KEY+1
C
C     WRITE THE RECORD
C
      CALL KWRITEN(IUNIT,KEY,4,IOUTBF,112,IERROR)
      RETURN
 1000 FORMAT(//,' ERROR WRITING SCANDATA IS ' Z8,//)
      END
C
C     SUBROUTINE MOVEIN (FILETYPE, POSITION IN ARRAY)
C
C     PURPOSE: ADD TO COUNTERS, WRITE RECORD AND CLOSE THE
C     OPEN FILE
C
      SUBROUTINE MOVEIN
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     2             IOUTBF(28),INSTNM(18),ISTART,INDCNT,INDST,
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     PUT FILETYPE IN THE BUFFER
C
      CALL MBS(IFTYPE,1,IOUTBF,48,4)
C
C     SEE IF WE NEED TO COUNT ALL RECORDS
C
      KK=4HK
      CALL CBS(KK,1,IOUTBF,58,1,IRES)
      IF(IRES.EQ.0.AND.INDCNT.EQ.1)CALL CNTIT
C
C     CLOSE THE FILE
C
      IF(INDOCM.EQ.0)CALL CLOS
      IF(INDOCM.NE.0) INDOCM = 0
C
C     CALL ROUTINE TO WRITE RECORD
C
      CALL WRTIT
C
C     ADD TO COUNTERS
C
      NUMS(KLMN,2)=NUMS(KLMN,2)+1
      NUMS(KLMN,3)=NUMS(KLMN,3)+IGRAN
      RETURN
      END
C
C     SUBROUTINE CNTIT
C     PURPOSE: COUNT ALL OF THE RECORDS IN A FILE IF
C     THAT INPUT OPTION WAS USED.
C
      SUBROUTINE CNTIT
C
C     GLOBAL THE VARIABLES
C
      GLOBAL KEYBUF(8),NAMBUF(12),INBUF(33),IOUTFD(12),INSN,
     1             IOUTSN,ICMNDS(7),NUMS(42,3),ICOMM(20),
     3             INDFID,IOPT,IENDAC(2),INDACT,INDPAC,INDRAN,
     4             INDDEF,IUNIT,IUNIT2,IHOLD(2),ISYNON,IERROR,KEY,
     5             IBYTE,IGRAN,IANS,KBYTE1,NPROC(20),IFTYPE,KLMN,
     6             INDOCM,NUMREC
C
C     POSITION TO THE BEGINNING OF FILE
C
      CALL PFIL
C
C     COUNT THE RECORDS
C
      CALL KOUNT
      RETURN
      END
