      SUBROUTINE PASS
C   
C   
C     THIS SUBROUTINE READS THE ASSEMBLY LANGUAGE DEFINITION SOURCE
C     AND SAVES THE DEFINITION ON A FILE IN A FORM THAT
C     CAN BE REFERENCED BY THE ASSEMBLY PROGRAM.  THE ROUTINE
C     EXECUTES ALL ASSEMBLER DIRECTIVES AND PRODUCES A LISTING
C     ON THE LIST DIVICE
C   
C   
      REAL IVAL
      DIMENSION LISTS(6),LCTL(6)
      DIMENSION ITERM(4),NUMS(10)
      INTEGER FTYPE
      REAL ITABV(249)
      COMMON ICRD,IPRT,MCFLE,IDFLE,MCREC,IDREC,IFORM,ITRUN,ILOUT,IXCOL
      COMMON MLAB,MOPC,IBIT,ICCNT,IWORD,IERRL,IERRI,IEND,IFRMC
      COMMON LSOR,LIF,LSYM,LREF,LDEF,LOCT,ITRMI,ITRMO
      COMMON ILEN,KLEN,LLEN,KWORD,IFLD(2400),IYFLD,IZFLD
      COMMON IFBIT,ZVAL,CVAL,JREAD,IN(80),INB(80),LINE,IPAGE,LISN
      COMMON IALPH(37),IAST,IDOLR,ISHRP
      COMMON ICOLN,IBLNK,ICTAB,ISEMI,ICOMM,IPLUS,IMIN,IMULT,IDIV
      COMMON IRPAR,ILPAR,IATT(9),JATT(5),LATT(9),IFPAR(16),NBASE,JBASE
      COMMON ICOL,IFCOL,MCOL,MLCOL,IOLIN,ICNT,LTITL(50),IADDR(4,12)
      COMMON ITYPE,JTYPE,FTYPE,IERR,IERRS,IOPVA,JCOL,IBUG
      COMMON ITAB(4,249),ITABS(249),ITABV,NAME(4),INDEX,INDET,ISYM,LTAB
      COMMON IXTAB(256),MXREF,IXT,IXPNT,IXCNT,IXPAG,MCORE(128)
C INCLUDE(:F1:METAD.COM)
      EQUIVALENCE (IBLNK,ITERM(1))
      EQUIVALENCE (NUMS(1),IALPH(1))
      EQUIVALENCE (LCTL(1),LSOR)
      DATA LISTS(1),LISTS(2),LISTS(3) /1HS,1HI,1HT/
      DATA LISTS(4),LISTS(5),LISTS(6) /1HX,1HD,1HQ/
C 
C     INITIALIZE IF STATEMENT NESTING LEVEL NUMBER
      IFSET = 0 
      IFON = 0
C     INITIALIZE IF STATEMENT CONTROL FLAG
      IFCTL = 2 
C     INITIALIZE CURRENT COLUMN NUMBER
100   ICOL = IFCOL
      JCOL = 1
C     SET LABEL INDICATOR (INDEX) TO ZERO 
      INDET = 0 
      INDEX = 0 
C     INITIALIZE ERROR INDICATOR
      IERRL = 0 
      IERRI = 0 
      IERR = 0
C     SET MODE FOR OUTPUT LISTING 
      LMODE = 1 
C     SET EXPLICIT LENGTH TO INDICATE NONE SPECIFIED
      ILEN = -1 
      IF(JREAD) 115,110,115 
C     READ NEXT DEFINITION LINE 
110   CALL INOUT(1) 
C     MOVE NEW LINE TO INPUT BUFFER 
115   DO 118 I=1,80 
      IN(I) = INB(I)
118   CONTINUE
      IXCOL = IFCOL 
      ICOL = IXCOL
      JCOL = ICOL 
      JREAD = 0 
C     DETERMINE ASSEMBLER DIRECTIVE 
120   CALL OPCOD(ICHK)
C     CHECK TO SEE IF THIS IS AN IF EXPANSION AND THIS LINE 
C     IS TO BE SKIPPED
      IF(IFCTL-2) 160,185,160
