C     *****************************************************************
C     *                                                               *
C     *  N6DSP --- PHASE 6 DATA STATEMENT PROCESSOR.  ENTERED BY A    *
C     *        CALL  N6DSP   WITH FIRST F60 ITEM FOR DATA STMT IN     *
C     *        VI05.  PROCESSES ENTIRE STATEMENT, EXECUTING A NORMAL  *
C     *        RETURN REGARDLESS OF WHAT HAPPENS WHILE PROCESSING.    *
C     *        RETURNS WITH FINAL F60 DATA STMT ITEM IN VI05.         *
C     *        WARNING --- LIST POLISH ACCEPTED IS SUBSET OF THAT     *
C     *        DEFINED FOR F30.                                       *
C     *                                                               *
C     *****************************************************************
C
C    CAUTION--THIS SUBROUTINE CALLS RFF60I.  THEREFORE REGISTERS R13,
C             R14, R7 AND R8 MUST NOT BE USED IN THIS SUBROUTINE.
C             NESTED DO LOOPS WILL CAUSE DISASTER.
C
      SUBROUTINE  N6DSP
C
      COMPILER (LIB=FILE1)
      INCLUDE  FORENV
      INCLUDE  FORCR                                                    RELOC
      COMPILER (GEN=NOTRA)
C
C         N6DSP PARAMETRIC DATA BASE.
C
          COMMON /N6FSZZ/ DUMM(3), VI05(24), DIAG
C
      COMMON  /SYMZ/ SYM(1)
      COMMON /N6MNZZ/DUMX(23),VI20
C
      PARAMETER  NLF60I=15,        @ F60 ITEM SIZE (WORDS)
     1           NLIMND=25,        @ MAX DO NEST LEVEL (DO/DO = LEV 1)
     2           N6DSSL=1000,       @ INTERNAL LIST/DATA BUFFER SIZE
     3           N6DSOL=50         @ OPERAND PUSHDOWN LENGTH (ITEMS)
C
      PARAMETER  DSID=3,           @ DATA STMT ITEM ID.
     1           ELID=27,          @ END LIST ITEM ID.
     2           EDID=47,          @ END DATA ITEM ID.
     3           EDSID=48          @ END DATA STMT ID.
C
      DEFINE   ID(I)=FLD(0,6,I)         @ ITEM ID FIELD.
      DEFINE   VRA(I)=FLD(12,3,I)       @ VARIABLE-REF 'A' FIELD.
      DEFINE   SYMP(I)=FLD(18,18,I)     @ SYM POINTER - HAS OTHER USES.
      DEFINE   STCRSA(I)=FLD(6,30,I)    @ STC/RSA FROM SYM W2.
      DEFINE   PDTF(I)=FLD(0,3,I)       @ VARIABLE TYPE FOR SYM REF'S
      DEFINE   TFLD(I)=FLD(12,3,I)      @ T FLD FROM SYM W3.
      DEFINE   PDDF(I)=FLD(3,3,I)       @ DIMENSIONALITY FOR SYM REF'S
      DEFINE   W3DF(I)=FLD(9,3,I)       @ SYM W3 D-FIELD
      DEFINE   W3CF(I)=FLD(15,3,I)      @ SYM W3 C-FIELD
      DEFINE   IDMOD(I)=FLD(6,6,I)      @ ITEM ID MODIFIER (S2)
      DEFINE   VRB(I)=FLD(15,1,I)       @ VAR/CONST SIGN BIT.
      DEFINE   RSA(I)=FLD(18,18,I)      @ RSA PORTION OF SYM W2.
      DEFINE   STC(I)=FLD(6,12,I)       @ STC PORTION OF SYM W2.
      DEFINE   STSEQ(I)=FLD(21,15,I)    @ SEQ NO FLD OF STMT TYPE ITEM.
      DEFINE  ID6(I)=FLD(1,5,I)         @ F60 ITEM ID, IGNORE BIT 1.    D TO I
          DEFINE Q1(I) = FLD(0,9,I)
          DEFINE Q2(I) = FLD(9,9,I)
          DEFINE Q3(I) = FLD(18,9,I)
          DEFINE Q4(I) = FLD(27,9,I)
          INTEGER FBLANK,ABLANK
           DATA  FBLANK,ABLANK /O050505050505,O040040040040/
          INTEGER XBLANK   @ ASCII OR FIELDATA BLANK
C
      DEFINE   INDX(I) = I-LOCSYM            @ CVT SYM ADDR TO INDX
      DEFINE   IMCON(I)=SYMP(I)*(1-2*VRB(I)) @ XPND IMM CON TO FULL WD.
      DEFINE   SYMM(I)=SYM(I)                     @ INDIRECT SYM SUBSCR
      DEFINE  SYMCON(I)=SYMM(INDX(SYMP(I)))*(1-2*VRB(I)) @ +- SYM CONST GUARD
      DEFINE   SYMVAR(I)=SYMM(INDX(SYMP(I))+3)*(1-2*VRB(I)) @ SIGNED VAR
C
      PARAMETER  SLIDT=9           @ NO. OF LIST ITEM ID'S RECOGNIZED.
C
      PARAMETER DIDBAS=38, DIDMAX=10,        @ BASE & NO. OF DATA IDS   RELOC
     $        BOPMAX=30,BMAX4=BOPMAX-4       @ MAX LENGTH OF BOPARG.    RELOC
C                                    LIST ITEM ID TABLE ---
      DIMENSION  LIDT(SLIDT)/  2,  @ VARIABLE REFERENCE ITEM
     1                         3,  @ CONSTANT ITEM
     2                         4,  @ OFFSET ITEM
     3                        15,  @ BEGIN DO ITEM
     4                         7,  @ DROP-OUT ITEM
     5                         8,  @ OPERATOR ITEM
     6                        16,  @ END DO ITEM
     7                        10,  @ STATEMENT TYPE ITEM
     8                        27/  @ END LIST ITEM (=ELID)
C
C         END PARAMETERS.
C
      PARAMETER  DPDL=NLIMND+1               @ DO PUSHDOWN SIZE.
C
      COMMON /N6QQQ/DUM(5),WA(N6DSSL),   @ WORK AREA FOR LIST DATA
     1           OPD(N6DSOL,2),    @ OPERAND PUSHDOWN
     2           DPD(DPDL,4)       @ DO PUSHDOWN  W1 = SYM W4 INDEX,
      DIMENSION  DOPRM(4)          @ TEMP FOR DO PARAMS.
