      SUBROUTINE SCAN
C   
C   
C     THIS ROUTINE FORMS A VALUE FROM THE INPUT COMMAND LINE
C     THE VALUE MAY BE DECIMAL OR HEXADECIMAL.  HEXADECIMAL 
C     CONSTANTS END WITH A H. 
C 
C 
      REAL IVAL,IVAL1,IVAL2,NOFF,NTDEP(64),NINST,INSCT
      COMMON ICRD,IPRT,IPCH,IRDR,IFIL,IMREC,IMFLE,IPFLE,IPREC,ITERM 
      COMMON IMBUF(128),IPBUF(80),IN(128),ILBUF(80),IWBUF(128),IFREC
      COMMON ISBIT,ICHBT,ICHWD,NBIT,NINST,NDONT,NCOL,NROW,NOFF,IBAT 
      COMMON LODLC,IEND,NBITT,IPS,IPE,IPLEN,IPASS,IROW,LCTL,MXREC 
      COMMON NPLIN,IWSEC,MSEC,IPROM,INDEX,IBITS,IBITE,LCOLS,LCOLE 
      COMMON INSCT,IVAL,IVAL1,IVAL2,MCOL,NPCNT,ICHAR,MSIZE,NWORD,ILLEN
      COMMON LMAP,LLIST,LPCH,INVRT,LHEX,LFILE,NAMEF(4),IERR,ICOL,ICNT 
      COMMON NPWID(32),NTWID(32),NPDEP(64),NTDEP,NVAL,MESSN,MESSF 
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRF,ICHRN,ICHRR,ICHR0,ICHR1
      COMMON ICHRX,IBLNK,ICOMM,IAST,IDOLR,IEQUL,IMIN,IADDR(4),NUMS(16)
      DATA ICHRH /1HH/
C 
C     *ENTRY PARAMETERS
C     ICOL  - STARTING COLUMN OF SCAN
C   
C     *EXIT PARAMETERS
C     ICHAR - TERMINATOR CHARACTER
C     ICOL  - ENDING COLUMN OF SCAN 
C     IERR  - RETURN STATUS 
C             0 = NO ERROR
C             1 = ILLEGAL CHARACTER OR VALUE TOO LARGE
C     IVAL  - VALUE OF CONSTANT (REAL)
C     NVAL  - VALUE OF CONSTANT (INTEGER) 
C 
C 
      IERR = 1
      IVAL = 0
      NVAL = 30000
      IFACT = 10
      RFACT = 10. 
C     SCAN TO START OF FIELD
100   IF(IN(ICOL)-IBLNK) 120,110,120
110   ICOL = ICOL+1 
      IF(ICOL-MCOL) 100,100,900 
C     FIND END OF FIELD 
120   IS = ICOL 
130   ICOL = ICOL+1 
      IF(ICOL-MCOL) 140,140,200 
140   ICHAR = IN(ICOL)
      IF(ICHAR-IBLNK) 150,200,150 
150   IF(ICHAR-ICOMM) 160,200,160 
160   IF(ICHAR-IAST) 170,200,170
170   IF(ICHAR-IMIN) 130,200,130
200   ICOL1 = ICOL-1
      IF(ICOL1) 990,990,210 
210   IF(IN(ICOL1)-ICHRH) 300,220,300 
220   IFACT = 16
      RFACT = 16. 
      ICOL1 = ICOL1-1 
C     FORM VALUE
300   DO 360 I=IS,ICOL1 
      DO 310 L=1,IFACT
      IF(IN(I)-NUMS(L)) 310,350,310 
310   CONTINUE
      GO TO 900 
350   IVAL2 = L-1 
      IVAL = IVAL*RFACT+IVAL2 
360   CONTINUE
C     CHECK VALUE 
      IF(IVAL-65536.) 400,900,900 
400   IERR = 0
C 
900   IF(IVAL-32768.) 910,990,990 
910   NVAL = IVAL 
990   RETURN
      END 
      SUBROUTINE MAP