160   IF(IERR-2) 250,165,250
C     SET ICOL TO POINT PAST LABEL
165   ICOL = JCOL+1
      GO TO 120
185   GO TO (350,200,920,240,187,986),IERR
C     NO OPCODE ON LINE, CHECK IF LABEL PRESENT
187   IF(INDET) 800,920,800
C     CHECK TO MAKE SURE THAT TWO LABELS ARE NOT ON LINE
200   IF(INDET) 202,202,930
C     PROCESS A LABEL
202   CALL LABEL(0)
205   LABST = 1
C     CHECK FOR A COLON
      IF(IN(ICOL)-ICOLN) 900,206,900
206   ICOL = ICOL+1
C     CHECK FOR DOUBLE COLON
      IF(IN(ICOL)-ICOLN) 212,210,212
210   ICOL = ICOL+1
      LABST = 2
212   IF(IN(ICOL) .EQ. IBLNK) GO TO 213
      IF(IN(ICOL) .NE. ICTAB) GO TO 214
213   ICOL=ICOL+1
      IF(ICOL-MCOL) 212,212,214
214   IF(IFCTL-2) 120,215,120
215   GO TO (915,220,900,916),IERR
C     PLACE LABEL IN SYMBOL TABLE
220   IF(ISYM-LTAB) 221,916,916
221   ISYM = ISYM+1
      INDEX = ISYM
      DO 225 I=1,IWORD
      ITAB(I,INDEX) = NAME(I)
225   CONTINUE
      ITABS(INDEX) = LABST+8
      ITABV(INDEX) = 0.
      CALL XREFT(0,0)
230   INDET = INDEX
C     HAVE PROCESSED LABEL, NOW FETCH OPCODE
      GO TO 120 
C     PROCESS A COMMENT 
240   IF(IFCTL-2) 588,805,588 
C     CHECK FOR AN IF CONTROL DIRECTIVE 
250   IF(ICHK-1010) 251,580,251 
251   IF(ICHK-1009) 252,560,252 
252   IF(ICHK-1008) 253,255,253 
253   IF(ICHK-1011) 588,600,588 
255   IF(IFSET-16) 256,985,985
256   IFSET = IFSET+1 
      IFPAR(IFSET) = 0
      GO TO 588 
350   GO TO (400,420,440,460,480,500,520,540,560,580,
     1  600,620,680,700),IOPVA
C 
C     PROCESS TITLE DIRECTIVE                                -- TITLE
C 
400   N = 1 
401   ICOL1 = ICOL+49 
      DO 405 J=ICOL,ICOL1 
      IF(J-MCOL) 403,403,406
403   LTITL(N) = IN(J)
      N = N+1
405   CONTINUE
406   IF(N-50) 407,407,800
407   DO 408 J=N,50 
      LTITL(J) = IBLNK
408   CONTINUE
      GO TO 800 
C 
C     PROCESS LIST DIRECTIVE                                 -- LIST
C   
420   LSET = 1
421   IF(ICOL-MCOL) 422,422,428 
422   DO 423 I=1,6
      IF(IN(ICOL)-LISTS(I)) 423,424,423
423   CONTINUE
C     ILLEGAL LIST OPERAND
      GO TO 925
C     SET CORRESPONDING LIST CONTROL FLAG 
424   LCTL(I) = LSET
      ICOL1 = ICOL+1
      ICOL = ICOL1+1
C     CHECK FOR END OF ARGUMENT LIST
      DO 425 I=1,3
      IF(IN(ICOL1)-ITERM(I)) 425,800,425
425   CONTINUE
427   IF(IN(ICOL1)-ICOMM) 925,421,925 
428   LSOR = LSET 
      GO TO 800 
C 
C     PROCESS NOLIST DIRECTIVE                               -- NOLIST
C 
440   LSET = 0
      GO TO 421
C 
C     PROCESS EQU DIRECTIVE                                  -- EQU 
C 
C     CHECK FOR EXPLICIT EXPRESSION LENGTH
460   DO 4611 I=1,10
      IF(IN(ICOL)-NUMS(I)) 4611,4612,4611 