C                             W2 = FINAL, W3 = INCR, W4 = WA LOOPORG - 1
C
      REAL  REAL                             @ ABOVE DIAGNOSTIC EXPECTED
      DOUBLE PRECISION  DPREC
      INTEGER CHRFP                     @ FIRST CHARACTER POSISITION
      INTEGER CHRLP                     @ LAST CHARACTER POSISITION
      INTEGER CHRFL                     @ FLAGS FOR CHARACTER ACTIVE
      INTEGER CHRIX                     @ COMPUTED GO TO INDEX FOR CHARACTER
      INTEGER CHRPCL                    @ LOCATION OF CHARACTER PACKET IN SYM TA
      INTEGER CHSP                       @ STARTING CHARACTER POSISITION
      INTEGER CHOUP                      @ INDEX TO STORE CHARACTERS
      INTEGER CHINP                     @ INDEX TO FETCH CHARACTERS
      INTEGER CHRLG                     @ ALLOCATED LENGTH OF CHARACTER STRING
          INTEGER CHRILG                @ LENGTH OF HOLERITH CONSTANT
      INTEGER CHRNU                     @ NUMBER OF CHARACTERS TO MOVE
      INTEGER CHRDUP                    @ FLAGS TO CATCH DUPLICATE LOADING
      INTEGER CHCH                      @ CURRENT CHARACTER BEING MOVED
      INTEGER CHFDAS/6/                 @ NUMBER CHARACTERS PER WORD
      INTEGER CHRRSA                    @ ORIGINAL RSA FOR A CHARACTER VARIABLE
      INTEGER CHRSBL                    @ OFFSET DUE TO SUBSCRIPTING
          INTEGER CRRASQ                 @ NON ZERO IF HOLERITH STRING IS ASCII
          INTEGER CHRASQ                 @ NON ZERO IF IDENTIFIER IS ASCII
      COMPLEX  CMPLX
      INTEGER  DATA(2)
      DIMENSION  NAMES(3) / 'WA','OPD','DPD' /  @ ARRAY NAMES FOR MESGS.D TO I
      EQUIVALENCE  (REAL,DPREC,CMPLX,DATA(1),INTGR)
      DATA  DG1,DG56,DG57,DG48,DG49,DG50,DGTBL,DGFTL,DGLNG / O30002,    D TO I
     1 4,5,O210006,O10007,O310010,O120011,O220012,3 / @ N6EMW ARGS.     D TO I
      DATA  DG100 / 15 /                     @ TYPE MISMATCH MESSAGE    IRA
      DATA DG20/O120024/    @ $ IS A SUBPROGRAM ARGUMENT
          INTEGER DQXRSA/ 22/ @ RSA IS TOO LARGE
C
      ARGUMENT MV6Q(L/A0/,C/LMJ(B11)/)
      ARGUMENT  EMROR (C/LMJ(B11)/)                                     RELOC
      INTEGER BOPARG(BOPMAX) / 3*0, O11300000000 /   @ BOP ARG LIST.    RELOC
      DEFINE  RSAN = H2(BOPARG(3))                                      RELOC
      DEFINE  STCL = H2(BOPARG(4))                                      RELOC
      EQUIVALENCE  (RSAX,BOPARG(3)), (STCX,BOPARG(4))                   RELOC
      DATA  BIDIN, BIDEX / O111,O212 /       @ INTERNAL, EXT IDS FOR BO RELOC
          DATA INCMSG/0/,HBLK/0/
C
C
C         INITIALIZE FOR NEW DATA STATEMENT.
      LOCSYM = LOC(SYM(1))-1            @ FORCE OUT COMPILER BUG.
      NXVI05 = 2                             @ PTR TO NXT WD IN VI05.
      SEQ=H2(VI20)       @ SEQUENCE NUMBER IN H2
      FLUSH = 0                              @ NOT FLUSH MODE.
      WARN = 0                               @ WARNING MESG FLAG.       IRA
      NMESG = 0                              @ LENGTH MISMATCH MESG FLG IRA
      CHRFL = 0                         @ SET CHARACTER MODE TO ZERO
          CHRILG= 0
      ASSIGN 190 TO FLSHSW                   @ SAME PURPOSE.
          DELETE 15,LMSC.NE.0
         IF  (S2(VI05).NE.0)    GO TO 10   @ SKIP DIAGNOSTIC IN MACRO   RELOC
        IF(VI05.GE.0)    GO TO 10
        IF(INCMSG.NE.0)     GO TO 10
          CALL P6EMW(0,DG1,0)       @ DATA IN INCLUDE
        INCMSG=INCMSG+1
15      @
10        @      JUMP AROUND FOR IGNORING MESSAGE FROM INCLUDE          RELOC
      IBMSAV = H1(COMDT)                     @ SAVE DATA=IBM STATUS.    DO J=$
C
C         INITIALIZE FOR NEW LIST/DATA STRING.
  100 ASSIGN 127 TO SRCHSW              @ SET SRCH FOR END STATEMENT.
      OPDT = 0                          @ TOP OF OPERAND PUSHDOWN.
      DPDT = 0                          @ TOP OF DO PUSHDOWN.
      REPCNT = 0                             @ NO ACTIVE REPEAT COUNT.
      ILNG = 0                               @ NO MULTIWORD DATA ITEM.
      LONG = 0                               @ NOT IN LONG-FLUSH MODE.
      ASSIGN 235 TO IBMSW                    @   SAME PURPOSE.
      RSAN = -1                         @ INDIC NOTHING YET OUTPUT.
      RULSW = 0                         @ INITIALIZE ASSIGNMENT RULE.
      H1(COMDT) = IBMSAV                     @ RESTORE DATA=IBM STATUS. DO J=$
C
C         MOVE A COMPLETE LIST/DATA STRING INTO WA.
C
  150 DO 200  WALNG=1,N6DSSL            @ WALNG PTS TO END OF WA STRG.
  151     IF (NXVI05.NE.NLF60I+1) GO TO 125       @ TEST END OF ITEM.
              CALL RFF60I ($9199)            @ GET NEXT F60 ITEM.       RELOC
              IF (ID6(VI05(1)).EQ.DSID) GO TO 120 @ TEST ITEM TYPE.     D TO I
                  IERR = 8                        @ NOT DATA STMT -
                  GO TO 9999                      @ OUTPUT MESSAGE.
  120         NXVI05 = 2
  125     GO TO SRCHSW                  @ DECIDE WHAT TO LOOK FOR.
  127     IF (ID(VI05(NXVI05)).EQ.EDSID) RETURN        @ SEEK END STMT
              ASSIGN 130 TO SRCHSW      @ SET SRCH FOR END LIST, TRY.
  130     IF (ID(VI05(NXVI05)).NE.ELID) GO TO 190      @ SEEK END LIST
              DPTR = WALNG+1            @ SET PTR TO DATA AREA.
              ASSIGN 135 TO SRCHSW      @ SET SRCH TO END DATA
              GO TO 190                 @ MOVE THE ITEM.
  135     IF (ILNG.EQ.0) GO TO 140           @ SEEK END DATA OR FLUSH.
              ILNG = ILNG - 1                @ BYPASS LITERALS.
              GO TO FLSHSW
  140     IDD = ID(VI05(NXVI05))-39          @ OBTAIN ID OF DATA ITEM.
          IF (IDD.NE.0) GO TO 144            @ NOT RELOC ITEM.          RELOC
          I = SRCHSW                         @ SAVE SRCHSW.             RELOC
          ASSIGN 141 TO SRCHSW               @ GO LOOK FOR OFFSET.      RELOC
          GO TO FLSHSW                                                  RELOC
  141     ASSIGN 142 TO SRCHSW               @ LOOK FOR END OF RELOC    RELOC
          GO TO FLSHSW                       @   ITEMS.                 RELOC
  142     IF (VI05(NXVI05).LT.0) SRCHSW = I  @ FIND END RELOC SPECS.    RELOC
          GO TO FLSHSW                                                  RELOC
  144     CONTINUE                                                      RELOC
          IF (IDD.LE.0.OR.IDD.GT.9) GO TO FLSHSW  @ BAD ITEM - PASS IT.
  145     GO TO (148,152,152,152,154,154,156,158,160), IDD
  148     GO TO FLSHSW                       @ REPEAT COUNT ITEM.
  152     ILNG = 1                           @ SINGLE-WORD CONST FOLLOWS
          GO TO FLSHSW
  154     ILNG = 2                           @ DBL-WORD CONST FOLLOWS
          GO TO FLSHSW
  156     ILNG = SYMP(VI05(NXVI05))          @ HOLLERITH STRING FOLLOWS
          GO TO FLSHSW
  158     IF (FLUSH.EQ.1) GO TO FLSHSW       @ END-DATA ITEM.
          GO TO 220
  160     IF (FLUSH.EQ.1) RETURN             @ END-STATEMENT ITEM.
          GO TO 998
  170     NXVI05 = NXVI05+1                  @ HERE IF FLSHSW IS ON.
          GO TO 151                          @ -DISABLES WA STORE
  190     WA(WALNG) = VI05(NXVI05)      @ MOVE THE WORD.
  195     NXVI05 = NXVI05 + 1
  200     CONTINUE
      IERR = 16               @ WA HAS OVERFLOWED.
      GO TO 9999              @ FATAL ERROR SITUATION.