C 
C 
C     THIS SUBROUTINE IS USED TO PRINT A PROM MAP 
C 
      REAL IVAL,IVAL1,IVAL2,NOFF,NTDEP(64),NINST,INSCT
      DIMENSION IALPH(16) 
      COMMON ICRD,IPRT,IPCH,IRDR,IFIL,IMREC,IMFLE,IPFLE,IPREC,ITERM 
      COMMON IMBUF(128),IPBUF(80),IN(128),ILBUF(80),IWBUF(128),IFREC
      COMMON ISBIT,ICHBT,ICHWD,NBIT,NINST,NDONT,NCOL,NROW,NOFF,IBAT 
      COMMON LODLC,IEND,NBITT,IPS,IPE,IPLEN,IPASS,IROW,LCTL,MXREC 
      COMMON NPLIN,IWSEC,MSEC,IPROM,INDEX,IBITS,IBITE,LCOLS,LCOLE 
      COMMON INSCT,IVAL,IVAL1,IVAL2,MCOL,NPCNT,ICHAR,MSIZE,NWORD,ILLEN
      COMMON LMAP,LLIST,LPCH,INVRT,LHEX,LFILE,NAMEF(4),IERR,ICOL,ICNT 
      COMMON NPWID(32),NTWID(32),NPDEP(64),NTDEP,NVAL,MESSN,MESSF 
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRF,ICHRN,ICHRR,ICHR0,ICHR1
      COMMON ICHRX,IBLNK,ICOMM,IAST,IDOLR,IEQUL,IMIN,IADDR(4),NUMS(16)
      EQUIVALENCE (IALPH(1),NUMS(1))
C 
C     *ENTRY PARAMETERS 
C     LCOLE - ENDING PROM COLUMN TO PRINT 
C     LCOLS - STARTING PROM COLUMN TO PRINT 
C     NROW  - NUMBER OF PROM ROWS 
C     NTDEP - STARTING PROM ADDRESSES 
C 
C     *EXIT PARAMETERS
C     PROM MAP PRINTED
C 
C 
      NCNT = 0
      IMBUF(1) = IBLNK
      IF(LCOLS-10) 10,20,20 
10    NCNT = 1
20    DO 60 I=LCOLS,LCOLE 
      NCNT = NCNT+1 
      IMBUF(NCNT) = ICHRC 
      IF(I-10) 30,40,40 
30    NCNT = NCNT+1 
      K = I+1 
      IMBUF(NCNT) = IALPH(K)
      IF(I-9) 35,50,35
35    NCNT = NCNT+1 
      IMBUF(NCNT) = IBLNK 
      GO TO 50
40    K1 = I/10 
      K2 = 1+I-K1*10
      K1 = K1+1 
      NCNT = NCNT+1 
      IMBUF(NCNT) = IALPH(K1) 
      NCNT = NCNT+1 
      IMBUF(NCNT) = IALPH(K2) 
50    NCNT = NCNT+1 
      IMBUF(NCNT) = IBLNK 
60    CONTINUE
C     OUTPUT HEADING
      WRITE(ITERM,1000) (IMBUF(I),I=1,NCNT)