4611  CONTINUE
      GO TO 4619
4612  ILEN = 0
      LCOL = ICOL 
4613  DO 4614 I=1,10
      IF(IN(ICOL)-NUMS(I)) 4614,4618,4614 
4614  CONTINUE
      IF(IN(ICOL)-ILPAR) 4616,4619,4616
4616  ICOL = LCOL
      ILEN = -1
      GO TO 4619
4618  ILEN = ILEN*10+I-1
      ICOL = ICOL+1
      GO TO 4613
C     READ VALUE THAT LABEL IS TO BE SET TO
4619  CALL ESCAN(IVAL)
      IF(IERR-1) 462,465,462
C     SET SYMBOL VALUE TO ZERO IF THERE WAS AN ERROR
462   IF(INDET) 463,464,463
C     CHECK FOR DUPLICATE LABEL
463   IF(IERRL-53) 4635,464,4635
4635  ITABV(INDET) = 0.
      ITABS(INDET) = LABST+8
464   GO TO (465,925,940,930,970,975,980,955,925),IERR
C     CHECK FOR MISSING LABEL
465   IF(INDET) 466,910,466
C     PLACE SYMBOL"S VALUE IN TABLE
C     CHECK FOR DUPLICATE LABEL
466   IF(IERRL-53) 467,800,467
467   ITABV(INDET) = IVAL
      ITABS(INDET) = KLEN*16+LABST+8
      GO TO 800
C   
C     PROCESS SET DIRECTIVE                                  -- SET
C   
C     CHECK FOR DUPLICATE LABEL
480   IF(IERRL-53) 484,481,484
481   JTYPE = ITABS(INDET)
      JTYPE = JTYPE-(JTYPE/8)*8 
      IF(JTYPE-3) 800,482,800
482   IERRL = 0 
484   LABST = 3 
      GO TO 460 
C   
C     PROCESS SPACE DIRECTIVE                                -- SPACE 
C 
500   CALL ESCAN(IVAL)
      GO TO (505,925,940,930,970,975,980,955,925),IERR
505   ICNT = IVAL 
      IF(ICNT-IOLIN) 515,515,510
510   ICNT = IOLIN
515   LMODE = 2 
      GO TO 800 
C 
C     PROCESS EJECT DIRECTIVE                                -- EJECT 
C 
520   LMODE = 3 
      IF(LSOR) 525,800,525
525   LINE = IOLIN
      GO TO 800 
C 
C     PROCESS IF DIRECTIVE                                   -- IF
C   
540   CALL ESCAN(IVAL)
      GO TO (542,925,940,930,970,975,980,955,925),IERR
542   IFON = 2
      IF(IVAL) 546,544,546
544   IFON = 1
546   IFCTL = IFON
      IF(IFSET-16) 548,985,985
548   IFSET = IFSET+1 
      IFPAR(IFSET) = IFON+IFON
      GO TO 800 
C 
C     PROCESS ELSE DIRECTIVE                                 -- ELSE
C 
560   IF(IFSET) 920,920,562 
562   IFON = IFPAR(IFSET)/2 
      IELSE = IFPAR(IFSET)-(IFON+IFON)
      IF(IFON) 588,588,564
564   IF(IELSE) 566,566,920 
566   IFCTL = 3-IFON
      IFPAR(IFSET) = IFCTL+IFCTL+1
      GO TO 800 
C 
C     PROCESS THE ENDIF DIRECTIVE                            -- ENDIF
C 
580   IF(IFSET-1) 920,582,584 
582   IFCTL = 2 
      IFSET = 0
      GO TO 800 
584   IFSET = IFSET-1 
      IFCTL = IFPAR(IFSET)/2
C     CHECK FOR CONDITIONAL ASSEMBLY EXPANSION THAT SHOULD NOT BE LISTED
587   IF(IFCTL-1) 588,588,800 
588   IF(LIF) 589,100,589 
589   ITYPE = -1
      GO TO 800 