C
C         STRING IS SECURE IN WA.  START LIST SCAN.
C
  220 LAP = 0                      @ INITIAL LIST AREA PTR.
      WA(WALNG) = VI05(NXVI05)     @ INSERT END DATA ITEM.
      NXVI05 = NXVI05+1
  230 GO TO IBMSW                            @ CONTINUE SCAN IF NOT FLUSH
  235 LAP = LAP + 1                          @ INCR LIST POINTER.
      IDC = ID(WA(LAP))            @ OBTAIN ID FIELD OF LIST ITEM.
      IF(CHRFL.LT.0) GO TO 720          @  READ CHARACTER SUBTABLE
      DO 250 I=1,SLIDT             @ SEARCH FOR ITEM DISPOSITION.
          IF (IDC.EQ.LIDT(I)) GO TO 260
  250     CONTINUE
  255 IERR = 24                    @ STRANGE LIST ITEM.
      GO TO 9999
C
C         BRANCH TO APPROPRIATE PROCESSING FOR THIS ITEM TYPE.
  260 GO TO     (300,   400,   500,   600,   700,   900,  1100,
C             VARREF  CONST  OFFST  BGNDO  DUMMY   OPER  ENDDO
     1         1200,  1300), I
C            STMTYPE  ELID
C
C         HERE FOR VARIABLE REFERENCE.  ASSUMES POSITIVE IF NOT SUBSCR.
300   IF(SYMM(INDX(WA(LAP))).EQ.'SUBST$') GO TO 350 @ CHARACTER DIRECTIVE
      IF (VRA (WA (LAP)).EQ.0) GO TO 340 @ JUMP IF SUBSCR VAR
      I = INDX(SYMP(WA(LAP)))                @ OBTAIN T/STC/RSA
      J = STCRSA(SYM(I+1))                   @   FROM SYM.
      PDTF(J) = TFLD(SYM(I+2))               @ ASSUME FLD NONDESTRUCT.
      CHRRSA = H2(J)                    @ SAVE ORIGINAL RSA
      IF (W3CF(SYM(I+2)).EQ.5) CRFL=1 ; CALL P6EMW(SEQ,DG20,SYM(I))
      K = 0                                  @ SET DIMENSIONALITY.
      IF (W3CF(SYM(I+2)).EQ.0) K = W3DF(SYM(I+2))
      PDDF(J) = K
      SYMREF = 1                             @ INDICATE NONIMMEDIATE.
C
C         INSERT J IN OPERAND PUSHDOWN, CONTINUE SCAN.
  320 OPDT = OPDT+1
      IF (OPDT.LE.N6DSOL) GO TO 330
      IERR = 17                              @ OPD OVERFLOW.
      GO TO 9999
  330 OPD(OPDT,1) = J                        @ INSERT THE ITEM.
      OPD(OPDT,2) = SYMREF                   @ INSERT THE SYMREF IND.
      GO TO 230
C
  340 J = SYMVAR(WA(LAP))                    @ SUBSCR VAR --- OBTAIN.
      SYMREF = 0                             @   INSERT IN OPD.
      GO TO 320
C
C
C     A SUBSTRING FUNCTION REFERENCE HAS BEEN FOUND
C     SET FLAG FOR CHARACTER ACTIVE AND GO AWAY
C     IN GOING AWAY DISCARD FUNCTION REFERENCE ITEM
350   H1(CHRFL) = 1                     @ FLAG TO TRAP DUMMY OPERATOR
      H2(CHRFL) = 1                     @ FLAG THAT CHARACTER IS ACTIVE
      GO TO 230                         @ GET NEXT ITEM
C         HERE FOR CONSTANT REFERENCE.  EXPECT SIGNED IMMEDIATE.
  400 IF (IDMOD(WA(LAP)).GT.1) GO TO 255     @ LOGICAL IS ERROR.
      IF (IDMOD(WA(LAP)).NE.0) GO TO 450                                GUARD
      J = SYMCON(WA(LAP))                    @ 0 = CONST IN SYM         GUARD
      GO TO 460                                                         GUARD
  450 J = IMCON(WA(LAP))                     @ 1 = IMMED CONST          GUARD
  460 SYMREF = 0                                                        GUARD
      GO TO 320                              @ INSERT IN OPD.
C
C         HERE FOR OFFSET ITEM.
  500 IF (IDMOD(WA(LAP)).EQ.0) GO TO 505  @ JUMP IF IN SYM.
      J = IMCON(WA(LAP))                  @ EVALUATE IMMED CONST
      GO TO 510
  505 J = SYMCON(WA(LAP))                 @ GET CONST IN SYM
  510 SYMREF = 0
      GO TO 320                              @ GO INSERT IN OPD.