1000  FORMAT(//,8X,4HPC  ,80A1) 
      IS = LCOLS
      IE = LCOLE
      DO 250 I=1,NROW 
      IMBUF(1) = ICHRR
      IF(I-10) 210,220,220
210   K = I+1 
      IMBUF(2) = IALPH(K) 
      IMBUF(3) = IBLNK
      GO TO 230 
220   K = 1+I/10
      IMBUF(2) = IALPH(K) 
      K = 1+I-(K-1)*10
      IMBUF(3) = IALPH(K) 
230   IVAL = NTDEP(I)+NOFF
      CALL AHEX
      WRITE(ITERM,1010) (IMBUF(K),K=1,3),(IADDR(K),K=1,4),(K,K=IS,IE)
1010  FORMAT(1X,3A1,3X,4A1,20(I4))
      IS = IS+NCOL
      IE = IE+NCOL
250   CONTINUE
      RETURN
      END 
      SUBROUTINE WORD 
C 
C 
C     THIS SUBROUTINES FORMS THE STARTING ADDRESS OF A PROM 
C 
C 
      REAL IVAL,IVAL1,IVAL2,NOFF,NTDEP(64),NINST,INSCT
      COMMON ICRD,IPRT,IPCH,IRDR,IFIL,IMREC,IMFLE,IPFLE,IPREC,ITERM 
      COMMON IMBUF(128),IPBUF(80),IN(128),ILBUF(80),IWBUF(128),IFREC
      COMMON ISBIT,ICHBT,ICHWD,NBIT,NINST,NDONT,NCOL,NROW,NOFF,IBAT 
      COMMON LODLC,IEND,NBITT,IPS,IPE,IPLEN,IPASS,IROW,LCTL,MXREC 
      COMMON NPLIN,IWSEC,MSEC,IPROM,INDEX,IBITS,IBITE,LCOLS,LCOLE 
      COMMON INSCT,IVAL,IVAL1,IVAL2,MCOL,NPCNT,ICHAR,MSIZE,NWORD,ILLEN
      COMMON LMAP,LLIST,LPCH,INVRT,LHEX,LFILE,NAMEF(4),IERR,ICOL,ICNT 
      COMMON NPWID(32),NTWID(32),NPDEP(64),NTDEP,NVAL,MESSN,MESSF 
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRF,ICHRN,ICHRR,ICHR0,ICHR1
      COMMON ICHRX,IBLNK,ICOMM,IAST,IDOLR,IEQUL,IMIN,IADDR(4),NUMS(16)
C 
C     *ENTRY PARAMETERS 
C     IPROM - NUMBER OF PROM TO LIST/PUNCH
C     MSEC  - NUMBER OF MICROWORDS PER DISK SECTOR
C     NCOL  - NUMBER OF PROM COLUMNS
C     NWORD - NUMBER OF COMPUTER WORDS PER MICROWORD
C 
C     *EXIT PARAMETERS
C     IBITE - INDEX OF ENDING BIT 
C     IBITS - INDEX OF START BIT
C     INDEX - INDEX OF START OF PROM WITHIN SECTOR
C     IROW  - ROW NUMBER OF PROM
C     IWSEC - RECORD NUMBER OF DISK SECTOR
C 
C 
C     FORM ROW NUMBER AND GET START ADDRESS 
      IROW = 1+(IPROM-1)/NCOL 
      IVAL = MSEC 
      IWSEC = 1.+NTDEP(IROW)/IVAL 
      IVAL1 = IWSEC-1 
      INDEX = NTDEP(IROW)-IVAL1*IVAL
      INDEX = 1+INDEX*NWORD 
      LCOL = IPROM-(IROW-1)*NCOL
      IBITS = NTWID(LCOL) 
      IBITE = IBITS+NPWID(LCOL)-1 
      RETURN
      END 
      SUBROUTINE OUT
C 
C 
C     THIS ROUTINE OBTAINS THE BITS FROM A MICROWORD
C     TO FORM A PROM. 
C 
C 
      REAL IVAL,IVAL1,IVAL2,NOFF,NTDEP(64),NINST,INSCT
      COMMON ICRD,IPRT,IPCH,IRDR,IFIL,IMREC,IMFLE,IPFLE,IPREC,ITERM 
      COMMON IMBUF(128),IPBUF(80),IN(128),ILBUF(80),IWBUF(128),IFREC
      COMMON ISBIT,ICHBT,ICHWD,NBIT,NINST,NDONT,NCOL,NROW,NOFF,IBAT
      COMMON LODLC,IEND,NBITT,IPS,IPE,IPLEN,IPASS,IROW,LCTL,MXREC 
      COMMON NPLIN,IWSEC,MSEC,IPROM,INDEX,IBITS,IBITE,LCOLS,LCOLE 
      COMMON INSCT,IVAL,IVAL1,IVAL2,MCOL,NPCNT,ICHAR,MSIZE,NWORD,ILLEN
      COMMON LMAP,LLIST,LPCH,INVRT,LHEX,LFILE,NAMEF(4),IERR,ICOL,ICNT 
      COMMON NPWID(32),NTWID(32),NPDEP(64),NTDEP,NVAL,MESSN,MESSF 
      COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRF,ICHRN,ICHRR,ICHR0,ICHR1
      COMMON ICHRX,IBLNK,ICOMM,IAST,IDOLR,IEQUL,IMIN,IADDR(4),NUMS(16)
C 
C     *ENTRY PARAMETERS 
C     IPASS - LIST/PUNCH FLAG 
C     IPROM - PROM NUMBER 
C     LCTL  - LIST/PUNCH OUTPUT CONTROL FLAG
C     LPCH  - 1 = PUNCH PROM OUTPUT
C 
C     *EXIT PARAMETERS
C     PROM LISTED AND/OR PUNCHED
C 
C 
      IEND = 0
      ICNT = 0
      LODLC = -1
C     GET STARTING PROM ADDRESS INFORMATION 
      CALL WORD
      IND = (IBITS-1)/16
C     FORM RELATIVE INDICES 
      IPS = IBITS-IND*16
      IPE = IBITE-IND*16
      IDIF = IPE-IPS
C     CALCULATE NUMBER OF PROMS WORDS PER OUTPUT LINE 
      NPLIN = 8 
      IF(IDIF-3) 100,100,20 
20    NPLIN = 4 
      IF(IDIF-15) 100,100,30
30    NPLIN = 2 
      IF(IDIF-31) 100,100,40
40    NPLIN = 1 
100   IF(IWSEC-IMREC) 150,200,150 
150   IMREC = IWSEC 
      CALL INOUT(3) 
C     GET BITS FOR NEXT MICROWORD 
200   NN = 0
210   ISCNT = IND 
220   INDET = INDEX+IND 
230   IVAL = IMBUF(INDET) 
      IF(IVAL) 240,250,250
240   IVAL = IVAL+65536.
250   DIV = 32768.
      DO 260 I=1,16 
      NN = NN+1 
      IWBUF(NN) = IVAL/DIV
      IVAL1 = IWBUF(NN) 
      IVAL = IVAL-IVAL1*DIV 
      DIV = DIV/2.
260   CONTINUE
      ISCNT = ISCNT+1 
      INDET = INDET+1 
      IF(NN-IPE) 270,400,400
270   IF(ISCNT-NWORD) 230,300,300 
C     HAVE OBTAINED ALL BITS, CHECK IF EXTRA BITS PER MICROWORD 
300   ID1 = IBITE-NBIT
      IF(ID1) 400,400,310 
310   DO 320 I=1,ID1
      NN = NN+1 
      IWBUF(NN) = NDONT 
320   CONTINUE
C 
C     OUTPUT LISTING AND/OR PROM
C 
400   IF(IPASS-1) 410,410,420
C     OUTPUT LISTING
410   CALL LOUT 
      IF(LCTL*LPCH) 500,500,420 
C     OUTPUT PUNCH
420   CALL POUT 
C     CHECK IF DONE - ELSE GET ADDITIONAL MICROWORDS
500   IF(IEND) 510,510,900
510   ICNT = ICNT+1 
      IF(ICNT-NPDEP(IROW)) 540,520,520
520   IEND = 1
      GO TO 400
540   INDEX = INDEX+NWORD
      IF((INDEX-1+NWORD)-MSIZE) 200,200,550
550   INDEX = 1
      IWSEC = IWSEC+1
      IF(IWSEC-MXREC) 100,100,600
C     FILL EXTRA MICROWORDS WITH DONT CARES
600   ID1 = 128
      INDEX=MSIZE+1
      NN = 0
      GO TO 310 
C 
900   RETURN
      END
 RETURN
      END