C 
C 
C     PROCESS THE END DIRECTIVE                              -- END 
C 
600   IEND = 1
      GO TO 800 
C   
C     PROCESS DEF DIRECTIVE                                  -- DEF 
C 
620   ITYP = 0
625   IXFLD = IYFLD
C     SET FIELD NUMBER
      JFLD = 0
C     INITIALIZE NUMBER OF BITS IN WORD 
      IWBIT = 0
C     CHECK FOR MISSING LABEL 
      IF(INDET) 6254,6252,6254
6252  IERRL = 52
      GO TO 6256
6254  IF(IERRL) 6256,6255,6256
6255  ITABS(INDET) = -(ITYP*16384+1)
C     SCAN NEXT FIELD 
6256  CALL SCAN(IVAL) 
C     IF ERROR, RESET FIELD TABLE POINTER 
      IF(IERR-1) 6257,6259,6257 
6257  IYFLD = IXFLD 
6259  GO TO (626,946,987,940,950,975,970,955,925,930,980),IERR
626   IF(FTYPE-4) 6265,670,655
6265  IWBIT = IWBIT+ILEN
C     INCREMENT NUMBER OF FIELDS
      JFLD = JFLD+1 
      IF(JFLD-32) 627,627,950
C     PLACE FIELD TYPE,LENGTH, AND ATTRIBUTES IN FIELD TABLE
627   IYFLD = IYFLD+1
      IF(IYFLD-IZFLD) 628,628,985
C     PACK DEFAULT CONSTANT TYPE INTO TWO BITS
628   IJ = 0
      J = 6
      DO 629 I=1,4
      IF(LATT(J)) 6295,6285,6295
6285  J = J+1
629   CONTINUE
      GO TO 6297
6295  IJ = I-1
6297  IJ = LATT(1)*64+LATT(2)*32+LATT(3)*16+LATT(4)*8+LATT(5)*4+IJ
6299  IFLD(IYFLD) = IJ*256+ILEN*4+FTYPE
630   IF(FTYPE-1) 6301,6305,6301
6301  IF(FTYPE-3) 635,6305,635
C     PLACE DEFAULT CONSTANT IN FIELD TABLE
6305  IF(IYFLD+2-IZFLD) 631,631,985
631   IF(IVAL) 632,633,633
C     DONT CARE DEFAULT FOR FIELD
632   IYFLD = IYFLD+1
      IFLD(IYFLD) = -1
      GO TO 635
C     ORDINARY CONSTANT DEFAULT FOR FIELD
633   ICON1 = IVAL/32768.
      REAL1 = ICON1
      ICON2 = IVAL-REAL1*32768.
      IYFLD = IYFLD+1
      IFLD(IYFLD) = ICON1
      IYFLD = IYFLD+1
      IFLD(IYFLD) = ICON2
C     CHECK FOR FIELD SEPARATOR
635   DO 636 I=1,3
      IF(IN(ICOL)-ITERM(I)) 636,655,636
636   CONTINUE
638   IF(IN(ICOL)-ICOMM) 910,639,910
639   ICOL = ICOL+1
      GO TO 6256
C     CHECK TO SEE IF WORD LENGTH IS CORRECT
655   IF(KWORD-IWBIT) 6555,656,6553
6553  IF(ITYP) 656,6555,656
6555  IYFLD = IXFLD
      GO TO 945
C     CHECK FOR MISSING LABEL
656   IF(INDET) 658,660,658
C     PUT DEF STATISTICS IN SYMBOL TABLE
658   ITABS(INDET) = -(ITYP*16384+JFLD*256+IWBIT)
      ITABV(INDET) = IXFLD+1
      GO TO 800
C     RESET FIELD TABLE INDEX
660   IYFLD = IXFLD
      GO TO 910
C     FOUND SUB FIELD NAME IS DEF FIELD SCAN
670   JTYPE = -ITABS(INDEX)/256
      KFLD = JTYPE-(JTYPE/64)*64
      INDEF = ITABV(INDEX)
      ILEN = -ITABS(INDEX)-JTYPE*256
      IWBIT = IWBIT+ILEN
      JFLD = JFLD+KFLD
      IF(JFLD-32) 672,672,945 