C
C         HERE FOR BEGIN DO ITEM.  SET UP TBL ENTRY, SUBSCR VALUE.
  600 DOPRM(1) = INDX(SYMP(WA(LAP))) + 3     @ INDEX OF SUBSCR VAR
      IF (SYMP(WA(LAP)).NE.0) GO TO 604      @ IF INDUC VAR IS A PARAM, DO J=$
         DOPRM(1)=4+H2(CRISYM)-LOC(SYM)
          WA(LAP+2) = WA(LAP+1)              @   TRUNCATE THE 'LOOP',   DO J=$
          H1(COMDT) = 1                      @ FORCE DATA=IBM THIS LIST.DO J=$
  604 DO 610 I=1,3                           @ OBTAIN DO PARAMS ---     DO J=$
          IF (ID(WA(LAP+I)).NE.3) GO TO 605  @ TST FOR CONST.
              IF (IDMOD(WA(LAP+I)).NE.0) GO TO 606                      GUARD
              DOPRM(I+1) = SYMCON(WA(LAP+I))   @ 0 = CONST IN SYM       GUARD
              GO TO 610                                                 GUARD
  606         DOPRM(I+1) = IMCON(WA(LAP+I))    @ 1 = IMMED CONST        GUARD
              GO TO 610
  605     IF (ID(WA(LAP+I)).NE.2) GO TO 255  @ TST FOR VAR (ASSUME INDX)
              DOPRM(I+1) = SYMVAR(WA(LAP+I)) @   YES - EVALUATE.
  610     CONTINUE
      IF (DOPRM(4).NE.0.AND.(DOPRM(4)*(DOPRM(3)-DOPRM(2)).GE.0))GOTO 620
          IERR = 50                          @ INCORRECT SIGN OR ZERO
          GO TO 9999                         @   INCREMENT.
  620 SYMM(DOPRM(1)) = DOPRM(2)              @ INITIALIZE LOOP PARAM.
      DOPRM(2) = DOPRM(1)
      LAP = LAP+3                            @ MOVE LIST POINTER.
      DPDT = DPDT+1                          @ INSERT IN DO TABLE.
      IF (DPDT.LE.DPDL) GO TO 640            @ TEST OVERFLOW
      IERR = 18                              @ YES --- OUTPUT MESSAGE
      GO TO 9999
  640 DO 650 I = 1,3                         @ STASH THE ENTRY.
  650     DPD(DPDT,I) = DOPRM(I+1)
      DPD(DPDT,4) = LAP
      GO TO 230                              @ CONTINUE SCAN.
C
C         HERE FOR DUMMY (DROP-OUT) ITEM.  INSERT NULL IN OPRND PUSHDN.
700   IF (H1(CHRFL).NE.0) GO TO 710     @ CHARACTER ACTIVE
      J = 0                             @ SET UP NULL OPERAND
      SYMREF = 0
      GO TO 320                              @ GO STACK IN OPD.
710   H1(CHRFL) = -1                    @ FLAG TO READ CHARACTER SUBTABLE
      CHRIX = 0                          @ INDEX TO READ SUBTABLE
      CHRPCL = WA(LAP)                  @ POINTER TO  PACKET LOCATION IN SYMTAB
      GO TO 230                          @ CONTINUE SCAN
720   CHRIX = CHRIX +1                  @ ADVANCE FOR EACH ITEM OF SUBTABLE
      GO TO ( 721,   722,   721,   723,   721,   724 )  , CHRIX
C      TEST FOR A COMMA AND DISCARD IT
C      IF NOT A COMMA ERROR OUT
721   IF(S1(WA(LAP)).NE.8) GO TO  255   @ TEST OPERATOR CODE
      IF(S2(WA(LAP)).NE.17) GO TO 255    @  TEST FOR COMMA CODE
      GO TO 230                         @ GET NEXT ITEM
C      THE NEXT ITEM SHOULD BE THE FIRST CHARACTER POSISITION
722   IF(ID(WA(LAP)).EQ.3) GO TO 726        @ CONSTANT
      IF(ID(WA(LAP)).NE.2) GO TO 255    @ UNRECOGNIZED ITEM
      CHRFP = SYMVAR(WA(LAP))           @ GET VALUE OF PARAMETER
      GO TO 230                         @ GET NEXT ITEM
726   IF(IDMOD(WA(LAP)).GT.1) GO TO 255 @ LOGICAL BAD
      IF(IDMOD(WA(LAP)).NE.0) GO TO     728    @ IMMEDIATE CONSTANT
      CHRFP = SYMCON(WA(LAP))           @ VALUE OF CONSTANT
      GO TO 230                         @ GET NEXT ITEM
728   CHRFP = IMCON(WA(LAP))            @ IMMEDIATE CONSTANT
      GO TO 230                         @ GET NEXT ITEM
723   IF(ID(WA(LAP)).EQ.3) GO TO 730     @ CONSTANT
      IF(ID(WA(LAP)).NE.2) GO TO 255    @ UNRECOGNIZED ITEM
      CHRLP = SYMVAR(WA(LAP))           @ GET VALUE OF PARAMETER
      GO TO 230                         @ GET NEXT ITEM
730   IF(IDMOD(WA(LAP)).GT.1) GO TO 255 @ LOGICAL BAD
      IF(IDMOD(WA(LAP)).NE.0) GO TO 732 @ IMMEDIATE CONSTANT
      CHRLP = SYMCON(WA(LAP))           @ VALUE OF CONSTANT
      GO TO 230                         @ GET NEXT ITEM
732   CHRLP = IMCON(WA(LAP))             @ IMMEDIATE CONSTANT
      GO TO 230                         @ GET NEXT ITEM
724   IF(S1(WA(LAP)).NE.8) GO TO 255    @ UNRECOGNIZED ITEM
      IF(S2(WA(LAP)).NE.16) GO TO       255      @ UNRECOGNIZED ITEM
      H1(CHRFL) = 0                     @ CHARACTER TABLE BUILT
      GO TO 230                         @ GET NEXT ITEM
C
C         HERE FOR OPERATOR ITEM.  START BY POPPING UP 2 OPERANDS.
  900 IF (OPDT.GE.2) GO TO 905
  902 IERR = 28                              @ INSUFFICIENT OPERANDS.
      GO TO 9999                             @ (OR EXCESSIVE.)
  905 OPND2 = OPD(OPDT,1)                    @ OBTAIN OPERANDS.
      SR2 = OPD(OPDT,2)
      OPND1 = OPD(OPDT-1,1)
      SR1 = OPD(OPDT-1,2)
      OPDT = OPDT-2                          @ PURGE FROM STACK.
C
C         TEST FOR 'ADD' OPERATOR.
      MODR = IDMOD(WA(LAP))                  @ OBTAIN FUNCTION ID.
      IF (MODR.NE.10) GO TO 920              @ JMP IF NOT ADD.
  910 J = OPND1 + OPND2                      @ PERFORM OPER.
      GO TO 1090                             @ GO CHK OPND TYP, SAVE.
C
  920 IF (MODR.NE.12) GO TO 930              @ TEST FOR MULTIPLY.
      J = OPND1 * OPND2                      @ YES, PERFORM.
      GO TO 1090
C
  930 IF (MODR.EQ.19) GO TO 910              @ TREAT OFFST+ AS ADD.
C
      IF (MODR.NE.15) GO TO 940              @ TST FOR SUBSCR CONNECT.
      IF (SR2.LT.SR1) GO TO 935              @ JMP IF TYPES OK.
  932 IERR = 35                              @ INCORR OPND TYPES - EXIT
      GO TO 9999                             @ (MUST BE SYM S-C IMMED.)
  935 IF (OPND2.GE.0) GO TO 937              @ TST FOR SUBSCR UNDRFLOW.
      IERR = 48
      GO TO 9999
  937 RSA(OPND1) = RSA(OPND1) + OPND2        @ APPEND SUBSCR.
      J = OPND1                              @ GO INSERT COMPLETE
      SYMREF = 1                             @ REF IN OPRND PUSHDOWN.
      GO TO 320
C
  940 IF (MODR.EQ.1) GO TO 950               @ TEST FOR = OP
      IERR = 36                              @ NO - CANNOT EXECUTE
      GO TO 9999                             @   THIS OPERATOR.
C
  950 IF (SR1.NE.1.OR.OPND2.NE.0) GO TO 932  @ JMP IF NOT SYM = DUMMY.
      IF(H2(CHRFL).NE.0) GO TO 3000     @ CHARACTER ACTIVE
  951 HOLOUT = 0                             @ TURN OFF OUT-OF-HOLLER
      VTYP = PDTF(OPND1)                     @ OBTAIN VARIABLE TYPE.
      OCTINT = 0                             @ NOT OCTAL INTEGER.       IRA
      VLNG = 1                               @ SET CORRECT VARIABLE
      IF (VTYP.EQ.3.OR.VTYP.EQ.4) VLNG = 2   @   LENGTH.
C
C         OBTAIN A UNIT OF DATA, DEFINED AS ONE CONSTANT.  EXCEPTION
C         IS HOLLERITH --- VLNG WORDS SUPPLIED IF AVAILABLE FROM CURRENT
C         LITERAL.
C
      IF (RULSW.NE.0) GO TO 1005        @ *** INCORPORATE ASSIGN RULE **
  952 IF (ILNG.EQ.0) GO TO 960               @ TST FOR MORE HOLLERITH.
          IF (ILNG.GE.2.OR.VLNG.NE.2) GO TO 955  @ YES - SEE IF ENOUGH.
              VLNG = 1                       @ NO - SHORTEN, INDICATE
          DATA(2) = ' ' ; HBLK=1 @ ADD A BLANK TO DP - COMPLEX WORDS
  955     DO 957 I=1,VLNG                    @ PROVIDE HOLLERITH
              DATA(I) = WA(DPTR)             @   CONSTANT.
              DPTR = DPTR+1
  957         CONTINUE
          DTYP = 6                           @ INDICATE BOOLEAN DATA.
          ILNG = ILNG-VLNG                   @ DECR LIT LENGTH.
          DLNG = VLNG                        @ INDICATE CORRECT DATA LEN
          GO TO 1005                         @ GO CONVERT/OUTPUT.
C
  960 IF (REPCNT.LE.0) GO TO 970             @ TST FOR REPEAT(S) LEFT.
          DPTR = DPSAV                       @ YES - POINT BACK.
          REPCNT = REPCNT - 1                @   DECR REPEAT COUNT.
C
  970 IDD = ID(WA(DPTR))-DIDBAS              @ OBTAIN NEXT DATA TYPE.   RELOC
      IF (IDD.GT.0.AND.IDD.LE.DIDMAX) GO TO 980    @ CHECK VALIDITY.    RELOC
          IERR = 32                          @ BAD DATA ITEM.
          GO TO 9999
  980 GO TO (9800,982,984,986,988,990,992,994,996,998), IDD @ JMP ON TY RELOC
C             047  50  51  52  53  54  55  56  57  060                  RELOC
C                                                                       RELOC
 9800 DTYP = 0                          @ 47 @ RELOCATABLE DATA ITEM.   RELOC
      OCTINT = 1                             @ TURN OFF DIAGNSOTIC      RELOC
      DATA(1) = WA(DPTR+1)                   @ SET INITIAL OFFSETS.     RELOC
      BPTR = 5                               @ BOP LIST INDEX.          RELOC
      DO 9808 I=1,BMAX4                      @ LOOP ON RELOC SPECS.     RELOC
          S = S2(WA(DPTR+I+1))               @ FRST BIT OF RELOCATION   RELOC
      S3(BOPARG(BPTR))=35-S     @ SET IT IN BOP ARGUMENT
          L = S3(WA(DPTR+I+1))               @ LENGTH OF FIELD.         RELOC
      S4(BOPARG(BPTR))=ABS(35-(L-1))  @ LAST BIT FOR BOP
          SP = INDX(H2(WA(DPTR+I+1)))        @ SYM INDEX FOR RELOC.     RELOC
          ST = STC(SYM(SP+1))                @ STORAGE CLASS.           RELOC
          SC = W3CF(SYM(SP+2))               @ CLASS FOR SYM.           RELOC
          RS = RSA(SYM(SP+1))                                           RELOC
          IF (SC.EQ.2) GO TO 9802            @ JUMP IF EXTERNAL.        RELOC
          IF (SC.EQ.1) ST = CRSTC2           @ INTERNAL SUBR.           RELOC
          SL = 1                             @ ONE-WORD ITEM.           RELOC
          T1(BOPARG(BPTR)) = BIDIN           @ MARK INTERNAL FOR BOP.   RELOC
          GO TO 9804                                                    RELOC
 9802 BOPARG(BPTR+1)=ABS(ST-CRC-CRSTC4)
          ST = 0                             @ SET STC TO ZERO.         RELOC
          T1(BOPARG(BPTR)) = BIDEX           @ TWO-WOD ID               RELOC
          SL = 2                                                        RELOC
 9804     IF (FLD(5,1,WA(DPTR+I+1)).EQ.0) GO TO 9806   @ IF NEG RELOC,  RELOC
          ST = -ST                           @ COMPLEMENT STORAGE CLASS RELOC
          RS = -RS                           @   AND OFFSET.            RELOC
 9806     T3(BOPARG(BPTR)) = ST              @ SET STC IN BOPARG,       RELOC
          FLD(S,L,DATA(1)) = FLD(S,L,DATA(1))+RS   @ TACK ON OFFSET.    RELOC
      BPTR = BPTR+SL                         @ MOVE AHEAD.              RELOC
          IF (WA(DPTR+I+1).LT.0) GO TO 9810  @ END OF RELOC SPECS?      RELOC
          IF (BPTR.GE.BOPMAX) GO TO 9809     @  NO, CHK LIMIT.          RELOC
 9808     CONTINUE                                                      RELOC
 9809 IERR = 30                              @ TOO MANY                 RELOC
      GO TO 9999                             @   RELOCATION SPECS.      RELOC
 9810 S1(BOPARG(1)) = BPTR-1                 @ NUMBER OF WORDS.         RELOC
      DPTR = DPTR+I                          @ MOVE PAST ITEM.          RELOC
      GO TO 9850                             @ COMMON WORK.             RELOC
C
  982 REPCNT = SYMP(WA(DPTR)) - 1       @ 50 @ REPEATER - SET COUNT.
      DPTR = DPTR + 1                        @ POINT TO NEXT ITEM.
      DPSAV = DPTR                           @ SET LOOPING POINT.
      GO TO 970                              @ PROCESS NEXT ITEM.
C
  984 DTYP = 1                          @ 51 @ INTEGER IN NXT WORD.
      OCTINT = S6(WA(DPTR))                  @ PICK UP OCT. INT. FLAG   IRA
  985 DATA(1) = WA(DPTR+1)                   @ SET DATA(1)
 9850 DATA(2) = 0                                                       RELOC
      DPTR = DPTR + 2                        @ POINT TO NEXT ITEM.
      DLNG = 1                               @ SINGLE WORD LENGTH
      GO TO 1005                             @ CONVERT/OUTPUT.
C
  986 DTYP = 2                          @ 52 @ REAL IN NXT WORD.
      GO TO 985                              @ REST LIKE INTEGER.
  988 DTYP = 5                          @ 53 @ LOGICAL IN NEXT WORD.
      GO TO 985