C     COPY SUB DEFINITION TO DEF DEFINITION 
672   DO 679 I=1,KFLD 
      JTYPE = IFLD(INDEF) 
      INDEF = INDEF+1 
      IYFLD = IYFLD+1 
      IF(IYFLD-IZFLD) 6725,6725,985 
6725  IFLD(IYFLD) = JTYPE 
      FTYPE = JTYPE-(JTYPE/4)*4+1 
      GO TO (679,675,679,674),FTYPE 
674   K = 1 
      J = INDEF 
      IF(IFLD(J)) 676,675,675
675   K = 2 
676   J = IYFLD+K 
      IF(J-IZFLD) 677,677,985 
677   DO 678 J=1,K
      IYFLD = IYFLD+1 
      IFLD(IYFLD) = IFLD(INDEF)
      INDEF = INDEF+1 
678   CONTINUE
679   CONTINUE
      GO TO 635 
C 
C     PROCESS SUB DIRECTIVE                                  -- SUB 
C 
680   ITYP = 1
      GO TO 625 
C 
C     PROCESS THE WORD DIRECTIVE                             -- WORD
C 
700   IF(KWORD) 701,920,920 
701   CALL ESCAN(IVAL)
      GO TO (702,925,940,930,970,975,980,955,925),IERR
702   IF(IVAL-128.) 704,704,980 
704   KWORD = IVAL
      GO TO 800 
C 
C     CHECK FOR FORMAT ERROR IF NO OTHER ERRORS 
C 
800   IF(IERRI) 805,802,805
802   IF(IN(ICOL)-ICOMM) 805,935,805
805   CALL LOUT(LMODE)
      IF(IEND) 840,100,840
840   WRITE(IPRT,1002) IERRS
      WRITE(ITRMO,1002) IERRS
1002  FORMAT(//,28H   TOTAL DEFINITION ERRORS =,I4)
      GO TO 995
C   
C     SET ERROR INDICATOR 
C 
C     LABEL ERROR 
900   IERRL = 51
      GO TO 990 
C     MISSING LABEL 
910   IERRL = 52
      GO TO 990 
C     DUPLICATE LABEL 
915   IERRL = 53
      GO TO 230 
C     SYMBOL TABLE FULL 
916   IERRL = 54
      GO TO 990 
C     ILLEGAL DIRECTIVE 
920   IERRI = 1
      GO TO 990 
C     ARGUMENT ERROR
925   IERRI = 2 
      GO TO 990 
C     SYNTAX ERROR - ILLEGAL EXPRESSION 
930   IERRI = 3 
      GO TO 990 
C     FORMAT ERROR
935   IERRI = 4 
      GO TO 805 
C     UNDEFINED SYMBOL
940   IERRI = 5 
      GO TO 990 
C     ILLEGAL MICROWORD LENGTH
945   IERRI = 6 
      GO TO 990 
C     ILLEGAL FIELD TYPE
946   IERRI = 15
      GO TO 990 
C     ILLEGAL FIELD LENGTH
950   IERRI = 7 
      GO TO 990 
C     ATTRIBUTE ERROR
955   IERRI = 8
      GO TO 990
C     CONSTANT TOO LARGE FOR A HOST MACHINE REAL NUMBER
970   IERRI = 10
      GO TO 990 
C     IMPLICIT AND EXPLICIT FIELD LENGTH CONFLICT 
975   IERRI = 9 
      GO TO 990 
C     VALUE ERROR 
980   IERRI = 11
      GO TO 990 
C     TABLE OVERFLOW ERROR
985   IERRI = 13
      GO TO 990 
C     UNEXPECTED CONTINUATION LINE
986   IERRI = 14
      GO TO 990 
C     ILLEGAL CHARACTER 
987   IERRI = 12
C     HAVE SET ERROR CODE, NOW OUTPUT LINE
990   GO TO 800 
995   RETURN
      END 

      END 