C
  990 DTYP = 3                          @ 54 @ DOUBLE PRECISION IN NXT.
  991 DATA(1) = WA(DPTR+1)                   @ HAND OVER THE CONSTANT.
      DATA(2) = WA(DPTR+2)
          OCTINT = S6(WA(DPTR))
      DPTR = DPTR + 3                        @ SCOOT POINTER.
      DLNG = 2                               @ LENGTH = 2 WORDS.
      GO TO 1005                             @ CONVERT/OUTPUT.
  992 DTYP = 4                          @ 55 @ COMPLEX IN NXT.
      GO TO 991                              @ REST LIKE DBL PREC.
C
  994 ILNG = SYMP(WA(DPTR))             @ 56 @ HOLLERITH FOLLOWS.
      DPTR = DPTR + 1                        @ SET LNGTH, MOVE PTR,
      GO TO 952                              @ GO DOLE IT OUT.
C
  996 IF (H2(COMDT).EQ.0) GO TO 997     @ 57 @ END OF DATA. IF
      IF (DPDT.EQ.0) GO TO 997               @   DATA=SHORT AND
      SYMI = DPD(DPDT,1) - 3                 @   THERE IS AN ACTIVE
      IF (SYM(SYMI).EQ.'I$') GO TO 100       @   DO ON I$, FINE.
  997     IERR=56                            @ ELSE, LIST TOO LONG.
          GO TO 9999
C
  998 IERR = 33                         @ 58 @ END OF STATEMENT ---
      GO TO 9999                             @   INTERNAL ERROR.
C
C         NOW, WE CONVERT MODE (IF SPECIFIED) AND OUTPUT THE WORD(S).
C
 1005 IF (DTYP.EQ.0) GO TO 1007              @ RELOC TYPE NOT CONVETED  RELOC
      IF (CRCRDT.NE.0) GO TO 1020            @ JUMP IF DATA=CONV.       RELOC
      IF (VLNG.NE.DLNG) HOLOUT = 1           @ SET INDIC FOR DISAGR LTH
      IF (DTYP.EQ.VTYP) GO TO 1007           @ DATA-VAR TYPE MISMATCH   IRA
      IF (DTYP.GT.5) GO TO 1007              @ ALLOW HOLLERITH.         IRA
      IF (DATA(1).EQ.0) GO TO 1007           @ ALLOW ZERO IN ALL TYPES. IRA
      IF (OCTINT.NE.0) GO TO 1007            @ ALLOW OCTAL CONSTANTS.   IRA
      IF (WARN.NE.0) GO TO 1007              @ LIMIT TO ONE MESSAGE.    IRA
      WARN = 1                                                          IRA
      NMESG = 1                              @ TURN OFF LENGTH MSG TOO. IRA
      CALL P6EMW (STSEQ(WA(LAP+1)),DG100,0)  @ EDIT MISMATCH WARNING.   IRA
 1007 IF (ID(WA(LAP+1)).EQ.10) GO TO 1010    @ TST FOR STMT TYPE NXT
        IF (LONG.EQ.1) GO TO 1012            @ SKIP IF DATA=IBM FLUSHING
          IERR = 22                          @ NO- WRITE MESG.
          GO TO 9999
 1010 SEQ = STSEQ(WA(LAP+1))                 @ OBTAIN SEQUENCE.
 1012 STCL = STC(OPND1)                      @ SAVE STC FOR DATA=IBM.
      DIML = PDDF(OPND1)                     @ SAVE DIMENSIONALITY.
      RSAN = RSA(OPND1)                      @ NEXT RSA.
      OLNG = VLNG                            @ SET NO. OF WORDS TO OUTPT
      IF (CRFL.NE.0) GO TO 1016                                         RELOC
      IF (DLNG.LT.VLNG) OLNG = DLNG        @ DO NOT OUTPUT NULL WORD 2.
          J=OLNG+HBLK ; HBLK=0 @ HBLK IS 0 OR 1 FOR HOLERITH DP VAR
          DO 1015 I=1,J     @ NUMBER OF WORDS TO OUTPUT
         BOPARG(2)=DATA(I)             @ WORD TO OUTPUT
          IBLAP1 = H1(DATA(I))                                          RELOC
      X=DATA(I)
      IF (CRLIST.EQ.2) CALL WRDSP(SEQ,RSAX,IBLAP1,X,STCX)
          IF (DTYP.NE.0) S1(BOPARG(1)) = 4   @ SET 4-WORD ITEM.         RELOC
          IF ( FLD(18,2,BOPARG(3)).NE.0) CALL P6EMW (SEQ,DQXRSA,0)
     *    ; GO TO 10000
      CALL MV6Q(BOPARG)
          CALL EMROR                                                    RELOC
 1015     RSAN = RSAN + 1                    @ BUMP RSA.
 1016 RSAN = RSA(OPND1) + VLNG               @ NEXT FOR DATA=IBM.       RELOC
      LAP = LAP+1                            @ BYPASS STMT TYPE ITEM.
C
C       ********************   BREAK HERE TO INCORP ASSIGNMENT RULES ***
      IF (CRCRDT.NE.0) GO TO 1017
      RULSW = 0                                                         IRA
      IF (DLNG.LE.VLNG) GO TO 1017
      DATA(1) = DATA(2)
      DATA(2) = 0
      RULSW = 1
      DLNG = 1
 1017 CONTINUE
C            *****************************
C
      IF (OPDT.NE.0) GO TO 902               @ ERR IF OPD NOT EMPTY.
C
      IF (HOLOUT.EQ.0) GO TO 230             @ CONTINUE SCAN IF NO ERR.
      IF (NMESG.NE.0) GO TO 230              @ ONLY ONE MESSAGE.        IRA
      CALL  P6EMW (SEQ,DGLNG,0)              @ UNEQUAL LENGTH.          D TO I
          NMESG = 1                          @ TURN OFF MESSAGES.
          GO TO 230                          @ CONTINUE NORMALLY.
C
C         HERE WE PERFORM TYPE CONVERSION.
C
 1020 COMB = 7*(DTYP-1) + VTYP          @ PICK TYPE COMBINATION.
      IF (COMB.LE.0.OR.COMB.GT.49) GO TO 1030
      DLNG = VLNG                            @ FAKE IDENTICAL LENGTHS.
C
C         TYPE COMBINATION TABLE ---
C
C           .------------ VARIABLE TYPE ------------.    CONSTANT
C           INTGR  REAL DPREC  CPLX   LOG  BOOL   OCT      TYPE
C
      GO TO (1007, 1038, 1044, 1048, 1030, 1030, 1030, @ INTEGER
     1       1032, 1007, 1046, 1050, 1030, 1030, 1030, @ REAL
     2       1034, 1040, 1007, 1052, 1030, 1030, 1030, @ DOUBLE PREC
     3       1036, 1042, 1054, 1007, 1030, 1030, 1030, @ COMPLEX
     4       1030, 1030, 1030, 1030, 1007, 1030, 1030, @ LOGICAL
     5       1007, 1007, 1007, 1007, 1007, 1007, 1030, @ BOOLEAN(HOLL)
     6       1007, 1007, 1007, 1007, 1030, 1007, 1007),COMB @ OCTAL
C
C         1007 INDICATES NO CONVERSION NEEDED.
C
 1030 IERR = 49                              @ *ERROR* - CANNOT CONVERT
      GO TO 9999                             @   TYPES GIVEN.
C         CONVERSIONS ---
1032  INTGR = REAL
      GO TO 1007
 1034 INTGR = DPREC
      GO TO 1007
 1036 INTGR = CMPLX
      GO TO 1007
 1038 REAL = INTGR
      GO TO 1007
 1040 REAL = DPREC
      GO TO 1007
 1042 REAL = CMPLX
      GO TO 1007
 1044 DPREC = INTGR
      GO TO 1007
 1046 DPREC = REAL
      GO TO 1007
 1048 CMPLX = INTGR
      GO TO 1007
 1050 CMPLX = REAL
      GO TO 1007
 1052 REAL = DPREC
      CMPLX = REAL
      GO TO 1007
 1054 REAL = CMPLX
      DPREC = REAL
      GO TO 1007
C
 1090 SYMREF = 0
      IF ((SR1+SR2).EQ.0) GO TO 320          @ VERIFY IMMED-OP-IMMED.
      GO TO 932                              @ NO --- OUTPUT MESG.
C
C
C     HERE GENERATE LOADS FOR CHARACTER VARIABLES
3000  STCL = STC(OPND1)                 @ STORAGE CLASS
C         CALL TON8
      IF(ID(WA(LAP+1)).EQ.10)
      SEQ = STSEQ(WA(LAP+1))  ; LAP = LAP + 1
      ELSE
      IERR = 22  ;  GO TO 9999
      ENDIF
      RSAN = RSA (OPND1)                @ RELATIVE STORAGE ASSIGNMENT
      ICH = INDX(H2(CHRPCL))            @ GET LOCATION OF CHARACTER PACKET
C     NEXT GET ALLOCATED LENGTH OF CHARACTER STRING FOR CHECKING
C     ON WHETHER SUBSTRINGS EXCEED MAXIMUM LENGTH
          IF(S2(SYMM(ICH)).EQ.3) CHFDAS =4 ; ELSE ; CHFDAS = 6
      IF(S1(SYMM(ICH+1)).EQ.2) CHRLG = SYMVAR(SYMM(ICH+1)) ; GO TO 3002
      IF(S1(SYMM(ICH+1)).NE.3) IERR = 32 ; GO TO 9999 @ BAD DATA ITEM
      IF(IDMOD(SYMM(ICH+1)).NE.0)
      CHRLG = IMCON(SYMM(ICH+1))
           ELSE
           CHRLG = SYMCON(SYMM(ICH+1))
      ENDIF
3002
      CHRSBL = ABS((RSAN-CHRRSA)*CHRLG)
          IF (CHFDAS.EQ.4) XBLANK = ABLANK ; ELSE ; XBLANK = FBLANK
      RSAN = CHRRSA
          CHRLP = CHRLP +H2(SYMM(ICH))-1+CHRSBL
      CHSP = H2(SYMM(ICH)) +CHRSBL      @ ALLOCATED STARTING POSISITION
      CHSP = CHSP+CHRFP-1                 @ COMPUTE EFFECTIVE STARTING POSISITIO
      RSAN = RSAN +CHSP/CHFDAS          @ RSA OF FIRST WORD TO BE LOADED
      CHOUP = MOD(CHSP,CHFDAS)+1          @ STARTING CHARACTER WITHIN WORD
          IF(CHRILG.GT.0) GO TO 3001
      CHINP = 1                         @ STARTING POSISITION TO GET CHARACTER
      IF(S1(WA(DPTR)).NE.46) GO TO 1030 @ LITTERAL NOT HOLERITH
      ILNG = H2 (WA(DPTR))               @ LENGTH OF STRING IN WORDS
      CHRILG = FLD(7,11,WA(DPTR))       @ LENGTH IN CHARACTERS
          CRRASQ = FLD(6,1,WA(DPTR))    @ ASCII INDICATOR
      DPTR = DPTR+1                      @ ADVANCE LITTERAL COUNTER
3001  IF(CHRLG.LT.CHRLP-CHSP)  IERR=57 ; GO TO 9999     @ STRING EXCEEDS
      CHRNU = CHRLP-CHSP+1             @ NUMBER OF CHARACTERS TO MOVE
      BOPARG(2) = 0                     @ INITIALIZE FOR PART WORDS LOAD
      CHRDUP = 0                        @ FLAGS TO CATCH DUPLICATE LOADING OF CH
3100  CHRNU = CHRNU - 1                 @ CHARACTERS REMAINIG
      IF (CHRNU.GE.0)                   @ TEST MORE CHARACTERS TO MOVE
      CHRILG = CHRILG-1                 @ DECREASE CHARACTERS IN STRING
      IF(CHRILG.LT.0) DATA = XBLANK   @ FORCE REMAINIG CHARACTERS TO BLANKS
      IF(CHINP.EQ.1)                    @ ON S1 TEST FOR NEW WORD OF DATA
          IF(CHRILG.GE.0) ILNG = ILNG-1 @ COUNT HOLERIT WORDS
           IF(CHRILG.GE.0)
           DATA = WA(DPTR)              @ GET NEXT WORD OF DATA
           DPTR = DPTR+1
           ELSE
           DATA = XBLANK         @ FINISH STRING OUT WITH BLANKS
           ENDIF
      ENDIF
          IF (CRRASQ.EQ.0)
      GO TO ( 3101, 3102, 3103, 3104, 3105, 3106), CHINP
3101  CHCH = S1(DATA)
      GO TO 3110
3102  CHCH = S2(DATA)
      GO TO 3110
3103  CHCH = S3(DATA)
      GO TO 3110
3104  CHCH = S4(DATA)
      GO TO 3110
3105  CHCH = S5(DATA)
      GO TO 3110
3106  CHCH = S6(DATA)
3110  CHINP = CHINP+1                   @ TEST END OF WORD
      IF(CHINP.EQ.7) CHINP = 1          @ SET FIRST CHARACTER NEXT WORD
      GO TO ( 3151, 3152, 3153, 3154, 3155, 3156 ) , CHOUP
3151  S1(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,32)
      GO TO 3160
3152  S2(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,16)
      GO TO 3160
3153  S3(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,8)
      GO TO 3160
3154  S4(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,4)
      GO TO 3160
3155  S5(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,2)
      GO TO 3160
3156  S6(BOPARG(2)) = CHCH
      CHRDUP = OR(CHRDUP,1)
      IBLAP1 = H1(BOPARG(2))
      X = BOPARG(2)
      IF(CRLIST.EQ.2) CALL WRDSP(SEQ,RSAX,IBLAP1,X,STCX)
      S6(BOPARG(1)) = CHRDUP            @ SET DUP TEST FLAGS
      CALL CHSRPT(BOPARG)               @ ADD ENTRY TO SORT FILE
      CHOUP = 0                         @ RESET TO NEXT WORD
      RSAN = RSAN + 1                   @ ADVANCE TO NEXT WORD
      BOPARG(2) = 0                     @ INITIALIZE FOR PART WORD LOADS
      CHRDUP = 0                        @ INITIALIZE TO CATCH DUPLICATE LOADS
3160  CHOUP = CHOUP +1                  @ ADVANCE TO NEXT CHARACTER
      GO TO 3100
          ELSE
          GO TO (3201,3202, 3203, 3204) , CHINP
3201      CHCH = Q1(DATA)
          GO TO 3210
3202      CHCH = Q2(DATA)
          GO TO 3210
3203      CHCH = Q3(DATA)
          GO TO 3210
3204      CHCH = Q4(DATA)
3210      CHINP = CHINP+1
          IF(CHINP.EQ.5) CHINP =1 @ SET FIRDT CHARACTER NEXT WORS
          GO TO ( 3251, 3252, 3253, 3254 ), CHOUP
3251      Q1(BOPARG(2)) = CHCH
          CHRDUP = OR(CHRDUP,8)
          GO TO 3260
3252      Q2(BOPARG(2)) = CHCH
          CHRDUP = OR(CHRDUP,4)
          GO TO 3260
3253      Q3(BOPARG(2)) = CHCH
          CHRDUP = OR(CHRDUP,2)
          GO TO 3260
3254      Q4(BOPARG(2)) = CHCH
          CHRDUP = OR(CHRDUP,1)
      IBLAP1 = H1(BOPARG(2))
      X = BOPARG(2)
      IF(CRLIST.EQ.2) CALL WRDSP(SEQ,RSAX,IBLAP1,X,STCX)
      S6(BOPARG(1)) = CHRDUP            @ SET DUP TEST FLAGS
      CALL CHSRPT(BOPARG)               @ ADD ENTRY TO SORT FILE
      CHOUP = 0                         @ RESET TO NEXT WORD
      RSAN = RSAN + 1                   @ ADVANCE TO NEXT WORD
      BOPARG(2) = 0                     @ INITIALIZE FOR PART WORD LOADS
      CHRDUP = 0                        @ INITIALIZE TO CATCH DUPLICATE LOADS
3260      CHOUP = CHOUP + 1  @ ADVANCE TO NEXT CHARACTER
          GO TO 3100
          ENDIF
      ENDIF                             @ FINISH WHILE STARTED AT 3100
      IBLAP1 = H1(BOPARG(2))
      X = BOPARG(2)
      IF(BOPARG(2).NE.0)
      IF(CRLIST.EQ.2) CALL WRDSP(SEQ,RSAX,IBLAP1,X,STCX)
      S6(BOPARG(1)) = CHRDUP            @ SET DUP TEST FLAGS
      CALL CHSRPT(BOPARG)               @ ADD ENTRY TO SORT FILE
      ENDIF
      GO TO 230                         @ PROCESS NEXT ITEM
C
C         HERE FOR END DO ITEM.
 1100 IF (DPDT.GT.0) GO TO 1105              @ IS THERE AN ACTIVE DO
      IERR = 19                              @   NO --- OUTPUT MESG.
      GO TO 9999
 1105 I = DPD(DPDT,1)                        @ OBTAIN SYM INDEX OF VAR
      SYM(I) = SYM(I) + DPD(DPDT,3)          @ INCR THE SUBSCR VAR
      IF (DPD(DPDT,3).LT.0) GO TO 1150       @ JMP IF NEG INCR.
      IF (SYM(I).GT.DPD(DPDT,2)) GO TO 1190  @ JMP IF END LOOP.
 1110 LAP = DPD(DPDT,4)                      @ MOVE SCAN BACK,
      GO TO 230                              @ RESTART LOOP.
 1150 IF (SYM(I).GE.DPD(DPDT,2)) GO TO 1110  @ TST FOR NEG INCR COMPL.
 1190 DPDT = DPDT-1                          @ DO COMPLETE - POP UP
      GO TO 230                              @   DO TABLE, CONTINUE.
C
C         HERE FOR STATEMENT TYPE ITEM.  NOT RIGHT, OUT OF CONTEXT.
 1200 IERR = 21
      GO TO 9999
C
C         HERE FOR END LIST ITEM.
 1300 IF ((DPDT+OPDT).EQ.0) GO TO 1350       @ CHECK FOR EMPTY PUSHDNS.
      IERR = 20                              @ NO - ERROR.
      GO TO 9999
 1350 IF (((REPCNT+ILNG).EQ.0) .AND. (ID(WA(DPTR)).EQ.EDID) .AND.
     1     (RULSW.EQ.0))   GO TO 100         @ TEST FOR NO MORE DATA.
      IF (H1(COMDT).NE.0) GO TO 1400         @ JMP IF DATA=IBM.
      IERR = 57                              @ EXCESS DATA.
      GO TO 9999
C
 1400 IF (RSAN.NE.-1) GO TO 1410
 1405     IERR = 57                          @ IF NULL LIST, GIVE
          GO TO 9999                         @   EXCESS DATA MESG.
 1410 ASSIGN 1430 TO IBMSW                   @ TELL EARLIER CODE WHAT'S
      LONG = 1                               @   UP.
      IF (DIML.EQ.0) GO TO 1405              @ REFUSE DATA=IBM ON SCALARS.
 1430 RSA(OPND1) = RSAN                      @ GO SIMULATE = OP.
      STC(OPND1) = STCL
      PDTF(OPND1) = VTYP
      PDDF(OPND1) = DIML
      GO TO 951
C
C         HERE IF SOME ERROR HAS OCCURRED.
 9999 IF (FLUSH.EQ.1.AND.IERR.EQ.8) RETURN  @ VALID COND DURING FLUSH.
      H1(COMDT) = IBMSAV                     @ PROTECT DATA=IBM STATUS. DO J=$
C
      IF (IERR.EQ.56.AND.LONG.NE.0) GO TO 100  @ NORMAL FOR DATA=IBM.
      IF (IERR-56) 9020,9000,9010                                           MO
 9000 CALL  P6EMW (SEQ,DG56,0)               @ LIST TOO LONG.               MO
      GO TO 100                                                             MO
 9010 CALL  P6EMW (SEQ,DG57,0)               @ TOO MUCH DATA.               MO
      GO TO 100                                                             MO
 9020 IF (IERR.LT.48) GO TO 9100                                            MO
      IF (IERR-49) 9030,9040,9050                                           MO
 9030 CALL  P6EMW (SEQ,DG48,OPND2+1)         @ SUBSCRIPT .LE. 0             MO
      GO TO 100                                                             MO
 9040 CALL  P6EMW (SEQ,DG49,0)               @ BAD CONVERSION.              MO
      GO TO 100                                                             MO
 9050 CALL  P6EMW (SEQ,DG50,DOPRM(1)-3)      @ BAD DO INCR.                 MO
      GO TO 100                                                             MO
 9100 IF (IERR.LT.16.OR.IERR.GT.18) GO TO 9200                              MO
      X=NAMES(IERR-15) ; CALL P6EMW(SEQ,DGTBL,X) @ TABLE OVERFLOW
      GO TO 10000                                                           MO
 9199 IERR=1                                 @ PREMATURE END F60.       RELOC
 9200 CALL  P6EMW (SEQ,DGFTL,IERR*1000+LAP)  @ INTERFACE ERROR.             MO
10000 FLUSH = 1                              @ RETURN 1 FOR *ERROR* ---
      ASSIGN 135 TO SRCHSW                   @ SET UP F60 READ ROUTINE
      ASSIGN 170 TO FLSHSW                   @   TO FLUSH CURR STMT.
      IF (ID(VI05(1)).NE.DSID) RETURN
      GO TO 150
C
      END
