      program main

      INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA,
     *    STACK, DOLIST, DOPT, OUTUT2, OUTUT3, PDSA, OUTUT4, REF, PREF,
     *    PNODE, PLAT, PCOM, COM
      LOGICAL ERR, SYSERR, OPT, P1ERR, ABORT, P2
      LOGICAL SW, QBR
      COMMON /SWS/ SW(10)
C*****SWS
C     SW(1) (LOG) IF TRUE, CAN USE END= OPTION IN READ STMTS
C
      COMMON /OPTNS/ OPT(5), P1ERR
C
C*****OPTNS
C     OPT(1) (LOG) IF TRUE, SYMBOL TABLE PRINTED FOR EACH P. U.
C     OPT(2) (LOG) IF TRUE, CROSS REFERENCES PRINTED FOR EACH SYMBOL
C     OPT(3) (LOG) IF TRUE, PASS 2 IS EXECUTED
C     OPT(4) (LOG) IF TRUE, LISTING PRINTED FOR EACH P. U.
C     OPT(5) (LOG) IF TRUE, FORTRAN PGM COMPILED AFTER VERIFIER
C     RUN;  IF ANY OF THESE ARE FALSE THE CORRESPONDING ACTION IS NOT TA
C     P1ERR (LOG) SET TO TRUE IF INFO NORMALLY SAVED FOR PASS 2 IS
C     SUPPRESSED FOR THIS P. U.
C
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C*****INPUT
C     NSTMT (INT) INDEX OF END-OF-INPUT-STMT CHARACTER IN STMT
C     PSTMT (INT) POINTS TO CURRENT POSITION IN STMT (EXCEPT IN LEXICAL
C     SUBPGMS WHERE IT IS UPDATED IN CALLING SUBPGM AFTER A TOKEN IS
C     FOUND)
C     STMT (INT) ENCODED FORM OF DEBLANKED INPUT STMT
C
      COMMON /CEXPRS/ LSTACK, STACK(620)
C
C*****CEXPRS
C     LSTACK (INT) LENGTH OF STACK
C     STACK(*), (INT) ARRAY USED IN EXPR AS A STACK; ALSO FOR AUXILLARY
C     STORAGE AND OUTPUT
C
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
C
C*****PARAMS
C     INUT (INT) LOGICAL INPUT NUMBER FOR THE HOST MACHINE
C     OUTUT (INT) LOGICAL OUTPUT NUMBER FOR THE HOST MACHINE
C     NOCHAR (INT) NUMBER OF CHARACTERS PER MACHINE WORD IN HOST
C     SYMLEN (INT) NUMBER OF WORDS NECESSARY ON HOST TO STORE 6
C     CHARACTERS (I.E. A FORTRAN SYMBOL)
C     OUTUT2 (INT), OUTUT3(INT), OUTUT4(INT) LOGICAL OUTPUT NUMBERS
C     FOR THE HOST MACHINE TO BE USED BY THE VERIFIER FOR INTERPASS
C     COMMUNICATION
C
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
C
C*****FACTS
C     NAME (INT) INDEX IN SYMBOL TABLE OF ENTRY FOR CURRENT P.U.
C     NOST (INT) STMT NUMBER OF CURRENT STMT BEING PROCESSED
C     ITYP (INT) TYPE OF STMT CURRENTLY BEING PROCESSED (SEE PU
C     FOR FURTHER DOC)
C
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C*****DETECT
C     ERROR (LOG) SET TO TRUE IN VARIOUS SUBPGMS USUALLY TO CEASE PROCES
C     OF CURRENT STMT
C     SYSERR (LOG) IRRECOVERABLE ERROR IN SYSTEM; (E.G., TABLE OVERFLOW)
C     IN PASS 1 CAUSES CURRENT P.U. TO HAVE AN END STMT SIMULATED AND
C     EXECUTION PROCEDES TO NEXT P.U.;  IN PASS 2 CAUSES PROCESSING
C     OF PROGRAM TO CEASE.
C
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
C
C*****TABL
C     NEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM DSA(1))
C     LABHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
C     LABELS IN P.U.
C     SYMHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
C     SYMBOLS IN P.U.
C     BNEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM
C     DSA(LDSA))
C
      COMMON /CHASH/ LHASH, HASH(401)
C
C*****CHASH
C     LHASH (INT) LENGTH OF HASH ARRAY
C     HASH (*) (INT) HASH TABLE USED TO INDEX INTO DSA
C
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C*****CTABL
C     LDSA (INT) LENGTH OF DSA
C     DSA(*) (INT) SYMBOL TABLE (SEE LOOKUP FOR MORE EXPLICIT DOC)
C
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
C
C*****DOS
C     DOPT (INT) POINTER TO FIRST FREE WORD IN DOLIST
C     LDO (INT) LENGTH OF DOLIST
C     DOLIST (*) (INT) ARRAY USED AS STACK FOR NESTING OF DOS (USED
C     TO TEST FOR LEGAL BRANCHING WITHIN P.U. (SEE DOSPEC FOR FURTHER
C     DOC)
C
      COMMON /LISTDO/ LPT, LEN, LS(64)
C
C*****LISTDO
C     LPT (INT) POINTER TO FIRST FREE WORD IN LS
C     LEN (INT) LENGTH OF LS
C     LS (*) (INT) ARRAY USED AS STACK FOR NESTING OF IMPLIED
C     DO'S IN INPUT/OUTPUT STMTS (SEE DOSPEC FOR FURTHER DOC)
C
      COMMON /PASS/ P2, QBR
C
C*****PASS
C     P2 (LOG) IF TRUE, VERIFIER IS IN PASS 2; ELSE VERIFIER IS IN PASS
C     QBR (LOG) IF TRUE, VERIFIER IS TO PRINT ERROR MESSAGES
C     ELSE IS NOT
C
      COMMON /CREF/ LREF, PREF, REF(100)
C
C*****CREF
C     LREF (INT) TOTAL LENGTH OF ARRAY REF
C     PREF (INT) CURRENT LENGTH OF REF
C     REF (*) (INT) ARRAY CONTAINING INFORMATION CONCERNING A SUBR/FCN
C     REF (SEE SETREF FOR FURTHER DOC)
C
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
C
C*****HEAD
C     LNODE (INT) LENGTH OF NODE
C     PNODE (INT) POINTER TO NEXT FREE WORD IN NODE
C     NODE (*) (INT) ARRAY OF INDICES OF P.U. ENTRIES IN LAT
C
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C*****GRAPH
C     LLAT (INT) LENGTH OF LAT
C     PLAT (INT)  POINTER TO NEXT FREE WORD IN LAT
C     LAT (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH P.U. IN PGM
C     AND THEIR INTER-RELNS (SEE SETNOD FOR FURTHER DOC)
C
      COMMON /COMS/ LCOM, PCOM, COM(300)
C
C*****COMS
C     LCOM (INT) LENGTH OF COM
C     PCOM (INT) POINTER TO NEXT FREE WORD IN COM
C     COM (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH COMMON BLOCK
C     IN PGM (SEE  SETCOM FOR FURTHER DOC)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /SCR2/ LNNODE, NNODE(500)
C
C***SCR1,SCR2,SCR3
C     INODE(INT), NNODE(INT) SCRATCH ARRAYS KEYED ON LENGTH NODE(*)
C     LINNODE = LNNODE .GE. MAX( LNODE, LCOM/(SYMLEN+5) )
C
C     THREE MORE BLOCK COMMON REGIONS ARE USED : STS -SEE TYPST
C     TRANS - SEE MAPCHR EXPRS - SEE EXPR FOR FURTHER DOC
C
      QBR = .FALSE.
      NOCHAR = 4
      INUT = 5
      OUTUT = 6
      OUTUT2 = 7
      OUTUT3 = 8
      OUTUT4 = 9
C	NOCHAR WAS &, OUT2-4 was 12,13,14 in distribution tape
      REWIND INUT
      REWIND OUTUT2
      REWIND OUTUT3
      REWIND OUTUT4
      LEN = 64
      SYMLEN = (5/NOCHAR) + 1
      P2 = .FALSE.
      ERR = .FALSE.
      ABORT = .FALSE.
      SYSERR = .FALSE.
      SW(1) = .FALSE.
      PDSA = 1
      LDSA = 5000
      LHASH = 401
      DO 10 I=1,LHASH
        HASH(I) = 0
   10 CONTINUE
      OPT(1) = .TRUE.
      OPT(2) = .TRUE.
      OPT(3) = .TRUE.
      OPT(4) = .TRUE.
      OPT(5) = .FALSE.
      LSTACK = 620
      LREF = 100
      PREF = 1
      LDO = 192
      CALL OVRLAY(1)
      CALL PU
      IF (.NOT.OPT(3) .OR. SYSERR) GO TO 30
      P2 = .TRUE.
      IF (.NOT.OPT(4)) WRITE (OUTUT,99999)
99999 FORMAT (1H1)
      CALL OVRLAY(2)
      LLAT = 6000
      PLAT = 1
      BNEXT = LDSA
      NEXT = 1
      LNODE = 500
      PNODE = 1
      LCOM = 300
      PCOM = 1
      LINODE = LNODE
      LNNODE = LNODE
C
C     PASS 1 CAN SUPPRESS PASS 2 PROCESSING FOR SPECIFIC P.U.
C     BUT NEVER SHUTS OFF PASS 2 COMPLETELY;  PASS 2 CAN CEASE
C     PROCESSING FOR VARIOUS REASONS:
C      1. 2 SUBPRGMS WITH SAME NAME(IN SETNOD)
C      2. NO PROGRAM UNIT SUCCESSFULLY PASSED TO PASS 2
C       (IN CONSTR)
C      3. RECURSION (IN ASLEV AND INVOKE)
C     IF MISSING SUBPRGMS ARE DISCOVERED, PASS 2 CAN
C     PROCEDE WITH INCOMPLETE PROCESSING, A MESSAGE
C     IS PRINTED TO INFORM THE USER
C
      REWIND OUTUT2
      REWIND OUTUT3
      REWIND OUTUT4
      CALL CONSTR(IROOT)
C     CAN RETURN FROM CONSTR IN ERROR CONDITION WITH FILES LACKING
C     VERIFIER SOFTWARE END OF FILE
      IF (ABORT .OR. SYSERR) GO TO 30
      REWIND OUTUT4
      REWIND OUTUT3
      REWIND OUTUT2
      CALL CHECKS(IROOT)
   20 REWIND INUT
      CALL OVRLAY(3)
      CALL COMPIL(.NOT.(ABORT.OR.SYSERR).AND.OPT(5))
      STOP
   30 WRITE (OUTUT,99998)
99998 FORMAT (47H1INTER-PROGRAM-UNIT COMMUNICATIONS NOT VERIFIED)
      GO TO 20
      END
      BLOCK DATA BLOCK0
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C                            PFORT VERIFIER
C
C                              B. G. RYDER
C                              A. D. HALL
C
C           BELL LABORATORIES, MURRAY HILL, NEW JERSEY 07974
C
C
C       COPYRIGHT C 1978,  BELL  TELEPHONE  LABORATORIES,  INCOR-
C       PORATED.   GENERAL  PERMISSION  IS  GRANTED  TO  MAKE AND
C       DISTRIBUTE UNMODIFIED COMPLETE COPIES  OF  THIS  COMPUTER
C       PROGRAM, BUT NOT FOR PROFIT, PROVIDED THAT THIS COPYRIGHT
C       NOTICE AND STATEMENT ARE INCLUDED.
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
      INTEGER Z
      COMMON /INTS/ Z(346)
      DATA Z(1) /3/
      DATA Z(2) /1HA/
      DATA Z(3) /1HB/
      DATA Z(4) /1HS/
      DATA Z(5) /201/
      DATA Z(6) /4/
      DATA Z(7) /1HI/
      DATA Z(8) /1HA/
      DATA Z(9) /1HB/
      DATA Z(10) /1HS/
      DATA Z(11) /210/
      DATA Z(12) /4/
      DATA Z(13) /1HD/
      DATA Z(14) /1HA/
      DATA Z(15) /1HB/
      DATA Z(16) /1HS/
      DATA Z(17) /192/
      DATA Z(18) /4/
      DATA Z(19) /1HA/
      DATA Z(20) /1HI/
      DATA Z(21) /1HN/
      DATA Z(22) /1HT/
      DATA Z(23) /201/
      DATA Z(24) /3/
      DATA Z(25) /1HI/
      DATA Z(26) /1HN/
      DATA Z(27) /1HT/
      DATA Z(28) /202/
      DATA Z(29) /5/
      DATA Z(30) /1HI/
      DATA Z(31) /1HD/
      DATA Z(32) /1HI/
      DATA Z(33) /1HN/
      DATA Z(34) /1HT/
      DATA Z(35) /194/
      DATA Z(36) /4/
      DATA Z(37) /1HA/
      DATA Z(38) /1HM/
      DATA Z(39) /1HO/
      DATA Z(40) /1HD/
      DATA Z(41) /329/
      DATA Z(42) /3/
      DATA Z(43) /1HM/
      DATA Z(44) /1HO/
      DATA Z(45) /1HD/
      DATA Z(46) /338/
      DATA Z(47) /5/
      DATA Z(48) /1HA/
      DATA Z(49) /1HM/
      DATA Z(50) /1HA/
      DATA Z(51) /1HX/
      DATA Z(52) /1H0/
      DATA Z(53) /273/
      DATA Z(54) /5/
      DATA Z(55) /1HA/
      DATA Z(56) /1HM/
      DATA Z(57) /1HA/
      DATA Z(58) /1HX/
      DATA Z(59) /1H1/
      DATA Z(60) /265/
      DATA Z(61) /4/
      DATA Z(62) /1HM/
      DATA Z(63) /1HA/
      DATA Z(64) /1HX/
      DATA Z(65) /1H0/
      DATA Z(66) /274/
      DATA Z(67) /4/
      DATA Z(68) /1HM/
      DATA Z(69) /1HA/
      DATA Z(70) /1HX/
      DATA Z(71) /1H1/
      DATA Z(72) /266/
      DATA Z(73) /5/
      DATA Z(74) /1HD/
      DATA Z(75) /1HM/
      DATA Z(76) /1HA/
      DATA Z(77) /1HX/
      DATA Z(78) /1H1/
      DATA Z(79) /256/
      DATA Z(80) /5/
      DATA Z(81) /1HA/
      DATA Z(82) /1HM/
      DATA Z(83) /1HI/
      DATA Z(84) /1HN/
      DATA Z(85) /1H0/
      DATA Z(86) /273/
      DATA Z(87) /5/
      DATA Z(88) /1HA/
      DATA Z(89) /1HM/
      DATA Z(90) /1HI/
      DATA Z(91) /1HN/
      DATA Z(92) /1H1/
      DATA Z(93) /265/
      DATA Z(94) /4/
      DATA Z(95) /1HM/
      DATA Z(96) /1HI/
      DATA Z(97) /1HN/
      DATA Z(98) /1H0/
      DATA Z(99) /274/
      DATA Z(100) /4/
      DATA Z(101) /1HM/
      DATA Z(102) /1HI/
      DATA Z(103) /1HN/
      DATA Z(104) /1H1/
      DATA Z(105) /266/
      DATA Z(106) /5/
      DATA Z(107) /1HD/
      DATA Z(108) /1HM/
      DATA Z(109) /1HI/
      DATA Z(110) /1HN/
      DATA Z(111) /1H1/
      DATA Z(112) /256/
      DATA Z(113) /5/
      DATA Z(114) /1HF/
      DATA Z(115) /1HL/
      DATA Z(116) /1HO/
      DATA Z(117) /1HA/
      DATA Z(118) /1HT/
      DATA Z(119) /209/
      DATA Z(120) /4/
      DATA Z(121) /1HI/
      DATA Z(122) /1HF/
      DATA Z(123) /1HI/
      DATA Z(124) /1HX/
      DATA Z(125) /202/
      DATA Z(126) /4/
      DATA Z(127) /1HS/
      DATA Z(128) /1HI/
      DATA Z(129) /1HG/
      DATA Z(130) /1HN/
      DATA Z(131) /329/
      DATA Z(132) /5/
      DATA Z(133) /1HI/
      DATA Z(134) /1HS/
      DATA Z(135) /1HI/
      DATA Z(136) /1HG/
      DATA Z(137) /1HN/
      DATA Z(138) /338/
      DATA Z(139) /5/
      DATA Z(140) /1HD/
      DATA Z(141) /1HS/
      DATA Z(142) /1HI/
      DATA Z(143) /1HG/
      DATA Z(144) /1HN/
      DATA Z(145) /320/
      DATA Z(146) /3/
      DATA Z(147) /1HD/
      DATA Z(148) /1HI/
      DATA Z(149) /1HM/
      DATA Z(150) /329/
      DATA Z(151) /4/
      DATA Z(152) /1HI/
      DATA Z(153) /1HD/
      DATA Z(154) /1HI/
      DATA Z(155) /1HM/
      DATA Z(156) /338/
      DATA Z(157) /4/
      DATA Z(158) /1HS/
      DATA Z(159) /1HN/
      DATA Z(160) /1HG/
      DATA Z(161) /1HL/
      DATA Z(162) /193/
      DATA Z(163) /4/
      DATA Z(164) /1HR/
      DATA Z(165) /1HE/
      DATA Z(166) /1HA/
      DATA Z(167) /1HL/
      DATA Z(168) /217/
      DATA Z(169) /5/
      DATA Z(170) /1HA/
      DATA Z(171) /1HI/
      DATA Z(172) /1HM/
      DATA Z(173) /1HA/
      DATA Z(174) /1HG/
      DATA Z(175) /217/
      DATA Z(176) /4/
      DATA Z(177) /1HD/
      DATA Z(178) /1HB/
      DATA Z(179) /1HL/
      DATA Z(180) /1HE/
      DATA Z(181) /200/
      DATA Z(182) /5/
      DATA Z(183) /1HC/
      DATA Z(184) /1HM/
      DATA Z(185) /1HP/
      DATA Z(186) /1HL/
      DATA Z(187) /1HX/
      DATA Z(188) /331/
      DATA Z(189) /5/
      DATA Z(190) /1HC/
      DATA Z(191) /1HO/
      DATA Z(192) /1HN/
      DATA Z(193) /1HJ/
      DATA Z(194) /1HG/
      DATA Z(195) /219/
      DATA Z(196) /3/
      DATA Z(197) /1HE/
      DATA Z(198) /1HX/
      DATA Z(199) /1HP/
      DATA Z(200) /713/
      DATA Z(201) /4/
      DATA Z(202) /1HD/
      DATA Z(203) /1HE/
      DATA Z(204) /1HX/
      DATA Z(205) /1HP/
      DATA Z(206) /704/
      DATA Z(207) /4/
      DATA Z(208) /1HC/
      DATA Z(209) /1HE/
      DATA Z(210) /1HX/
      DATA Z(211) /1HP/
      DATA Z(212) /731/
      DATA Z(213) /4/
      DATA Z(214) /1HA/
      DATA Z(215) /1HL/
      DATA Z(216) /1HO/
      DATA Z(217) /1HG/
      DATA Z(218) /713/
      DATA Z(219) /4/
      DATA Z(220) /1HD/
      DATA Z(221) /1HL/
      DATA Z(222) /1HO/
      DATA Z(223) /1HG/
      DATA Z(224) /704/
      DATA Z(225) /4/
      DATA Z(226) /1HC/
      DATA Z(227) /1HL/
      DATA Z(228) /1HO/
      DATA Z(229) /1HG/
      DATA Z(230) /731/
      DATA Z(231) /6/
      DATA Z(232) /1HA/
      DATA Z(233) /1HL/
      DATA Z(234) /1HO/
      DATA Z(235) /1HG/
      DATA Z(236) /1H1/
      DATA Z(237) /1H0/
      DATA Z(238) /713/
      DATA Z(239) /6/
      DATA Z(240) /1HD/
      DATA Z(241) /1HL/
      DATA Z(242) /1HO/
      DATA Z(243) /1HG/
      DATA Z(244) /1H1/
      DATA Z(245) /1H0/
      DATA Z(246) /704/
      DATA Z(247) /3/
      DATA Z(248) /1HS/
      DATA Z(249) /1HI/
      DATA Z(250) /1HN/
      DATA Z(251) /713/
      DATA Z(252) /4/
      DATA Z(253) /1HD/
      DATA Z(254) /1HS/
      DATA Z(255) /1HI/
      DATA Z(256) /1HN/
      DATA Z(257) /704/
      DATA Z(258) /4/
      DATA Z(259) /1HC/
      DATA Z(260) /1HS/
      DATA Z(261) /1HI/
      DATA Z(262) /1HN/
      DATA Z(263) /731/
      DATA Z(264) /3/
      DATA Z(265) /1HC/
      DATA Z(266) /1HO/
      DATA Z(267) /1HS/
      DATA Z(268) /713/
      DATA Z(269) /4/
      DATA Z(270) /1HD/
      DATA Z(271) /1HC/
      DATA Z(272) /1HO/
      DATA Z(273) /1HS/
      DATA Z(274) /704/
      DATA Z(275) /4/
      DATA Z(276) /1HC/
      DATA Z(277) /1HC/
      DATA Z(278) /1HO/
      DATA Z(279) /1HS/
      DATA Z(280) /731/
      DATA Z(281) /4/
      DATA Z(282) /1HT/
      DATA Z(283) /1HA/
      DATA Z(284) /1HN/
      DATA Z(285) /1HH/
      DATA Z(286) /713/
      DATA Z(287) /4/
      DATA Z(288) /1HS/
      DATA Z(289) /1HQ/
      DATA Z(290) /1HR/
      DATA Z(291) /1HT/
      DATA Z(292) /713/
      DATA Z(293) /5/
      DATA Z(294) /1HD/
      DATA Z(295) /1HS/
      DATA Z(296) /1HQ/
      DATA Z(297) /1HR/
      DATA Z(298) /1HT/
      DATA Z(299) /704/
      DATA Z(300) /5/
      DATA Z(301) /1HC/
      DATA Z(302) /1HS/
      DATA Z(303) /1HQ/
      DATA Z(304) /1HR/
      DATA Z(305) /1HT/
      DATA Z(306) /731/
      DATA Z(307) /4/
      DATA Z(308) /1HA/
      DATA Z(309) /1HT/
      DATA Z(310) /1HA/
      DATA Z(311) /1HN/
      DATA Z(312) /713/
      DATA Z(313) /5/
      DATA Z(314) /1HD/
      DATA Z(315) /1HA/
      DATA Z(316) /1HT/
      DATA Z(317) /1HA/
      DATA Z(318) /1HN/
      DATA Z(319) /704/
      DATA Z(320) /5/
      DATA Z(321) /1HA/
      DATA Z(322) /1HT/
      DATA Z(323) /1HA/
      DATA Z(324) /1HN/
      DATA Z(325) /1H2/
      DATA Z(326) /841/
      DATA Z(327) /6/
      DATA Z(328) /1HD/
      DATA Z(329) /1HA/
      DATA Z(330) /1HT/
      DATA Z(331) /1HA/
      DATA Z(332) /1HN/
      DATA Z(333) /1H2/
      DATA Z(334) /832/
      DATA Z(335) /4/
      DATA Z(336) /1HD/
      DATA Z(337) /1HM/
      DATA Z(338) /1HO/
      DATA Z(339) /1HD/
      DATA Z(340) /832/
      DATA Z(341) /4/
      DATA Z(342) /1HC/
      DATA Z(343) /1HA/
      DATA Z(344) /1HB/
      DATA Z(345) /1HS/
      DATA Z(346) /729/
      END
      BLOCK DATA BLOCK1
      INTEGER EX(4,4), PT, PB, AO(4,4), RO(3,3)
      COMMON /EXPRS/ PT, PB, AO, RO, EX
      DATA AO(1,1), AO(1,2), AO(2,1) /3*0/, AO(1,3), AO(1,4), AO(3,1),
     *    AO(3,2), AO(4,1), AO(4,3) /6*-1/, AO(2,2) /1/, AO(3,3) /2/,
     *    AO(4,4), AO(2,4), AO(4,2) /3*3/, AO(3,4), AO(2,3) /2*-1/
      DATA RO(1,1), RO(1,2), RO(2,1), RO(2,2), RO(3,3) /5*4/, RO(1,3),
     *    RO(2,3), RO(3,1), RO(3,2) /4*-1/
      DATA EX(1,1) /0/, EX(1,2) /0/, EX(1,3) /0/, EX(1,4) /-1/, EX(2,1)
     *    /0/, EX(2,2) /1/, EX(2,3) /1/, EX(2,4) /-1/, EX(3,1) /-1/,
     *    EX(3,2) /-1/, EX(3,3) /2/, EX(3,4) /-1/, EX(4,1) /-1/,
     *    EX(4,2) /-1/, EX(4,3) /3/, EX(4,4) /-1/
      END
      BLOCK DATA BLOCK2
C
      COMMON /TRANS/ Q(70)
      INTEGER Q
C
      DATA Q(1) /1H0/, Q(2) /1H1/, Q(3) /1H2/, Q(4) /1H3/, Q(5) /1H4/
      DATA Q(6) /1H5/, Q(7) /1H6/, Q(8) /1H7/, Q(9) /1H8/, Q(10) /1H9/
C
      DATA Q(31) /1HA/, Q(32) /1HB/, Q(33) /1HC/, Q(34) /1HD/, Q(35) /
     *    1HE/
      DATA Q(36) /1HF/, Q(37) /1HG/, Q(38) /1HH/, Q(39) /1HI/, Q(40) /
     *    1HJ/
      DATA Q(41) /1HK/, Q(42) /1HL/, Q(43) /1HM/, Q(44) /1HN/, Q(45) /
     *    1HO/
      DATA Q(46) /1HP/, Q(47) /1HQ/, Q(48) /1HR/, Q(49) /1HS/, Q(50) /
     *    1HT/
      DATA Q(51) /1HU/, Q(52) /1HV/, Q(53) /1HW/, Q(54) /1HX/, Q(55) /
     *    1HY/
      DATA Q(56) /1HZ/
C
      DATA Q(61) /1H+/, Q(62) /1H-/, Q(63) /1H)/, Q(64) /1H=/, Q(65) /
     *    1H./
      DATA Q(66) /1H(/, Q(67) /1H*/, Q(68) /1H//, Q(69) /1H,/, Q(70) /
     *    1H /
      END
      BLOCK DATA BLOCK3
      INTEGER K(186), KI(30), KT(30)
      COMMON /STS/ K, KI, KT
      DATA K(1) /33/, K(2) /44/, K(3) /50/, K(4) /31/, K(5) /41/, K(6)
     *    /34/, K(7) /45/, K(8) /47/, K(9) /34/, K(10) /32/, K(11)
     *    /38/, K(12) /48/, K(13) /38/, K(14) /44/, K(15) /43/
      DATA K(16) /47/, K(17) /34/, K(18) /30/, K(19) /41/
      DATA K(20) /38/, K(21) /43/, K(22) /49/, K(23) /34/, K(24) /36/,
     *    K(25) /34/, K(26) /47/
      DATA K(27) /32/, K(28) /44/, K(29) /42/, K(30) /45/, K(31) /41/,
     *    K(32) /34/, K(33) /53/, K(34) /41/, K(35) /44/, K(36) /36/,
     *    K(37) /38/, K(38) /32/, K(39) /30/, K(40) /41/
      DATA K(41) /34/, K(42) /53/, K(43) /49/, K(44) /34/, K(45) /47/,
     *    K(46) /43/, K(47) /30/, K(48) /41/, K(49) /33/, K(50) /38/,
     *    K(51) /42/, K(52) /34/, K(53) /43/, K(54) /48/, K(55) /38/,
     *    K(56) /44/, K(57) /43/, K(58) /32/, K(59) /44/, K(60) /42/,
     *    K(61) /42/, K(62) /44/, K(63) /43/, K(64) /48/, K(65) /50/,
     *    K(66) /31/, K(67) /47/, K(68) /44/, K(69) /50/, K(70) /49/,
     *    K(71) /38/, K(72) /43/, K(73) /34/
      DATA K(74) /35/, K(75) /50/, K(76) /43/, K(77) /32/, K(78) /49/,
     *    K(79) /38/, K(80) /44/, K(81) /43/, K(82) /31/, K(83) /41/,
     *    K(84) /44/, K(85) /32/, K(86) /40/, K(87) /33/, K(88) /30/,
     *    K(89) /49/, K(90) /30/, K(91) /34/, K(92) /46/, K(93) /50/,
     *    K(94) /38/, K(95) /51/, K(96) /30/, K(97) /41/, K(98) /34/,
     *    K(99) /43/, K(100) /32/, K(101) /34/, K(102) /33/, K(103)
     *    /30/, K(104) /49/, K(105) /30/
      DATA K(106) /30/, K(107) /48/, K(108) /48/, K(109) /38/, K(110)
     *    /36/, K(111) /43/, K(112) /36/, K(113) /44/, K(114) /49/,
     *    K(115) /44/, K(116) /47/, K(117) /34/, K(118) /49/, K(119)
     *    /50/, K(120) /47/, K(121) /43/
      DATA K(122) /32/, K(123) /44/, K(124) /43/, K(125) /49/, K(126)
     *    /38/, K(127) /43/, K(128) /50/, K(129) /34/, K(130) /32/,
     *    K(131) /30/, K(132) /41/, K(133) /41/, K(134) /48/, K(135)
     *    /49/, K(136) /44/, K(137) /45/, K(138) /38/, K(139) /35/,
     *    K(140) /33/, K(141) /44/, K(142) /45/, K(143) /30/, K(144)
     *    /50/, K(145) /48/, K(146) /34/
      DATA K(147) /47/, K(148) /34/, K(149) /30/, K(150) /33/, K(151)
     *    /52/, K(152) /47/, K(153) /38/, K(154) /49/, K(155) /34/,
     *    K(156) /47/, K(157) /34/, K(158) /52/, K(159) /38/, K(160)
     *    /43/, K(161) /33/, K(162) /34/, K(163) /43/, K(164) /33/,
     *    K(165) /35/, K(166) /38/, K(167) /41/, K(168) /34/, K(169)
     *    /31/, K(170) /30/, K(171) /32/, K(172) /40/, K(173) /48/,
     *    K(174) /45/, K(175) /30/, K(176) /32/, K(177) /34/, K(178)
     *    /34/, K(179) /43/, K(180) /33/
      DATA K(181) /35/, K(182) /44/, K(183) /47/, K(184) /42/, K(185)
     *    /30/, K(186) /49/
      DATA KI(1) /15/, KI(2) /4/, KI(3) /7/, KI(4) /7/, KI(5) /7/,
     *    KI(6) /8/, KI(7) /9/, KI(8) /6/, KI(9) /10/, KI(10) /8/,
     *    KI(11) /9/, KI(12) /11/, KI(13) /4/, KI(14) /6/, KI(15) /4/,
     *    KI(16) /6/, KI(17) /8/, KI(18) /4/, KI(19) /4/, KI(20) /2/,
     *    KI(21) /2/, KI(22) /5/, KI(23) /4/, KI(24) /5/, KI(25) /6/,
     *    KI(26) /7/, KI(27) /9/, KI(28) /3/, KI(29) /6/, KI(30) /0/
      DATA KT(1), KT(2), KT(3), KT(4), KT(5), KT(6), KT(7), KT(8)
     *    /8*1/, KT(9), KT(10), KT(11) /3*0/, KT(12) /2/, KT(13) /3/,
     *    KT(14), KT(15), KT(16), KT(17), KT(18), KT(19), KT(20),
     *    KT(21), KT(22), KT(23), KT(24), KT(25), KT(26), KT(27)
     *    /14*5/, KT(29), KT(30) /2*5/, KT(28) /6/
      END
      SUBROUTINE COMPIL(FLAG)
C
      LOGICAL FLAG
C
      RETURN
C
      END
      SUBROUTINE OVRLAY(N)
C
      RETURN
C
      END
      SUBROUTINE SATT1(INDEX, FIELD, ATT)
C
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
      INTEGER INDEX, FIELD, ATT
      INTEGER LDSA, PDSA, DSA
      INTEGER FWTH(8), FPOS(8)
C
      DATA FWTH(1) /16/, FPOS(1) /1/
      DATA FWTH(2) /2/, FPOS(2) /16/
      DATA FWTH(3) /2/, FPOS(3) /32/
      DATA FWTH(4) /2/, FPOS(4) /64/
      DATA FWTH(5) /2/, FPOS(5) /128/
      DATA FWTH(6) /2/, FPOS(6) /256/
      DATA FWTH(7) /4/, FPOS(7) /512/
      DATA FWTH(8) /32/, FPOS(8) /2048/
C
      DSA(INDEX) = DSA(INDEX) + (ATT-MOD(DSA(INDEX)/FPOS(FIELD),
     *    FWTH(FIELD)))*FPOS(FIELD)
C
      RETURN
C
      END
      INTEGER FUNCTION IGATT1(INDEX, FIELD)
C
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
      INTEGER INDEX, FIELD
      INTEGER LDSA, PDSA, DSA
      INTEGER FWTH(8), FPOS(8)
C
      DATA FWTH(1) /16/, FPOS(1) /1/
      DATA FWTH(2) /2/, FPOS(2) /16/
      DATA FWTH(3) /2/, FPOS(3) /32/
      DATA FWTH(4) /2/, FPOS(4) /64/
      DATA FWTH(5) /2/, FPOS(5) /128/
      DATA FWTH(6) /2/, FPOS(6) /256/
      DATA FWTH(7) /4/, FPOS(7) /512/
      DATA FWTH(8) /32/, FPOS(8) /2048/
C
      IGATT1 = MOD(DSA(INDEX)/FPOS(FIELD),FWTH(FIELD))
C
      RETURN
C
      END
      INTEGER FUNCTION EXCH(J1, J2, DSA, LDSA, HASH, LHASH, OFFSET)
      INTEGER DSA(LDSA), HASH(LHASH), OFFSET
      INTEGER OUTUT, SYMLEN, OUTUT2, OUTUT3, OUTUT4
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
C
C     DSA(HASH(J1)+OFFSET) CONTAINS ELE TO BE COMPARED
C      DSA(HASH(J2)+OFFSET) CONTAINS ELE TO BE COMPARED
C
      JJ1 = HASH(J1) + OFFSET
      JJ2 = HASH(J2) + OFFSET
      DO 40 I=1,SYMLEN
        K1 = JJ1 + I - 1
        K2 = JJ2 + I - 1
        IF (DSA(K1)) 10, 20, 20
   10   IF (DSA(K2)) 30, 50, 50
   20   IF (DSA(K2)) 70, 30, 30
   30   IF (DSA(K1)-DSA(K2)) 70, 40, 50
   40 CONTINUE
C
C     COMPARISON SHOWS ELEMENTS IN PROPER ORDER
C
   50 EXCH = 0
   60 RETURN
C
C     COMPARISON SHOWS NEED FOR EXCHANGE
C
   70 I = HASH(J1)
      HASH(J1) = HASH(J2)
      HASH(J2) = I
      EXCH = -1
      GO TO 60
      END
      SUBROUTINE SSORT(EX, X, LX, Q, L, OFFSET)
      INTEGER EX, X(LX), Q(L), OFFSET
      EXTERNAL EX
C
C     ENTRIES SPACED 1 APART IN HASH TABLE
C     EX IS EXCHANGE ROUTINE--RETURNS<0 IF EXCHANGES ITEMS
C     RETURNS >=0 IF DOESN'T
C     L  IS NUMBER OF THINGS TO BE SORTED,  SPACING IS 1 HERE
C     START SHELL SORT
C
      M = 1
   10 IF (M.GE.L) GO TO 20
      M = M*2
      GO TO 10
   20 M = M/2
      IF (M.LT.1) RETURN
      K = L - M
C
C      IN PASS1 ARE SORTING SYMBOL TABLE
C      IN PASS 2 ARE SORTING LATTICE
C     OR COMMON BLOCK DEFS
C
      DO 50 J=1,K
        I = J
   30   IF (EX(I+M,I,X,LX,Q,L,OFFSET)) 40, 50, 50
C
C     BUBBLE SORT W/I SUBLIST
C
   40   I = I - M
        IF (I.GE.1) GO TO 30
   50 CONTINUE
      GO TO 20
      END
      SUBROUTINE ERROR1(MESS, LMESS)
C
      INTEGER MESS(20), LMESS
      INTEGER ZERO(1)
C
      DATA ZERO(1) /0/
C
      CALL ERROR2(MESS, LMESS, ZERO(1), ZERO(1), 1, 1)
C
      RETURN
C
      END
      SUBROUTINE ERROR2( I,  JJ, K, NN, SPBEF, SPAFT )
C
C     PRINTS ERROR MESSAGES AND SYMBOLIC NAME
C     I IS PACKED HOLLERITH STRING
C     JJ IS NUMBER OF CHARACTERS TO BE PRINTED ( N = JJ)
C     K CONTAINS INTEGER OR HOLLERITH INFO TO FOLLOW MESSAGE
C     NN CONTROLS TYPE OF LINE TO BE PRINTED
C
C     NN = 0 MEANS PRINT MESSAGE
C
C     NN < 0 MEANS IF JJ=0 NO MESSAGE, ELSE PRINT MESSAGE
C     ON NEXT LINE IF NN = -1 PRINT PGM UNIT AND/OR STMT NO
C     (CONTROLLED BY CONTENTS OF K).
C     ON NEXT LINE IF NN = -2 PRINT PARAMETER NUMBER IN K
C     NN = -3 USED FOR SPACING CONTROL IN LONG MESSAGES
C
C     NN > 0 MEANS PRINT MESSAGE FOLLOWED BY IDENTIFIER IN K
C     SPBEF, SPAFT CONTROL LINE SPACING BEFORE AND AFTER MESSAGE
C     IF = 1, BLANK LINE EMMITTED
C
      INTEGER I(1), J(80), OUTUT, PDSA, DSA, M(6), K(6), W
      INTEGER SPBEF, SPAFT
      LOGICAL OPT, P1ERR, P2, QBR
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, I1, I2, I3, I4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /PASS/ P2, QBR
      DATA W /1HW/, KK /1H-/
C
C     ERROR IN P.U. DURING PROCESSING OF A HEADING STMT, SPECIFI STMT,
C     EQUIV STMT, OR DATA STMT CAUSES PASS 2 TO BE SUPPRESSED FOR THAT
C     P.U.
C
      IF (QBR) GOTO 45
      IF(SPBEF.EQ.1) WRITE(OUTUT, 99998)
      N = JJ
      IF (N.GT.72) N = 72
      J(2) = KK
      IF (N.GE.1) CALL S5UNPK(I, J, N)
      IF (ITYP.LT.14 .AND. J(2).NE.W) P1ERR = .TRUE.
      IF (NN) 50, 10, 30
C
C     NN=0
C
   10 CONTINUE
      WRITE (OUTUT,99997) (J(L),L=1,N)
      IF(P2 .OR. OPT(4)) GOTO 40
      CALL S5UNPK(DSA(NAME+4), J(1), 6)
      WRITE (OUTUT,99999) NOST, (J(L),L=1,6)
99999 FORMAT (16H *** AT STMT NO , I6, 13H IN PGM UNIT , 6A1)
99998 FORMAT(1H )
      GO TO 40
C
C     NN>0
C
   30 CONTINUE
      IF (N.GT.68) N = 68
      CALL S5UNPK(K, J(73), 6)
      WRITE (OUTUT,99997) (J(L),L=1,N), KK, KK, (J(L),L=73,78)
99997 FORMAT (4H ***, 76A1)
 40   IF(SPAFT.EQ.1) WRITE(OUTUT, 99998)
 45   RETURN
C
C     NN<0
C
   50 CONTINUE
      IF (N.GE.1) WRITE (OUTUT,99997) (J(L),L=1,N)
      IF( -2.EQ.NN ) GOTO 70
      IF( -3.EQ.NN ) GOTO 40
      CALL S5UNPK(DSA(NAME+4), M(1), 6)
C     WRITE OUT STMT NO AND/OR PGM UNIT
      IF (K(1).EQ.0) GO TO 60
      WRITE (OUTUT,99996) K(1), (M(L),L=1,6)
99996 FORMAT (16H *** AT STMT NO , I6, 1X, 13H IN PGM UNIT , 6A1)
      GO TO 40
   60 WRITE (OUTUT,99995) (M(L),L=1,6)
99995 FORMAT (17H *** IN PGM UNIT , 6A1)
      GO TO 40
C     WRITE OUT PARAMETER NO FOR PARAMETERLIST ERRORS
 70   WRITE(OUTUT,99994) K(1)
99994 FORMAT(22H *** PARAMETER NUMBER ,I6)
      GOTO 40
      END
      LOGICAL FUNCTION ARDECL(K2, KK)
C
C     K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT
C     KK IS SYMBOL TABLE INDEX FOR THIS ARRAY
C     PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS.
C     CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE.
C     ENTERS INTO SYMBOL TABLE AND TYPES ID;  SETS USAGE ON ARRAY
C     DECLARATOR
C     CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS
C     VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS.
C     ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES
C     IT OFF ARRAY SYMBOL TABLE ENTRY.  -1 LENGTH INDICATES VARIABLE
C     DIMENSION
C     CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT.
C
C     ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS
C     FALSE FOR ARRAYS AND VARIABLES
C     CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV.
C     STMT ;  IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS
C     NEGATIVE.
C
      LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH
      INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      ERR = .FALSE.
      FLUSH = .FALSE.
      ARRY = .FALSE.
      CORNER = .TRUE.
      ARDECL = .FALSE.
C
C     CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR;
C     CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO
C     ARRY=.TRUE.
C
      ICNT = 0
      CALL NEXTOK(PSTMT, K2, I1)
      IF (I1.EQ.0) GO TO 10
      CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      ERR = .TRUE.
      GO TO 280
   10 IF (STMT(K2).EQ.65) ARRY = .TRUE.
      KK = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 70
      ARDECL = .TRUE.
      L = IGATT1(KK,8)
      IF (L.EQ.0 .OR. L.EQ.10) GO TO 30
      IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30
   20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45)
      ERR = .TRUE.
      GO TO 280
C
C     SET TYPE (EXPLICITLY FOR TYPE STMTS)
C
   30 I1 = IGATT1(KK,1)
      IF (ITYP.GE.6) GO TO 50
C
C     TYPE EXPLICITLY
C
      IF (I1.GE.8) GO TO 40
      CALL SATT1(KK, 1, ITYP+7)
      GO TO 60
   40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34)
      GO TO 60
C
C     TYPE IMPLICITLY
C
   50 IF (I1.GT.0) GO TO 60
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(KK, 1, I1)
C
C     IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE
C
C     CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT
C
   60 IF (ARRY) GO TO 80
      IF (IGATT1(KK,7).EQ.0) GO TO 65
      IF (ITYP.EQ.12)
     1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE
     2  , 46)
      IF (ITYP.EQ.13)
     1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39)
   65 CONTINUE
      I1 = IGATT1(KK,4)
      IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR.
     *    ITYP.EQ.13))) GO TO 70
      ERR = .TRUE.
      CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32)
   70 RETURN
   80 ISIZ = 1
      VAR = .FALSE.
      IF (L.EQ.0) CALL SATT1(KK, 8, 10)
C
C     LOOP TO FIND BOUNDS;  CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS
C     SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT
C     ALREADY SET
C     ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT.
C     CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS
C
      L = IGATT1(KK,7)
      IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90
      IF (L.EQ.0) GO TO 100
      CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44)
      ERR = .TRUE.
      GO TO 270
   90 IF (L.EQ.0) CALL ERROR1(
     *    44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44)
  100 IF (K2+1.LT.NSTMT) GO TO 120
  110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28)
      GO TO 270
C
C     CHECK FOR POSITIVE INTEGER BOUND
C
  120 PSTMT = K2 + 1
      IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130
      IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL
      IF (ITYP.NE.12) GO TO 170
      IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE.
      GO TO 170
C
C     SEEK A VARIABLE BOUND
C
  130 CALL NEXTOK(PSTMT, I1, L)
      IF (L.NE.0) GO TO 110
      IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140
      CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32)
      ERR = .TRUE.
      GO TO 270
  140 VAR = .TRUE.
      L = LOOKUP(I1,.FALSE.)
      IF (SYSERR) GO TO 70
      N = IGATT1(L,8)
      IF (N.NE.0 .AND. N.NE.10) GO TO 20
      I2 = IGATT1(L,4)
      IF (I2.EQ.1) GO TO 150
      CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42)
      ERR = .TRUE.
      GO TO 270
  150 I2 = IGATT1(KK,4)
      IF (I2.EQ.1) GO TO 160
      CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT,
     *    50)
      ERR = .TRUE.
      GO TO 270
  160 CALL SATT1(L, 6, 1)
      CALL SATT1(L, 8, 10)
      N = IGATT1(L,1)
      IF (N.GT.0) GO TO 170
      N = 1
      IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2
      CALL SATT1(L, 1, N)
      GO TO 170
C
C     FIND "," AND ACCUMULATE LENGTH
C
  170 ICNT = ICNT + 1
      IF (ICNT.LE.3) GO TO 180
      ISIZ = ISIZ/LL
      CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30)
      ICNT = 3
      FLUSH = .TRUE.
      GO TO 190
  180 K2 = I1
      IF (STMT(K2).EQ.68) GO TO 100
C
C     FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT
C
      IF (STMT(K2).NE.62) GO TO 110
  190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260
      CALL SATT1(KK, 7, ICNT)
C
C     STORE LENGTH OF ARRAY
C
      IF (VAR) GO TO 240
      IF (DSA(KK+2).EQ.0) GO TO 200
      N = DSA(KK+2)
      DSA(N) = ISIZ
      GO TO 220
  200 IF (NEXT+2.GE.BNEXT) GO TO 210
      DSA(KK+2) = NEXT
      DSA(NEXT) = ISIZ
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 220
  210 SYSERR = .TRUE.
      CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33)
  220 IF (FLUSH) GO TO 270
  230 K2 = K2 + 1
      GO TO 70
C
C     FIXUP FOR VARIABLY DIMENSIONED ARRAYS
C
  240 IF (DSA(KK+2).EQ.0) GO TO 250
      N = DSA(KK+2)
      DSA(N) = -1
      GO TO 220
  250 IF (NEXT+2.GE.BNEXT) GO TO 210
      DSA(KK+2) = NEXT
      DSA(NEXT) = -1
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 220
C
C     CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT
C
  260 IF (ITYP.NE.12) GO TO 220
      IF (CORNER) KK = -KK
      GO TO 220
C
C     CODE TO FLUSH CONSTRUCT--TO NEXT ")"
C
  270 IF (K2.EQ.NSTMT) GO TO 70
      IF (STMT(K2).EQ.62) GO TO 230
      K2 = K2 + 1
      GO TO 270
C
C     CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/"
C
  280 K = 90
      IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67
  290 IF (K2.EQ.NSTMT) GO TO 70
      L = STMT(K2)
      IF (L.EQ.65) GO TO 270
      IF (L.EQ.68 .OR. L.EQ.K) GO TO 70
      K2 = K2 + 1
      GO TO 290
      END
      SUBROUTINE ASSASF(IGP)
      INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD
      LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
C
C     PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS
C     FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT
C
      CALL NEXTOK(PSTMT, K2, K)
      ASF = .FALSE.
      IF (K.NE.0) GO TO 180
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      I1 = IGATT1(K,1)
      IF (I1.NE.0) GO TO 10
      I1 = 1
      IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2
      CALL SATT1(K, 1, I1)
C
C     LOOK FOR A "("  ; FIND ARRAY = CASE AND SEND IT TO ERROR
C     FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO
C     ASSIGNMENT CODE
C
   10 I2 = IGATT1(K,7)
      I1 = MOD(I1,8)
      IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180
      IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240
C
C     ASF DEFN
C
      ITYP = 31
      ASF = .TRUE.
      IGP = 4
      NUM = 0
      IASF = K
   20 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
C
C     ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET
C
      CALL NEXTOK(PSTMT, K2, I)
      IF (I.EQ.0) GO TO 30
      CALL ERROR1(17H ILLEGAL ASF DEFN, 17)
      GO TO 190
   30 I = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      NUM = NUM + 1
      I2 = IGATT1(I,1)
      IF (I2.GT.0) GO TO 40
      I2 = 1
      IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2
      CALL SATT1(I, 1, I2)
   40 I2 = IGATT1(I,8)
      IF (I2.EQ.0) GO TO 50
      IF (I2.EQ.1) GO TO 60
      CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29)
      GO TO 210
   50 CALL SATT1(I, 8, 1)
C     STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL
C     TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE
   60 DSA(I+2) = K
C
C     LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA
C
      IF (DSA(K+2).EQ.0) GO TO 120
      L = DSA(K+2)
   70 IF (DSA(L+1).EQ.0) GO TO 80
      L = DSA(L+1)
      GO TO 70
   80 IF (NEXT+2.LT.BNEXT) GO TO 100
   90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33)
      SYSERR = .TRUE.
      GO TO 190
  100 DSA(L+1) = NEXT
  110 DSA(NEXT) = I
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 130
  120 IF (NEXT+2.GE.BNEXT) GO TO 90
      DSA(K+2) = NEXT
      GO TO 110
  130 IF (STMT(K2).NE.62) GO TO 170
C
C     CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID
C
      I2 = DSA(K+2)
      DO 160 I=1,NUM
        L = DSA(K+2)
        DO 150 J=1,NUM
          IF (I.EQ.J) GO TO 140
          IF (DSA(L).NE.DSA(I2)) GO TO 140
          CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18)
          CALL SATT1(K, 8, 0)
          GO TO 190
  140     L = DSA(L+1)
  150   CONTINUE
        I2 = DSA(I2+1)
  160 CONTINUE
      GO TO 200
  170 IF (STMT(K2).EQ.68) GO TO 20
  180 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
  190 RETURN
C
C     = AND EXPR CHECK
C
  200 PSTMT = K2 + 1
  210 IF (PSTMT.GE.NSTMT) GO TO 180
      IF (STMT(PSTMT).NE.63) GO TO 180
      PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
      L = EXPR(I)
      IF (SYSERR) GO TO 190
C
C     CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE
C
      IF (.NOT.ASF) GO TO 230
      I2 = IGATT1(K,8)
      IF (I2.EQ.0) GO TO 220
      CALL ERROR1(17H ILLEGAL ASF NAME, 17)
      GO TO 190
  220 CALL SATT1(K, 8, 2)
  230 IF (L/8.EQ.1) GO TO 280
      L = MOD(L,8)
C
C     COMPARE TYPES OF RHS AND LHS
C
      IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR.
     *    (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190
      IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL
     *    ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38)
      GO TO 190
C
C     PROCESSING  FOR ASSIGNMENT STMT
C
  240 I = IGATT1(K,8)
      IF (I.NE.0) GO TO 250
      I = 10
      CALL SATT1(K, 8, 10)
  250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260
      CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31)
      GO TO 190
  260 CALL SATT1(K, 5, 1)
      IF (STMT(K2).EQ.65) GO TO 270
      IF (DOVAR(K)) CALL ERROR1(
     *    57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
     *    57)
      PSTMT = K2
      GO TO 210
  270 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 180
      CALL SUBS(I, I2)
C
C     PEEL SUBSCRIPTS OFF
C
      IF (SYSERR .OR. ERR) GO TO 190
      PSTMT = I
      GO TO 210
  280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30)
      GO TO 190
      END
      SUBROUTINE ASSIGN
      INTEGER PSTMT, STMT
      LOGICAL TOKLAB, ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C      PROCESSES AN ASSIGN STMT: ASSIGN <LABEL> TO <VAR>
C
      IF (PSTMT.GE.NSTMT) GO TO 10
      IF (.NOT.TOKLAB(1,K2,KK,.FALSE.)) GO TO 80
      IF (SYSERR) GO TO 20
      PSTMT = K2
      IF (PSTMT+2.GE.NSTMT) GO TO 10
      IF (STMT(PSTMT).EQ.49 .AND. STMT(PSTMT+1).EQ.44) GO TO 30
   10 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
   20 RETURN
   30 PSTMT = PSTMT + 2
      IF (PSTMT.GE.NSTMT) GO TO 10
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 10
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 20
      I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (I3.EQ.0) GO TO 40
      IF (I3.NE.8) GO TO 90
      GO TO 50
   40 CALL SATT1(K, 8, 8)
   50 IF (I1.NE.0) GO TO 60
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
   60 IF (MOD(I1,8).EQ.2 .AND. I2.EQ.0) GO TO 70
      CALL ERROR1(35H ASSIGN VARIABLE NOT INTEGER SCALAR, 35)
      GO TO 20
   70 IF (K2.NE.NSTMT) GO TO 10
      GO TO 20
   80 CALL ERROR1(14H MISSING LABEL, 14)
      GO TO 20
   90 CALL ERROR1(23H ILLEGAL VARIABLE USAGE, 23)
      GO TO 20
      END
      SUBROUTINE COMMON
      INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4)
      LOGICAL ERR, SYSERR, ABORT, ARDECL
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/
C
C     PROCESSES A COMMON STMT
C     FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE
C     CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT
C
      IF (STMT(PSTMT).EQ.67) GO TO 30
C
C     SET SYMBOL TABLE ENTRY FOR BLANK COMMON
C
   10 I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) GO TO 170
      IF (PSTMT.GE.NSTMT) GO TO 200
      L = PSTMT
      DO 20 I1=1,4
        STMT(I1) = S(I1)
   20 CONTINUE
      PSTMT = 1
      KK = LOOKUP(5,.FALSE.)
      IF (SYSERR) GO TO 190
      PSTMT = L
      CALL SATT1(KK, 8, 7)
      GO TO 60
   30 PSTMT = PSTMT + 1
      IF (STMT(PSTMT).NE.67) GO TO 40
      PSTMT = PSTMT + 1
      GO TO 10
   40 IF (PSTMT.GE.NSTMT) GO TO 200
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 200
      KK = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 190
      I1 = IGATT1(KK,1)
      N = IGATT1(KK,8)
      IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50
      CALL ERROR1(20H ILLEGAL COMMON NAME, 20)
      GO TO 190
   50 CALL SATT1(KK, 8, 7)
      I1 = IGATT1(NAME,8)
      IF (I1.EQ.11) CALL SATT1(KK, 2, 1)
      PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200
C
C     ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT
C     VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM
C
   60 IF (ARDECL(K2,N)) GO TO 70
      CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR,
     *    47)
      GO TO 190
   70 IF (SYSERR .OR. ERR) GO TO 190
C
C     SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON
C     PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D
C     WORD--FOR ARRAYS
C
      I1 = IGATT1(N,2)
      IF (I1.NE.0) GO TO 160
      CALL SATT1(N, 2, 1)
      I1 = IGATT1(N,7)
      IF (I1.EQ.0) GO TO 80
      L = DSA(N+2)
      DSA(L+1) = KK
      GO TO 90
   80 CALL SATT1(N, 8, 10)
      IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(N+2) = NEXT
      DSA(NEXT) = 0
      DSA(NEXT+1) = KK
      NEXT = NEXT + 2
C
C     SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE
C     ENTRY OF COMMON NAME
C
   90 IF (DSA(KK+2).EQ.0) GO TO 130
      L = DSA(KK+2)
  100 IF (DSA(L+1).EQ.0) GO TO 110
      L = DSA(L+1)
      GO TO 100
  110 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(L+1) = NEXT
  120 DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
      GO TO 140
  130 IF (NEXT+2.GE.BNEXT) GO TO 180
      DSA(KK+2) = NEXT
      GO TO 120
C
C     CHECK FOR END OF STMT
C
  140 IF (K2.EQ.NSTMT) GO TO 190
      IF (STMT(K2).NE.68) GO TO 150
      PSTMT = K2 + 1
      GO TO 60
  150 IF (STMT(K2).NE.67) GO TO 200
      PSTMT = K2
      GO TO 30
  160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23)
      GO TO 140
  170 CALL ERROR1(
     *    51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51)
      GO TO 190
  180 SYSERR = .TRUE.
      CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33)
  190 RETURN
  200 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      GO TO 190
      END
      SUBROUTINE DIMENS
C
C     PROCESSES DIMENSION STMT, RECORDING OF ARRAY BOUNDS, LENGTH
C     ETC. DONE IN ORDER
C
      INTEGER STMT, PSTMT
      LOGICAL ERR, SYSERR, ABORT, ARDECL
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
   10 IF (ARDECL(K2,K3)) GO TO 20
      CALL ERROR1(35H ILLEGAL SYNTAX OF ARRAY DECLARATOR, 35)
      GO TO 40
   20 IF (SYSERR) RETURN
      IF (K2.EQ.NSTMT) GO TO 40
      IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 30
      CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      GO TO 40
   30 PSTMT = K2 + 1
      GO TO 10
   40 RETURN
      END
      SUBROUTINE DOCHK(KK)
      INTEGER DOLIST, DOPT, OUTUT, SYMLEN, OUTUT2, DSA, PDSA, OUTUT3,
     *    STACK, OUTUT4
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C     KK IS SYMBOL TABLE ENTRY OF LABEL
C     ROUTINE CHECKS ALL LABELS FOR BEING END OF DO-STMTS; IF LABEL IS
C     END-OF-DO, ALL LABELS WITHIN THAT DO, HAVE END-OF-DEFN STMT NO
C     RECORDED IN THEM; DOPT IS DECREMENTED, A MOCK END-OF-DO IS
C     CREATED BY THE END STMT IN THE PGM UNIT; DOLIST MUST BE EMPTY
C     AFTER THIS PROCESSING OF AN END,
C     PERFORMS FIXUP ON SCOPE OF LABELS ENDING MULTIPLE NESTED DO'S
C
      IF (ITYP.EQ.28) GO TO 50
      IF (DOLIST(DOPT+1).NE.KK) GO TO 40
   10 CALL FIXLAB(.FALSE.)
      DOPT = DOPT - 6
      IF (ITYP.EQ.15 .OR. ITYP.EQ.16 .OR. (ITYP.GE.19 .AND.
     *    ITYP.LE.22)) CALL ERROR1(26H ILLEGAL ENDING STMT ON DO, 26)
      IF (DOLIST(DOPT+1).NE.KK) GO TO 40
C
C     GET REFERENCE TO NESTED DO ENDING AND MAKE REFERENCE
C     TO DO STATEMENT  A NEGATIVE  NUMBER
C     SO IT WON'T BE AN ILLEGAL BRANCH
C
      K = DSA(KK+1)
      L = DOLIST(DOPT)
   20 IF (DSA(K).EQ.L) GO TO 30
      K = DSA(K+1)
      GO TO 20
   30 DSA(K) = -DSA(K)
      GO TO 10
   40 RETURN
   50 CALL FIXLAB(.TRUE.)
      IF (DOPT-6.LE.0) GO TO 40
      LL = 1
      L = DOPT/6
      DO 60 I=1,L
        J = DOPT + 7 - 6*I
        K = DOLIST(J)
        CALL S5UNPK(DSA(K+4), STACK(LL), 6)
        LL = LL + 6
   60 CONTINUE
      LL = LL - 1
      IF (LL.LE.55) GO TO 70
99999 FORMAT (/25H MISSING DO ENDING LABEL , 55A1)
      WRITE (OUTUT,99999) (STACK(L),L=1,55)
      WRITE (OUTUT,99998) (STACK(L),L=56,LL)
      GO TO 40
99998 FORMAT (25X, 55A1)
   70 WRITE (OUTUT,99999) (STACK(L),L=1,LL)
      GO TO 40
      END
      SUBROUTINE DOSPEC(KK, K2, LOG)
      INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP
      LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /LISTDO/ LPT, LEN, LS(64)
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT
C     DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY
C     WORD 1-CURRENT STMT NO
C     WORD 2-INDEX OF LABEL IN DSA
C     WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA
C     WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS
C     LS ARRAY IS IMPLICIT  DO STACK- IN EACH ENTRY IS SAME DATA
C     AS WORDS 3-6 OF DOLIST ENTRIES.
C
      IF (.NOT.LOG) GO TO 10
      IF (LPT.LE.1) GO TO 20
      LPT = LPT - 4
      LS(LPT) = 0
      LS(LPT+1) = 0
      LS(LPT+2) = 0
      LS(LPT+3) = 0
      GO TO 40
   10 IF (DOPT.LE.LDO-11) GO TO 30
   20 CALL ERROR1(20H DO NESTING TOO DEEP, 20)
      GO TO 190
   30 DOPT = DOPT + 6
      DOLIST(DOPT) = NOST
      DOLIST(DOPT+1) = KK
      DOLIST(DOPT+2) = 0
      DOLIST(DOPT+3) = 0
      DOLIST(DOPT+4) = 0
      DOLIST(DOPT+5) = 0
C
C     DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE
C
   40 IF (PSTMT.LT.NSTMT) GO TO 60
   50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35)
      GO TO 190
   60 CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 50
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 180
      I1 = IGATT1(K,1)
      IF (I1.GT.0) GO TO 70
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
   70 I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220
      IF (I3.NE.0) GO TO 80
      I3 = 10
      CALL SATT1(K, 8, 10)
   80 IF (I3.NE.10) GO TO 220
      CALL SATT1(K, 5, 1)
      IF (DOVAR(K)) CALL ERROR1(
     *    57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
     *    57)
      I3 = IGATT1(K,2)
      IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON,
     *    37)
      IF (K.EQ.NAME) CALL ERROR1(
     *    49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49)
      IF (.NOT.LOG) GO TO 90
      LS(LPT) = K
      GO TO 100
   90 DOLIST(DOPT+2) = K
C
C     FIND AN =
C
  100 IF (STMT(K2).NE.63) GO TO 50
C
C     DO-LIMITS  LIMS COUNTS NUMBER OF  LIMITS; THESE MUST BE INTEGER
C     SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS
C
      LIMS = 0
  110 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 50
      IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120
      LIMS = LIMS + 1
      GO TO 170
  120 CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 210
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 180
      LIMS = LIMS + 1
      IF (.NOT.LOG) GO TO 130
      IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
      I1 = LPT + LIMS
      LS(I1) = K
      GO TO 140
  130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
      I1 = DOPT + 2 + LIMS
      DOLIST(I1) = K
  140 I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (I3.NE.0) GO TO 150
      CALL SATT1(K, 8, 10)
      I3 = 10
  150 IF (I3.NE.10) GO TO 50
      IF (I1.GT.0) GO TO 160
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
  160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210
C
C     CHECK FOR END OF STMT
C
  170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200
C
C     IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT;
C     THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO
C
      IF (LIMS.LE.1) GO TO 230
  180 RETURN
  190 ERR = .TRUE.
      GO TO 180
C
C     CHECK FOR A "," MUST FIND HERE
C
  200 IF (STMT(K2).NE.68) GO TO 50
      IF (LIMS.GE.3) GO TO 230
      GO TO 110
  210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER,
     *    47)
      GO TO 190
  220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36)
      GO TO 190
  230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18)
      GO TO 190
      END
      LOGICAL FUNCTION DOVAR(INDX)
      INTEGER DOPT, DOLIST
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
C
C     CHECKS VAR AT DSA(INDX) NOT IN DOSTACK ALREADY
C     AS A LIMIT OR INDEX OF PREVIOUSLY DEFINED AND CURRENTLY
C     DEFINED DO
C
      DOVAR = .FALSE.
      IF (DOPT) 40, 40, 10
   10 DO 30 I=1,DOPT,6
        L1 = I + 2
        L2 = L1 + 3
        DO 20 K=L1,L2
          IF (DOLIST(K).EQ.INDX) GO TO 50
   20   CONTINUE
   30 CONTINUE
   40 RETURN
   50 DOVAR = .TRUE.
      GO TO 40
      END
      SUBROUTINE EQUIV
      INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD
      LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
C
C     PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY ,
C     IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER
C     ELEMENTS;  ARDECL CALLED TO PROCESS DECLARATORS
C     SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE
C     CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES.
C     E.G. A(1,1,1)
C
   10 IF (STMT(PSTMT).EQ.65) GO TO 30
   20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      GO TO 150
   30 TYPE = -1
      IPT = 1
      CORNR = .TRUE.
      SAME = .TRUE.
   40 PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 20
      IF (.NOT.ARDECL(K2,KK)) GO TO 150
      IF (SYSERR .OR. ERR) GO TO 150
C
C     KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT
C
      L = IGATT1(IABS(KK),7)
      IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE.
      KK = IABS(KK)
C
C     SET USAGE, IF UNSET
C
      L = IGATT1(KK,8)
      IF (L.EQ.0) CALL SATT1(KK, 8, 10)
C
C     STORE VARIABLE IN STACK, CHECK VARIABLE TYPE
C
      STACK(IPT) = KK
      IPT = IPT + 1
      CALL SATT1(KK, 3, 1)
      I = IGATT1(KK,1)
      I = MOD(I,8)
      IF (-1.EQ.TYPE) TYPE = I
      IF (TYPE.EQ.I) GO TO 50
      SAME = .FALSE.
C
C     END OF DELARATOR CHECKS; NEED , OR )
C
   50 IF (STMT(K2).NE.68) GO TO 60
      PSTMT = K2
      GO TO 40
   60 IF (STMT(K2).NE.62) GO TO 20
C
C     CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED
C
      IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1(
     *    53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53)
C
C     CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON
C     REGION APPEARS
C
      KK = IPT - 1
C
C     PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK
C
      DO 80 I=1,KK
        L = IGATT1(STACK(I),2)
        IF (L) 80, 80, 70
 70   IF(IPT+1.GT.LSTACK) GOTO 160
        L = STACK(I)
        L = DSA(L+2)
        STACK(IPT) = DSA(L+1)
        IPT = IPT + 1
   80 CONTINUE
      IF (KK+2.GE.IPT) GO TO 90
      CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40)
      GO TO 130
   90 IF (KK+1.EQ.IPT) GO TO 130
C
C     MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK
C     THAT ANY ONE OF THEM IS ACTUALLY  IN
C
      DO 120 I=1,KK
        L = IGATT1(STACK(I),2)
        IF (L.EQ.1) GO TO 120
        CALL SATT1(STACK(I), 2, 1)
        L = STACK(I)
        IF (DSA(L+2)) 100, 100, 110
 100  IF(NEXT+2.GE.BNEXT) GOTO 170
        DSA(L+2) = NEXT
        DSA(NEXT) = 0
        DSA(NEXT+1) = STACK(IPT-1)
        NEXT = NEXT + 2
        GO TO 120
  110   L = DSA(L+2)
        DSA(L+1) = STACK(IPT-1)
  120 CONTINUE
  130 IF (K2+1.EQ.NSTMT) GO TO 150
      IF (STMT(K2+1).NE.68) GO TO 20
      PSTMT = K2 + 2
      GO TO 10
  150 RETURN
 160  CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34)
 180  SYSERR = .TRUE.
      GOTO 150
 170  CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32)
      GOTO 180
      END
      SUBROUTINE EXTERN
      LOGICAL ERR, SYSERR, ABORT
      LOGICAL BR, INTEXT
      INTEGER STMT, PSTMT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     PROCESS AN EXTERNAL STMT. CAUSES IDS TO BE MARKED AS EXTERNAL
C     PROCEDURES. ERROR OCCURS IF ID HAS PREVIOUSLY DEFINED INCONSISTANT
C     USAGE. EXTERNAL CAN'T APPEAR IN BLOCK DATA PGM UNIT.
C
      L = IGATT1(NAME,8)
      IF (L.EQ.11) GO TO 60
   10 CALL NEXTOK(PSTMT, K2, KK)
      IF (KK.EQ.0) GO TO 20
      CALL ERROR1(19H ILLEGAL IDENTIFIER, 19)
      GO TO 70
   20 KK = LOOKUP(K2,.FALSE.)
      IF (SYSERR) RETURN
      L = IGATT1(KK,8)
      IF (L.EQ.0) GO TO 30
      CALL ERROR1(26H ILLEGAL USE OF IDENTIFIER, 26)
      GO TO 40
   30 CALL SATT1(KK, 8, 13)
C
C     CAUSE EXTERNAL BIT TO BE SET IF POSSIBLE BASIC EXTERNAL
C
   40 BR = INTEXT(KK,0,0,.FALSE.)
      IF (K2.EQ.NSTMT) GO TO 70
      IF (STMT(K2).NE.68) GO TO 50
      PSTMT = K2 + 1
      GO TO 10
   50 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      GO TO 70
   60 CALL ERROR1(
     *60H ILLEGAL USAGE OF EXTERNAL STMT WITHIN BLOCK DATA SUBPROGRAM,
     *    60)
   70 RETURN
      END
      SUBROUTINE FIXLAB(ND)
C
C     ROUTINE SETS END-OF-DEF-STMT NO FOR LABELS
C     WHEN CALLED BY END STMT, FIXES ALL LABEL DEFS YET UNBOUND
C     TO THE END OF PGM STMT NO.  WHEN CALLED BY DO STMT
C     FIXES UP ALL LABELS AT THE LEVEL OF THE CURRENT
C     DO TO END-OF-DO STMT NO;  ND TRUE MEANS AN END STMT CALLED FIXLAB
C
      LOGICAL ND
      INTEGER DOLIST, DOPT, BNEXT, SYMHD, DSA, PDSA
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      LEV = -DOPT/6
      I = LABHD
   10 IF (I.EQ.0) RETURN
      K = IGATT1(I,2)
      IF (K.NE.1) GO TO 30
      K = IGATT1(I,1)
      IF (K.NE.1) GO TO 30
      K = DSA(I+2)
      IF (ND) GO TO 20
      IF (DSA(K+1).EQ.LEV) DSA(K+1) = NOST
      GO TO 30
   20 IF (DSA(K+1).LE.0) DSA(K+1) = NOST
   30 I = DSA(I+3)
      GO TO 10
      END
      SUBROUTINE FORMAT
      INTEGER STMT, PSTMT
      LOGICAL TOKPNO, SIGN, ERROR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     ROUTINE PROCESSES FORMAT STMT
C     FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2)
C     Q1,Q2 ARE EMPTY OR ARE SEPARARTERS
C     T1,T2 ETC. ARE FORMAT-ITEMS
C     Z1,Z2, ETC. ARE SEPARATERS
C     CHECKS FOR <= 2 LEVELS OF PARENTHESES
C
      ERROR = .FALSE.
      ICNT = 0
C
C     "("
C
      IF (STMT(PSTMT).EQ.65) GO TO 30
   10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
C
C     SEARCH FOR FORMAT ITEMS
C
   20 RETURN
   30 ICNT = ICNT + 1
      IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28)
      PSTMT = PSTMT + 1
C
C     LOOK FOR Q1
C
      CALL SEPAR(I)
C     TAKES CARE OF FORMAT()
      IF (STMT(PSTMT).EQ.62) GO TO 180
      IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION  (, ,
     *    25)
   40 IF (STMT(PSTMT).EQ.65) GO TO 30
      IF (PSTMT.GE.NSTMT) GO TO 10
      SIGN = .FALSE.
C
C     SEARCH FOR REPEAT FACTER (POSITIVE INTEGER)
C
      IF (TOKPNO(PSTMT,K2,N)) GO TO 70
C
C     HOLLERITH STRINGS
C
      IF (STMT(PSTMT).LT.0) GO TO 120
C
C     "-"       IN P SCALING FORMAT-ITEM
C
      IF (STMT(PSTMT).NE.61) GO TO 50
      SIGN = .TRUE.
      PSTMT = PSTMT + 1
   50 IF (PSTMT.GE.NSTMT) GO TO 10
C
C     LOOK FOR <INT> IN PSCALING FORMAT-ITEM
C     P SCALING FORMAT-ITEM
C     ( -       ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT>
C
      CALL NEXTOK(PSTMT, K2, K)
C
C     CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS
C
      IF (K.NE.1 .AND. SIGN) GO TO 100
      IF (K.EQ.1) GO TO 60
      N = STMT(PSTMT)
      GO TO 90
   60 SIGN = .TRUE.
      PSTMT = K2
      N = STMT(PSTMT)
      GO TO 80
C
C     LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR
C
   70 PSTMT = K2
      N = STMT(PSTMT)
C
C     "("
C
      IF (N.EQ.65) GO TO 30
C
C     "X"
C
      IF (N.EQ.53) GO TO 120
C
C     "P"
C
   80 IF (N.EQ.45) GO TO 130
      IF (SIGN) GO TO 100
C
C     A,I,L
C
   90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110
C
C     D,E,F,G
C
      IF (N.GE.33 .AND. N.LE.36) GO TO 150
  100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20)
      GO TO 20
C
C     A,I,L FOUND. LOOK FOR <WIDTH>
C
  110 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100
      IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160
      CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1,
     *    48)
      ERROR = .TRUE.
      GO TO 160
C
C     SKIP TO NEXT CHAR IN X OR HOLLERITH
C
  120 PSTMT = PSTMT + 1
      GO TO 170
C
C     LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT
C
  130 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.1) GO TO 10
      PSTMT = K2
C
C     AFTER D,E,F,G FIND <WIDTH> . <INT>
C
  140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10
  150 IF (PSTMT+1.GE.NSTMT) GO TO 10
      PSTMT = PSTMT + 1
      IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100
      IF (STMT(K2).NE.64) GO TO 100
      IF (K2+1.GE.NSTMT) GO TO 10
      PSTMT = K2 + 1
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.1) GO TO 100
  160 PSTMT = K2
C
C     FINISHED A FORMAT-ITEM
C     LOOK FOR SEPARATER OR ")"
C
  170 IF (STMT(PSTMT).NE.62) GO TO 210
  180 ICNT = ICNT - 1
      IF (ICNT.LT.0) GO TO 190
      IF (PSTMT+1.LT.NSTMT) GO TO 200
      IF (ICNT.EQ.0) GO TO 20
  190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
      GO TO 20
  200 PSTMT = PSTMT + 1
      GO TO 170
  210 CALL SEPAR(I)
      IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24)
      IF (STMT(PSTMT).NE.62) GO TO 40
      IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION  ,) ,
     *    25)
      GO TO 180
      END
      INTEGER FUNCTION GETTOK(K1, K2)
C
C     GETTOK FINDS NEXT TOKEN IN STMT(K1)-STMT(K2-1)
C     AND RETURNS A VALUE:
C     0= DOUBLE PRECISION CONSTANT-
C     2= INTEGER CONSTANT
C     1= REAL CONSTANT-
C     3= COMPLEX CONSTANT
C     4= LOGICAL CONSTANT
C     5= HOLLERITH CONSTANT
C     6= ID
C    >10=OPERATOR   (10+CODE FOR OPERATOR;HERE ARRAY AND FCN REFS ARE 16
C
      INTEGER PSTMT, STMT
      LOGICAL ERR, SYSERR, ABORT, TOKLOP, TOKRL, TOKCOM, TOKLOG
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
   10 GETTOK = -1
      IF (.NOT.TOKRL(K1,K2,K)) GO TO 20
      GETTOK = 1
      IF (K.EQ.0) GETTOK = 0
      GO TO 40
   20 CALL NEXTOK(K1, K2, K)
      K = K + 1
      GO TO (50, 30, 60, 70), K
   30 GETTOK = 2
   40 RETURN
C
C     PROCESS ID, SEE IF ITS A FCN  CALL OR ARRAY NAME
C
   50 GETTOK = 6
      IF (STMT(K2).NE.65) GO TO 40
      GETTOK = 16
      K2 = K2 + 1
      GO TO 40
   60 GETTOK = 5
      GO TO 40
   70 K = STMT(K1)
      IF (K.EQ.64) GO TO 100
      IF (K.EQ.65) GO TO 80
      IF (K.EQ.62) GETTOK = 12
      IF (K.EQ.68) GETTOK = 18
      IF (K.EQ.60 .OR. K.EQ.61) GETTOK = 11
      IF (K.EQ.66 .OR. K.EQ.67) GETTOK = 17
      IF (K2.EQ.K1+2) GETTOK = 13
      IF (GETTOK+1) 40, 120, 40
   80 GETTOK = 15
      IF (TOKCOM(K1,K)) GO TO 90
      GO TO 40
   90 GETTOK = 3
      K2 = K
      GO TO 40
C
C     CHECK FOR LOGICAL CONSTANTS,OPERATORS
C
  100 IF (.NOT.TOKLOG(K1,K2)) GO TO 110
      GETTOK = 4
      GO TO 40
  110 IF (.NOT.TOKLOP(K1,K2,K)) GO TO 120
      GETTOK = K
      GO TO 40
  120 CALL ERROR1(26H ILLEGAL CHARACTER IGNORED, 26)
      IF (K1+1.GE.NSTMT) GO TO 130
      K1 = K1 + 1
      GO TO 10
  130 ERR = .TRUE.
      RETURN
      END
      SUBROUTINE GOTO
      INTEGER STMT, PSTMT
      LOGICAL TOKLAB, DONE, ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     PROCESSES UNCONDITIONAL, ASSIGNED, AND COMPUTED GOTO  STMTS
C
      IF (PSTMT.GE.NSTMT) GO TO 100
      DONE = .FALSE.
C
C     UNCONDITIONAL GOTO
C
      IF (TOKLAB(1,K2,K,.FALSE.)) GO TO 110
C
C     COMPUTED GOTO
C
      IF (SYSERR) GO TO 110
      IF (STMT(PSTMT).EQ.65) GO TO 70
C
C     ASSIGNED GOTO:  GOTO <VAR> , ( <LAB> , ETC. )
C
   10 CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 100
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 110
      I1 = IGATT1(K,1)
      IF (I1.NE.0) GO TO 20
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
   20 I2 = IGATT1(K,7)
      IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(
     *    31H NOT AN INTEGER SCALAR VARIABLE, 31)
      I1 = IGATT1(K,8)
      IF (DONE) GO TO 40
C
C     CHECK FOR ASSIGN VARIABLE IN USAGE
C
      IF (I1.EQ.0) GO TO 30
      IF (I1.NE.8) CALL ERROR1(26H ID NOT AN ASSIGN VARIABLE, 26)
      GO TO 60
   30 CALL SATT1(K, 8, 8)
      GO TO 60
C
C     CHECK FOR VARIABLE IN USAGE
C
   40 IF (I1.EQ.0) GO TO 50
      IF (I1.NE.10) CALL ERROR1(19H ILLEGAL ID IN GOTO, 19)
      GO TO 130
   50 CALL SATT1(K, 8, 10)
      GO TO 130
C
C     LOOK FOR ","
C
   60 IF (STMT(K2).NE.68) GO TO 100
      K2 = K2 + 1
      DONE = .TRUE.
      IF (STMT(K2).NE.65) GO TO 100
      GO TO 80
   70 PSTMT = PSTMT + 1
      GO TO 90
   80 PSTMT = K2 + 1
C
C     LOOK FOR  ( <LAB> , ETC.)
C
   90 IF (PSTMT.GE.NSTMT) GO TO 100
      IF (.NOT.TOKLAB(1,K2,K,.FALSE.)) GO TO 100
      IF(SYSERR) GOTO 110
      IF (STMT(K2).EQ.68) GO TO 80
      IF (STMT(K2).NE.62) GO TO 100
      IF (DONE) GO TO 120
      DONE = .TRUE.
      IF (STMT(K2+1).NE.68) GO TO 100
      PSTMT = K2 + 2
      IF (PSTMT.LT.NSTMT) GO TO 10
  100 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
  110 RETURN
C
C     CHECK END OF STMT IS REACHED
C
  120 K2 = K2 + 1
  130 IF (K2.NE.NSTMT) CALL ERROR1(
     *    34H EXTRANEOUS INFO AFTER END OF STMT, 34)
      GO TO 110
      END
      SUBROUTINE ID(K2)
      INTEGER STMT, PSTMT
      LOGICAL ERR, SYSERR, ABORT, DOVAR
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
C
C     ROUTINE CHECKS IDENTIFIERS IN <LIST> FOR BEING ARRAY,ARRAY ELEMENT
C      OR VARIABLE.- RETURNS ERR=.TRUE. IF MUST CEASE PROCESSING
C     FIRST CHECK USAGE
C
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 50
C
C     CHECK USAGE
C
      I3 = IGATT1(K,8)
      IF (I3.NE.0) GO TO 10
      CALL SATT1(K, 8, 10)
      GO TO 20
   10 IF (I3.NE.10) CALL ERROR1(27H ILLEGAL IDENTIFIER IN LIST, 27)
C
C     SET TYPE
C
   20 I3 = IGATT1(K,1)
      IF (I3.NE.0) GO TO 30
      I3 = 1
      IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I3 = 2
      CALL SATT1(K, 1, I3)
C
C     CHECK FOR READING INTO DO CONTROL VARIABLE OR LIMIT
C
   30 IF (ITYP.NE.23) GO TO 40
      IF (DOVAR(K)) CALL ERROR1(
     *    57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
     *    57)
C
C     MARK VARIABLES AS SET IF VALUES READ IN
C
      CALL SATT1(K, 5, 1)
C
C     SEPARATE OUT ARRAY ELEMENTS AND CHECK SUBSCRIPTS
C
   40 IF (STMT(K2).NE.65) GO TO 50
      I3 = IGATT1(K,7)
      IF (I3.EQ.0) GO TO 60
      PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 80
      CALL SUBS(K2, I3)
      ERR = .FALSE.
   50 RETURN
   60 CALL ERROR1(40H ILLEGAL SUBSCRIPTING OF SCALAR VARIABLE, 40)
   70 ERR = .TRUE.
      GO TO 50
   80 CALL ERROR1(19H SUBSCRIPTING ERROR, 19)
      GO TO 70
      END
      LOGICAL FUNCTION IDLIST(IDO)
      INTEGER PSTMT, STMT
      LOGICAL ERR, SYSERR, ABORT, IDO
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     RECOGNIZES  IDLIST=<ID>  Õ, <ID>! ;LAST <ID> CANNOT BE FOLLOWED BY
C     A '='; IDLIST MUST CONTAIN AT LEAST ONE ID.  IDLIST=.FALSE. WILL
C     BE RETURNED FOR AN IRRECOVERABLE SYNTAX ERROR.
C     IDO SET TO .TRUE. WHEN <IDLIST> IS FOLLOWED BY <DOSPEC>
C
      IDO = .FALSE.
      IDLIST = .TRUE.
      IF (PSTMT.GE.NSTMT) GO TO 60
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 60
      IF (STMT(K2).EQ.63) GO TO 20
      CALL ID(K2)
      IF (ERR .OR. SYSERR) GO TO 20
   10 PSTMT = K2
      IF (STMT(PSTMT).EQ.68 .AND. STMT(PSTMT+1).EQ.65 .OR.
     *    STMT(PSTMT).EQ.62 .OR. PSTMT.EQ.NSTMT) GO TO 30
      IF (STMT(PSTMT).EQ.68) GO TO 50
      CALL ERROR1(35H ILLEGAL TOKEN FOLLOWING IDENTIFIER, 35)
   20 IDLIST = .FALSE.
      ERR = .FALSE.
   30 RETURN
   40 IDO = .TRUE.
      GO TO 30
C
C     MAKE SURE <ID> =  ISN'T NEXT CONSTRUCT
C
   50 K2 = K2 + 1
      IF (K2.GE.NSTMT) GO TO 60
      CALL NEXTOK(K2, K3, K)
      IF (STMT(K3).EQ.63) GO TO 40
      PSTMT = K2
      K2 = K3
      CALL ID(K2)
      IF (ERR .OR. SYSERR) GO TO 20
      GO TO 10
   60 CALL ERROR1(23H ILLEGAL SYNTAX IN LIST, 23)
      GO TO 20
      END
      SUBROUTINE IFS(LOG)
      LOGICAL TOKLAB, ERR, SYSERR, ABORT, LOG
      INTEGER STMT, PSTMT, EXPR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     ROUTINE PROCESSES ARITHMETIC AND LOGICAL IF STMTS
C     LOG RETURNED AS TRUE IF LOGICAL-IF IS ENCOUNTERED;PU CHECKS FOR
C     ACCEPTIBLE EXECUTABLE STMT AFTER LOGICAL EXPRESSION
C
      LOG = .FALSE.
      L = MOD(EXPR(I),8)
      IF (-1.EQ.L .OR. SYSERR) GO TO 30
      LOG = L.EQ.4
      IF (LOG) GO TO 30
C
C     ARITHMETIC IF--SEARCH FOR  <LAB>,<LAB>,<LAB>
C
      IF (L.GT.2) GO TO 50
      I = 0
      IF (PSTMT.GE.NSTMT) GO TO 20
   10 IF (.NOT.TOKLAB(1,K2,L,.FALSE.)) GO TO 40
      IF (SYSERR) GO TO 30
      I = I + 1
      IF (I.EQ.3) GO TO 60
      IF (STMT(K2).NE.68) GO TO 20
      PSTMT = K2 + 1
      IF (PSTMT.LT.NSTMT) GO TO 10
   20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
   30 RETURN
   40 CALL ERROR1(14H MISSING LABEL, 14)
      GO TO 30
   50 CALL ERROR1(39H COMPLEX EXPRESSION ILLEGAL IN ARITH-IF, 39)
      GO TO 30
   60 IF (K2.EQ.NSTMT) GO TO 30
      CALL ERROR1(34H EXTRANEOUS INFO AFTER END OF STMT, 34)
      GO TO 30
      END
      LOGICAL FUNCTION INTEXT(LL, L1, L2, BR)
C
C     LL POINTS TO DSA ENTRY OF FCN NAME
C     L1 POINTS INTO STACK TO BEGINNING OF ARGS
C     L2 POINTS INTO STACK TO LAST ARG ENTRY
C      BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS
C     BR FALSE MEANS JUST LOOK FOR EXTERNALS
C      ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL
C     FCNS;  RETURNS TRUE IF FINDS INTRINSIC FCN.  CHECKS INTRINSICS
C      ARGS FOR USAGE, TYPE AND NUMBER.  MARKS POSSIBLE BASIC EXTDRNAL
C     FCNS SENT DOWN TO IT
C
      INTEGER STACK, BL, PDSA, DSA, FCN(6), Z
      LOGICAL BR
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /INTS/ Z(346)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA BL /1H /
      INTEXT = .FALSE.
      CALL S5UNPK(DSA(LL+4), FCN(1), 6)
      K = 1
      DO 40 I=1,55
        K1 = K + 1
        K2 = K1 + Z(K) - 1
        L = 0
        DO 10 J=K1,K2
          L = L + 1
          IF (FCN(L).NE.Z(J)) GO TO 30
   10   CONTINUE
        IF (L.EQ.6) GO TO 60
        L = L + 1
        DO 20 J=L,6
          IF (FCN(J).NE.BL) GO TO 30
   20   CONTINUE
        GO TO 60
   30   K = K2 + 2
   40 CONTINUE
   50 RETURN
C
C     DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE
C      INTRINSIC FCN
C
   60 L = MOD(Z(K2+1),1024)/512
C
C     IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY
C     EXPLICITLY SET
C
      IF (L.NE.1) GO TO 70
      L = IGATT1(LL,1)
      IF (L/8.GE.1) GO TO 190
      L = MOD(Z(K2+1),8)
      IF (BR) L = L + 8
      CALL SATT1(LL, 1, L)
C
C       MARK AS USED IN PASS 1
C
      GO TO 190
C
C      CHEKC IF IN EXTERNAL STMT  IF SO NOT AN INTRINSIC
C
   70 IF (.NOT.BR) GO TO 50
      L = IGATT1(LL,8)
      IF (L.EQ.13) GO TO 50
C
C     CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED
C
      L = IGATT1(LL,1)
      J = MOD(Z(K2+1),8)
      IF (L.GE.8) GO TO 80
      CALL SATT1(LL, 1, J+8)
      GO TO 90
   80 IF (J.NE.MOD(L,8)) GO TO 50
C
C     K POINTS TO THE FUNCTION ENTRY IN Z
C     K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER
C     FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS:
C     BITS 0-2 TYPE FCN
C     BITS 3-5 TYPE ARGS
C     BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS
C      BITS 7-8 MINIMUM NUMBER OF ARGS
C      BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL
C      BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED
C
C     FCN IS INTRINSIC
C     CHECK NUMBER OF ARGS
C
   90 I = MOD(Z(K2+1),128)/64
      J = MOD(Z(K2+1),512)/128
      IF (I) 100, 100, 120
C
C     VARIABLE NUMBER OF ARGS ALLOWED
C     MUST BE AT LEAST J
C
  100 IF ((L2-L1+1)/2.GE.J) GO TO 130
 110  CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4),
     * 1, 1,  1)
      GO TO 180
C
C     FIXED NUMBER OF ARGS
C
  120 IF ((L2-L1+1)/2.NE.J) GO TO 110
C
C     CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG;
C     CHECK TYPE AND THAT ARGS ARE SCALARS
C
  130 L = MOD(Z(K2+1),64)/8
      DO 170 N=L1,L2,2
C
C     CHECK FOR EXPRESSION AS ARG
C
        IF (STACK(N).EQ.0) GO TO 160
C
C     CHECK USAGE
C
        I = IGATT1(STACK(N),8)
        IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND.
     *      STACK(N+1).NE.6)) GO TO 160
        IF (I.NE.0) GO TO 140
        CALL SATT1(STACK(N), 8, 10)
        GO TO 160
  140   IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150
        I = STACK(N)
        IF (DSA(I+2).EQ.IASF) GO TO 160
  150   CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40,
     *  DSA(LL+4), 1, 1, 1)
        GO TO 170
C
C     CHECK STRUCTURE
C
  160   IF (STACK(N+1)/8.EQ.1) CALL ERROR2(
     *      48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48,
     *  DSA(LL+4), 1, 1, 1)
C
C     CHECK TYPE
C
        IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2(
     *      43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43,
     *  DSA(LL+4), 1, 1, 1)
  170 CONTINUE
  180 INTEXT = .TRUE.
      I = IGATT1(LL,8)
      IF (I.NE.0) GO TO 190
      CALL SATT1(LL, 8, 14)
C
C     MARK FCN AS USED
C
  190 K = Z(K2+1)/1024
      IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024
      GO TO 50
      END
      SUBROUTINE IO
      LOGICAL ERR, SYSERR, TOKPNO, OK, ABORT, TOKLAB
      INTEGER STMT, PSTMT
      INTEGER EN(4)
      LOGICAL SW
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /SWS/ SW(10)
      DATA EN(1), EN(2), EN(3), EN(4) /34,43,33,63/
C
C     ROUTINE RECOGNIZES READ,WRITE,REWIND,BACKSPACE,ENDFILE,PAUSE STMTS
C
      OK = .TRUE.
      ASSIGN 160 TO IFORM
      IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 240
C
C     SYNTAX OF READ, WRITE STMTS IS THE SAME EXCEPT A BINARY WRITE
C     NEEDS A <LIST>. (SEE USE OF OK)
C        "READ" (U<UNIT> / <UNIT> , <FORM>!)   U<LIST>!
C         <UNIT> IS INTEGER SCALAR VARIABLE OR POSITIVE INTEGER CONST
C         <FORM> IS <LABEL> OR  <ARRAY NAME>.
C
      IF (STMT(PSTMT).NE.65) GO TO 230
      PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 120
   10 IF (TOKPNO(PSTMT,K2,K)) GO TO 60
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.EQ.0) GO TO 20
      CALL ERROR1(13H ILLEGAL UNIT, 13)
      GO TO 110
   20 K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 110
      I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (I3.NE.0) GO TO 30
      CALL SATT1(K, 8, 10)
      GO TO 40
   30 IF (I3.EQ.10) GO TO 40
      CALL ERROR1(13H ILLEGAL UNIT, 13)
   40 IF (I1.NE.0) GO TO 50
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
   50 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(13H ILLEGAL UNIT, 13)
   60 PSTMT = K2
C
C     DISTINGUISH ( <UNIT> )  FROM  ( <UNIT>,<FORM> )
C
      IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 100
      IF (STMT(PSTMT).EQ.68) GO TO 130
      IF (STMT(PSTMT).EQ.62 .AND. ITYP.EQ.24) OK = .FALSE.
C
C     CODE FINDS ")" AND TRIES TO FIND LIST
C
   70 IF (STMT(PSTMT).NE.62) GO TO 230
      PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 90
      CALL LIST
      GO TO 110
   80 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      PSTMT = PSTMT + 1
      GO TO 70
   90 IF (OK) GO TO 110
      CALL ERROR1(13H MISSING LIST, 13)
  100 IF (PSTMT.LT.NSTMT) CALL ERROR1(
     *    34H EXTRANEOUS INFO AFTER END OF STMT, 34)
  110 RETURN
  120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      GO TO 110
C
C     IDENTIFY END= IF THERE
C
  130 IF (ITYP.NE.23) GO TO IFORM, (160, 80)
      I1 = PSTMT + 1
      DO 140 K=1,4
        IF (STMT(I1).NE.EN(K)) GO TO IFORM, (160, 80)
        I1 = I1 + 1
  140 CONTINUE
      IF (.NOT.SW(1)) CALL ERROR1(
     *    37H WARNING - NON-PORTABLE EOF CONSTRUCT, 37)
C
C     HAVE FOUND END=, TRY FOR LABEL
C
      PSTMT = I1
      IF(.NOT.TOKLAB(1,K2,K,.FALSE.))
     1CALL ERROR1(44H MISSING LABEL IN NON-PORTABLE EOF CONSTRUCT ,44)
      IF(SYSERR) GOTO 110
  150 PSTMT = K2
      GO TO 70
C
C     SEARCH FOR FORM
C
  160 PSTMT = PSTMT + 1
      IF (PSTMT.GE.NSTMT) GO TO 230
      IF (TOKLAB(3,K2,K,.FALSE.)) GO TO 220
      IF(SYSERR) GOTO 110
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.EQ.0) GO TO 180
  170 CALL ERROR1(13H ILLEGAL FORM, 13)
      GO TO 110
  180 K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 110
      I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
      IF (I3.NE.0) GO TO 190
      CALL SATT1(K, 8, 10)
      GO TO 200
  190 IF (I3.EQ.10) GO TO 200
      CALL ERROR1(13H ILLEGAL FORM, 13)
  200 IF (I1.NE.0) GO TO 210
      I1 = 2
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
 210  IF((MOD(I1,8).NE.2.AND.MOD(I1,8).NE.5).OR.I2.EQ.0) GOTO 170
C
C     HAVE SUCCESSFULLY FOUND A FORM
C
  220 IF (SYSERR) GO TO 110
      PSTMT = K2
      ASSIGN 80 TO IFORM
      IF (STMT(PSTMT).EQ.68) GO TO 130
      GO TO 70
  230 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      GO TO 110
C
C     LAST 4 I-O  STMTS
C
  240 IF (ITYP.EQ.27 .OR. ITYP.EQ.22) CALL ERROR1(
     *    39H WARNING - USE OF NON-PORTABLE I/O STMT, 39)
      IF (ITYP.EQ.22) GO TO 100
      IF (PSTMT.LT.NSTMT) GO TO 10
      CALL ERROR1(13H MISSING UNIT, 13)
      GO TO 110
      END
      SUBROUTINE LDOVAR
      COMMON /LISTDO/ LPT, LEN, LS(64)
C
C     CHECKS PROPER NESTING OF DOS WITHIN LIST CONSTRUCT
C
      IF (LPT.GE.61) GO TO 50
      DO 40 KQ=LPT,60,4
        KK = KQ + 4
        DO 30 L=1,4
          LL = L + KQ - 1
          IF (LS(LL)) 10, 30, 10
   10     DO 20 K=KK,61,4
      IF (LS(K).EQ.LS(LL)) CALL ERROR1(
     *57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, 57)
   20     CONTINUE
   30   CONTINUE
   40 CONTINUE
   50 RETURN
      END
      SUBROUTINE NEXTOK(K1, K2, CODE)
      INTEGER STMT, CODE, PSTMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     NEXT TOKEN IN STMT(K1)-STMT(K2-1). CODES ARE:
C     DIGIT STRING(1)
C     HOLLERITH(2)
C     IDENTIFIER(0)
C     SPECIAL CHARACTER(3)
C
      IF (STMT(K1).LT.0) GO TO 50
      IF (STMT(K1).GT.9) GO TO 20
C
C     DIGIT STRING
C
      CODE = 1
      K2 = K1 + 1
   10 IF (K2.EQ.NSTMT) GO TO 60
      IF ((STMT(K2).GT.9) .OR. (STMT(K2).LT.0)) GO TO 60
      K2 = K2 + 1
      GO TO 10
   20 IF (STMT(K1).GT.55) GO TO 40
C
C     IDENTIFIER
C
      CODE = 0
      K4 = K1 + 1
      K2 = K4
      DO 30 I=K4,NSTMT
        IF (STMT(I).GT.55 .OR. STMT(I).LT.0) GO TO 60
        K2 = K2 + 1
   30 CONTINUE
C
C
C     SPECIAL CHARACTER
C
   40 K2 = K1 + 1
      CODE = 3
      IF (STMT(K1).NE.66) GO TO 60
      IF (STMT(K2).EQ.66) K2 = K2 + 1
      GO TO 60
C
C     HOLLERITH
C
   50 CODE = 2
      K2 = K1 + 1
   60 RETURN
      END
      SUBROUTINE OUTSYM
      INTEGER HASH, STACK, BL, DSA, OUTUT, SYMHD, BNEXT, SYMLEN, ATT(8)
      INTEGER CODE(11), CC(30), C(4), Q(70), SYM, PDSA
      INTEGER OUTUT2, OUTUT3, OUTUT4
      LOGICAL OK
      LOGICAL OPT, P1ERR, COMM
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /TABL/ NEXT, LAB, SYM, BNEXT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /TRANS/ Q
      DATA BL /1H /
      DATA CODE(1) /1HD/, CODE(2) /1HR/, CODE(3) /1HI/, CODE(4) /1HC/,
     *    CODE(5) /1HL/, CODE(11) /1HE/, CODE(7) /1HA/, CODE(8) /1HS/,
     *    CODE(9) /1HF/, CODE(10) /1HN/, CODE(6) /1HH/, C(1) /4/, C(2)
     *    /11/, C(3) /7/, C(4) /8/
      DATA CC(2), CC(16), CC(20), CC(22), CC(26), CC(28) /6*1H /,
     *    CC(3), CC(5), CC(9), CC(11) /1HF,1HS,1HF,1HF/, CC(1), CC(4) /
     *    1HU,1HA/, CC(6), CC(8), CC(10), CC(12), CC(14) /1HF,4*1HN/,
     *    CC(7), CC(13) /2*1HS/, CC(15) /1HC/, CC(17) /1HG/, CC(18) /
     *    1HT/, CC(19) /1HL/, CC(21) /1HV/, CC(25) /1HM/, CC(23) /1HB/,
     *    CC(24) /1HD/, CC(27) /1HE/
      DATA CC(29) /1HI/, CC(30) /1HF/
C
C     ROUTINE PRINTS OUT SYMBOL TABLE FOR A PROGRAM UNIT
C
      IF (NAME.EQ.0 .OR. .NOT.OPT(1)) RETURN
      II = IGATT1(NAME,8)
      CALL S5UNPK(DSA(NAME+4), STACK(1), 6)
      WRITE (OUTUT,99999) (STACK(I),I=1,6)
99999 FORMAT (14H1PROGRAM UNIT , 5X, 6A1)
      IF (II.EQ.11 .OR. II.EQ.12 .OR. DSA(NAME+2).EQ.0) GO TO 60
C
C     PRINT FCN/SUBROUTINE ARGS
C
      KK = DSA(NAME+2)
      I = 0
   10 L = 20
      CALL RDLIST(KK, 9, M, 0)
      IF (M) 20, 60, 20
   20 DO 30 I1=1,M
        J = STACK(I1) + 4
        CALL S5UNPK(DSA(J), STACK(L), 6)
        L = L + 7
        STACK(L-1) = BL
   30 CONTINUE
      MM = M*7 + 19
      IF (I) 40, 40, 50
   40 WRITE (OUTUT,99998) (STACK(L),L=20,MM)
99998 FORMAT (//10H ARGUMENTS, 9X, 63A1)
      I = 1
      GO TO 10
   50 WRITE (OUTUT,99997) (STACK(L),L=20,MM)
99997 FORMAT (19X, 63A1)
      GO TO 10
C
C     PRINT SYMBOLS FOR PROGRAM UNIT
C
   60 CALL SORT(SYM, LBR)
      COMM = .FALSE.
      WRITE (OUTUT,99996)
99996 FORMAT (//1X, 4HNAME, 5X, 4HTYPE, 2X, 3HUSE, 1X, 10HATTRIBUTES,
     *    1X, 10HREFERENCES//)
      DO 230 JBR=1,LBR
        SYMHD = HASH(JBR)
        DO 70 I=20,35
          STACK(I) = BL
   70   CONTINUE
        DO 80 I=1,8
          ATT(I) = IGATT1(SYMHD,I)
   80   CONTINUE
C     SKIPS OVER SYMBOL TABLE ENTRY FOR MAIN, BLOCK DATA,
C     AND CURRENT SUBROUTINE NAME
        IF (SYMHD.EQ.NAME .AND. ATT(8).NE.4) GO TO 230
        IF (ATT(8).NE.7) GO TO 90
        COMM = .TRUE.
        GO TO 230
   90   CALL S5UNPK(DSA(SYMHD+4), STACK(20), 6)
        I1 = ATT(8)
        L = 2*(I1+1) - 1
        STACK(28) = CC(L)
        STACK(29) = CC(L+1)
C     LEAVE BLANK IRRELEVANT TYPE INFO FOR EXT SUBR, COMMON, EXT ENTS
      IF(ATT(8).EQ.6 .OR. ATT(8).EQ.7 .OR. ATT(8).EQ.13)
     1 GOTO 100
      I1 = MOD(ATT(1),8)
      IF (ATT(1).GE.8) STACK(26)=CODE(11)
      STACK(27) = CODE(I1 + 1)
  100   DO 110 I=1,4
          L = I + 29
          J = C(I)
          IF (ATT(I+1).EQ.1) STACK(L) = CODE(J)
  110   CONTINUE
        IF (ATT(8).EQ.7) STACK(30) = BL
        IF (ATT(8).NE.10 .AND. ATT(8).NE.8) GO TO 140
        IF (ATT(7)) 120, 130, 120
  120   STACK(34) = CODE(7)
        J = ATT(7) + 1
        STACK(35) = Q(J)
        GO TO 140
  130   STACK(34) = CODE(8)
C
C     XREF LIST
C
  140   IF (OPT(2)) GO TO 160
  150   WRITE (OUTUT,99995) (STACK(L),L=20,35)
        GO TO 230
  160   OK = .FALSE.
        N = DSA(SYMHD+1)
        IF (N.LE.0) GO TO 150
      N = DSA( N+1 )
 170  CALL RFLIST( N, M, J, DSA(SYMHD+1) )
C
C     FIRST TIME PRINT WHOLE LINE
C
        K = M
        IF (M.GE.57) K = 57
        WRITE (OUTUT,99995) (STACK(L),L=20,35), (STACK(L),L=50,K)
99995   FORMAT (1X, 6A1, 5X, 2A1, 3X, 2A1, 3X, 6A1, 2X, 8(I5, 1X))
        IF (M-57) 220, 220, 180
  180   L = (M-57)/8
        LL = 58
        IF (L) 220, 210, 190
  190   DO 200 K=1,L
          LK = LL + 7
          WRITE (OUTUT,99994) (STACK(I),I=LL,LK)
          LL = LK + 1
  200   CONTINUE
        IF (LK.EQ.M) GO TO 220
  210   WRITE (OUTUT,99994) (STACK(I),I=LL,M)
99994   FORMAT (30X, 8(I5, 1X))
C
C     MAY HAVE TO CALL REFLIST AGAIN
C
  220   IF (J) 230, 230, 170
  230 CONTINUE
C
C     PRINT LABELS
C
      IF (LAB.EQ.0) GO TO 320
      CALL SORT(LAB, LBR)
      DO 310 JBR=1,LBR
        LABHD = HASH(JBR)
        CALL S5UNPK(DSA(LABHD+4), STACK(20), 6)
        OK = .FALSE.
        IF (OPT(2)) GO TO 240
        WRITE (OUTUT,99993) (STACK(L),L=20,25)
        GO TO 310
  240   II = DSA(LABHD+1)
      II = DSA(II+1)
 250  CALL RFLIST(II, M, J, DSA(LABHD+1) )
        K = M
        IF (M.GE.57) K = 57
        WRITE (OUTUT,99993) (STACK(I),I=20,25), (STACK(I),I=50,K)
99993   FORMAT (1X, 6A1, 23X, 8(I5, 1X))
        IF (M-57) 300, 300, 260
  260   L = (M-57)/8
        LL = 58
        IF (L) 300, 290, 270
  270   DO 280 K=1,L
          LK = LL + 7
          WRITE (OUTUT,99992) (STACK(I),I=LL,LK)
          LL = LK + 1
  280   CONTINUE
        IF (LK.EQ.M) GO TO 300
  290   WRITE (OUTUT,99992) (STACK(I),I=LL,M)
99992   FORMAT (30X, 8(I5, 1X))
  300   IF (J) 310, 310, 250
  310 CONTINUE
  320 IF (.NOT.COMM) GO TO 390
      CALL SORT(SYM, LBR)
      WRITE (OUTUT,99991)
99991 FORMAT (//14H COMMON BLOCKS//)
      DO 380 JBR=1,LBR
        SYMHD = HASH(JBR)
        I = IGATT1(SYMHD,8)
        IF (I.NE.7) GO TO 380
        CALL S5UNPK(DSA(SYMHD+4), STACK(100), 6)
        N = 0
        II = DSA(SYMHD+2)
  330   L = 11
        CALL RDLIST(II, 10, M, 0)
        IF (M) 340, 380, 340
  340   DO 350 I=1,M
          J = STACK(I) + 4
          CALL S5UNPK(DSA(J), STACK(L), 6)
          L = L + 7
          STACK(L-1) = BL
  350   CONTINUE
        L = L - 1
        IF (N) 360, 360, 370
  360   WRITE (OUTUT,99990) (STACK(I),I=100,105), (STACK(I),I=11,L)
99990   FORMAT (1X, 6A1, 3X, 70A1)
        N = 1
        GO TO 330
  370   WRITE (OUTUT,99989) (STACK(K),K=11,L)
99989   FORMAT (10X, 70A1)
        GO TO 330
  380 CONTINUE
  390 RETURN
      END
      SUBROUTINE POP
      LOGICAL ERR, SYSERR, ABORT
      INTEGER PB, PT, STACK, OP(12), EX(4,4), AO(4,4), RO(3,3)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /EXPRS/ PT, PB, AO, RO, EX
      COMMON /DETECT/ ERR, SYSERR, ABORT
      DATA OP(1), OP(3), OP(7), OP(9), OP(10), OP(11) /6*2/, OP(4) /1/,
     *    OP(5) /0/, OP(6), OP(8), OP(2) /3*-1/, OP(12) /1/
C
C     JOB OF SUBROUTINE IS TO POP THE STACK;  DOES ALL POPS
C     EXCEPT REMOVAL OF "FCN(" CONSTRUCTION
C     OP(I) CONTAINS NUM OF ARGS OF OPERATER I  PB CHECKED BEFORE
C     CALLING POP; POP CHECKS PT; ERROR RETURNS FROM THIS ROUTINE STOP
C     EXPRESSION PROCESSING (I.E. ERR=.TRUE.)
C
      ERR = .FALSE.
      I = STACK(PB+1)
      K = OP(I-10)
      IF (K) 190, 180, 10
   10 L = PT - 1
      KQ = K
   20 IF (K) 80, 80, 30
   30 IF (STACK(L)/8.EQ.1) GO TO 220
      IF (STACK(L).GE.8 .OR. STACK(L-1).EQ.0) GO TO 40
      J = IGATT1(STACK(L-1),8)
      IF (J.EQ.0) CALL SATT1(STACK(L-1), 8, 10)
   40 GO TO (60, 50), K
   50 K1 = MOD(STACK(L),8) + 1
      GO TO 70
   60 K2 = MOD(STACK(L),8) + 1
   70 L = L - 2
      K = K - 1
      GO TO 20
C
C     11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( 17 *,/ 18 ,
C     19 .AND. 20 .OR. 21 .EQ.  22 UNARY +,-
C
   80 L = I - 10
      GO TO (90, 190, 120, 150, 190, 190, 90, 190, 130, 130, 100, 140),
     *    L
   90 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
      KK = AO(K1,K2)
      GO TO 160
  100 IF (K1.GT.3 .OR. K2.GT.3) GO TO 110
      KK = RO(K1,K2)
      GO TO 160
  110 IF ((K1.NE.6 .OR. K2.NE.6) .AND. (K1.NE.6 .OR. K2.NE.3) .AND.
     *    (K1.NE.3 .OR. K2.NE.6) ) GO TO 210
      KK = 4
      GO TO 160
  120 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
      KK = EX(K2,K1)
      GO TO 160
  130 KK = 4
      IF (K1.NE.5 .OR. K2.NE.5) GO TO 210
      GO TO 160
  140 KK = K2 - 1
      IF (KK.LT.0 .OR. KK.GT.3) GO TO 210
      GO TO 160
  150 IF (K2.NE.5) GO TO 210
      KK = 4
  160 IF (-1.EQ.KK) GO TO 210
C
C     STORE ON STACK 0 TO SHOW EXPRESSION RESULT(NO DSA INDEX)
C     ALSO STORE TYPE OF RESULTING OPERAND
C
      PT = PT - 2*KQ
      STACK(PT) = 0
      STACK(PT+1) = KK
      PT = PT + 2
      PB = PB + 1
  170 RETURN
C
C     POPPING "("
C
  180 PB = PB + 1
      GO TO 170
  190 CALL ERROR1(25H ILLEGAL ELEMENT ON STACK, 25)
  200 ERR = .TRUE.
      RETURN
  210 CALL ERROR1(34H ILLEGAL COMBINATION OF DATA TYPES, 34)
      GO TO 200
  220 CALL ERROR1(21H ILLEGAL USE OF ARRAY, 21)
      GO TO 200
      END
      SUBROUTINE RDLIST(HEAD, L, N, M)
C
C     HEAD IS THE HEAD OF A LINEAR LINKED LIST IN DSA
C     L IS  MAX NUMBER OF ITEMS DESIRED
C     N IS NUMBER OF ITEMS RETURNED
C     M IS END OF LIST MARKER
C
      INTEGER HEAD, STACK, DSA, PDSA
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      N = 0
   10 IF (HEAD.EQ.M .OR. N.GE.L) GO TO 20
      N = N + 1
      STACK(N) = DSA(HEAD)
      HEAD = DSA(HEAD+1)
      GO TO 10
   20 RETURN
      END
      SUBROUTINE RFLIST( I1, I2, I4, I3 )
C
C     I1 IS POINTER TO FIRST ELEMENT ON XREF LIST IN DSA
C     I2 IS COUNT OF HOW MANY REFS ARE RETURNED IN STACK
C     I4 IS 1 IF RFLIST MUST BE CALLED AGAIN; ELSE IS 0
C     I3 IS LAST OF LIST ELEMENTS
C
      INTEGER DSA, PDSA, STACK
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      I4 = 0
      I2 = 49
 10   IF ( I2+1.GE.LSTACK ) GOTO 30
      I2 = I2 + 1
      STACK(I2) = DSA(I1)
      IF( I1.EQ.I3 ) GOTO 20
      I1 = DSA(I1+1)
      GOTO 10
   20 RETURN
   30 I4 = 1
      GO TO 20
      END
      SUBROUTINE SEPAR(ICHAR)
C
C      FINDS SEPARATER CONSTRUCT IN FORMAT STMTS
C     SEPARATER IS A  COMBINATION OF "/" AND ","
C     ",," IS ALWAYS ILLEGAL IN A SEPARATER
C     MIXING OF "/" AND "," IS WARNED AGAINST
C
C     ICHAR CONTAINS LENGTH OF SEPARATOR FOUND
      INTEGER PSTMT, STMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      ICHAR = PSTMT
      ICOM = 0
C
C     " , "
C
   10 IF (STMT(PSTMT).NE.68) GO TO 20
      ICOM = ICOM + 1
C
C      CHECK FOR ",,"
C
      PSTMT = PSTMT + 1
      IF (STMT(PSTMT).EQ.68) GO TO 30
   20 IF (STMT(PSTMT).NE.67) GO TO 50
      PSTMT = PSTMT + 1
      GO TO 10
   30 CALL ERROR1(19H ILLEGAL ADJACENT ,, 19)
C
C      FLUSH TO NEXT NON-SEPARATER
C
   40 PSTMT = PSTMT + 1
      IF (STMT(PSTMT).EQ.67 .OR. STMT(PSTMT).EQ.68) GO TO 40
   50 ICHAR = PSTMT - ICHAR
      IF (ICOM.GT.0 .AND. ICHAR.GT.1) CALL ERROR1(
     *    36H ILLEGAL MIXING OF / AND , IN FORMAT, 36)
      RETURN
      END
      SUBROUTINE SETNAM(KK)
      LOGICAL ERR, SYSERR, ABORT
      INTEGER STMT, PSTMT, S(5)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
C
C     KK=11 FOR BLOCK DATA PGM;  KK=12 FOR MAIN PGM
C     NAME POINTS TO SYMBOL TABLE ENTRY FOR NEW PGM
C
      IF (KK.EQ.11) GO TO 30
      PSTMT = 1
      DO 10 I=1,5
        STMT(I) = S(I)
   10 CONTINUE
      NAME = LOOKUP(6,.FALSE.)
      IF (SYSERR) RETURN
      CALL SATT1(NAME, 8, 12)
   20 RETURN
   30 PSTMT = 5
      STMT(PSTMT) = S(1)
      NAME = LOOKUP(11,.FALSE.)
      IF (SYSERR) RETURN
      CALL SATT1(NAME, 8, 11)
      GO TO 20
      END
      SUBROUTINE SORT(IPT, L)
      EXTERNAL EXCH
      INTEGER HASH, PDSA, DSA
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C     PUT ALL SUMBOL INDICES IN HASH TABLE TO SORT THEM
C
      L = 0
      I = IPT
   10 IF (I.EQ.0) GO TO 20
      L = L + 1
      HASH(L) = I
      I = DSA(I+3)
      GO TO 10
C
C     CALL SORT ROUTINE
C     UPON RETURN HASH CONTAINS INDICES OF ALL SYMBOLS OR LABELS IN
C     DSA IN LEXICOGRAPHIC ORDER
C
   20 CALL SSORT(EXCH, DSA, LDSA, HASH, L, 4)
      RETURN
      END
      SUBROUTINE SUBS(K2, NO)
      INTEGER STMT, PSTMT
      LOGICAL ERR, SYSERR, ABORT, TOKPNO
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     STMT(PSTMT)-STMT(K2-1) CONTAIN SUBSCRIPT CONSTRUCT
C     NO IS NUMBER OF SUBSCRIPTS EXPECTED
C     ROUTINE CHECKS SYNTAX AND NUMBER OF SUBSCRIPTS
C     IF FLUSH OF CONSTRUCT IS NECESSARY, AND NSTMT IS REACHED
C     ERR=.TRUE.
C
      ICNT = 0
   10 CALL NEXTOK(PSTMT, K2, K)
      IF (K.EQ.0) GO TO 70
      IF (TOKPNO(PSTMT,K2,LL)) GO TO 60
   20 CALL ERROR1(28H ILLEGAL SYNTAX OF SUBSCRIPT, 28)
C
C     FLUSH TO END OF SUBSCRIPT CONSTRUCTION
C
   30 IF (STMT(K2).EQ.62) GO TO 40
      K2 = K2 + 1
      IF (K2.LT.NSTMT) GO TO 30
      ERR = .TRUE.
      GO TO 50
   40 K2 = K2 + 1
   50 RETURN
   60 IF (STMT(K2).NE.66) GO TO 130
      PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 20
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 20
C
C     ACESS SYMBOL TABLE ENTRY FOR VARIABLE TO DETERMINE
C     USAGE AND TYPE
C
   70 KQ = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 30
      I1 = IGATT1(KQ,1)
      I1 = MOD(I1,8)
      I2 = IGATT1(KQ,7)
      I3 = IGATT1(KQ,8)
      IF (I3.EQ.0) GO TO 90
      IF (I3.EQ.10) GO TO 100
   80 CALL ERROR1(43H ILLEGAL VARIABLE IN SUBSCRIPT CONSTRUCTION, 43)
      GO TO 120
   90 CALL SATT1(KQ, 8, 10)
C
C     IMPLICITLY TYPE VARIABLES FIRST ENCOUNTERED IN SUBSCRIPT
C     CONSTRUCT
C
  100 IF (I1.GT.0) GO TO 110
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(KQ, 1, I1)
  110 IF (I2.NE.0 .OR. I1.NE.2) GO TO 80
  120 IF (STMT(K2).NE.60 .AND. STMT(K2).NE.61) GO TO 130
      CALL NEXTOK(K2+1, K3, K)
      IF (K.NE.1) GO TO 20
      K2 = K3
  130 ICNT = ICNT + 1
      IF (STMT(K2).EQ.68) GO TO 140
      IF (STMT(K2).NE.62) GO TO 20
      IF (NO.NE.ICNT) CALL ERROR1(34H INCOMPATIBLE NUMBER OF SUBSCRIPTS,
     *    34)
      IF (ICNT.GT.3) CALL ERROR1(20H TOO MANY SUBSCRIPTS, 20)
      GO TO 40
  140 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 20
      GO TO 10
      END
      SUBROUTINE SUBFCN(TYPE)
C
C     TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
C     ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
C     NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
C     ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
C     LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
C     SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE.  IN CASE
C     OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
C     PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
C
      INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
      KCELL = 0
      CALL NEXTOK(PSTMT, K2, I1)
      IF (I1.NE.0) GO TO 120
C
C     SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
C     OR IMPLICIT TYPE
C
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      NAME = K
      L = ITYP - 8
      GO TO (10, 20), L
   10 CALL SATT1(K, 8, 3)
      GO TO 40
   20 CALL SATT1(K, 8, 4)
      IF (TYPE.LT.0) GO TO 30
      CALL SATT1(K, 1, TYPE+8)
      GO TO 40
   30 L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(K, 1, L)
   40 IF (STMT(K2).NE.65) GO TO 140
   50 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 120
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 80
C
C     ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
C     LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
C     USAGE
C
      N = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      I2 = IGATT1(N,4)
      I1 = IGATT1(N,8)
      IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
      L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(N, 1, L)
      L = IGATT1(N,4)
      IF (L.EQ.1) GO TO 80
      CALL SATT1(N, 4, 1)
      IF (NEXT+2.GE.BNEXT) GO TO 150
      IF (KCELL.EQ.0) GO TO 60
      DSA(KCELL+1) = NEXT
      GO TO 70
C
C     START PARAM LIST
C
   60 DSA(K+2) = NEXT
   70 KCELL = NEXT
      DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
C
C     SEARCH FOR  ")" OR ","
C
      IF (STMT(K2).EQ.62) GO TO 100
      IF (STMT(K2).EQ.68) GO TO 50
   80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
   90 RETURN
  100 K2 = K2 + 1
  110 IF (K2.EQ.NSTMT) GO TO 90
      CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
      GO TO 90
  120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      PSTMT = 6
      DO 130 I1=1,5
        STMT(I1+5) = S(I1)
  130 CONTINUE
      NAME = LOOKUP(11,.FALSE.)
      IF (SYSERR) GO TO 90
      CALL SATT1(NAME, 8, 11)
      GO TO 90
  140 IF (ITYP.EQ.9) GO TO 110
      CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
      GO TO 120
  150 SYSERR = .TRUE.
      CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
      GO TO 90
      END
      LOGICAL FUNCTION TOKCOM(K1, K2)
C
C     TOKCOM RETURNS TRUE IS FINDS CONST IN STMT(K1)-STMT(K2-1)
C     ( (OPTIONAL SIGN) REAL CONST, (OPTIONAL SIGN) REAL CONST )  IS
C     COMPLEX CONSTRUCT; TOKCOM RESETS K2
C
      LOGICAL TOKRL
      INTEGER STMT, PSTMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      TOKCOM = .FALSE.
      IF (STMT(K1).NE.65) GO TO 10
      K3 = K1 + 1
      IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
      IF (TOKRL(K3,K2,K)) IF (K-1) 10, 20, 10
   10 RETURN
   20 IF (STMT(K2).NE.68) GO TO 10
      K3 = K2 + 1
      IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
      IF (TOKRL(K3,K2,K)) IF (K-1) 10, 30, 10
      GO TO 10
   30 IF (STMT(K2).NE.62) GO TO 10
      K2 = K2 + 1
      TOKCOM = .TRUE.
      GO TO 10
      END
      LOGICAL FUNCTION TOKLAB(K1, K2, KK, DEF)
      INTEGER STMT, PSTMT, SYMHD, DSA, PDSA, BNEXT, DOPT, DOLIST
      LOGICAL DEF, NON0, SYSERR, ABORT, ERR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /FACTS/ NAME, NOST, ITYPE, IASF
C
C     LOOKS FOR DEFNS OF LABEL IF DEF = .TRUE., ELSE LOOKS FOR
C     REFS. IF IT FINDS A LABEL TOKLAB=.TRUE.
C     IN REFERENCE LABEL IS IN STMT(PSTMT)-STMT(K2-1)
C     IN DEFN LABEL IS IN STMT(1)-STMT(K2-1)
C     KK IS SYMBOL TABLE INDEX OF LABEL
C     K1 IS TYPE OF LABEL EXPECTED OR DEFINED--1-EXECUTABLE
C     2-NONEXECUTABLE, 3-FORMAT
C     IN REF, ROUTINE SETS USAGE OF SYMBOL AND CHECKS FOR
C     COMPATIBLE REFERENCES(I.E. GOTO 5 AND WRITE(6,5) ARE INCOMPAT.)
C     IN DEF, ROUTINE SETS USAGE OF SYMBOL, CHECKS FOR DUPLICATE
C     DEFNS, CHECKS FOR COMPATIBLITY BETWEEN DEFN AND PREVIOUS
C     REFS, CREATES SCOPE AREA FOR LABEL INITIALIZING WORD1 TO
C     CURRENT HEADING STMT NO ON DOLIST AND WORD2 TO CURRENT LEVEL
C     IN REFS AND DEFS LABELS MUST BE POSITIVE NUMBERS
C
      TOKLAB = .FALSE.
      IF (DEF) GO TO 80
      NON0 = .FALSE.
      J = PSTMT + 4
      IF (J.GT.NSTMT) J = NSTMT
      K3 = PSTMT
      DO 10 K2 = PSTMT,J
        IF(STMT(K2).GT.9 .OR. STMT(K2).LT.0) GOTO 60
        IF(STMT(K2) .GT. 0) NON0 = .TRUE.
        IF(.NOT.NON0) K3 = K3+1
 10   CONTINUE
      K2 = J+1
      IF(.NOT.NON0) GOTO 70
C     NOTE CAN CHANGE PSTMT HERE BECAUSE WE KNOW WE HAVE A LAB
 20   PSTMT = K3
      KK = LOOKUP(K2,.TRUE.)
      IF (SYSERR) GO TO 50
      IF (ITYPE.EQ.14) DSA(BNEXT+1) = -DSA(BNEXT+1)
      I = IGATT1(KK,8)
      IF (I.EQ.0) CALL SATT1(KK, 8, 9)
      I1 = IGATT1(KK,1)
      IF (I1.NE.0) GO TO 30
      CALL SATT1(KK, 1, K1)
      GO TO 40
   30 IF (K1.NE.I1) CALL ERROR1(30H INCOMPATIBLE LABEL REFERENCES, 30)
   40 TOKLAB = .TRUE.
   50 RETURN
   60 IF (K2.EQ.PSTMT) GO TO 50
      IF (NON0) GO TO 20
   70 CALL ERROR1(30H LABEL MUST BE POSITIVE NUMBER, 30)
      GO TO 50
C
C     TAKES DEF OF LABEL; CHECKS FOR DUPLICATE DEFS.; SETS DEFINED
C     BIT IN SYMBOL TABLE;  STORES BEGINNING BINDING STMT NO
C
   80 K2 = 0
      NON0 = .FALSE.
      DO 90 I=1,5
        IF (STMT(I).EQ.69) GO TO 90
        IF ((STMT(I).GT.9) .OR. (STMT(I).LT.0)) GO TO 140
        IF (STMT(I).GT.0) NON0 = .TRUE.
        IF (.NOT.NON0) GO TO 90
        K2 = K2 + 1
        STMT(K2) = STMT(I)
   90 CONTINUE
      IF (K2.EQ.0) GO TO 50
      IF (.NOT.NON0) GO TO 70
      K2 = K2 + 1
      KK = LOOKUP(K2,.TRUE.)
      IF (SYSERR) GO TO 50
      I = IGATT1(KK,2)
      IF (I.EQ.1) GO TO 120
      CALL SATT1(KK, 2, 1)
      CALL SATT1(KK, 8, 9)
      I1 = IGATT1(KK,1)
      IF (I1.EQ.0) GO TO 100
      IF (I1.EQ.K1) GO TO 110
      CALL ERROR1(44H ILLEGAL REFERENCE TO LABEL IN PREVIOUS CODE, 44)
  100 CALL SATT1(KK, 1, K1)
  110 IF (K1.NE.1) GO TO 40
      IF (NEXT+2.GE.BNEXT) GO TO 130
      DSA(KK+2) = NEXT
      DSA(NEXT) = DOLIST(DOPT)
      DSA(NEXT+1) = -DOPT/6
      NEXT = NEXT + 2
      GO TO 40
  120 CALL ERROR1(16H DUPLICATE LABEL, 16)
      GO TO 50
  130 CALL ERROR1(33H IN TOKLAB, TABLE OVERFLOW OF DSA, 33)
      SYSERR = .TRUE.
      GO TO 50
  140 CALL ERROR1(24H ILLEGAL SYMBOL IN LABEL, 24)
      GO TO 50
      END
      LOGICAL FUNCTION TOKLOG(K1, K2)
C
C     ROUTINE RETURNS TRUE IF FINDS .TRUE. OR .FALSE.
C     IN STMT(K1)-STMT(K2-1)
C
      INTEGER STMT, CONS(13), PSTMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      DATA CONS(1) /64/, CONS(2) /35/, CONS(3) /30/, CONS(4) /41/,
     *    CONS(5) /48/, CONS(6) /34/, CONS(7) /64/, CONS(8) /64/,
     *    CONS(9) /49/, CONS(10) /47/, CONS(11) /50/, CONS(12) /34/,
     *    CONS(13) /64/
      TOKLOG = .FALSE.
      KCNT = 1
      L1 = 1
      L2 = 7
      K2 = K1
   10 DO 20 I=L1,L2
        IF (STMT(K2).NE.CONS(I)) GO TO 30
        K2 = K2 + 1
   20 CONTINUE
      TOKLOG = .TRUE.
      RETURN
   30 KCNT = KCNT + 1
      IF (KCNT.GE.3) RETURN
      K2 = K1
      L1 = 8
      L2 = 13
      GO TO 10
      END
      LOGICAL FUNCTION TOKLOP(K1, K2, KCODE)
C
C     ROUTINE RETURNS TRUE IF FINDS LOGICAL OR RELATIONAL
C     OPERATORS IN STMT(K1)-STMT(K2-1);  RETURNS OPERATOR CODE
C     IN KCODE (SEE EXPR FOR CODES)
C
      INTEGER C(20), CC(9), CODE(9), PSTMT, STMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      DATA C(1) /30/, C(2) /43/, C(3) /33/, C(4) /43/, C(5) /44/, C(6)
     *    /49/, C(7) /44/, C(8) /47/, C(9) /34/, C(10) /46/, C(11)
     *    /43/, C(12) /34/, C(13) /36/, C(14) /49/, C(15) /36/, C(16)
     *    /34/, C(17) /41/, C(18) /49/, C(19) /41/, C(20) /34/
      DATA CC(1), CC(2) /2*3/, CC(3), CC(4), CC(5), CC(6), CC(7),
     *    CC(8), CC(9) /7*2/, CODE(1) /19/, CODE(2) /14/, CODE(3) /20/,
     *    CODE(4), CODE(5), CODE(6), CODE(7), CODE(8), CODE(9) /6*21/
      TOKLOP = .FALSE.
      IF (STMT(K1).NE.64) RETURN
      J = 1
      DO 30 I=1,9
        KK = J + CC(I) - 1
        K2 = K1 + 1
        DO 10 L=J,KK
          IF (STMT(K2).NE.C(L)) GO TO 20
          K2 = K2 + 1
   10   CONTINUE
        KCODE = CODE(I)
        IF (STMT(K2).NE.64) RETURN
        K2 = K2 + 1
        TOKLOP = .TRUE.
        RETURN
   20   J = J + CC(I)
   30 CONTINUE
      RETURN
      END
      LOGICAL FUNCTION TOKPNO(K1, K2, LL)
C
C     ROUTINE RECOGNIZES A POSITIVE INTEGER CONSTANT
C     IN STMT(K1)-STMT(K2-1), AND RETURNS ITS VALUE IN LL
C
      INTEGER STMT, PSTMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      TOKPNO = .FALSE.
      CALL NEXTOK(K1, K2, K)
      IF (K.NE.1) RETURN
      K=K2-1
      LL = 0
      DO 10 KK=K1,K
        LL = 10 * LL + STMT(KK)
   10 CONTINUE
      IF (LL.GT.0) TOKPNO = .TRUE.
      RETURN
      END
      LOGICAL FUNCTION TOKRL(K1, K2, CODE)
      INTEGER STMT, CODE, PSTMT
      LOGICAL TOKLOP
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     ROUTINE RETURNS TRUE IF FINDS A REAL CONSTANT IN
C     STMT(K1)-STMT(K2-1) . ELSE IT RETURNS FALSE.
C     BASIC CONSTRUCT IS: <INT> . <INT>
C     <INT> .
C     . <INT>
C     EACH OF THESE MAY BE FOLLOWED BY <D,E> <+,-> <INT>
C     ALSO LEGAL IS IN-CONST FOLLOWED BY EXPONENT CONSTRUCT
C
      TOKRL = .FALSE.
      CALL NEXTOK(K1, K2, K)
      IF (K.EQ.3 .AND. STMT(K1).EQ.64) GO TO 10
      IF (K.EQ.1 .AND. STMT(K2).EQ.64) GO TO 40
C     IF HAVE INT-CONST NEED EXPONENT FOR THIS TO BE A REAL-CONST
      IF (K-1) 80, 50, 80
C
C     FIND BASIC REAL CONSTANT
C
C     (. INT-CONST) CONSTRUCT
   10 CALL NEXTOK(K2, K3, K)
      IF (K.NE.1) GO TO 80
   20 K2 = K3
   30 TOKRL = .TRUE.
      CODE = 1
      GO TO 50
C     (INT-CONST .) CONSTRUCT; CHECK FOR (INT . INT )
   40 K2 = K2 + 1
      CALL NEXTOK(K2, K3, K)
      IF (K.EQ.1) GO TO 20
      IF (TOKLOP(K2-1,K4,K)) GO TO 80
      GO TO 30
C
C     CHECK FOR EXPONENT
C
   50 IF (STMT(K2).NE.33) GO TO 60
      CODE = 0
      GO TO 70
   60 IF (STMT(K2).NE.34) GO TO 80
      CODE = 1
   70 K3 = K2 + 1
      IF (K3.EQ.NSTMT) GO TO 80
      IF ((STMT(K3).EQ.60) .OR. (STMT(K3).EQ.61)) K3 = K3 + 1
      CALL NEXTOK(K3, K4, K)
      IF (K.NE.1) GO TO 80
      K2 = K4
      TOKRL = .TRUE.
   80 RETURN
      END
      SUBROUTINE TYPE
      LOGICAL ERR, SYSERR, ARDECL, ABORT
      INTEGER STMT, PSTMT, DSA, PDSA
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C     PROCESSES TYPE STMT BY FINDING IDS OR ARRAY DECLS
C     THEY ARE ENTERED INTO SYMBOL TABLE AND TYPED EXPLICITLY
C     NO USAGE IS SET.
C
   10 IF (.NOT.ARDECL(K2,INDX)) GO TO 20
      IF (SYSERR) GO TO 30
      L = IGATT1(INDX,6)
      IF(L.EQ.1) CALL ERROR1(63
     1H WARNING - SHOULD TYPE ADJUSTABLE DIMENSION VARIABLE BEFORE USE
     2, 63)
      IF (K2.EQ.NSTMT) GO TO 30
      IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 40
   20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
   30 RETURN
   40 PSTMT = K2 + 1
      GO TO 10
      END
      SUBROUTINE TYPST(ITYP, KK, KL)
      INTEGER PSTMT, K(186), KI(30), STMT, CODE, KT(30)
      LOGICAL ERR, SYSERR, ASSMT, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /STS/ K, KI, KT
C
C*****STS
C     K(*) (INT) ARRAY CONTAINS A TABLE OF INTERNAL CODES FOR EACH
C     "KEYWORD" IN FORTRAN STMTS
C     KI(*) (INT) ARRAY CONTAINING NUMBER OF CHARACTERS IN EACH
C     KEYWORD IN K
C     KT(*)  (INT) ARRAY CONTAINING CLASS OF EACH STMT IN K
C     (SEE PU FOR FURTHER DOC OF IGP -CLASS)
C     TEST IF ITS AN ASSIGNMENT; IF SO ITYP = 30
C     ELSE SEARCH K ARRAY FOR STMT;  ITYP CONTAINS CODED
C     TYPE OF STMT; KK CONTAINS GENERAL CLASS OF STMTS IT FALLS IN
C     KL IS COUNT OF NUMBER OF LETTERS IN FIRST WORD OF STMT
C
      CALL TYPST2(ASSMT)
      IF (ASSMT) GO TO 40
      J = 1
      CODE = 0
   10 I = PSTMT
      CODE = CODE + 1
      L = J + KI(CODE) - 1
      DO 20 LL=J,L
        IF (STMT(I).NE.K(LL)) GO TO 30
        I = I + 1
   20 CONTINUE
      ITYP = CODE
      KK = KT(CODE)
      KL = KI(CODE)
      RETURN
   30 J = L + 1
      IF (CODE.LT.29) GO TO 10
      ERR = .TRUE.
      RETURN
   40 ITYP = 30
      KK = KT(30)
      KL = 0
      RETURN
      END
      SUBROUTINE TYPST2(ASSMT)
      INTEGER PSTMT, STMT
      LOGICAL EQUALS, ASSMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C     ALGORITHM FOR IDENTIFYING ASSIGNMENT STMTS:
C
      EQUALS = .FALSE.
      LEVEL = 0
      IGP = 0
C
C     62.....)     63.....=     65.....(     68.....,
C
      DO 40 I=PSTMT,NSTMT
        IF (STMT(I).EQ.65) LEVEL = LEVEL + 1
        IF (STMT(I).NE.62) GO TO 10
        LEVEL = LEVEL - 1
        IF (EQUALS) GO TO 40
        IF (LEVEL.EQ.0) IGP = IGP + 1
        IF (IGP.EQ.1 .AND. LEVEL.EQ.0 .AND. STMT(I+1).NE.63) GO TO 60
        GO TO 40
   10   IF (LEVEL) 50, 20, 30
   20   IF (STMT(I).EQ.68) GO TO 60
        IF (STMT(I).EQ.63) EQUALS = .TRUE.
        GO TO 40
   30   IF (STMT(I).EQ.63) GO TO 60
   40 CONTINUE
      IF (.NOT.EQUALS) GO TO 60
      ASSMT = .TRUE.
   50 RETURN
   60 ASSMT = .FALSE.
      GO TO 50
      END
      SUBROUTINE SATT2(INDEX, FIELD, ATT)
C
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
      INTEGER INDEX, FIELD, ATT
      INTEGER LLAT, PLAT, LAT
      INTEGER FWTH(8), FPOS(8)
C
      DATA FWTH(1) /16/, FPOS(1) /1/
      DATA FWTH(2) /2/, FPOS(2) /16/
      DATA FWTH(3) /2/, FPOS(3) /32/
      DATA FWTH(4) /2/, FPOS(4) /64/
      DATA FWTH(5) /2/, FPOS(5) /128/
      DATA FWTH(6) /2/, FPOS(6) /256/
      DATA FWTH(7) /4/, FPOS(7) /512/
      DATA FWTH(8) /32/, FPOS(8) /2048/
C
      LAT(INDEX) = LAT(INDEX) + (ATT-MOD(LAT(INDEX)/FPOS(FIELD),
     *    FWTH(FIELD)))*FPOS(FIELD)
C
      RETURN
C
      END
      INTEGER FUNCTION IGATT2(INDEX, FIELD)
C
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
      INTEGER INDEX, FIELD
      INTEGER LLAT, PLAT, LAT
      INTEGER FWTH(8), FPOS(8)
C
      DATA FWTH(1) /16/, FPOS(1) /1/
      DATA FWTH(2) /2/, FPOS(2) /16/
      DATA FWTH(3) /2/, FPOS(3) /32/
      DATA FWTH(4) /2/, FPOS(4) /64/
      DATA FWTH(5) /2/, FPOS(5) /128/
      DATA FWTH(6) /2/, FPOS(6) /256/
      DATA FWTH(7) /4/, FPOS(7) /512/
      DATA FWTH(8) /32/, FPOS(8) /2048/
C
      IGATT2 = MOD(LAT(INDEX)/FPOS(FIELD),FWTH(FIELD))
C
      RETURN
C
      END
      SUBROUTINE CALLS
      INTEGER STMT, PSTMT, EXPR, M(3), OUTUT3, OUTUT4
      LOGICAL ERR, SYSERR, ABORT
      LOGICAL OPT, P1ERR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /PARAMS/ I1, I2, I6, I4, I5, OUTUT3, OUTUT4
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /OPTNS/ OPT(5), P1ERR
      DATA M(1) /4/, M(2) /2/, M(3) /0/
C
C      CHECK FOR LEGAL SUBROUTINE NAME BEFORE CALLING EXPR
C      TO PROCESS ARGUMENTS
C     IF NO ARGS, CALLS SAVES PASS 2 DATA ITSELF WITHOUT
C     CALLING EXPR
C
      IF (PSTMT.GE.NSTMT) GO TO 10
      CALL NEXTOK(PSTMT, K2, K)
      IF (K.NE.0) GO TO 10
      IF (K2.EQ.NSTMT) GO TO 40
      IF (STMT(K2).EQ.65) GO TO 30
   10 CALL ERROR1(26H MISSING ROUTINE NAME OR (, 26)
   20 RETURN
C
C     BY A CALL TO EXPR
C
   30 I3 = EXPR(K)
      IF (SYSERR) GO TO 20
      IF (PSTMT.NE.NSTMT) CALL ERROR1(18H ILLEGAL CALL STMT, 18)
      GO TO 20
C
C     SAVE SUBROUTINE CALL W/O ARGS
C
   40 K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 20
      I3 = IGATT1(K,8)
      IF (I3.NE.13 .AND. I3.NE.0) GO TO 50
      CALL SATT1(K, 8, 6)
      GO TO 60
C
C     MAKE SURE EXTERNAL REFERENCED ID IS NOT USED AS ANYTHING
C     OTHER AS A SUBROUTINE ELSEWHERE IN THIS P-U
C
   50 IF (I3.EQ.6) GO TO 60
      CALL ERROR1(24H ILLEGAL SUBROUTINE NAME, 24)
      GO TO 20
   60 IF (OPT(3) .AND. .NOT.P1ERR) WRITE (OUTUT3) M, K, NOST, M(3)
      GO TO 20
      END
      SUBROUTINE DATA
      LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR
      INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA,
     *    PDSA
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CEXPRS/ LSTACK, STACK(620)
      DATA IS /1H*/
C
C     ROUTINE PROCESSES A DATA STMT
C
   10 DECNT = 0
   20 IF (ARDECL(K2,KK)) GO TO 30
      IF (.NOT.ERR) GO TO 30
      CALL ERROR1(19H ILLEGAL DECLARATOR, 19)
      IF(.NOT.SYSERR)  GOTO 260
   30 IF (SYSERR) RETURN
C
C     SET DECLARATOR USAGE AS VARIABLE;  CHECK ITS NOT IN BLANK COMMON
C     CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM
C     FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK
C     TYPE OF ITS CORRESPONDING DATA-ITEM;  ADD IN COUNT SO CAN
C     CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS
C     KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK
C
      I = IGATT1(KK,8)
      IF (I.EQ.0) CALL SATT1(KK, 8, 10)
      I = IGATT1(KK,2)
      NN = IGATT1(NAME,8)
      IF (I) 60, 60, 40
C
C     IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR
C     IN DATA STMT
C
   40 I = DSA(KK+2)
      I = DSA(I+1)
      CALL S5UNPK(DSA(I+4), S(1), 6)
      IF (S(1).EQ.IS) GO TO 50
C
C     FOUND NO "*" SO ARE IN LABELLED COMMON
C
      IF (NN.EQ.11) GO TO 70
      CALL ERROR1(
     *    55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE,
     *    55)
      GO TO 260
C
C     FOUND BLANK COMMON
C
   50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON,
     *    48)
      GO TO 260
   60 IF (NN.NE.11) GO TO 70
      CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33)
      GO TO 260
   70 I = IGATT1(KK,1)
      CALL SATT1(KK, 5, 1)
      NN = 1
      IF (IGATT1(KK,7).EQ.0) GO TO 75
      IF (STMT(K2-1).EQ.62) GO TO 75
      N = DSA(KK+2)
      NN = DSA(N)
   75 CONTINUE
      IF (DECNT+3.LE.LSTACK) GO TO 76
      CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 )
      GO TO 260
   76 CONTINUE
      STACK(DECNT+1) = MOD(I,8)
      STACK(DECNT+2) = KK
      STACK(DECNT+3) = NN
      DECNT = DECNT + 3
      IF (STMT(K2).EQ.67) GO TO 100
      IF (STMT(K2).NE.68) GO TO 90
      PSTMT = K2 + 1
      IF (PSTMT.LT.NSTMT) GO TO 20
   80 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      RETURN
   90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33)
      GO TO 260
C
C     FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR
C     SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN
C     REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND
C
  100 DATCNT = 0
      ERROR = .FALSE.
      PSTMT = K2 + 1
  110 IF (PSTMT.EQ.NSTMT) GO TO 80
      SIGN = .FALSE.
      REPL = .FALSE.
      NN = 1
  120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130
      PSTMT = PSTMT + 1
      SIGN = .TRUE.
  130 IF (PSTMT.EQ.NSTMT) GO TO 80
      KK = GETTOK(PSTMT,K2)
      IF (ERR) GO TO 80
      IF (KK.LT.6) GO TO 150
  140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18)
      GO TO 260
  150 KK = KK + 1
      GO TO (200, 200, 160, 190, 190, 180), KK
C
C     MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO
C
  160 IF (REPL) GO TO 200
      IF(SIGN .OR. STMT(K2).NE.66) GOTO 200
      IF(TOKPNO(PSTMT,K2,NN)) GOTO 170
      CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27)
      NN = 1
  170 REPL = .TRUE.
      PSTMT = K2 + 1
      GO TO 120
C
C     CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD
C
  180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190
      CALL ERROR1(
     *    53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53)
      ERROR = .TRUE.
C
C     CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED
C
  190 IF (SIGN) GO TO 140
C
C     CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS
C     NN IS REPLICATION FACTOR;
C
200   IBR=0
      DO 220 I = 1,NN
        IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
        IF (DATCNT .GE. DECNT) GO TO 240
        STACK(DATCNT+3) = STACK(DATCNT+3) - 1
        IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220
        IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND.
     *      (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210
        CALL SATT1(STACK(DATCNT+2), 1, 5)
        GO TO 220
 210  IBR = 1
  220 CONTINUE
      IF(IBR .EQ. 1) CALL ERROR1(52
     1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52)
C
C     CHECK FOR "," BETWEEN DATA-ITEMS
C
      IF (STMT(K2).NE.68) GO TO 230
      PSTMT = K2 + 1
      GO TO 110
C
C     CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS
C
  230 IF (STMT(K2).NE.67) GO TO 90
      IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
      IF (DATCNT.EQ.DECNT) GO TO 250
  240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34)
      IF (DATCNT.GE.DECNT) GO TO 260
  250 PSTMT = K2 + 1
      IF (PSTMT.EQ.NSTMT) RETURN
      IF (STMT(PSTMT).NE.68) GO TO 90
      PSTMT = PSTMT + 1
      IF (PSTMT.NE.NSTMT) GO TO 10
      GO TO 80
C
C     FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT
C
  260 IF (PSTMT+1.GE.NSTMT) RETURN
      IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270
      PSTMT = PSTMT + 1
      GO TO 260
  270 PSTMT = PSTMT + 2
      IF (PSTMT.GE.NSTMT) RETURN
      GO TO 10
      END
      SUBROUTINE DOSTMT
      LOGICAL TOKLAB, ERR, SYSERR, ABORT
      INTEGER STMT, PSTMT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     ROUTINE PROCESSES A DO STMT. DOSTMT PEELS OFF THE
C     LABEL. CALLS DOSPEC TO GET THE <DO-SPECIFICATION>
C
      IF (TOKLAB(1,K2,KK,.FALSE.)) GO TO 10
      CALL ERROR1(23H MISSING LABEL AFTER DO, 23)
      GO TO 20
   10 IF (SYSERR) GO TO 20
      PSTMT = K2
      CALL DOSPEC(KK, K2, .FALSE.)
   20 RETURN
      END
      SUBROUTINE END
C
C     ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS
C     CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S
C     CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING;
C     CHECKS SUCH BOUNDS FOR TYPE INTEGER
C     CALLS OUTSYM TO PRINT SYMBOL TABLE
C     CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS,
C     PROPER BRANCHING THROUGHOUT PGM,
C     FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED
C     SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET
C     RESETS FCN USAGE IN FCN  SUBPROGRAM
C
      INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4
      INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA
      LOGICAL OPT, P1ERR
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      I = IGATT1(NAME,8)
      IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40
C
C     ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS
C
      LL = 1
      L = DSA(NAME+2)
      NPAR = 0
   10 IF (L.EQ.0) GO TO 40
      NPAR = NPAR + 1
C     CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT
C     IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY
      I = IGATT1(DSA(L),8)
      IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20
      I = DSA(L)
      DSA(I+2) = NPAR
      GO TO 30
   20 I = IGATT1(DSA(L),6)
      IF (I.EQ.0) GO TO 30
      I = IGATT1(DSA(L),7)
      IF (I.NE.0) GO TO 30
      I = IGATT1(DSA(L),5)
      K = DSA(L)
      IF (I.GT.0) CALL ERROR2(
     *    57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING ,
     *  57, DSA(K+4), 1, 1, 1)
      I = IGATT1(K,1)
      IF (MOD(I,8).NE.2) CALL ERROR2(
     *  47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47
     *  , DSA(K+4), 1, 1, 1)
   30 L = DSA(L+1)
      GO TO 10
C
C     OUTPUT TABLE
C
   40 CALL DOCHK(1)
C
C     CHECK LABELS DEFINED AND WITHIN SCOPE
C
      I = LABHD
   50 IF (I.EQ.0) GO TO 110
      L = IGATT1(I,2)
      IF (L.EQ.1) GO TO 60
      CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1)
      GO TO 100
   60 L = IGATT1(I,1)
      IF (L.NE.1) GO TO 100
      L = DSA(I+2)
      L1 = DSA(L)
      KK = DSA(L+1)
      L2 = DSA(I+1)
C
C     L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST
C
      L3 = L2
   70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90
      IF (DSA(L2).LT.0) GO TO 80
      CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1)
      GO TO 90
   80 DSA(L2) = IABS(DSA(L2))
   90 L2 = DSA(L2+1)
      IF (L2.NE.L3) GO TO 70
  100 I = DSA(I+3)
      GO TO 50
C
C     SET <ID> USAGE IF NOT YET SET
C
  110 I = SYMHD
  120 IF (I.EQ.0) GO TO 150
      K = IGATT1(I,8)
      IF (K.NE.0) GO TO 130
      CALL SATT1(I, 8, 10)
      GO TO 140
  130 IF (K.NE.6) GO TO 140
      IF (IGATT1(I,1)/8.NE.1) GO TO 140
      CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4),
     *  1, 1, 1)
  140 I = DSA(I+3)
      GO TO 120
C
C     RESET FCN USAGE IN FCN PROGRAM UNIT
C
  150 I = IGATT1(NAME,8)
      IF (I.NE.10) GO TO 160
      CALL SATT1(NAME, 8, 4)
      I = IGATT1(NAME,5)
      IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23)
C
C     SAVE BINARY COPY OF SYMBOL TABLE
C
  160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170
      CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36)
      K = 3
      L = 1
      WRITE(OUTUT2) L,K,L
      WRITE(OUTUT3) L,K,L
      GOTO 180
 170  K = 1
      L = NEXT - 1
      I = L + 3
      WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD
      L = 3
      WRITE (OUTUT3) K, L, K
  180 CALL OUTSYM
      RETURN
      END
      INTEGER FUNCTION EXPR(LOGEX)
C
C     LOGEX IS A DUMMY ARG , NEVER USED
C     FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND
C     PRE IS PRECEDENCE TABLE,  PRE(I,J) GIVES ACTION TAKEN WHEN OP I
C     IS ON THE STACK, OP J IN THE INPUT
C     CUROP IS CURRENT TOKEN TYPE
C     PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP)
C     STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC)
C     OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC)
C     PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS
C
C*****EXPRS
C     PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS
C     FROM STACK(1))
C     PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS
C     FROM STACK(LSTACK))
C     AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS
C     AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J)
C     RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS
C     RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0
C     EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION
C     EX(I,J) = TYPE OF (TYPE I <**> TYPE J)
C
      INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3),
     *    STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT,
     *    GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3,
     *    OUTUT4, PREF, REF
      LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR
      LOGICAL INTEXT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /EXPRS/ PT, PB, AO, RO, EX
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA K /0/
      DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/,
     *    PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/,
     *    PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/,
     *    PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/,
     *    PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/,
     *    PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/,
     *    PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/,
     *    PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/,
     *    PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/,
     *    PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/,
     *    PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/,
     *    PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/,
     *    PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/,
     *    PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/
      DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/,
     *    PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/,
     *    PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/,
     *    PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/,
     *    PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/,
     *    PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/,
     *    PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/,
     *    PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/,
     *    PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/,
     *    PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/,
     *    PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/,
     *    PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/,
     *    PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/,
     *    PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/,
     *    PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/,
     *    PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/,
     *    PRE(11,4) /-1/, PRE(11,11) /6/
      DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2)
     *    /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4),
     *    PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12),
     *    PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12),
     *    PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/
      DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4),
     *    IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6)
     *    /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/,
     *    JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8)
     *    /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/
      DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1),
     *    ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/,
     *    ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/,
     *    ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3),
     *    ADJ(4,4) /3*0/, ADJ(4,2) /-1/
C
C     CODES IN OPERAND STACK
C     0....DOUBLE PRECISION       1....REAL   2....INTEGER
C     3....COMPLEX      4....LOGICAL   5....HOLLERITH
C     6....PROCEDURE NAME
C     CODES FOR OPERATORS
C     11 +,-    12 )   13 **  14 .NOT.  15 (  16  FCN(
C     17 /,*  18 ,  19 .AND.  20 .OR.  21 .EQ.  22 UNARY -,+
C
      PB = LSTACK
      PT = 1
      CALLST = .FALSE.
      PREVOP = -1
      CUROP = 0
      PARENS = 0
      FLUSH = .FALSE.
      EXPR = -1
   10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110
C
C     FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN
C     TYPE OF EXPRESSION
C
   20 IF (PARENS.EQ.0) GO TO 40
   30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37)
      IF (FLUSH) GO TO 530
      GO TO 80
   40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60
   50 CALL POP
      IF (ERR) GO TO 530
      IF (PB.LT.LSTACK) GO TO 50
   60 IF (PT.NE.3) GO TO 90
      IF (STACK(1).EQ.0) GO TO 70
      I = IGATT1(STACK(1),8)
      IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10)
   70 EXPR = STACK(2)
   80 PSTMT = K2
      ERR = .FALSE.
      RETURN
   90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29)
      IF (FLUSH) GO TO 530
      GO TO 80
  100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31)
      GO TO 530
C
C     CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN,
C
  110 CUROP = GETTOK(PSTMT,K2)
      IF (ERR) GO TO 80
C
C     SEE END OF EXPRESSION:  ")" <ID> OR <LABEL>; GETTOK RETURNS
C     SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE
C
      IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR.
     *    PREVOP.NE.12) GO TO 120
      K2 = PSTMT
      GO TO 20
C
C     CHECK FOR ADJACENT OPERATORS OR OPERANDS.
C
  120 IF (PREVOP.LE.6) GO TO 130
      I = IBR(PREVOP-10)
      GO TO 140
  130 I = IBR(13)
      IF(PREVOP.EQ.(-1)) I = IBR(14)
  140 IF (CUROP.LE.6) GO TO 150
      I2 = JBR(CUROP-10)
      GO TO 160
  150 I2 = JBR(13)
  160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22
      IF (ADJ(I,I2)) 170, 190, 180
  170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44)
      GO TO 530
  180 CALL ERROR1(
     *    54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54)
  190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290
      IF (CUROP.LT.6) GO TO 280
C
C     PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY
C     LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY
C     TYPE IDENTIFIERS IF NECESSARY.
C
      IF (CUROP.EQ.6) GO TO 200
      K = LOOKUP(K2-1,.FALSE.)
      GO TO 210
  200 K = LOOKUP(K2,.FALSE.)
  210 IF (SYSERR) GO TO 530
      I1 = IGATT1(K,1)
      I2 = IGATT1(K,7)
      I3 = IGATT1(K,8)
C
C     IMPLICITLY TYPE IDENTIFIERS AND FCNS
C
      IF (I1.GT.0) GO TO 220
      I1 = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
      CALL SATT1(K, 1, I1)
C
C     SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF.
C
  220 I1 = MOD(I1,8)
      IF (CUROP.NE.16) GO TO 250
      IF (I2.EQ.0) GO TO 240
C
C     ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND  PEEL  OFF
C     SUBSCRIPTS, CHECKING THEIR NUMBER
C
      IF (ITYP.NE.31) GO TO 230
      CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39)
  230 CUROP = I1
      I1 = CUROP + 16
      PSTMT = K2
      CALL SUBS(K2, I2)
      IF (ERR .OR. SYSERR) GO TO 80
      GO TO 270
C
C     PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE
C     IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED
C     AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT.
C
  240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13
     *    .OR. I3.EQ.14) GO TO 290
C
C     ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH
C     STORES CALL TEMPLATE
C
      CALL ERROR1(18H ILLEGAL USE OF ID, 18)
      GO TO 530
C
C     VARIABLE, ARRAY, PROCEDURE NAME
C
  250 IF (I2.EQ.0) GO TO 260
C
C     ARRAY
C
      CUROP = I1
      I1 = CUROP + 8
      IF (I3.EQ.0) CALL SATT1(K, 8, 10)
      GO TO 270
C
C     VARIABLE OR PROCEDURE
C     LEAVE IDS USAGE UNSET
C     THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING
C     DEFINED AS FCN  OR SUBROUTINE REFS BY FOLLOWING PGMS
C
  260 IF (I3.EQ.0) GO TO 270
      IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6
      IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270
      IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270
      CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36)
      GO TO 530
C
C     ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK
C     UPDATE PREVOP,PSTMT.  ALSO ENTER SYMBOL TABLE INDEX FOR THESE
C     PREVOP = 0,1,...6 FOR OPERANDS
C     11,12,...22 FOR OPERATORS
C
  270 IF (PT+2.GE.PB) GO TO 100
      STACK(PT) = K
      STACK(PT+1) = I1
      PT = PT + 2
      PREVOP = CUROP
      PSTMT = K2
      GO TO 10
C
C     ARE PROCESSING A CONSTANT
C
  280 I1 = CUROP
      K = 0
      GO TO 270
C
C     ARE PROCESSING AN OPERATER
C     PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK
C     AND OPERATOR J IN INPUT
C
  290 KNAME = K
      IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1
      IF (CUROP.EQ.12) PARENS = PARENS - 1
      IF (PARENS.GE.0) GO TO 300
      FLUSH = .TRUE.
      GO TO 30
C
C     CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS
C
  300 IF (PB.EQ.LSTACK) GO TO 460
      I = STACK(PB+1) - 10
      I2 = CUROP - 10
      K = PRE(I,I2)
  310 IF (-1.NE.K) GO TO 320
      FLUSH = .TRUE.
      GO TO 90
  320 GO TO (330, 470, 520, 480, 480, 490, 510), K
C
C     CREATE TEMPLATE FROM FCN CALL
C
  330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE.
      L1 = STACK(PB+2)
      L2 = PT - 1
C
C     CHECK FOR NO ARGS
C
      IF (L2.GT.L1) GO TO 340
      CALL ERROR1(18H MISSING ARGUMENTS, 18)
      GO TO 450
C
C     CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL
C     VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG
C
  340 DO 380 I=L1,L2,2
        IF (STACK(I)) 350, 380, 350
  350   IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32
        I1 = IGATT1(STACK(I),4)
        IF (I1) 380, 380, 360
  360   I1 = IGATT1(STACK(I),6)
        IF (I1) 380, 380, 370
  370   STACK(I+1) = STACK(I+1) + 64
  380 CONTINUE
C
C     CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER
C     OR VICE VERSA
C
      I = STACK(PB+3)
      L = IGATT1(I,8)
      IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410
      IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390
C
C     FOUND AN INTRINSIC FCN
C      CHECK NOT IN A CALL STMT USED AS A SUBROUTINE
C
      IF (CALLST) GO TO 420
      GO TO 450
C
C     DEFINE FCN( USAGE IF UNSET
C     SET USAGE OF ID USED AS A PROC
C
  390 IF (CALLST) GO TO 400
      CALL SATT1(I, 8, 5)
      GO TO 430
  400 CALL SATT1(I, 8, 6)
      GO TO 430
C
C     CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT
C
  410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR.
     *    L.EQ.2)) GO TO 430
  420 CALL ERROR1(18H ILLEGAL REFERENCE, 18)
      GO TO 450
  430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450
C
C     LOAD INTO STACK COUNT OF WORDS IN  DESCRIPTOR, INDEX OF FCN
C     IN SYMBOL TABLE,  STMT NO  OF  REFERENCE
C
      IF (PT+3.GE.PB) GO TO 100
      STACK(PT) = PT - STACK(PB+2)
      STACK(PT+1) = STACK(PB+3)
      STACK(PT+2) = NOST
      STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8)
      L3 = PT + 3
      ICOD = 2
      L = L2 - L1 + 5
      IF (L.LE.LREF) GO TO 440
      CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44)
      GO TO 450
  440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2)
C
C     FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK
C
  450 PT = STACK(PB+2)
      I1 = IGATT1(STACK(PB+3),1)
      STACK(PT) = 0
      STACK(PT+1) = MOD(I1,8)
      PT = PT + 2
      PB = PB + 3
      GO TO 520
C
C     HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO
C     OPERATOR STACK.  FCN( HAS SPECIAL PUSH.
C
  460 IF (CUROP.NE.16) GO TO 480
C
C     FOUND "FCN(" CONSTRUCT  ; STORE 3 THINGS IN STACK
C     PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK   ;
C     OPERAND CODE FOR FCN(
C
  470 IF (PB-3.LE.PT) GO TO 100
      STACK(PB) = KNAME
      STACK(PB-1) = PT
      STACK(PB-2) = CUROP
      PB = PB - 3
      GO TO 520
C
C     SIMPLE PUSH ONTO OPERATOR STACK
C
  480 IF (PB-1.EQ.PT) GO TO 100
      STACK(PB) = CUROP
      PB = PB - 1
      GO TO 520
C
C     POP OPERATOR FROM STACK.  IF STACK EMPTY, PUSH CUROP ONTO
C     STACK.  ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP).
C
  490 CALL POP
      IF (ERR) GO TO 530
      IF (PB.LT.LSTACK) GO TO 500
      GO TO 480
  500 I = STACK(PB+1) - 10
      K = PRE(I,CUROP-10)
      GO TO 310
C
C     POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION
C
  510 CALL POP
      IF (ERR) GO TO 530
C
C     UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR
C
  520 PREVOP = CUROP
      PSTMT = K2
      GO TO 10
C
C     JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE
C     EXPRESSION
C
  530 K2 = PSTMT
      ERR = .FALSE.
  540 IF (K2.GE.NSTMT) GO TO 80
      IF (STMT(K2).EQ.65) PARENS = PARENS + 1
      IF (STMT(K2).NE.62) GO TO 550
      PARENS = PARENS - 1
      IF (PARENS.EQ.0) GO TO 560
  550 K2 = K2 + 1
      GO TO 540
  560 I = GETTOK(K2,I2)
      K2 = I2
      IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80
      GO TO 540
      END
      SUBROUTINE INSTMT(EOF, NCARD)
      LOGICAL ILLEG, ILHOL, ILCONT
      LOGICAL NEWRD, EOF, CONT, OPT, P1ERR
      INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT
      INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4
      DIMENSION IBR(5)
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      DATA NEWRD /.TRUE./
      DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H /
      DATA CARD(1) /1H /
C
C     ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR
C     PER ELEMENT IN THE ARRAY STMT.
C     IN SHOULD BE CALLED AGAIN IF ERR IS TRUE.
C     EACH CARD IS WRITTEN OUT BEFORE BEING PARSED.
C     IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND
C     HOLLERITHS:
C     STATE = 0.....LOOK FOR BREAK CHAR
C     1.....HAVE BREAK CHAR AND NEED DIGIT
C     2.....HAVE DIGIT AND NEED DIGIT OR "H"
C     3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH
C     NOTE: USE "90" AS AN END OF STMT MARKER
C
C     NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER
C     IS USED.  EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1)
C     IS READ     NCARD GIVES # OF CARDS READ FOR THIS STMT
C
   10 NOST = NOST + 1
      STATE = 0
      NSTMT = 0
      ILLEG = .FALSE.
      ILCONT = .FALSE.
      ILHOL = .FALSE.
      NCARD = 0
      CONT = .FALSE.
   20 IF (NEWRD) CALL IN(CARD, INUT)
      IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40
C
C     DEAL WITH OPTIONS CARD
C
      IF (CONT) GO TO 50
      CALL INOPT(CARD)
   30 IF (OPT(4)) WRITE (OUTUT,99999) CARD
99999 FORMAT (11X, 80A1)
      NEWRD = .TRUE.
      GO TO 20
   40 IF (CARD(1).NE.IBR(2)) GO TO 70
C
C     DEAL WITH COMMENT CARD
C
      IF (.NOT.CONT) GO TO 30
C
C     HAVE COMPLETED STMT
C
   50 NEWRD = .FALSE.
      NSTMT = NSTMT + 1
      STMT(NSTMT) = 90
   60 IF (ILLEG) CALL ERROR1(
     *    40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40)
      IF (ILHOL) CALL ERROR1(
     *    46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46)
      IF (ILCONT) CALL ERROR1(
     *    45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45)
      RETURN
   70 IF (CARD(1).NE.IBR(3)) GO TO 80
C
C     HAVE EOF
C
      IF (CONT) GO TO 50
      EOF = .TRUE.
      GO TO 60
   80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100
C
C     DEAL WITH CONTINUATION CARD
C
      II = MAPCHR(CARD(6),ILCONT)
      IF (CONT) GO TO 110
      CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40)
C
C     FLUSH TO NEXT NONCONTINUATION CARD
C
   90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
99998 FORMAT (1H , I5, 5X, 80A1)
      CALL IN(CARD, INUT)
      IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND.
     *    CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND.
     *    CARD(6).NE.IBR(5)) GO TO 90
      NEWRD = .FALSE.
      GO TO 10
C
C     DEAL WITH A NON-CONTINUATION CARD
C
  100 IF (CONT) GO TO 50
C     DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD
  110 NCARD = NCARD + 1
      IF (NCARD.LT.21) GO TO 120
      CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33)
      GO TO 90
  120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
      NEWRD = .TRUE.
      BLK = 0
      IF (NSTMT.NE.0) GO TO 150
      DO 130 I=1,5
        NSTMT = NSTMT + 1
        STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
  130 CONTINUE
  140 I = 7
      GO TO 180
  150 DO 160 I=1,5
        IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170
  160 CONTINUE
      GO TO 140
  170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40)
      GO TO 140
  180 IF (I.LE.72) GO TO 200
C
C     AFTER TRANSLATE CARD CHECK FOR BLANK CARD
C     AND GO BACK FOR A CONTINUATION CARD
C
      IF (BLK.NE.66) GO TO 190
      CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33)
      GO TO 90
  190 CONT = .TRUE.
      GO TO 20
  200 IF (STATE.NE.3) GO TO 210
C
C     STATE 3 --ARE PROCESSING A HOLLERITH
C
      HCOUNT = HCOUNT - 1
      KK = MAPCHR(CARD(I),ILHOL)
      IF (HCOUNT.EQ.0) STATE = 0
      GO TO 290
  210 NSTMT = NSTMT + 1
      STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
      IF (STMT(NSTMT).NE.69) GO TO 220
C
C     BLANK ENCOUNTERED AND DELETED
C
      BLK = BLK + 1
      NSTMT = NSTMT - 1
      GO TO 290
  220 KK = STATE + 1
      GO TO (280, 260, 230), KK
C
C     STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H
C
  230 IF (STMT(NSTMT).LE.9) GO TO 290
      IF (STMT(NSTMT).NE.37) GO TO 270
C
C     PROCESS HOLLERITH COUNT
C
      STMT(NSTMT) = -STMT(NSTMT)
      STATE = 3
      KK = NSTMT - KST
      I10 = 1
      HCOUNT = 0
      DO 240 K=1,KK
        JJ = NSTMT - K
        HCOUNT = HCOUNT + I10*STMT(JJ)
        I10 = I10*10
  240 CONTINUE
      STMT(KST) = HCOUNT - 2048
      NSTMT = KST
      IF (HCOUNT.LE.0) GO TO 250
      GO TO 290
C
C     AVOID THE 0H CONSTRUCTION
C
  250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44)
      STATE = 0
      GO TO 290
C
C     STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H
C
  260 IF (STMT(NSTMT).GT.9) GO TO 270
      STATE = 2
      KST = NSTMT
      GO TO 290
C
C     CHECK FOR NESTED SPECIAL HEADING CHARS
C
  270 STATE = 0
  280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290
      STATE = 1
  290 I = I + 1
      GO TO 180
      END
      SUBROUTINE IN(CARD, INUT)
C
      INTEGER CARD(80)
      LOGICAL EOF
C
      DATA EOF /.FALSE./
      DATA IDOT /1H./
C
      IF (EOF) RETURN
C
C     READ A CARD. PHYSICAL EOF SHOULD TRANSFER TO 100
C
      READ (INUT,99999,END=100) CARD
99999 FORMAT (80A1)
      IF (CARD(1).NE.IDOT) RETURN
C
C     HERE FOR EOF
C
 100  CARD(1) = IDOT
      EOF = .TRUE.
C
      RETURN
      END
      SUBROUTINE INOPT(CARD)
      INTEGER S(8), CARD(80), J(5)
      LOGICAL OPT, P1ERR
      COMMON /OPTNS/ OPT(5), P1ERR
      DATA S(1), S(2), S(3), S(4), S(5), S(6), S(7) /1HS,1HR,1HP,1HL,
     *    1HC,1H,,1HN/, S(8) /1H /
C
C     OPT(1) IF TRUE, PRINT SYMBOL TABLE
C      IF FALSE, NOSYMBOL TABLE PRINTED
C     OPT(2) IF TRUE, PRINT CROSS REFERENCES
C      IF FALSE, NO REFS PRINTED
C     OPT(3) IF TRUE, DO PASS 2; ELSE DO NOT
C     OPT(4) IF TRUE GET LISTING OF PGM; ELSE DO NOT
C      OPT(5) IF TRUE, COMPILE PGM AFTER PROCESSING; ELSE DO NOT
C     SET OPTIONS FROM CARD READ IN BY "IN"
C     P2 IS TURNED OFF ONLY ONCE A RUN;  IT CANNOT BE TURNED ON AGAIN
C     OPTIONS CARD IS ONLY ACCEPTED IF SYNTAX ON CARD IS OK
C     SYNTAX IS C* FOLLOWED BY AT LEAST ONE OPTION OF THEFORM
C     OPT BLANKS, OPT N, AT LEAST ONE OF (S,R,P,L,C), OPT BLANKS
C     WHERE OPTIONS ARE SEPARATEDBY COMMAS
C
      DO 10 I=1,5
        J(I) = 0
   10 CONTINUE
      IP = 2
   20 IP = IP + 1
      IF (IP.GE.73) GO TO 60
C      DEBLANK LEADING BLANKS
      IF (CARD(IP).EQ.S(8)) GO TO 20
      L = 1
C
C     CHECK FOR NEGATIVE
C
      IF (CARD(IP).NE.S(7)) GO TO 30
      L = -1
      IP = IP + 1
      IF (IP.GE.73) GO TO 60
   30 DO 40 I=1,5
        IF (S(I).NE.CARD(IP)) GO TO 40
        J(I) = J(I) + L
        GO TO 50
   40 CONTINUE
      GOTO 100
C
C     FLUSH BLANKS TO NEXT COMMA
C
   50 IP = IP + 1
      IF (IP.GE.73) GO TO 60
      IF (CARD(IP).EQ.S(6)) GO TO 20
      IF(CARD(IP).NE.S(8)) GOTO 100
      GO TO 50
   60 DO 90 K=1,5
        IF (J(K)) 70, 90, 80
   70   OPT(K) = .FALSE.
        GO TO 90
C     DO NOT LET USER TURN ON PASS2 AFTER WE TURN IT OFF
   80   IF (K.EQ.3 .AND. .NOT.OPT(3)) GO TO 90
        OPT(K) = .TRUE.
   90 CONTINUE
 100  RETURN
      END
      SUBROUTINE LIST
      INTEGER STMT, PSTMT
      LOGICAL ERR, SYSERR, ABORT, IDLIST, IDO, FINDO
      LOGICAL SIO
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /LISTDO/ LPT, LEN, LS(64)
C
C     ROUTINE PROCESSES THE LIST CONSTRUCT, USED IN I-O STMTS
C     LEV USED TO COUNT PARENTHESES LEVELS
C
      SIO = .FALSE.
      LPT = LEN + 1
      FINDO = .FALSE.
      ICNT = 0
      LEV = 0
   10 IF (STMT(PSTMT).NE.65) GO TO 20
      LEV = LEV + 1
      IF (LEV.GT.ICNT) ICNT = ICNT + 1
      PSTMT = PSTMT + 1
      GO TO 10
   20 IF (PSTMT.GE.NSTMT) GO TO 120
C
C     ALLOW <ID>=ARRAY,ARRAY ELE., VARIABLE
C
      IF (.NOT.IDLIST(IDO)) GO TO 130
C
C     FALSE RETURN SIGNIFIES ERROR IN IDLIST
C     TRUE RETURN SIGNIFIES NO ERROR IN IDLIST
C     IDO = .TRUE. MEANS , <DOSPEC> IS NEXT
C     IDO = .FALSE. MEANS AT END-OF-STMT, ", (" , OR ")"
C
C      FOUND <DOSPEC> )
C
      IF (SYSERR) GO TO 130
      IF (.NOT.IDO) GO TO 30
      PSTMT = PSTMT + 1
      GO TO 100
C
C      FOUND END OF SIMPLE LIST "( <IDLIST> )"
C
   30 IF (STMT(PSTMT).EQ.62) GO TO 60
   40 IF (PSTMT.NE.NSTMT) GO TO 50
C
C     AT END OF STMT
C
      IF (FINDO) CALL LDOVAR
      IF (LEV.NE.0) GO TO 120
      GO TO 130
C
C      NEED "," AND NEW <LIST> CONSTRUCT
C
   50 IF (STMT(PSTMT).NE.68) GO TO 120
      PSTMT = PSTMT + 1
      GO TO 10
C
C     MUST CHECK FOR ILLEGALLY NESTED SIMPLE LISTS
C     SIMPLE LIST= ( <IDLIST> )
C     ICNT COUNTAINS LEVEL OF LAST SIMPLE LIST WITHIN A
C      PARENTHESIZED EXPRESSION
C
   60 SIO = .TRUE.
      IF (LEV.EQ.0) GO TO 120
      PSTMT = PSTMT + 1
      IF (ICNT.LE.LEV) GO TO 80
   70 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
      GO TO 130
   80 LEV = LEV - 1
      IF (LEV) 120, 110, 90
C
C     CHECK FOR CONSTRUCT FOLLOWING <DOSPEC>
C
   90 IF (STMT(PSTMT).EQ.62) GO TO 70
      IF (STMT(PSTMT).NE.68) GO TO 120
      CALL NEXTOK(PSTMT+1, K2, K)
      IF (K.NE.0 .OR. STMT(K2).NE.63) GO TO 40
      PSTMT = PSTMT + 1
C
C     LOOK FOR DOSPEC
C
  100 CALL DOSPEC(0, K2, .TRUE.)
      IF (SYSERR .OR. ERR) GO TO 130
      FINDO = .TRUE.
      IF (STMT(K2).NE.62) GO TO 120
      PSTMT = K2 + 1
      IF (ICNT.GT.LEV) ICNT = ICNT - 1
      GO TO 80
C
C     CHECK NESTED DOSPECS IN LIST
C
  110 IF (LEV.NE.0 .OR. .NOT.FINDO) GO TO 40
      FINDO = .FALSE.
      CALL LDOVAR
      LPT = LEN + 1
      GO TO 40
  120 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
      IF (FINDO) CALL LDOVAR
  130 IF (SIO) CALL ERROR1(34H REDUNDANT PARENTHESES ARE ILLEGAL, 34)
      RETURN
      END
      INTEGER FUNCTION LOOKUP(K1, LABEL)
C
C     STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
C     LABEL IS TRUE IF SYMBOL IS A LABEL.  ROUTINE
C     RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
C     A NEW ENTRY ID NESESSARY.  IT ENTERS SYMBOL INTO
C     SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
C     ENTRY FOR THE CURRENT STATMT NUMBER
C
      INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
      INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
      INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
      LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /TRANS/ Q
      COMMON /OPTNS/ OPT(5), P1ERR
      DATA BLANK /1H /
      K = K1 - PSTMT
      IF (K.LE.6) GO TO 10
      CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
      K = 6
   10 KK = K
      DO 20 I=1,K
        II = PSTMT + I - 1
        J = STMT(II) + 1
        LL(I) = Q(J)
   20 CONTINUE
      DO 30 I=1,SYMLEN
        L(I) = BLANK
   30 CONTINUE
      CALL S5PACK(LL, L, K)
C
C     HAVE PACKED SYMBOL;NOW CALCULATE HASH
C     HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
C
      IF (KK.LT.3) GO TO 50
      IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
   40 IHASHS = MOD(IHASHS,LHASH)
      ISAVE = IHASHS
      IHASH = IHASHS + 1
      GO TO 80
   50 IHASHS = STMT(PSTMT)
      GO TO (60, 70), KK
   60 IHASHS = IHASHS*69 + 69
      GO TO 40
   70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
      GO TO 40
   80 IF (HASH(IHASH).EQ.0) GO TO 140
C
C     IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
C     ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
C     TABLE  AFTER RESOLVING COLLISION
C
      DO 90 J=1,SYMLEN
        II = HASH(IHASH) + 3 + J
        IF (L(J).NE.DSA(II)) GO TO 100
   90 CONTINUE
      LOOKUP = HASH(IHASH)
      IF (DSA(LOOKUP+1)) 190, 190, 200
C
C     RESOLVE CONFLICTS BY LINEAR CONGRUENCE
C
  100 IHASHS = MOD(IHASHS+1,LHASH)
      IF (IHASHS.EQ.ISAVE) GO TO 110
      IHASH = IHASHS + 1
      GO TO 80
  110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
  120 SYSERR = .TRUE.
      RETURN
  130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
      GO TO 120
C
C     CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
C
  140 HASH(IHASH) = NEXT
      IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
      LOOKUP = NEXT
C
C*****DSA
C     1ST WORD..... ATTRIBUTE WORD
C     FIELD 1
C
C     BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
C      3 COMPLEX,4 LOGICAL, 5 HOLLERITH
C      TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
C      3 FORMAT STMT
C     BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
C     FIELD 2
C     BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
C      (FOR LABEL) DEFINED 1, REFERENCED 0
C      (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
C     FIELD 3
C     BIT 5****EQUIVALENCED 1
C     FIELD 4
C     BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
C     FIELD 5
C     BIT 7****VALUE SET BY P.U. 1
C     FIELD 6
C     BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
C     FIELD 7
C     BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
C     FIELD 8
C     BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
C     SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
C     COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
C     CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
C     13, INTRINSIC FCN 14
C     BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
C     ATTRIBUTE MENTIONED
C
C     2ND WD..... XREF LIST TAIL POINTER
C     3D WORD.....EXTRA INFO POINTER
C
C     FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
C     CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
C     DIMENSIONED ARRAY);  SECOND WORD CONTAINING INDEX OF COMMON
C     ENTRY IN DSA;
C     FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
C     LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
C     IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
C     NESTING LEVEL;  WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
C     ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
C     OF LAST STMT AT THAT NESTING LEVEL;
C     FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
C     OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
C     FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
C     A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
C     DUMMIES OF THAT SUBPGM;
C
C     4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
C     OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
C     5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
C
      J = NEXT + 2
      DO 150 I=NEXT,J
        DSA(I) = 0
  150 CONTINUE
      J = J + 1
      DO 160 I=1,SYMLEN
        II = I + J
        DSA(II) = L(I)
  160 CONTINUE
C
C     SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
C
      IF (LABEL) GO TO 170
      DSA(J) = SYMHD
      SYMHD = NEXT
      GO TO 180
  170 DSA(J) = LABHD
      LABHD = NEXT
  180 NEXT = 4 + SYMLEN + NEXT
C
C     BEGINNEW XREF LIST
C
  190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
      IF (NEXT+2.GE.BNEXT) GO TO 130
      DSA(BNEXT-1) = NOST
      DSA(LOOKUP+1) = BNEXT - 1
      DSA(BNEXT) = BNEXT - 1
      BNEXT = BNEXT - 2
      GO TO 210
C
C     XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
C     THERE
C
  200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
      IF (NEXT+2.GE.BNEXT) GO TO 130
      J = DSA(LOOKUP+1)
      IF (DSA(J).EQ.NOST) GO TO 210
      DSA(BNEXT) = DSA(J+1)
      DSA(J+1) = BNEXT - 1
      DSA(LOOKUP+1) = BNEXT - 1
      DSA(BNEXT-1) = NOST
      BNEXT = BNEXT - 2
  210 RETURN
      END
      INTEGER FUNCTION MAPCHR(CHAR, ERR)
C
C     MAPCHR RETURNS THE INTERNAL CODE OF THE CHARACTER CHAR
C
      INTEGER CHAR
      INTEGER LET(46), ICODE(46)
      LOGICAL ERR
C
      DATA LET(7), ICODE(7) /1H0,0/
      DATA LET(16), ICODE(16) /1H1,1/
      DATA LET(22), ICODE(22) /1H2,2/
      DATA LET(24), ICODE(24) /1H3,3/
      DATA LET(26), ICODE(26) /1H4,4/
      DATA LET(28), ICODE(28) /1H5,5/
      DATA LET(25), ICODE(25) /1H6,6/
      DATA LET(38), ICODE(38) /1H7,7/
      DATA LET(34), ICODE(34) /1H8,8/
      DATA LET(32), ICODE(32) /1H9,9/
      DATA LET(3), ICODE(3) /1HA,30/
      DATA LET(36), ICODE(36) /1HB,31/
      DATA LET(14), ICODE(14) /1HC,32/
      DATA LET(6), ICODE(6) /1HD,33/
      DATA LET(5), ICODE(5) /1HE,34/
      DATA LET(33), ICODE(33) /1HF,35/
      DATA LET(27), ICODE(27) /1HG,36/
      DATA LET(37), ICODE(37) /1HH,37/
      DATA LET(8), ICODE(8) /1HI,38/
      DATA LET(44), ICODE(44) /1HJ,39/
      DATA LET(46), ICODE(46) /1HK,40/
      DATA LET(13), ICODE(13) /1HL,41/
      DATA LET(12), ICODE(12) /1HM,42/
      DATA LET(4), ICODE(4) /1HN,43/
      DATA LET(2), ICODE(2) /1HO,44/
      DATA LET(18), ICODE(18) /1HP,45/
      DATA LET(43), ICODE(43) /1HQ,46/
      DATA LET(11), ICODE(11) /1HR,47/
      DATA LET(15), ICODE(15) /1HS,48/
      DATA LET(10), ICODE(10) /1HT,49/
      DATA LET(30), ICODE(30) /1HU,50/
      DATA LET(42), ICODE(42) /1HV,51/
      DATA LET(45), ICODE(45) /1HW,52/
      DATA LET(39), ICODE(39) /1HX,53/
      DATA LET(35), ICODE(35) /1HY,54/
      DATA LET(41), ICODE(41) /1HZ,55/
      DATA LET(31), ICODE(31) /1H+,60/
      DATA LET(29), ICODE(29) /1H-,61/
      DATA LET(19), ICODE(19) /1H),62/
      DATA LET(23), ICODE(23) /1H=,63/
      DATA LET(17), ICODE(17) /1H.,64/
      DATA LET(20), ICODE(20) /1H(,65/
      DATA LET(21), ICODE(21) /1H*,66/
      DATA LET(40), ICODE(40) /1H/,67/
      DATA LET(9), ICODE(9) /1H,,68/
      DATA LET(1), ICODE(1) /1H ,69/
C
      DO 10 I=1,46
        IF (CHAR.EQ.LET(I)) GO TO 20
   10 CONTINUE
C
C     UNKNOWN, RETURN BLANK AND SET ERR = .TRUE.
C
      MAPCHR = 69
      ERR = .TRUE.
      RETURN
C
C     KNOWN, RETURN INTERNAL CODE, LEAVE ERR ALONE
C
   20 MAPCHR = ICODE(I)
      RETURN
      END
      SUBROUTINE PU
      INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA
      INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4
      INTEGER Q(70)
      LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF
      LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT
      LOGICAL P2, QBR
      COMMON /OPTNS/ OPT(5), P1ERR
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DOS/ DOPT, LDO, DOLIST(192)
      COMMON /TRANS/ Q
      COMMON /PASS/ P2, QBR
C
C     ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT.  NEW IS
C     USED TO HANDLE P.U.'S WITHOUT END STMTS.  FLUSHING OF STMTS
C     TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING
C     LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS
C     EOF OF INPUT FILE
C     ERR USED AS ERROR DIAGNOSTIC INDICATOR
C     NEWRD, NEW USED TO CONTROL INPUT
C
      EOF = .FALSE.
      NEW = .FALSE.
C
C     INTER-PROGRAM INITIALIZATION
C     NOST CONTAINS CURRENT STATEMENT NUMBER
C     ITYP CONTAINS TYPE OF STMT
C     BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE
C     EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN
C      PROGRAM UNIT EXISTING
C     NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME
C     P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR
C      PASS 2
C     RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE
C     NEXT, BNEXT POINT INTO DSA
C     LABHD POINTS TO HEAD OF LABELS LIST IN DSA
C     SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA
C     KGP, IGP USED TO CHECK STMT SEQUENCING
C     DOPT,DOLIST USED TO CHECK DO LOOP NESTING
C
   10 NOST = 0
      ITYP = 0
      LTYP = 0
      BLKD = .FALSE.
      EXECUT = .FALSE.
      NAME = 0
      P1ERR = .FALSE.
      RET = .FALSE.
      NEXT = 1
      BNEXT = LDSA
      LABHD = 0
      SYMHD = 0
      KGP = 0
      DOPT = 1
      DOLIST(1) = 1
      DO 20 I=2,6
        DOLIST(I) = 0
   20 CONTINUE
      DO 30 I=1,LHASH
        HASH(I) = 0
   30 CONTINUE
C
C     DONT GOTO NEW PAGE IF NOT PRODUCING LISTING
C
      IF (.NOT.OPT(4)) GO TO 40
      WRITE (OUTUT,99999)
99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //)
C
C     INPUT NEW STMT; RETURN WHEN HIT EOF STMT
C     FIND LABELS
C
C     HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END
C
   40 IF (.NOT.NEW) GO TO 70
      NEW = .FALSE.
      NOST = 1
      IF (.NOT.OPT(4)) GO TO 80
      K = NSTMT - 1
      DO 50 I=1,K
        II = STMT(I) + 1
        STACK(I) = Q(II)
   50 CONTINUE
      WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K)
99998 FORMAT (1H , I5, 5X, 80A1)
      GO TO 80
   60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
      ERR = .FALSE.
   70 CALL INSTMT(EOF, NCARD)
      IF (EOF) GO TO 400
   80 LAB = .FALSE.
C
C     TYPST TYPES THE CURRENT STAMT
C     ITYP IS NO 1-30 TELLING STMT WE HAVE
C      KGP IS LEVEL NO 0-6 OF STMT.
C     ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP)
C
      PSTMT = 6
      CALL TYPST(ITYP, IGP, ICNT)
      IF (ERR) GO TO 60
      PSTMT = 6 + ICNT
      IF (ITYP.GE.6) GO TO 100
      I = ITYP - 1
      CALL TYPST(ITYP, II, K2)
      IF (ITYP.NE.10) GO TO 90
      PSTMT = PSTMT + K2
      IGP = II
      GO TO 110
   90 ITYP = I + 1
  100 I = -1
  110 II = 1
      IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2
      IF (ITYP.EQ.29) II = 3
      KEEP = PSTMT
      PSTMT = 1
      IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE.
      IF (SYSERR) GO TO 450
C
C     CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS
C
      IF (NAME) 140, 120, 140
  120 IF (IGP) 130, 150, 130
  130 CALL SETNAM(12)
      GO TO 150
  140 IF (IGP.EQ.0) GO TO 490
C
C     CHECK SEQUENCING OF STMTS
C
  150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160
      IF (IGP.GE.KGP) GO TO 170
      CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24)
      GO TO 450
  160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32)
      GO TO 450
C
C     CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT.
C     TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE
C
  170 IF (EXECUT .OR. IGP.LT.4) GO TO 180
      EXECUT = .TRUE.
      K = IGATT1(NAME,8)
      IF (K.EQ.4) CALL SATT1(NAME, 8, 10)
  180 PSTMT = KEEP
      LOGIF2 = .FALSE.
C
C     VALUES OF ITYP
C     1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG
C     6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION
C     8 COMMON
C     9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA
C     12 EQUIVALENCE
C     13 DATA
C     14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN,
C     17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE,
C     23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30
C     ASSIGNMENT, 32 LOGICAL IF
C     28 END
C     29 FORMAT
C     31 ASF DEFN
C     CLASS CODES
C     0-HEADING STMTS
C     1-SPECIFICATION STMTS (INCLUDING TYPE STMTS)
C     2-EQUIVALENCE
C     3-DATA
C     4-ASF DEF
C     5-EXECUTABLE STMTS AND FORMAT STMTS
C     6-END STMT
C
  190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240,
     *    270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340,
     *    340, 340, 340, 340, 410, 390, 290), ITYP
C
C     TYPE STMTS (SYSERR)
C
  200 CALL TYPE
      GO TO 430
C
C     EXTERNAL STMT (SYSERR)
C
  210 CALL EXTERN
      GO TO 430
C
C     DIMENSION STMT(SYSERR)
C
  220 CALL DIMENS
      GO TO 430
C
C     SUBR/FCN DEFNS (SYSERR)
C
  230 CALL SUBFCN(I)
      GO TO 430
C
C     BLOCK DATA STMT (SYSERR)
C
  240 CALL SETNAM(11)
      BLKD = .TRUE.
      GO TO 430
C
C     COMMON STMT
C
  250 CALL COMMON
      GO TO 430
  260 CALL DATA
      GO TO 430
  270 CALL EQUIV
      GO TO 430
  280 CALL DOSTMT
      GO TO 430
  290 CALL ASSASF(IGP)
      IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320
      GO TO 430
C
C     IF STMTS
C
  300 CALL IFS(LOGIF1)
C
C     FOUND AN ARITH. IF
C
      IF (.NOT.LOGIF1) GO TO 430
C
C     FOUND LOGICAL IF WITHIN LOGICAL IF
C
      IF (LOGIF1 .AND. LOGIF2) GO TO 320
C
C     FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT
C
      LOGIF2 = .TRUE.
      CALL TYPST(ITYP, K, K2)
      IF (.NOT.ERR) GO TO 310
      CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
      GO TO 430
  310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320
      PSTMT = PSTMT + K2
      GO TO 190
  320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27)
      GO TO 430
C
C     GOTO STMTS
C
  330 CALL GOTO
      GO TO 430
C
C      I-O STMTS
C
  340 CALL IO
      GO TO 430
C
C     ASSIGN  STMT
C
  350 CALL ASSIGN
      GO TO 430
C
C     RETURN  CANNOT  APPEAR IN MAIN PGM
C
  360 I = IGATT1(NAME,8)
      IF (I.EQ.12) CALL ERROR1(
     *    44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44)
      RET = .TRUE.
      GO TO 380
C
C     CALL STMT
C
  370 CALL CALLS
      GO TO 430
C
C     CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS
C
  380 IF (PSTMT.NE.NSTMT) CALL ERROR1(
     *    34H EXTRANEOUS INFO AFTER END OF STMT, 34)
      GO TO 430
C
C     FORMAT
C
  390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26)
      CALL FORMAT
      GO TO 430
C
C     CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT
C
  400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500
      CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
      LAB = .FALSE.
      ITYP = 28
  410 CALL END
C
C     CHECK FOR NO CONTINUATION
C
      IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION,
     *    34)
C
C     CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN
C
      IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20)
     *    .OR. BLKD) GO TO 420
      CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29)
C
C     CHECK THERE HAVE BEEN EXECUTABLE STMTS
C     CHECK FOR A RETURN STMT IF NECESSARY
C
  420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1(
     *    42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42)
      I = IGATT1(NAME,8)
      IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430
      CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36)
C
C     CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE
C     CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2
C     DUE TO ERRORS IN THIS PGM UNIT
C
  430 KGP = IGP
      IF (ITYP.NE.29) LTYP = ITYP
      IF (LOGIF2) LTYP = 32
      IF (SYSERR) GO TO 450
      IF (.NOT.LAB) GO TO 440
      CALL DOCHK(KK)
      IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1(
     *    37H WARNING - LABELED NONEXECUTABLE STMT, 37)
  440 IF (EOF) GO TO 500
      ERR = .FALSE.
      IF (ITYP.EQ.28) GO TO 10
      GO TO 70
C
C     FLUSH CODE TO NEXT HEADR OR END SMT
C
  450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44)
      P1ERR = .TRUE.
      IF (SYSERR) SYSERR = .FALSE.
      LAB = .FALSE.
  460 CALL INSTMT(EOF, NCARD)
      IF (EOF) GO TO 500
      PSTMT = 6
      CALL TYPST(ITYP, IGP, ICNT)
      IF (.NOT.ERR) GO TO 470
      ERR = .FALSE.
      GO TO 460
  470 IF (ITYP.EQ.28) GO TO 410
      IF (ITYP.GT.5) GO TO 480
      PSTMT = PSTMT + ICNT
      CALL TYPST(ITYP, IGP, ICNT)
      IF (ERR) ERR = .FALSE.
      IF (ITYP.EQ.10) GO TO 490
      GO TO 460
  480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460
C
C     HAVE FOUND A HEADER STMT; SIMULATE AN END STMT
C
  490 NEW = .TRUE.
      CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
      ITYP = 28
      LAB = .FALSE.
      GO TO 410
C
C     PUT ENDING MARKER ON THE DATA FOR PASS2
C
  500 I = 1
      II = 4
      WRITE (OUTUT3) I, II, I
      WRITE (OUTUT2) I, II, I
      RETURN
      END
      SUBROUTINE COMCHK(MAIN)
      INTEGER TEMP(1), PLAT, STAR, PCOM, COM, PNODE, SYMLEN
      INTEGER ZERO(1)
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR2/ LNN, NN(500)
      DATA STAR /1H*/
      DATA ZERO(1) /0/
C
C     ALGORITHM TO CHECK FOR LEGAL USE OF COMMON IN PGM UNITS
C     NODE(MAIN) POINTS TO SUPEROOT ENTRY IN LAT
C
      IF (PCOM.LE.0) GO TO 130
      LK = 1
   10 IF (LK.GE.PCOM-1) GO TO 130
C
C     CHECK COMMON ISNT BLANK COMMON
C
      CALL S5UNPK(COM(LK), TEMP, 1)
      IF (TEMP(1).EQ.STAR) GO TO 120
C
C     CHECK THAT COMMON BLOCK NOT IN BLOCK DATA PGM
C     NEED NOT CHECK THE COMMON
C
      K = LK + SYMLEN + 1
      IF (COM(K).EQ.1) GO TO 120
C
C     NEED ALGORITHM TO CHECK OUT THIS COMMON
C
      L = PNODE - 1
      DO 20 K=1,L
        NN(K) = 0
        IF (NODE(K).LT.0) NN(K) = 1
   20 CONTINUE
      ICNT = 0
      NN(MAIN) = 2
C
C     SEARCH FOR A 2 NODE
C
   30 L = PNODE - 1
      DO 40 K=1,L
        IF (NN(K).EQ.2) GO TO 50
   40 CONTINUE
      GO TO 120
C
C     FOUND A 2 NODE; CHANGE TO 1 TO SHOW HAVE VISITED IT;
C     IF SUBPGM CONTAINS COMMON IN QUESTION INCREMENT COUNT;
C     IF COUNT> 1 ERROR IN USAGE
C     IF SUBPGM DOESN'T CONTAIN COMMON, MARK HIS DESC 2 IF THEY ARE 0.
C
   50 NN(K) = 1
      LBR = NODE(K)
      L = NODE(K) + SYMLEN + 2
      L = LAT(L)
   60 IF (L.EQ.0) GO TO 90
      IF (LAT(L).NE.LK) GO TO 80
C
C     FOUND COMMON LK AT THIS NODE
C     MARK NODE TO A 3
C
      NN(K) = 3
      ICNT = ICNT + 1
      IF (ICNT.LE.1) GO TO 30
      CALL ERROR2(31H ILLEGAL USAGE OF COMMON BLOCK , 31, COM(LK),
     *  1, 1, 0)
      K = PNODE - 1
      DO 70 I=1,K
        L = NODE(I)
        IF (NN(I).EQ.3) CALL ERROR2(19H WHICH APPEARED IN , 19, LAT(L),
     *  1, 0, 0)
   70 CONTINUE
      CALL ERROR2( 1H1, 0, ZERO(1), -3, 0, 1)
      GO TO 120
   80 L = LAT(L+2)
      GO TO 60
C
C     ARE DONE SEARCHING FOR COMMON LK AT THIS NODE
C     ADD DESCENDENTS ONTO LIST TO BE VISITED
C
   90 L = NODE(K) + SYMLEN + 4
      L = LAT(L)
  100 IF (L.EQ.0) GO TO 30
      K = PNODE - 1
C
C     FIND DESC OF NODE AND IF NOT VISITED SET TO 2
C
      DO 110 I=1,K
        IF (NODE(I).NE.LAT(L)) GO TO 110
        IF (NN(I).EQ.0) NN(I) = 2
  110 CONTINUE
      L = LAT(L+1)
      GO TO 100
  120 LK = LK + SYMLEN + 5
      GO TO 10
  130 RETURN
      END
      LOGICAL FUNCTION COMPAR(A, B)
      INTEGER SYMLEN, A(2), B(2)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C     ROUTINE TESTS TWO IDENTIFIERS FOR SAMENESS; RETURNS TRUE IF
C     SAME, ELSE FALSE
C
      DO 10 I=1,SYMLEN
        IF (A(I).NE.B(I)) GO TO 30
   10 CONTINUE
      COMPAR = .TRUE.
   20 RETURN
   30 COMPAR = .FALSE.
      GO TO 20
      END
      INTEGER FUNCTION FINDND(K1, K2)
      INTEGER K1(2)
      INTEGER PLAT, PNODE
      LOGICAL COMPAR
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C     FINDS SUBPROGRAM WHOSE PACKED NAME IS IN K1(2) AND
C     RETURNS INDEX OF ITS LAT ENTRY AS VALUE OF FINFND
C     RETURNS IN K2 INDEX IN NODE OF LAT INDEX
C     IGNORES ASF NODES IN LAT BY IGNORING NEGATIVE NODE
C     ENTRIES
C
      IF (PNODE-1) 40, 40, 10
   10 K = PNODE - 1
      DO 30 I=1,K
        IF (NODE(I)) 30, 30, 20
   20   FINDND = NODE(I)
        K2 = I
        IF (COMPAR(LAT(FINDND),K1)) GO TO 50
   30 CONTINUE
   40 FINDND = 0
   50 RETURN
      END
      INTEGER FUNCTION FINDCM(K1)
      INTEGER K1(2)
      INTEGER PCOM, COM, SYMLEN
      LOGICAL COMPAR
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C     ROUTINE FINDS COMMON BLOCK WHOSE NAME IS AT K1 IN COM
C     RETURNS INDEX IN COM OR 0 IF CANNOT FIND IT
C
      IF (PCOM-1) 30, 30, 10
   10 K = PCOM - 1
      KK = SYMLEN + 5
      DO 20 I=1,K,KK
        FINDCM = I
        IF (COMPAR(COM(I),K1)) GO TO 40
   20 CONTINUE
   30 FINDCM = 0
   40 RETURN
      END
      INTEGER FUNCTION INREF(IDUM)
      INTEGER REF, PREF
      COMMON /CREF/ LREF, PREF, REF(100)
C
C     ROUTINE TO INPUT CALL TEMPLATES, RETURNS -1 FOR EOF,  0 FOR END
C     OF REFS FOR THIS PGM UNIT, AND 1 FOR REF RETRIEVED
C
      READ (IDUM) PREF, K, (REF(L),L=1,PREF)
      IF (K-3) 10, 30, 40
   10 INREF = 1
   20 RETURN
   30 INREF = 0
      GO TO 20
   40 INREF = -1
      GO TO 20
      END
      LOGICAL FUNCTION INSYM(IDUM,II)
      INTEGER OUTUT, OUTUT2, OUTUT3, SYMHD, PDSA, SYMLEN, DSA, BNEXT
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, I1
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C     ROUTINE TO INPUT SYMBOL TABLE; RETURNS TRUE FOR SUCCESSFUL, ELSE
C     FALSE. KCODE=1 FOR TABLE, 3 FOR DUMMY TABLE, 4 FOR EOF
C     DUMMY TABLE CAUSES REFS FOR THIS PU TO BE FLUSHED IF
C     IDUM NE 0
C
 5    READ(OUTUT2) PDSA, KCODE, (DSA(I),I=1,PDSA)
      IF (KCODE-3) 10, 40, 30
   10 NAME = DSA(PDSA-2)
      SYMHD = DSA(PDSA-1)
      LABHD = DSA(PDSA)
      PDSA = PDSA - 3
      INSYM = .TRUE.
   20 RETURN
   30 INSYM = .FALSE.
      GO TO 20
C     FLUSH REFS FOR DUMMY TABLE IF IDUM NONZERO
 40   IF(IDUM.EQ.0) GOTO 5
 50   IF(INREF(IDUM)) 60, 60, 50
C     WRITE END OF REFS FOR DUMMY REFS IF II NE 0; ELSE GOT TO
C     NEXT SYMBOL TABLE
 60   IF(II.EQ.0) GOTO 5
      L = 1
      K = 3
      WRITE(II) L,K,L
      GOTO 5
      END
      INTEGER FUNCTION MATCH(HEAD, INCR, N)
      INTEGER PLAT, HEAD
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C     ROUTINE READS DOEN A LINEAR LINKED LIST IN LAT TO FIND ENTRY
C     WHOSE FIRST WORD CONTAINS N;  EACH LIST ELEMENT IS INCR+1 LONG;
C     HEAD IS POINTER TO FIRST LIST ELEMENT
C     RETURNS 0 FOR NO MATCH ON LIST OR THE EMPTY LIST
C
      IF (HEAD) 40, 40, 10
   10 MATCH = HEAD
   20 IF (LAT(MATCH).EQ.N) GO TO 50
      MATCH = MATCH + INCR
      IF (LAT(MATCH)) 40, 40, 30
   30 MATCH = LAT(MATCH)
      GO TO 20
   40 MATCH = 0
   50 RETURN
      END
      SUBROUTINE MKCOM(PP, K)
      INTEGER PLAT, PDSA, FINDCM, DSA, SYMLEN, PP, PCOM, COM
      LOGICAL SYSERR, ERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C     WANT TO MARK COMMONLIST ENTRY SET FOR SUBPGM PP; MAY HAVE TO
C     CREATE ENTRY
C
      N = FINDCM(DSA(K+4))
      L = SYMLEN + 2 + PP
      KK = -K
      IF (N.NE.0) KK = N
C
C     LOOK FOR DSA ENTRY ON LIST
C
      I = MATCH(LAT(L),2,KK)
      IF (I) 30, 30, 10
   10 LAT(I+1) = 1
   20 RETURN
C
C     CREATE NEW ENTRY
C
   30 IF (PLAT+3.GT.LLAT) GO TO 40
      LAT(PLAT+1) = 1
      LAT(PLAT+2) = LAT(L)
      LAT(L) = PLAT
      LAT(PLAT) = KK
      PLAT = PLAT + 3
      GO TO 20
   40 SYSERR = .TRUE.
      CALL ERROR1(32H IN MKCOM, TABLE OVERFLOW OF LAT, 32)
      GO TO 20
      END
      INTEGER FUNCTION OUTCOM(IH, L)
      INTEGER STACK,PLAT
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C     READS DOWN COM LIST OF PU NODE, PUTS INDICES OF ENTRIES
C     IN STACK. IH IS HEAD OF LIST, L RETURNS NO OF ENTRIES
C
      OUTCOM = 0
      IF (IH) 40, 40, 10
   10 L = 1
      K = IH
 20   IF (L+1.GT.LSTACK) GOTO 50
      STACK(L) = LAT(K)
      IF (LAT(K+1).EQ.1) STACK(L) = -STACK(L)
      L = L + 1
      K = LAT(K+2)
      IF (K) 30, 30, 20
 30   L = L - 1
      IF(L.GT.0)  OUTCOM=1
   40 RETURN
   50 SYSERR = .TRUE.
      CALL ERROR1(35H IN OUTCOM, TABLE OVERFLOW OF STACK, 35)
      GO TO 40
      END
      INTEGER FUNCTION OUTLAT(IH, L, ISR)
      INTEGER STACK, PLAT
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      INTEGER SYMLEN
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
C
C     IH POINTS TO A PARENTS OR DESCS LIST IN LAT; L IS NUM
C     OF ELEMENTS FOUND ON LIST; ISR IS ENTRY IN LAT OF
C     SUPERROOT
C
C
      OUTLAT = 0
      IF (IH) 50, 50, 10
   10 K = IH
      L = 1
   20 M = LAT(K)
C     SKIP OVER CALLS TO ASFS AND OVER SUPEROOT
      IF(MOD(IGATT2(M+SYMLEN+6,1),8).EQ.4 .OR. M.EQ.ISR) GOTO 30
      IF(L+1.GT.LSTACK) GOTO 60
      STACK(L) = M
      L = L + 1
   30 K = LAT(K+1)
      IF (K) 40, 40, 20
   40 L = L - 1
      IF (L.GT.0) OUTLAT = 1
   50 RETURN
   60 CALL ERROR1(35H IN OUTLAT, TABLE OVERFLOW OF STACK, 35)
      SYSERR = .TRUE.
      GO TO 50
      END
      SUBROUTINE OUT2A( IT, JJ, N, ISW )
C
C     IT CONTINAS TITLE FOR FIRST LINE OF OUTPUT
C     JJ CONTAINS NUMBER OF CHARS IN TITLE, J<=25
C     N CONTAINS NUMBER OF ELEMENTS TO BE PRINTED
C     ISW TELLS IF THESE ARE COMMON NAMES OR PROC NAMES
C
      INTEGER IT(25), II(25), BL, PLAT, PCOM, COM, STACK, OUTUT, S
      INTEGER BUF(54)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ II1, OUTUT, II2, II3, II4, II5, II6
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /COMS/ LCOM, PCOM, COM(300)
      DATA BL/1H /,S/1HS/
C
C     UNPACK TITLE
C
      NN = JJ
      IF(JJ.GT.25) NN=25
      CALL S5UNPK( IT(1), II(1), NN)
      K1 = NN + 1
      IF(K1.GT.25) GOTO 15
      DO 10 K =K1, 25
        II(K) = BL
 10   CONTINUE
C
C     SETUP FIRST LINE OF ELEMENTS
C
 15   K = 6
      IF (K.GT.N) K = N
      IB = 1
      DO 50 I = 1, K
        IL = STACK(I)
        GOTO (20, 30),ISW
C       FOR PARE OR DESC LISTS
 20     CALL S5UNPK( LAT(IL), BUF(IB), 6 )
        BUF(IB + 7) = BL
        GOTO 40
C       FOR COMMON LISTS- INDEX TO ELEMENTS IS NEGATIVE
C       IF COMMON IS SET BY PGM UNIT
 30     BUF(IB + 7) = BL
        IF(IL.LT.0) BUF(IB + 7) = S
        IL = IABS(IL)
        CALL S5UNPK( COM(IL), BUF(IB), 6 )
 40     BUF(IB + 6) = BL
        BUF(IB + 8) = BL
        IB = IB + 9
 50   CONTINUE
      IB = IB - 1
      WRITE(OUTUT,99999) (II(L),L=1,25), (BUF(I),I=1,IB)
99999 FORMAT(80A1)
      IF(K.EQ.N) GOTO 110
C       WRITE SUBSEQUENT LINES
 60   IB = 1
      K1 = K + 1
      K = K + 6
      IF (K.GT.N) K = N
      DO 100 I = K1, K
        IL = STACK(I)
        GOTO (70, 80), ISW
C       FOR PAR OR DESC LISTS
 70     CALL S5UNPK( LAT(IL), BUF(IB), 6 )
        BUF(IB + 7) = BL
        GOTO 90
C     FOR   COMMON LISTS
 80     BUF(IB + 7) = BL
        IF(IL.LT.0) BUF(IB + 7) = S
        IL = IABS(IL)
        CALL S5UNPK( COM(IL), BUF(IB), 6 )
 90     BUF(IB + 6) = BL
        BUF(IB +8) = BL
        IB = IB + 9
 100  CONTINUE
      IB = IB - 1
      WRITE(OUTUT,99998) (BUF(I),I =1,IB)
99998 FORMAT(25X,55A1)
      IF(K.LT.N) GOTO 60
 110  RETURN
      END
      SUBROUTINE OUT2C
      INTEGER COM, PCOM, STACK, BL, SYMLEN, OUTUT, S, PLAT
      EXTERNAL EXCH
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, I3
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /SCR2/ LICOM, ICOM(500)
      DATA BL /1H /, S /1HS/
C
C     PRINTS COM ARRAY
C
      IF (PCOM-1) 80, 80, 10
   10 K1 = SYMLEN + 5
      K = 1
      LCOMS = (PCOM-1)/(SYMLEN+5)
      DO 20 I=1,LCOMS
        ICOM(I) = K
        K = K + K1
   20 CONTINUE
      CALL SSORT(EXCH, COM, LCOM, ICOM, LCOMS, 0)
      WRITE (OUTUT,99999)
99999 FORMAT (///14H1COMMON BLOCKS///1X, 4HNAME, 3X, 3HSET, 1X,
     *    18H DP,COM INT,RL,LOG//)
      DO 70 IBR=1,LCOMS
        I = ICOM(IBR)
        CALL S5UNPK(COM(I), STACK(1), 6)
        DO 30 L=1,3
          II = I + SYMLEN + L
          KK = 7 + L
          STACK(KK) = COM(II)
   30   CONTINUE
        IF (STACK(8)) 40, 40, 50
   40   STACK(8) = BL
        GO TO 60
   50   STACK(8) = S
   60   WRITE (OUTUT,99998) (STACK(II),II=1,6), STACK(8),
     *      (STACK(II),II=9,10)
99998   FORMAT (1X, 6A1, 3X, A1, I8, 3X, I8)
   70 CONTINUE
   80 RETURN
      END
      SUBROUTINE SCAN(MAINND)
      INTEGER PLAT, SYMLEN, PNODE, STACK
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON/ SCR1/ LINODE, INODE(500)
      COMMON /SCR2/ LICOM, ICOM(500)
C
C     SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON
C     UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED
C
C
C     STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE
C     TO SUPEROOT NODE
C     INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS
C               1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH
C     SYSERR IS SET BY SCAN
C
      DO 10 I=1,PNODE
        INODE(I) = 0
   10 CONTINUE
      INODE(MAINND) = 1
      MAIN = NODE(MAINND)
      NUM = 0
C
C     CYCLE THROUGH ALL TERMINAL NODES
C
   20 NUM = NUM + 1
      IF (NUM.GT.PNODE-1) GO TO 240
C
C      CHECK IF AN NODE IS ASF OR IF IT HAS DESC
C     OR IF IT HAS NO PARENTS
C
      IF (NODE(NUM).LE.0) GO TO 20
      I = NODE(NUM) + SYMLEN + 4
C
C     NO PARENTS
C
      IF (LAT(I-1).EQ.0) GO TO 20
C
C     TEST DESC FOR BEING ALL ASFS
C
      IF (LAT(I).EQ.0) GO TO 40
      L = LAT(I)
   30 K = LAT(L) + SYMLEN + 6
      IF (MOD(LAT(K),8).NE.4) GO TO 20
      L = LAT(I+1)
      IF (L) 40, 40, 30
C
C     HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL
C     PATHS UPWARDS FROM IT  TO ROOT
C     ILEN--POINTER TO TOP OF CURRENT PATH
C     JNODE--CURRENT NODE
C
   40 INODE(NUM) = 1
      ILEN = 2
      STACK(2) = NODE(NUM)
      STACK(1) = 0
C
C     STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV
C     NODE; 2ND WORD-NODE INDEX
C     PROCESS NODE
C     1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT
C      SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT
C      ARGLIST ENTRY AS SET FOR A SET ARG.
C     2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS
C     3. GET NEW NODE
C
   50 J = STACK(ILEN) + SYMLEN + 1
C
C     ARG PROCESSING
C
      J = LAT(J)
   60 IF (J.EQ.0) GO TO 90
      I = IGATT2(J,5)
      IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80
      L = LAT(J+2)
   70 IF (L.EQ.0) GO TO 80
C
C     SET PARENT ARGS
C
      CALL SATT2(LAT(L), 5, 1)
      L = LAT(L+1)
      GO TO 70
C
C     GO ON TO NEXT ARG
C
   80 J = LAT(J+3)
      GO TO 60
C
C     COMMON PROCESSING
C
   90 J = STACK(ILEN) + SYMLEN + 2
      II = 0
      J = LAT(J)
C
C     ACCUMULATE COMMON REGIONS
C
  100 IF (J.EQ.0) GO TO 110
      ICOM(II+1) = LAT(J)
      IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1)
      II = II + 1
      J = LAT(J+2)
      GO TO 100
  110 IF (II.EQ.0) GO TO 150
C
C     GET PARENT NODE AND ADD COMMON REGIONS TO IT
C
      K = STACK(ILEN) + SYMLEN + 3
      K = LAT(K)
  120 L = LAT(K) + SYMLEN + 2
      DO 140 I=1,II
        LL = MATCH(LAT(L),2,IABS(ICOM(I)))
        IF (LL.EQ.0) GO TO 130
        IF (ICOM(I).LT.0) LAT(LL+1) = 1
        GO TO 140
C
C     COPY COMMONNODE ENTRIES ONTO PARENTS LIST
C
  130   IF (PLAT+3.GT.LLAT) GO TO 270
        LAT(PLAT+2) = LAT(L)
        LAT(PLAT+1) = 0
        LAT(PLAT) = IABS(ICOM(I))
        IF (ICOM(I).LT.0) LAT(PLAT+1) = 1
        LAT(L) = PLAT
        PLAT = PLAT + 3
  140 CONTINUE
C
C     GOONTO NEW PARENT
C
      K = LAT(K+1)
      IF (K.NE.0) GO TO 120
C
C     FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT
C     I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT;
C     J CONTAINS PARENTS INDEX IN LAT
C     IF NO MORE PARENTS, MUST BACKUP A LEVEL
C
  150 I = STACK(ILEN) + SYMLEN + 3
  160 IF (LAT(I).EQ.0) GO TO 200
      I = LAT(I)
  170 J = LAT(I)
C
C     CHECK THAT NEW ENTRY HAS PARENTS
C     AND THAT IT IS NOT THE SUPEROOT
C
      K = J + SYMLEN + 3
      IF (LAT(K).GT.0) GO TO 210
C
C     IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT
C     MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE
C
      LL = PNODE - 1
      DO 180 L=1,LL
        IF (J.NE.NODE(L)) GO TO 180
        INODE(L) = 1
        GO TO 190
  180 CONTINUE
  190 I = I + 1
      GO TO 160
C
C     MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH
C     AN UNTRIED PATH;  CHECK FIRST FOR DONE WITH ENTIRE PATH
C
  200 IF (STACK(ILEN-1).EQ.0) GO TO 20
      ILEN = ILEN - 2
      J = STACK(ILEN+1)
      IF (LAT(J+1).EQ.0) GO TO 200
C
C     FOUND AN UNTRIED PATH ON THE STACK
C
      I = LAT(J+1)
      GO TO 170
C
C     MARK ENTRY AS VISITED
C
  210 LL = PNODE - 1
      DO 220 L=1,LL
        IF (J.NE.NODE(L)) GO TO 220
        INODE(L) = 1
        GO TO 230
  220 CONTINUE
C
C     ENTER ON STACK
C
  230 IF (ILEN+2.GT.LSTACK) GO TO 260
      STACK(ILEN+1) = I
      STACK(ILEN+2) = J
      ILEN = ILEN + 2
      GO TO 50
  240 RETURN
  250 SYSERR = .TRUE.
      GO TO 240
  260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33)
      GO TO 250
  270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31)
      GO TO 250
      END
      INTEGER FUNCTION SETARG(PP, N)
      INTEGER PLAT, DSA, PP, SYMLEN, PDSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C     SETS UP LIST OF ARGUMENTS , HANGING OFF NODE AT LAT(PP)
C     ARGES ARE KEPT IN ORDERED LINEAR LINKED LIST
C     ORDERING CORRESPONDS TO LEFT TO RIGHT APPEARENCE IN DEFN
C     N-SUBPRGM ENTRY IN DSA
C     PP- CURRENT RTNE NODE IN LAT
C     ARGUMENT NODE
C     WD 1      ATTRIBUTES
C     WD2       LENGTH WITH -1 FOR VARIABLEY DIMENSIONED ARRAYS
C     WD3       HEAD OF PARENT REFS LIST
C     WD4       HEAD OF DESCENDENTS REFS LIST
C     WD5       PTR TO NEXT ARG
C
C     FIND FIRST ARGUMENT & ZERO COUNT
C
      J = DSA(N+2)
      SETARG = 0
      IPROC = 0
C
C     FIND FIRST ENTRY ON DSA ARGLIST;
C     KK HEAD OF TO BE CREATED ARGLIST IN LAT
C
      I = DSA(J)
      KK = PP + SYMLEN + 1
C
C     SETUP STORAGE FOR ARG ENTRY
C
   10 IF (PLAT+4.GE.LLAT) GO TO 80
C
C     ENTER ATTRIBUTE WORD AND ZERO REST OF ENTRY
C
      LAT(PLAT) = DSA(I)
      LAT(KK) = PLAT
      KK = PLAT + 3
      DO 20 IA=1,3
        L = IA + PLAT
        LAT(L) = 0
   20 CONTINUE
      K = IGATT1(I,8)
      IF (K.NE.10) GO TO 50
C
C     GET STRUCTURE  OF ARG
C
      K = IGATT1(I,7)
      IF (K) 40, 40, 30
C
C     ARRAY
C
   30 K = DSA(I+2)
      LAT(PLAT+1) = DSA(K)
      GO TO 60
C
C     SCALAR
C
   40 LAT(PLAT+1) = 1
      GO TO 60
C     SET RELATIVE ORDER OF PROC ARGS IN ITS 2ND WORD
   50 IPROC = IPROC + 1
      LAT(PLAT+1) = IPROC
C
C     CHECK FOR MORE ARGS; ADVANCE  PLAT
C
   60 PLAT = PLAT + 4
      SETARG = SETARG + 1
      IF (DSA(J+1)) 90, 90, 70
   70 J = DSA(J+1)
      I = DSA(J)
      GO TO 10
   80 SYSERR = .TRUE.
      CALL ERROR1(33H IN SETARG, TABLE OVERFLOW OF LAT, 33)
   90 RETURN
      END
      SUBROUTINE SETASF(PP, K)
      INTEGER PP, SYMLEN, PLAT, PDSA, SETARG, PNODE, DSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /DETECT/ ERR, SYSERR, ABORT
C
C     SETUP ASF NODE;  IT HAS A NODE JUST LIKE A RTNE
C     EXCEPT ITS INDEX IN NODE IS NEGATIVE
C     PP-COM ADDRESS OF PARENT SUBPGM
C     K-DSA ADDRESS OF ASF ENTRY
C
      IF (PNODE+1.GT.LNODE) GO TO 40
      IF (PLAT+SYMLEN+11.GT.LLAT) GO TO 60
C
C     CREATE NEW NODE ENTRY
C
      NODE(PNODE) = -PLAT
      PNODE = PNODE + 1
C
C     ENTER NAME AND ZERO REST OF NODE
C
      DO 10 I=1,SYMLEN
        L = K + 3 + I
        LL = PLAT + I - 1
        LAT(LL) = DSA(L)
   10 CONTINUE
      DO 20 I=1,6
        L = LL + I
        LAT(L) = 0
   20 CONTINUE
C
C     SET LAST ELEMENT TO TYPE OF PGM UNIT
C     STORE IN SAME WORD ASF TYPE
C
      I = IGATT1(K,1)
      LAT(L+1) = 4 + 8*MOD(I,8)
C
C     SETUP PARENT'S LIST TO POINT TO PP IN ASF NODE
C
      L = PLAT + SYMLEN + 3
      LAT(L) = L + 4
      LAT(L+4) = PP
      LAT(L+5) = 0
      KQ = PLAT
      PLAT = L + 6
C
C     SETUP REFERENCE IN PP'S DESCENDENTS LIST
C
      II = PP + SYMLEN + 4
      LAT(PLAT) = KQ
      LAT(PLAT+1) = LAT(II)
      LAT(II) = PLAT
      PLAT = PLAT + 2
C
C     SETUP ARGUMENTS
C
      L = KQ + SYMLEN
      LAT(L) = SETARG(KQ,K)
   30 RETURN
   40 CALL ERROR1(34H IN SETASF, TABLE OVERFLOW OF NODE, 34)
   50 SYSERR = .TRUE.
      GO TO 30
   60 CALL ERROR1(33H IN SETASF, TABLE OVERFLOW OF LAT, 33)
      GO TO 50
      END
      SUBROUTINE SETCOM(PP, K)
      LOGICAL SYSERR, ERR, ABORT, BLANK
      INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3),
     *    FINDND, ST, SS(1), FINDCM
      INTEGER ZERO(1)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /COMS/ LCOM, PCOM, COM(300)
C
C     COM ENTRY
C     WORD 1.....PACKED CHARACTERS OF COMMON-NAME
C     WORD 2....TOTAL LENGTH OF COMMON BLOCK
C     WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM
C      0 IF NOT
C     WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS,
C     REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY
C     WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS
C     THIS DEFN OF THE COMMON BLOCK
C
C     FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW
C     ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME.
C     GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON-
C     CHECKS FOR VARIABLY DIMENSIONED ARRAYS.
C     FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP)
C     IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN,
C     TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN
C     TWO BLOCK DATA PGMS.  COMMON IS AT DSA(K)
C
      DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/
      DATA ZERO(1) /0/
C
C     CHECK ISNT IN NODE AS PROCEDURE NAME
C
      IF (FINDND(DSA(K+4),KK)) 20, 20, 10
   10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41,
     *  DSA(K+4), 1, 1, 1)
C
C     CHECK IF IN COM ALREADY
C
   20 KK = FINDCM(DSA(K+4))
      IF (KK) 30, 30, 60
C
C     CREATE NEW ENTRY
C
   30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260
      DO 40 I=1,SYMLEN
        L = PCOM + I - 1
        LL = K + I + 3
        COM(L) = DSA(LL)
   40 CONTINUE
C
C     MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA
C     SUBPROGRAM WHICH SET IT
C
      DO 50 I=1,4
        LL = L + I
        COM(LL) = 0
   50 CONTINUE
      COM(LL+1) = PP
      IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1
      KK = PCOM
      PCOM = PCOM + SYMLEN + 5
C
C     GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS
C
   60 L = 0
      S(1) = 0
      S(2) = 0
      S(3) = 0
      I = DSA(K+2)
   70 IF (I) 130, 130, 80
C
C     READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE
C
   80 K1 = IGATT1(DSA(I),1)
      K2 = IGATT1(DSA(I),7)
      K1 = MOD(K1,8)
      IF (K1.EQ.5) K1 = 2
C
C     R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON
C
      LL = R(K1+1)
      IF (LL.LT.L) GO TO 120
      IF (K2) 90, 90, 100
   90 S(LL) = S(LL) + 1
      GO TO 110
  100 K2 = DSA(I)
      K2 = DSA(K2+2)
      S(LL) = S(LL) + DSA(K2)
  110 I = DSA(I+1)
      L = LL
      GO TO 70
C
C     ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES
C     TRUNCATION OF THE DEFINITION
C
  120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41,
     *  COM(KK), 1, 1, 0)
      CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1)
  130 S(3) = S(1) + S(2)
C
C     HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET
C
      L = PP + SYMLEN + 2
      I = MATCH(LAT(L),2,-K)
      IF (I.GT.0) GO TO 140
      I = MATCH(LAT(L),2,KK)
      IF (I.LE.0) GO TO 150
  140 LAT(I) = KK
      GO TO 160
C
C     CREATE NEW ENTRY
C
  150 IF (PLAT+3.GT.LLAT) GO TO 280
      LAT(PLAT) = KK
      LAT(PLAT+1) = 0
      LAT(PLAT+2) = LAT(L)
      LAT(L) = PLAT
      PLAT = PLAT + 3
  160 I = KK + SYMLEN
      IF (COM(I)) 170, 170, 190
C
C     NEW DEFN
C
  170 COM(I) = S(3)
      COM(I+2) = S(1)
      COM(I+3) = S(2)
  180 RETURN
C
C     COMPARE LENGTHS OF EACH TYPE
C
  190 L = KK + SYMLEN + 2
      BLANK = .FALSE.
      CALL S5UNPK(COM(KK), SS(1), 1)
      IF (SS(1).EQ.ST) BLANK = .TRUE.
      IBR = 0
      IF (COM(L+1).NE.S(2)) IBR = 1
      IF (COM(L).NE.S(1)) IBR = -1
C     BLANK COMMON DEFNS MATCH
      IF (IBR.EQ.0 .AND. BLANK) GO TO 180
C     NAMED COMMON DEFNS MATCH
      IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210
C     BLANK COMMON DONT MATCH
      IF (IBR.NE.0 .AND. BLANK) GO TO 230
C     NAMED COMMONS DONT MATCH -- ERROR
 200  CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1,
     *  0)
      K1 = KK + SYMLEN + 4
      K1 = COM(K1)
      CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0)
      CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1)
      IF (BLANK) GO TO 180
C
C     CHECK DOUBLE SETTING OF BLOCK
C
  210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180
      IF (COM(L-1).NE.1) GO TO 220
      CALL ERROR2(
     *    53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS  , 53,
     *  COM(KK), 1, 1, 1)
      GO TO 180
  220 COM(L-1) = 1
      GO TO 180
C
C     CHECK ARE LENGTHENING BLANK COMMON OFF THE END
C
 230  IF(IBR.EQ.(-1)) GOTO 250
C     ARE LENGTHENING OFF END
C     KEEP LONGEST DEFN
      IF (COM(L+1).GT.S(2)) GO TO 180
  240 COM(L+1) = S(2)
      LL = SYMLEN + KK
      COM(LL) = S(3)
      COM(LL+4) = PP
      GO TO 180
C     SEE ARE REALLY LENGTHENING OFF END IF
C     DEFNS DIFFER IN FIRST DATA TYPE AREAS
  250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180
      IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200
      COM(L) = S(1)
      GO TO 240
  260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33)
  270 SYSERR = .TRUE.
      GO TO 180
  280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33)
      GO TO 270
      END
      SUBROUTINE SETEXT
      INTEGER Z, FINDND, PLAT, PNODE, PP, SS(3), SYMLEN
      INTEGER BLANK
      LOGICAL ERR, SYSERR, ABORT
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /INTS/ Z(346)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      DATA BLANK /1H /
C
C     SUBROUTINE SETS UP DEFNS FOR BASIC EXTERNAL FCNS USED IN PASS 1
C     FLUSH PAST INTRINSICS IN TABLE
C
      K = 1
      DO 10 I=1,31
        K = K + Z(K) + 2
   10 CONTINUE
C
C     SEARCH EXTERNAL ENTRIES IN TABLE TO SEE WHICH HAVE BEEN USED
C
      DO 90 I=1,24
        N = K + Z(K) + 1
        L = Z(N)/1024
        IF (L) 80, 80, 20
C
C     SEE IF THIS EXTERNAL FCN HAS BEEN USER DEFINED
C
   20   L = Z(K)
        DO 30 J=1,SYMLEN
          SS(J) = BLANK
   30   CONTINUE
        CALL S5PACK(Z(K+1), SS, L)
        LL = FINDND(SS(1),J)
        IF (LL.NE.0) GO TO 80
C
C     SETUP LATTICE ENTRY FOR THIS EXERNAL FCN
C
        IF (PNODE+1.GE.LNODE) GO TO 120
        IF (PLAT+SYMLEN+8.GE.LLAT) GO TO 110
C     SET LEVEL OF BASIC EXTERNAL FUNCTION TO -2
        INODE(PNODE) = -2
        NODE(PNODE) = PLAT
        PNODE = PNODE + 1
        DO 40 J=1,SYMLEN
          L = PLAT + J - 1
          LAT(L) = SS(J)
   40   CONTINUE
        PP = PLAT
        PLAT = PLAT + SYMLEN
        LAT(PLAT) = MOD(Z(N),512)/128
        L = PLAT + 1
        LL = PLAT + 5
        DO 50 NN=L,LL
          LAT(NN) = 0
   50   CONTINUE
        LAT(PLAT+6) = 6 + 8*MOD(Z(N),8)
        NO = LAT(PLAT)
        PLAT = PLAT + 7
C
C     FILL IN ARG ENTRIES
C     NO CONTAINS NUMBER OF ARGS
C
        IF ((PLAT+4)*NO.GE.LLAT) GO TO 110
        L = PP + SYMLEN + 1
   60   LL = PLAT + 3
        DO 70 NN=PLAT,LL
          LAT(NN) = 0
   70   CONTINUE
        CALL SATT2(PLAT, 1, MOD(Z(N),64)/8)
        CALL SATT2(PLAT, 4, 1)
        CALL SATT2(PLAT, 8, 10)
        LAT(L) = PLAT
        LAT(PLAT+1) = 1
        L = PLAT + 3
        PLAT = PLAT + 4
        IF (NO.EQ.1) GO TO 80
        NO = NO - 1
        GO TO 60
   80   K = N + 1
   90 CONTINUE
  100 RETURN
  110 CALL ERROR1(33H IN SETEXT, TABLE OVERFLOW OF LAT, 33)
      GO TO 130
  120 CALL ERROR1(34H IN SETEXT, TABLE OVERFLOW OF NODE, 34)
  130 SYSERR = .TRUE.
      GO TO 100
      END
      SUBROUTINE SETPD(I, K2)
      INTEGER PDSA, DSA, PLAT, SYMLEN
      LOGICAL ERR, SYSERR, ABORT
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C     SUBROUTINE ADDS PGM UNIT AT LAT(I) ONTO K2 DESC-LIST
C     ADDS K2 ONTO I PARENTS  LIST
C
      IF (PLAT+4.GT.LLAT) GO TO 20
C
C     SEE THAT K2 IS NOT ALREADY ON I PARENTS LIST
C     0 RETURN INDICATES EMPTY LIST OR NO MATCH
C
      J = I + SYMLEN + 3
      IF (MATCH(LAT(J),1,K2).NE.0) GO TO 10
      LAT(PLAT+1) = LAT(J)
      LAT(PLAT) = K2
      LAT(J) = PLAT
      J = K2 + SYMLEN + 4
      LAT(PLAT+3) = LAT(J)
      LAT(PLAT+2) = I
      LAT(J) = PLAT + 2
      PLAT = PLAT + 4
   10 RETURN
C
C     ERROR RETURNS
C
   20 SYSERR = .TRUE.
      CALL ERROR1(32H IN SETPD, TABLE OVERFLOW OF LAT, 32)
      GO TO 10
      END
      SUBROUTINE SETREF(GREEN,INDIR)
      INTEGER CHK1, KBR(1)
      INTEGER REF, PREF, PDSA, DSA, PLAT, PNODE, FINDND, SYMLEN
      LOGICAL ERR, SYSERR, ABORT, COMPAR, GREEN, INDIR
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON/ SCR1/ LINODE, INODE(500)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /TABL/ NEXT, LABHD, ISYM, IBNEXT
      DATA IBR /1/, JBR /3/, KBR(1) /0/
C
C     GREEN = T IF ENCOUNTER EXTERNAL ENTITIES AT ALL
C     INDIR = T IF ENCOUNTER ANY INDIRECT REFS
C      READS IN ALL REFS FOR A PROGRAM UNIT; FINDS MISSING
C      SUBPROGRAM REFS AND DISCARDS THEM; CHECKS ASF REFS AND
C      DISCARDS THEM; WRITES INDIRECT REFS OUT ON I6 WITHOUT
C      PROCESSING; DOES MINIMAL CHECKING OF DIRECT REFS
C      CREATING PAR/DESC LINKS AND WRITING GOOD
C      REFS OUT ON I6, AFTER DONE WITH REFS, SEARCHES
C      FOR EXTERNAL ENTITIES (USAGE 13) TO FIX UP LEVELS
C
      IJK = FINDND(DSA(NAME+4),IIJK)
C      READ IN A NEW REF; IF HIT END OF REFS RECORD
C      END OF REFS ON I6 AND RETURN
   10 IF (INREF(I5)) 20, 20, 80
C      WRITE END OF REFS
   20 WRITE (I6) IBR, JBR, IBR
C      CHECK FOR NON DUMMY EXTERNALS IN SYMBOL TABLE WHICH
C      C AUSE CHANGES IN LEVEL CALCS
      K = ISYM
   30 IF (K) 40, 40, 50
 150  SYSERR=.TRUE.
      CALL ERROR1(33H IN SETREF, TABLE OVERFLOW OF LAT,33)
   40 RETURN
   50 IF (IGATT1(K,8).NE.13 .OR. IGATT1(K,4).EQ.1) GO TO 70
      L = FINDND(DSA(K+4),IL)
      IF (L.NE.0) GO TO 60
      CALL ERROR2(18H MISSING EXTERNAL , 18, DSA(K+4), 1, 1, 0)
      CALL ERROR2(1H1,0,KBR(1),-1, 0, 1)
      GO TO 70
C     FOUND AN EXTERNAL ENTITY
 60   GREEN = .TRUE.
C     ENTER ONTO GREEN LINKS LIST AT NODE
      N = IJK + SYMLEN + 3
C     J IS HEAD OF GREEN LINKS LIST (SEE SETPD)
 160  IF(LAT(N+1).LE.0) GOTO 170
      N = LAT(N+1)
      GOTO 160
 170  J = N+1
      IF(PLAT+2.GT.LLAT) GOTO 150
      LAT(PLAT) = -L
      LAT(PLAT+1) = LAT(J)
      LAT(J) = -PLAT
      PLAT = PLAT+2
      IF(-2.EQ.INODE(IL).OR.INODE(IL).GT.INODE(IIJK)) GOTO 70
      INODE(IL) = INODE(IIJK) + 1
      CALL ASLEV(-IL)
      IF (ABORT .OR. SYSERR) GO TO 40
   70 K = DSA(K+3)
      GO TO 30
C
C      REF IS  WD1--NUMBER OF ARGS(2 WD ENTRIES)
C            WD2--PTR TO PGM UNIT CALLED IN DSA
C            WD3--STMT NO OF  CALL
C            WD4--CODE, 0 FOR SUBR REFS; 1 FOR FCN REFS
C             WD5+-ARG ENTRIES (WD1-SYMBOL TABLE INDEX OR 0
C                             WD2-TYPE/STRUCTURE INFO)
C
   80 IF (REF(4).LT.4) GO TO 100
C
C      ASF REFERENCE; CHECKED AND THEN DISCARDED
C
      K1 = PNODE - 1
      DO 90 I=1,K1
        IF (NODE(I).GE.0) GO TO 90
        IJR = IABS(NODE(I))
        L = IJR + SYMLEN + 3
        L = LAT(L)
        K = REF(2)
C
C      IF HAVE ASF REF, FIND ASF BY NAME AND PAR CHECKS
C
        IF (COMPAR(DSA(K+4),LAT(IJR)) .AND. LAT(L).EQ.IJK) GO TO 110
   90 CONTINUE
      L = REF(2) + 4
      CALL ERROR2(18H MISSING ASF DEFN , 18, DSA(L), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
      GO TO 10
C
C      WRITE INDIRECT REF OUT ON I6
C
  100 K2 = IGATT1(REF(2),4)
      IF(K2.EQ.0) GOTO 140
      INDIR = .TRUE.
      GOTO 130
C      CHECK FOR MISSING SUBPROGRAM
 140  K1 = REF(2)
      IJR = FINDND(DSA(K1+4),IIJR)
      IF (IJR.NE.0) GO TO 110
      CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(K1+4), 1
     *  ,1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
      GO TO 10
C      CHECK DIRECT REFS AND ASF REFS
C      1 MEANS OK 0 MEANS N.G.
  110 IF (CHK1(IJK,IJR)) 10, 10, 120
  120 IF (REF(4).EQ.4) GO TO 10
C      GOOD DIRECT REF; CREATE PAR/DES LINKS
      CALL SETPD(IJR, IJK)
      IF (SYSERR) GO TO 40
      IF (-2.EQ.INODE(IIJR) .OR. INODE(IIJR).GT.INODE(IIJK)) GO TO 130
C      FIX UP LEVELS
      INODE(IIJR) = INODE(IIJK) + 1
      CALL ASLEV(IIJR)
      IF (SYSERR .OR. ABORT) GO TO 40
  130 WRITE (I6) PREF, IBR, (REF(L),L=1,PREF)
      GO TO 10
      END
      SUBROUTINE UNSAFE
C
C     ROUTINE READS IN ALL DIRECT AND INDIRECT REFS FOR THE CURRENT
C     PGM-UNIT; CHECKS FOR THE 3 UNSAFE REFS
C
      LOGICAL IBR
      INTEGER PLAT, PDSA, DSA, SYMLEN, PREF, REF, INREF, FINDCM
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /FACTS/ NAME, I1, I2, IASF
      COMMON /PARAMS/ I3, I4, I5, SYMLEN, I6, I7, I8
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
   10 IF (INREF(I7).LE.0) RETURN
C     CHECK FOR REF WITHOUT ARGS
      I = REF(1)
      IF (I.EQ.0) GO TO 10
      LL = REF(2)
      L = LL + SYMLEN + 1
      L = LAT(L)
C
C     LPOINTS TO DUMMY ARGUMENT IN LAT
C
      DO 70 K=1,I,2
        J = 4 + K
        IF (REF(J).EQ.0) GO TO 20
        N = IGATT1(REF(J),8)
        IF (N.EQ.10 .OR. N.EQ.4) GO TO 30
        GO TO 60
C
C     LOOK FOR EXPRESSION BEING MATCHED TO AN ARG WHICH
C     IS SET; TYPE 1 UNSAFE REF
C
   20   IF (IGATT2(L,5).EQ.0) GO TO 60
        CALL ERROR2(
     *      56H EXPRESSION MATCHED TO POSSIBLY SET ARG IN REFERENCE TO ,
     *  56, LAT(LL), 1, 1, 0)
      CALL ERROR2(24H TYPE 1 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
        GO TO 60
C
C     CHECK FOR ACTUAL ARG IN COMMON BEING SENT DOWN WHERE RTNE
C     BENEATH CHANGES ARG OR COMMON REGION
C     TYPE 3 UNSAFE REFERENCE
C
   30   N = IGATT1(REF(J),2)
        IF (N.NE.1) GO TO 40
C
C     SEE IF  ACTUAL IS AN ARRAY
C
        N = IGATT2(L,7)
        IF (N.NE.0) GO TO 40
        N = REF(J) + 2
        N = DSA(N)
        N = DSA(N+1) + 4
        N = FINDCM(DSA(N))
        NN = LL + SYMLEN + 2
        NN = MATCH(LAT(NN),2,N)
        IF (NN.EQ.0) GO TO 40
        N = IGATT2(L,5)
        IF (N.EQ.0 .AND. LAT(NN+1).EQ.0) GO TO 40
        CALL ERROR2(42H ARG OR COMMON MAY BE SET BY REFERENCE TO , 42,
     *  LAT(LL), 1, 1, 0)
      CALL ERROR2(24H TYPE 3 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
C
C     CHECK FOR DO CONTROL VAR OR LIMIT MATCHED
C     TO DUMMY ARG POSSIBLY SET
C
   40   NN = IGATT2(L,5)
        IF (NN.EQ.0) GO TO 60
        NN = REF(J+1)/32
        IF (NN.NE.1) GO TO 50
        CALL ERROR2(
     *      51H DO CONTROL VARIABLE OR LIMIT CAN BE SET IN REF TO , 51,
     *  LAT(LL), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C
C     CHECK FOR ADJUSTIBLE DIMENSION VARIABLE MATCHED TO DUMMY
C     ARG POSSIBLY SET
C
   50   NN = REF(J+1)/64
        IF (NN.NE.1) GO TO 60
        CALL ERROR2(
     *      52H ADJUSTIBLE DIMENSION VARIABLE CAN BE SET IN REF TO ,
     *  52, LAT(LL), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
   60   L = LAT(L+3)
   70 CONTINUE
C
C     CHECK FOR SAME ACTUAL ARG SENT DOWN FOR DIFFERENT DUMMY-ARGS
C     AND ONE OF DUMMIES MAY BE SET
C
C     TYPE 2 UNSAFE REFERENCE
      IF (REF(1).LE.2) GO TO 130
      LR = LL + SYMLEN + 1
      LR = LAT(LR)
C
C     OUTER LOOP GOES TO NEXT TO LAST ARG
C
      I = REF(1) + 3
      II = I - 2
      DO 120 K=5,II,2
        J = REF(K)
        IF (J.EQ.0) GO TO 110
        JBR = IGATT1(J,8)
        IF (JBR.NE.10 .AND. JBR.NE.4) GO TO 110
        L = LAT(LR+3)
        MM = K + 2
        DO 100 M=MM,I,2
          IF (REF(M).NE.J) GO TO 90
C
C     HAVE TWO ACTUALS MAPPED ONTO DIFFERENT DUMMIES
C
C     IF BOTH DUMMIES ARE ARRAYS OR BOTH ARE UNSET, NO UNSAFE
      IF( IGATT2(L,7).NE.0 .AND. IGATT2(LR,7).NE.0 ) GOTO 90
      IF( IGATT2(L,5).EQ.0 .AND. IGATT2(LR,5).EQ.0 ) GOTO 90
 80   CALL ERROR2(64
     *H ACTUAL ARG ASSOCIATED WITH 2 DUMMY ARGS POSSIBLY SET IN REF TO
     *, 64, LAT(LL), 1, 1, 0)
      CALL ERROR2(24H TYPE 2 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
   90     L = LAT(L+3)
  100   CONTINUE
  110   LR = LAT(LR+3)
  120 CONTINUE
C
C     CHECK FOR EXTERNAL FCNS WITHIN ASF-DEFS WHICH CONTAIN
C     ASF-DUMMIES AND WHICH SET THEIR ARGS
C
  130 IF (REF(4).NE.1) GO TO 10
      II = REF(1) + 3
      IBR = .FALSE.
      DO 140 K=5,II,2
        J = REF(K)
        IF (J.EQ.0) GO TO 140
        IF (IGATT1(J,8).EQ.1) IBR = .TRUE.
  140 CONTINUE
      IF (.NOT.IBR) GO TO 10
C
C     SEE IF EXTERNAL FCN SETS ANY OF ITS ARGS
C
      K = LL + SYMLEN + 1
      K = LAT(K)
      II = REF(1)/2
      DO 150 L=1,II
        IF (IGATT2(K,8).EQ.10 .AND. IGATT2(K,5).EQ.1) IBR = .FALSE.
  150 CONTINUE
      IF (IBR) GO TO 10
      CALL ERROR2(37H ILLEGAL USAGE OF ASF-DUMMY IN REF TO, 37,
     *  LAT(LL), 1, 1, 0)
      CALL ERROR2(1H , 0, REF(3), -1 ,0, 1)
      GO TO 10
      END
      SUBROUTINE CHECKS(IROOT)
C
C     MAIN IS INDEX IN NODE OF SUPEROOT IN LAT
C
      LOGICAL ERR, SYSERR, ABORT, INSYM
      COMMON /PARAMS/ I1, I2, I3, I4, I5, I6, I7
      COMMON /DETECT/ ERR, SYSERR, ABORT
      CALL COMCHK(IROOT)
      CALL SCAN(IROOT)
      IF (SYSERR) GO TO 20
 10   IF(.NOT.INSYM(I6,0)) GOTO 30
      CALL UNSAFE
      GO TO 10
   20 WRITE (I2,99999)
99999 FORMAT (31H1UNSAFE REFERENCES NOT VERIFIED)
   30 RETURN
      END
      SUBROUTINE CONSTR(MAINND)
      LOGICAL SYSERR, ERR, ABORT, INSYM, GREEN, INDIR
      LOGICAL OVER
C      NOTE SETNOD SETS ABORT FOR 2 P.U. WITH SAME NAME
C      CONSTR SETS ABORT IF IT FINDS NO SYMBOL TABLES FROM PASS1
C      ASLEV SETS ABORT IF IT FINDS RECURSION IN CALLING GRAPH
      INTEGER OUTUT2, OUTUT3, OUTUT4, SYMLEN
      INTEGER PNODE, PLAT, LS(2)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, OUTUT2, OUTUT3, OUTUT4
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      DATA IBR /1/, JBR /4/
      DATA LS(1) /1H,/, LS(2) /1H /
C
C      CONSTR DIRECTS THE FIRST PORTION OF PASS2
C      CALLS SETNOD TO CONSTRUCT THE LAT NODES FOR EACH P.U..
C      CALLS SETEXT TO SETUP BASIC EXERNALS NODES
C      AS NEEDED.
C      CALLS SETREF TO MAKE CONNECTS BETWEEN THE NODES
C      CALLS INVOKE TO CALCULATE LEVELS AND ASSIMILATE
C      ALL PROC INFO NECESSARY
C     CALLS ERASE TO GET RID OF NON-REFERENCE LINKS IN
C     CALLING GRAPH
C      CALLS CHKALL TO DO FINAL CHECKS OF ALL REFS AND TO
C      WRITE ALL GOOD REFS OUT FOR FUTURE PROCESSING
C     FORMS SUPERROOT IN GRAPH
C      CALLS OUTPUT ROUTINES WHENEVER CAN, TO GIVE PARTIAL
C      LISTINGS OF CURRENT DATA STRUCTURE
C
C     USE INSYM TO POSSIBLY SKIP OVER BAD REFS WITH DUMMY SYM TBL
C     SETREF READS REFS FROM OUTUT3, WRITES ON OUTUT4
C     INVOKE READS FROM OUTUT4
C     CHKALL READS FROM OUTUT4, WRITES OUTUT3
C     UNSAFE READS FROM OUTUT3
C      INITIALIZE LEVEL ARRAY AND ISR
      ISR = 0
      DO 10 I=1,LNODE
        INODE(I) = 0
   10 CONTINUE
C     INITIALIZE LOGICAL FLAGS FOR DETECTION OF PRESENCE OF
C     EXTERNAL ENTITIES (GREEN) AND INDIRECT REFS(INDIR)
      GREEN = .FALSE.
      INDIR = .FALSE.
 20   IF(.NOT.INSYM(0,0)) GOTO 30
C
C      SUCCESSFULLY READ SYMBOL TABLE
C
      CALL SETNOD
      IF (SYSERR .OR. ABORT) GO TO 130
      GO TO 20
   30 REWIND OUTUT2
      IF (PNODE.EQ.1) GO TO 150
C      CHANGE LEVEL ON ASFS SO DONT PROCESS THEM
      L = PNODE - 1
      DO 40 I=1,L
        IF (NODE(I).LT.0) INODE(I) = -2
   40 CONTINUE
C
C      SETUP BASIC EXTERNAL DEFNS AS NEEDED
C
      CALL SETEXT
      IF (SYSERR) GO TO 130
C
C      READ IN SYMBOL TABLES
C      SETREF WILL READ IN REFS
C
 50   IF(.NOT.INSYM(OUTUT3, OUTUT4)) GOTO 60
      CALL SETREF ( GREEN, INDIR  )
      IF (SYSERR .OR. ABORT) GO TO 130
      GO TO 50
   60 REWIND OUTUT2
      REWIND OUTUT3
      WRITE (OUTUT4) IBR, JBR, IBR
      REWIND OUTUT4
      IF(.NOT.INDIR) GOTO 70
C
C       CALL LEVEL ALG
C
      CALL INVOKE
      IF (ABORT .OR. SYSERR) GO TO 130
      REWIND OUTUT2
      REWIND OUTUT4
C
C      CHECK AND EXPAND REFS AND SAVE ALL GOOD ONES FOR LATER
C
 70   IF(.NOT.INSYM(OUTUT4,OUTUT3)) GOTO 80
      CALL CHKALL
      IF (SYSERR) GO TO 130
      GO TO 70
   80 WRITE (OUTUT3) IBR, JBR, IBR
C
C      CONSTRUCT SUPEROOT IN LAT
C
      IF (PNODE+1.GT.LNODE) GO TO 180
      IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 160
      NODE(PNODE) = PLAT
C      MAINND IS SUPEROOT INDEX IN NODE
C      ISR IS SUPEROOT INDEX IN LAT
      MAINND = PNODE
      ISR = PLAT
      PNODE = PNODE + 1
      LAT(PLAT) = LS(1)
      PLAT = PLAT + 1
      IF (SYMLEN.EQ.1) GO TO 100
      DO 90 I=2,SYMLEN
        L = PLAT + I - 2
        LAT(L) = LS(2)
   90 CONTINUE
      PLAT = L + 1
  100 L = PLAT + 5
      DO 110 I=PLAT,L
        LAT(I) = 0
  110 CONTINUE
      LAT(L+1) = 5
      PLAT = L + 2
C
C      LOOK FOR CALLABLE PGM UNITS WITHOUT PARENTS
C
      L = PNODE - 2
      DO 120 I=1,L
        K = SYMLEN + 3 + IABS(NODE(I))
        IF (LAT(K).EQ.0) CALL SETPD(IABS(NODE(I)), ISR)
        IF (SYSERR) GO TO 130
 120  CONTINUE
 130  IF(.NOT.GREEN) GOTO 190
C     ERASE GREEN LINKS
      L = PNODE - 2
      DO 210 I = 1,L
C     SKIP ASF NODES
      IF(NODE(I) .LT. 0) GOTO 210
C     FIND HEAD OF GREEN LINKS
      N = NODE(I) + SYMLEN + 3
 220  IF(LAT(N+1) .LE. 0) GOTO 230
      N = LAT(N+1)
      GOTO 220
 230  LAT(N+1) = 0
 210  CONTINUE
 190  OVER = SYSERR
      SYSERR = .FALSE.
      CALL OUT2 (ISR)
      SYSERR = SYSERR.OR.OVER
      IF(SYSERR) CALL ERROR1(
     *    56H ILLEGAL COMMON USAGE AND UNSAFE REFERENCES NOT VERIFIED,
     *    56)
      CALL OUT2C
  140 RETURN
  150 ABORT = .TRUE.
      GO TO 140
  160 CALL ERROR1(33H IN CONSTR, TABLE OVERFLOW OF LAT, 33)
  170 SYSERR = .TRUE.
      GO TO 130
  180 CALL ERROR1(34H IN CONSTR, TABLE OVERFLOW OF NODE, 34)
      GO TO 170
      END
      SUBROUTINE OUT2(ISR)
      INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12),
     *    OUTLAT, OUTCOM, OUTUT
      LOGICAL ERR, SYSERR, ABORT
      EXTERNAL EXCH
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/,
     *    C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL
     *    /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/
      DATA BL /1H /
C
C     ROUTINE PRINTS CALLING GRAPH
C
      IF (PNODE.LE.2) GO TO 110
C
C     GRAPH
C
      I3 = PNODE - 1
      IF (ISR.NE.0) I3 = I3 - 1
C
C     SORT LATTICE
C
      DO 10 I=1,I3
        INODE(I) = IABS(NODE(I))
   10 CONTINUE
      CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0)
      DO 100 IA=1,I3
        I = INODE(IA)
        L = I + SYMLEN + 6
        IF (MOD(LAT(L),8).EQ.4) GO TO 100
        CALL S5UNPK(LAT(I), STACK(1), 6)
        WRITE (OUTUT,99999) (STACK(L),L=1,6)
99999   FORMAT (///1X, 6A1//)
C
C     GET ARGS IF ANY
C
        IS = 1
        K = SYMLEN + I
        L = LAT(K)
        IF (L) 70, 70, 20
   20   K = K + 1
        K = LAT(K)
        IF (L*8.GT.LSTACK) GO TO 120
        DO 60 LL=1,L
          Q(1) = IGATT2(K,8)
          IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30
          Q(1) = IGATT2(K,1)
          Q(2) = IGATT2(K,5)
          Q(3) = IGATT2(K,7)
          STACK(IS) = IBL
          STACK(IS+2) = IBL
          IF (Q(1).GE.8) STACK(IS) = C(1)
          L1 = MOD(Q(1),8) + 2
          STACK(IS+1) = C(L1)
          IF (Q(2).EQ.1) STACK(IS+2) = C(7)
          STACK(IS+3) = C(7)
          IF (Q(3).NE.0) STACK(IS+3) = C(8)
          GO TO 40
   30     STACK(IS) = IP
          STACK(IS+1) = IBL
          STACK(IS+2) = IBL
          STACK(IS+3) = IBL
   40     DO 50 LK=4,7
            L1 = LK + IS
            STACK(L1) = BL
   50     CONTINUE
          IS = IS + 8
          K = LAT(K+3)
   60   CONTINUE
      IS = IS - 1
C     PRINT ARGUMENTS
      K = 48
      IF (K.GT.IS) K = IS
      WRITE(OUTUT,99998)(STACK(LK), LK=1,K)
99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X))
      IF( K.EQ.IS ) GOTO 70
 65   LK = K + 1
      K = LK + 47
      IF(K.GT.IS) K = IS
      WRITE(OUTUT,99997) (STACK(L1),L1=LK,K)
99997 FORMAT(25X,6(8A1,1X))
      IF(K.LT.IS) GOTO 65
C
C     GET COMMON NAMES
C
   70   K = I + SYMLEN + 2
        K = OUTCOM(LAT(K),IS)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 80
      CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2)
C
C     FIND PARENTS
C
   80   K = I + SYMLEN + 3
        K = OUTLAT(LAT(K),IS,ISR)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 90
      CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1)
C
C     FIND DESCENDENTS
C
   90   K = I + SYMLEN + 4
        K = OUTLAT(LAT(K),IS,ISR)
        IF (SYSERR) GO TO 110
        IF (K.EQ.0) GO TO 100
      CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1)
  100 CONTINUE
  110 RETURN
  120 SYSERR = .TRUE.
      CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33)
      GO TO 110
      END
      SUBROUTINE SETNOD
      INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM,
     *    SETARG, FINDND, FINDCM
      LOGICAL ERR, SYSERR, ABORT
      COMMON /COMS/ LCOM, PCOM, COM(300)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT
      COMMON /SCR1/ LINODE, INODE(500)
C
C     LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES
C     PLAT-IS NEXT FREE WORD IN LAT
C     LLAT-IS LENGTH OF LAT
C     NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT
C        (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES)
C     PNODE-IS NEXT FREE WORD IN NODE
C     LNODE-IS LENGTH OF NODE
C
C     P.U. NODE IN LAT
C     WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM
C     WD2.....NUMBER OF ARGS
C     WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF
C     ARGUMENT NODES IN LAT
C     WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES
C     IN LAT
C     WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR PARENT NODES
C     WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C     LAT OF ENTRIES FOR DESCENDENT NODES
C     WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF
C     BAD REFERENCES;  INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR
C     NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE
C     TYPES OF BAD REFS
C     WD8.....BITS 0-2 TYPE OF SUBPGM:  0 SUBR, 1 FCN, 2 BLOCK DATA,
C      3 MAIN, 4 ASF, 5 SUPEROOT
C     BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL,
C     2 INT, 3 COMP, 4 LOG
C
C     ARGUMENT NODE IN LAT
C     WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP)
C     WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO
C     HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED
C     WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF
C     SUBPRGM IN WHICH THE ASSOC OCCURS
C     WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS
C     (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG)
C     WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS
C     (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH)
C     WD 5.....PTR TO NEXT ARG NODE OR 0
C
C     COMMON NODE IN LAT
C     WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM
C     WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0
C     WD 3.....PTR TO NEXT COMMON NODE
C     CREATE NODE PTR TO NEW NODE IN LAT
C
      IF (PNODE.GT.LNODE) GO TO 170
      IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190
C
C     CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM
C     OR A COMMON BLOCK
C
      II = IGATT1(NAME,8)
      IF (II.EQ.11) GO TO 10
      IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20
   10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30
   20 ERR = .TRUE.
   30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45,
     *  DSA(NAME+4), 1, 1, 1)
      IF (.NOT.ERR) GO TO 40
      ERR = .FALSE.
      ABORT = .TRUE.
      GO TO 160
   40 NODE(PNODE) = PLAT
      IROOT = PNODE
      PNODE = PNODE + 1
C
C     ENTER NAME INTO NODE
C
      DO 50 I=1,SYMLEN
        L = NAME + 3 + I
        LL = PLAT - 1 + I
        LAT(LL) = DSA(L)
   50 CONTINUE
C
C     PP POINTS TO CURRENT RTNE NODE IN LAT
C
      PP = PLAT
      PLAT = LL + 6
      LL = LL + 1
      DO 60 I=LL,PLAT
        LAT(I) = 0
   60 CONTINUE
C
C     0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT
C
      LAT(PLAT+1) = II/4
C     INITIALIZE LEVEL OF BLOCK DATA TO -2
      IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2
      IF (LAT(PLAT+1).NE.1) GO TO 70
      L = IGATT1(NAME,1)
      LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8)
   70 PLAT = PLAT + 2
C
C     HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS
C
      IF (DSA(NAME+2)) 80, 90, 80
   80 L = PP + SYMLEN
      LAT(L) = SETARG(PP,NAME)
      IF (SYSERR) GO TO 160
C
C     READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS
C     AND SETTING OF COMMON REGION
C
   90 K = SYMHD
  100 IF (K) 110, 160, 110
  110 LL = IGATT1(K,8)
C
C     CHECK FOR ASF AND COMMON DEFNS OR COMMON
C     SETTING INFO
C
      GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140,
     *    140, 140, 140), LL
C
C     CREATE ASF NODE
C
  120 CALL SETASF(PP, K)
      IF (SYSERR) GO TO 160
      GO TO 140
C
C     CREATE COM ENTRY
C
  130 CALL SETCOM(PP, K)
      IF (SYSERR) GO TO 160
  140 K = DSA(K+3)
      GO TO 100
C
C     CHECK IF ELEMENT IN COMMON
C
  150 LL = IGATT1(K,2)
      L = IGATT1(K,5)
      IF (L.NE.1 .OR. LL.NE.1) GO TO 140
      L = DSA(K+2)
      L = DSA(L+1)
      CALL MKCOM(PP, L)
      IF (SYSERR) GO TO 160
      GO TO 140
  160 RETURN
  170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34)
  180 SYSERR = .TRUE.
      GO TO 160
  190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33)
      GO TO 180
      END
      INTEGER FUNCTION CHK1(IR, IE)
C
C      PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
C      CHK1 RETURNS 1 IF REF OK ELSE 0
C      CHECKS FOR INCONSISTENT SYBPGM USAGE, CORRECT NO. OF
C      ARGS, CORRECT USAGE MATCH UP OF ARGS
C
      INTEGER PREF, REF, PDSA, DSA, PLAT, SYMLEN, IBR(1)
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      CHK1 = 0
C      CHECKS FOR SELF RECURSION
      IF (IE.NE.IR) GO TO 10
      CALL ERROR2(24H RECURSIVE CALL OF SELF , 24, REF(3), -1, 1, 1)
      GO TO 100
C      CHECKS FOR USAGE OF SUBPGM CONSISTENT WITH DEF
   10 I = IE + SYMLEN + 6
      N = MOD(LAT(I),8)
      IF (N.EQ.REF(4) .OR. N.EQ.6 .AND. REF(4).EQ.1) GO TO 20
      CALL ERROR2(38H INCONSISTENT REFERENCE TO SUBPROGRAM , 38,
     *  LAT(IE), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
      GO TO 100
C      CHECKS FOR CORRECT NO. ARGS
   20 I = IE + SYMLEN
      IF (LAT(I).EQ.REF(1)/2) GO TO 30
      CALL ERROR2(42H INCORRECT NUMBER OF ARGS IN REFERENCE TO , 42,
     *  LAT(IE), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
      GO TO 100
C      ARE DONE WITH REF IF IT HAS NO ARGS
 30   CHK1 = 1
      IF(LAT(I)) 100, 100, 40
C      CHECK USAGES OF ARGS IN CALL VS USAGES OF ARGS IN DEF
C      N POINTS TO DUMMY ARG ENTRY
   40 I = LAT(I)
      N = IE + SYMLEN + 1
      L = 5
      DO 80 K=1,I
        MD = IGATT2(LAT(N),8)
        IF (MD.NE.13 .AND. MD.NE.5 .AND. MD.NE.6) GO TO 60
C      HAVE A PROC ARG IN DEF
C      NEED A PROC ARG IN REF
        IF (REF(L).EQ.0) GO TO 50
        MR = IGATT1(REF(L),8)
        IF (MR.EQ.13 .OR. MR.EQ.6 .OR. MR.EQ.5) GO TO 70
 50   IBR(1) = K
      CALL ERROR2(36H INCOMPATIBLE USAGE ASSOCIATED WITH ,36,IBR,-2,1,0)
      CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
      CHK1 = 0
      GOTO 70
C      HAVE VARIABLE OR ARRAY AS ARG IN DEF
C      NEED SAME IN REF
   60   IF (REF(L).EQ.0) GO TO 70
        MR = IGATT1(REF(L),8)
        IF (MR.EQ.13 .OR. MR.EQ.5 .OR. MR.EQ.6) GO TO 50
   70   N = LAT(N) + 3
        L = L + 2
   80 CONTINUE
  100 RETURN
      END
      INTEGER FUNCTION CHK2(IR, IE)
C
C     PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
C     CHK2 RETURNS 1 IF REF IS OK, ELSE 0
C     CHECKS TYPE OF FCN IF FCN IS REFERENCED,
C      CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE
C     TYPE AND STRUCTURE OF VARIABLE
C     AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN
C     DUMMIES FOR SETTING INFO TRANSFER IN SCAN
C     BAD STRUCTURE MATCHING MAKES REF BAD
C     NO DUMMY LINKS CREATED IN THIS CASE
C
      INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1)
      LOGICAL ERR, SYSERR, ABORT
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      CHK2 = 1
C     CHECK TYPE OF FCN CALLED IF A FCN
      IF (REF(4).NE.1) GO TO 10
      I = IE + SYMLEN + 6
      IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10
      IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10
      CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39,
     *  LAT(IE), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C     CYCLE THROUGH ARGS IF ANY
   10 I = IE + SYMLEN
      IF (LAT(I).EQ.0) GO TO 170
      I = LAT(I)
      N = IE + SYMLEN + 1
      L = 5
      DO 160 K=1,I
        AER(1) = K
        L1 = IGATT2(LAT(N),8)
        IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90
C     CHECK STRUCTURE AND TYPE OF VARIABLES
C     AND ARRAY ARGUMENTS
        K1 = MOD(IGATT2(LAT(N),1),8)
        K2 = IGATT2(LAT(N),7)
        IF (K2.GT.1) K2 = 1
        L1 = MOD(REF(L+1),8)
        L2 = MOD(REF(L+1),32)/8
C
C     CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED
C     ALWAYS TO INTEGER ARRAYS
C
        IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20
        IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40
      CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0)
      CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        CHK2 = 0
        GO TO 150
   20   IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30
      CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0)
      CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C
C     CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE
C
   30   IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR.
     *      L2.EQ.0)) GO TO 40
      CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2,
     *  1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1,0,1)
        CHK2 = 0
        GO TO 150
C
C     CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT
C     IF SO CREATE ARGLINK.
C     NO ARGLINK CREATED IF FCN CALLED IS AN ASF
C
   40   IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150
        K1 = IGATT1(REF(L),4)
        IF (K1.EQ.0) GO TO 150
C
C     FIND REL. POSITION OF CALLING PGM
C     DUMMY , L1 PTS TO IT IN LAT
        L3 = DSA(NAME+2)
        KK = 0
   50   KK = KK + 1
        IF (DSA(L3).EQ.REF(L)) GO TO 60
        L3 = DSA(L3+1)
        GO TO 50
   60   K2 = 0
        L1 = IR + SYMLEN - 2
   70   L1 = LAT(L1+3)
        K2 = K2 + 1
        IF (K2.LT.KK) GO TO 70
C     FIND REL POSITION OF CALLED DUMMY ARG
C     L2 PTS TO IT IN LAT
        K1 = 0
        L2 = IE + SYMLEN - 2
   80   L2 = LAT(L2+3)
        K1 = K1 + 1
        IF (K1.LT.K) GO TO 80
        IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150
        IF (PLAT+2.GT.LLAT) GO TO 180
        LAT(PLAT) = L1
        LAT(PLAT+1) = LAT(L2+2)
        LAT(L2+2) = PLAT
        PLAT = PLAT + 2
        GO TO 150
C     CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE
C     LAT(N) PTS TO DUMMY ARG ENTRY IN LAT
C     REF(L) PTS TO CORRESP REF ARG IN DSA
   90   IF (IGATT1(REF(L),4).EQ.1) GO TO 110
C     REFERENCE CONTAINS AN AACTUAL PROC NAME
C     CHECK FOR MISSING SUBPROGRAM
        L3 = REF(L)
        L2 = FINDND(DSA(L3+4),L3)
        IF (L2.NE.0) GO TO 100
        L3 = REF(L) + 4
      CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        GO TO 150
C     CALL CHK3 TO PREFORM CHECKS
  100   L5 = L2 + SYMLEN + 6
      CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER)
        GO TO 150
C     REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS
C     WHICH CAN CORRESPOND TO THAT DUMMY
C     FIRST FIND ITS CORRESP ACTUAL, IF ANY
  110   L2 = REF(L)
        L2 = DSA(L2+2)
C      L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR)
C      OF THE DUMMY ARG AT REF(L)
        L3 = IR + SYMLEN + 1
        L3 = LAT(L3)
        IF (L2.EQ.1) GO TO 130
        DO 120 L4=2,L2
          L3 = LAT(L3+3)
  120   CONTINUE
C     L3 PTS TO DUMMY ARG IN CALLING RTNE
  130   L3 = LAT(L3+1)
C     L3 CONTAINS OFFSET FOR PROC ACTUALS
C     MATCHED TO THIS DUMMY ARG
C     IN TEMPLATED OFF LAT(IR)
        L2 = IR + SYMLEN + 5
        IF (LAT(L2).NE.0) GO TO 140
        L3 = REF(L) + 4
        CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35,
     *  DSA(L3), 1, 1, 0)
      CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        GO TO 150
C      L2 PTS TO ACTUALS TEMPLATE
  140   L2 = LAT(L2)
        L4 = L2 + L3
C      LAT(L4) IS ACTUAL PAIRED TO REF(L)
        L5 = LAT(L4) + SYMLEN + 6
      CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER)
C     CYCLE TO NEXT ACTUAL
        L2 = LAT(L2) + L2
        IF (LAT(L2)) 150, 150, 140
  150   L = L + 2
        N = LAT(N) + 3
  160 CONTINUE
  170 RETURN
  180 SYSERR = .TRUE.
      CHK2 = 0
      CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31)
      GO TO 170
      END
      INTEGER FUNCTION FIND(K)
C
C      FIND HAS TO FIND THE INDEX IN NODE
C      OF THE LATTICE ENTRY AT K, DOES A
C     LINEAR SEARCH ON NODE ARRAY
C      P.U. ASSUMES NODE ARRAY SET UP PROPERLY
C      AND THAT NODES ITS ASKED TO FIND ARE ALWAYS IN THE
C      ARRAY SOMEWHERE. CAN BE ASKED TO FIND INDEX OF
C      ANY NODE IN LATTICE, EVEN ASFS
C
      INTEGER PNODE
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      L = PNODE - 1
      DO 10 I=1,L
        IF (K.NE.IABS(NODE(I))) GO TO 10
        FIND = I
        GO TO 20
   10 CONTINUE
   20 RETURN
      END
      SUBROUTINE ASLEV(IPT)
C
C      ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT)))
C      AND READJUSTS THE LEVELS IN THE SUBLATTICE
C      IN ACCORDANCE WITH NEW LEVEL AT ROOT
C     NOTE, IPT LT 0 FROM CALL IN SETREF  (EXT) AND FROM ACTUALS
C     PASSED DOWN IN PROC
C
      INTEGER PNODE, STACK, PLAT, FIND, SYMLEN
      INTEGER ZERO(1)
      LOGICAL SYSERR, ERR, ABORT, GR
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /SCR2/ LSTACK, STACK(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      DATA ZERO(1) /0/
C
C     STACK (IS) IS SIGNED NODE INDEX OF SUBPGM
C     IF GT 0, NODE IS ALONG A RED LINK TO PARENT
C     IF LT 0, NODE IS ALONG  A GREEN LINK TO PARENT
C
C     STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS
C     SUBPGM, OR 0 FOR END OF DESC LIST
C
      K = IABS (IPT )
      K = SYMLEN + NODE(K) + 4
      STACK(2) = IPT
      STACK (1) = IABS ( LAT(K) )
      IS = 2
C      DOES TOP OF STACK ENTRY HAVE UNVISITED DESC
   10 IF (STACK(IS-1).NE.0) GO TO 20
C      TEST IF ARE DONE WITH SUBLATTICE
      IF (IS.EQ.2) RETURN
C      POP UP A LEVEL IN PATH
      IS = IS - 2
      GO TO 10
C      UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK
   20 K = STACK(IS-1)
      STACK(IS-1) = IABS (LAT(K+1))
C     LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED
C     SIGN INDICATES COLOR OF LINK TO PARENT, (I.E.
C     NODE AT TOP OF STACK)
C     LT 0 IS GREEN LINK, GT 0 IS RED LINK
C     L IS INDEX IN NODE(*) OF DESC BEING PROCESSED
C     KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED
      LL = 1
      IF( LAT(K) .LT. 0) LL = -1
      KK = IABS(LAT(K))
      L = FIND(KK)
C     SKIP ALL DESC WITH NEGATIVE LEVELS
      IF (INODE(L).LT.0) GO TO 10
C     SEE IF STACK TOO SHORT FOR LOOPS
      IF( IS.LE.2) GOTO 40
C     CHECK FOR LOOPS IN PATH STACK DESC
      LOOP = 0
      GR = .FALSE.
      IF(LL.EQ.(-1)) GR = .TRUE.
      DO 60 I = 2,IS,2
      IF(LOOP) 70,70,90
   90 IF(STACK(I).LT.0) GR = .TRUE.
      GOTO 60
 70   IF(L.EQ.IABS(STACK(I))) LOOP = I
 60   CONTINUE
C      NO LOOPS
      IF(LOOP.EQ.0) GOTO 40
C     LOOP OF MIXED COLORED LINKS
C     DO NOT STACK DESC
      IF(GR) GOTO 10
C     RECURSION
      ABORT = .TRUE.
      CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0)
      DO 80 K=LOOP,IS,2
      KK = IABS(STACK(K))
      KK = NODE(KK)
 80   CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0)
      CALL ERROR2(1H1, 0, ZERO, -3, 0, 1)
   30 RETURN
C      TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR
C      THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC
   40 K = IABS (STACK(IS))
      IF (INODE(L).GT.INODE(K)) GO TO 10
C      PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL
      INODE(L) = INODE(K) + 1
C      TEST AGAINST LNODE BECAUSE  SCRATCH ARRAY
C      IS AS LONG AS NODE ARRAY
      IF (IS+2.GT.LNODE) GO TO 50
      STACK(IS+2) = LL * L
      K = NODE(L) + SYMLEN + 4
      STACK(IS+1) = IABS( LAT(K))
      IS = IS + 2
      GO TO 10
   50 SYSERR = .TRUE.
      CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43)
      GO TO 30
      END
      SUBROUTINE INVOKE
C
C      PGM UNIT STEPS THROUGH NODES IN INVOCATION ORDER
C      PUSHING ACTUAL PROC ARGS DOWN LATTICE WHERE NECESSARY
C      AND READJUSTING LEVEL IF NECESSARY
C
      INTEGER PNODE, PLAT, PDSA, DSA, SYMLEN, PREF, REF, FIND, CHK1,
     *  ZERO(1), FINDND
      LOGICAL ERR, SYSERR, ABORT, OK, AOK
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /FACTS/ NAME, NOST, ITYPE, IASF
      DATA ZERO(1)/0/
C      NC IS CURRENT NODE, NP IS PREVIOUS NODE PROCESSED
      NC = 0
   10 NP = NC
      OK = .TRUE.
      AOK = .TRUE.
C
C      SEARCH FOR NEXT NODE TO DO, NODE WITH LOWEST POSIT LEVEL IN INODE
C      UPON ENTRY TO INVOKE, SUPEROOT IS -1, ASFS AND BLOCK DATA
C      ARE -2. IF CANT FIND A POSITIVE LEVEL ARE DONE
C
      L = PNODE - 1
      DO 20 I=1,L
        IF (INODE(I).LT.0) GO TO 20
        NC = I
        GO TO 40
   20 CONTINUE
   30 RETURN
   40 J = NC
      DO 50 I=J,L
        IF (INODE(I).GE.0 .AND. INODE(I).LT.INODE(NC)) NC = I
   50 CONTINUE
C      READ IN SYMBOL TABLE FOR NODE(NC) AND POSITION REFS CORRECTLY
      CALL RDSYM(NC, NP)
   60 IF (INREF(I6)) 140, 140, 70
C      HAVE A REFERENCE TO PROCESS
   70 IF (IGATT1(REF(2),4).EQ.1) GO TO 80
C      PROCESSING A DIRECT REFERENCE
C      NEED ONLY PROCESS REF TEMPLATE IF ANY PROC ACTUAL ARGS IN REF
      L = REF(2)
      L = FINDND(DSA(L+4),K)
      CALL PROC(NODE(NC), L, K, AOK)
      IF (SYSERR .OR. ABORT) GO TO 30
      GO TO 60
C      PROCESSING AN INDIRECT REF
   80 K = NODE(NC) + SYMLEN + 5
      K = LAT(K)
      IF (K.EQ.0) GO TO 150
C      K PTS TO A TEMPLATE OF ACTUALS AT LAT(NODE(NC))
C      L GIVES REL POSIT AMONG PROC DUMMIES IN LAT(NODE(NC))
C      OF PROC DUMMY BEING CALLED
      L = REF(2)
      L = DSA(L+2)
      I = NODE(NC) + SYMLEN + 1
      I = LAT(I)
      IF (L.EQ.1) GO TO 100
      DO 90 M=2,L
        I = LAT(I+3)
   90 CONTINUE
C
C      I PTS TO DUMMY PROC ARG ENTRY IN LAT
C
  100 M = LAT(I+1) + K
      M = LAT(M)
C      M PTS TO ACTUAL SUBSTITUTABLE FOR I
      L = FIND(M)
C      RECURSION DUE TO INDIRECT REF COMPLETING THE LOOP
      IF (-1.NE.INODE(L)) GO TO 110
      ABORT = .TRUE.
      CALL ERROR2(26H RECURSIVE LOOP INVOLVING , 26, DSA(NAME+4), 1,1,0)
      CALL ERROR2(14H AND POSSIBLY , 14, LAT(M), 1, 0, 1)
      GO TO 30
C      NOTE NEED NOT WORRY ABOUT MISSING SUBPGM SINCE
C      THEN ITS LAT INDEX COULDNOT BE IN TEMPLATE
  110 IF (CHK1(NODE(NC),M).EQ.0) GO TO 130
C      PROCESSED A LEGAL INDIRET REF
      CALL SETPD(M, NODE(NC))
      IF (SYSERR) GO TO 30
      IF (-2.EQ.INODE(L) .OR. INODE(NC).LT.INODE(L)) GO TO 120
      INODE(L) = INODE(NC) + 1
      CALL ASLEV(L)
      IF (ABORT .OR. SYSERR) GO TO 30
C      LOOK FOR MORE ACTUALS
 120  CALL PROC(NODE(NC), M, L, AOK)
      IF (SYSERR .OR. ABORT) GO TO 30
  130 K = LAT(K) + K
      K = LAT(K)
      IF (K) 60, 60, 100
C      MARK CURRENT NODE DONE
  140 INODE(NC) = -1
      GO TO 10
  150 IF (.NOT.OK) GO TO 60
      K = NODE(NC)
      CALL ERROR2(20H NO ACTUAL PROCS IN ,20, LAT(K), 1, 1, 0)
      CALL ERROR2(28H CANNOT PROCESS FORMAL REFS , 28,
     *  ZERO, -3, 0, 1)
      OK = .FALSE.
      GO TO 60
      END
      SUBROUTINE RDSYM(IC, IP)
C
C      PGM UNIT RDSYM POSITIONS I4,I6 CORRECTLY AND INPUTS SYMBOL
C      TABLE OF PGM UNIT AT NODE(IC) WHEN LAST ONE READ WAS THAT OF NODE
C
      INTEGER SYMLEN, PDSA, PLAT, FINDND, PNODE, DSA
      LOGICAL INSYM, L
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      IF (IP.LT.IC) GO TO 10
      REWIND I4
      REWIND I6
 10   L = INSYM(I6,0)
      IF (FINDND(DSA(NAME+4),I).EQ.NODE(IC)) RETURN
   20 IF (INREF(I6).EQ.1) GO TO 20
      GO TO 10
      END
      SUBROUTINE PROC(IP, IM, IIM, OK)
C
C      P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM))
C      PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN
C      CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT
C      AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS
C      SENT TO LAT(IM) VS LEVEL (IM)
C
      LOGICAL ERR, SYSERR, ABORT, OK
      INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND,
     *    FIND, SS(120), KBR(1)
      COMMON /CEXPRS/ LSTACK, STACK(620)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /HEAD/ LNODE, PNODE, NODE(500)
      COMMON /SCR1/ LINODE, INODE(500)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      EQUIVALENCE (SS(1),STACK(501))
      DATA KBR(1) /0/
      LSS = 501
C      ARE THERE ARGS IN THIS REF
      IF (REF(1).NE.0) GO TO 20
   10 RETURN
C      CYCLE THROUGH REF ARGS
C      JJ IS LAST ENTRY IN REF FOR ARGS
C      IS PTS TO FIRST FREE WD IN STACK
C      MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE
C      NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS
   20 JJ = REF(1) + 4
      IS = 1
      MAX = 0
      DO 90 I=5,JJ,2
C      SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS
        IF (REF(I).EQ.0) GO TO 90
        IF (REF(I+1).NE.6) GO TO 90
C      SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP)
C      OR ACTUAL PROCEDURE
        IF (IGATT1(REF(I),4).EQ.1) GO TO 40
C      HAVE AN ACTUAL PROCEDURE
        L = REF(I)
        L = FINDND(DSA(L+4),K)
        IF (L.NE.0) GO TO 30
C      IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS
C      PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES
      L = REF(I)
      CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0)
      CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
        GO TO 10
   30   IF (IS+2.GT.LSS) GO TO 200
C      2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG
C      IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC
        STACK(IS) = 1
        STACK(IS+1) = L
        IF (MAX.EQ.0) MAX = 1
        IS = IS + 2
        GO TO 90
C      HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS
C      MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP
   40   L = IP + SYMLEN + 5
        L = LAT(L)
        IF (L.NE.0) GO TO 50
      IF (.NOT.OK) GOTO 10
      CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1)
      OK = .FALSE.
        GO TO 10
C      COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG
C      K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP)
C      L PTS TO TEMPLATE AT LAT(IP)
   50   K = REF(I)
        K = DSA(K+2)
C     J POINTS TO FIRST ELEMENT ON ARGLIST
        J = IP + SYMLEN + 1
        J = LAT(J)
        IF (K.LE.1) GO TO 70
        DO 60 LL=2,K
          J = LAT(J+3)
   60   CONTINUE
C      K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP)
C      THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL
C      PROCS OFF TEMPLATES AT LAT(IP)
C     J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP)
   70   K = LAT(J+1)
        IF (IS+1.GE.LSS) GO TO 200
C      J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY
C      ACTUALS ARE MATCHED TO THIS DUMMY
        J = IS
        STACK(IS) = 0
        IS = IS + 1
   80   IF (IS+1.GE.LSS) GO TO 200
C      N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF
C      WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY
C      WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC
        STACK(J) = STACK(J) + 1
        LL = K + L
        STACK(IS) = LAT(LL)
        IS = IS + 1
        L = LAT(L) + L
        L = LAT(L)
        IF (L.NE.0) GO TO 80
        IF (STACK(J).GT.MAX) MAX = STACK(J)
   90 CONTINUE
C      HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC
C      ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM
C      THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS
C      ARE NOT THERE ALREADY
C      BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION
C      IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS
C      PASSED DOWN VS LEVEL OF LAT(IM)
      IF (MAX.EQ.0) GO TO 10
      DO 190 I=1,MAX
C      CREATE PROC INDICES PORTION OF TEMPLATE IN SS
        K = 1
        ISS = 1
  100   IF (K.GE.IS) GO TO 110
        L = 1
        IF (STACK(K).GT.1) L = I
        IF (ISS+1.GE.120) GO TO 200
        J = K + L
        SS(ISS) = STACK(J)
        K = K + STACK(K) + 1
        ISS = ISS + 1
        GO TO 100
C      HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1)
C      SEE IF IT HAS A DUPLICATE AT LAT(IM)
  110   K = IM + SYMLEN + 5
        K = LAT(K)
        IST = ISS - 1
  120   IF (K.EQ.0) GO TO 150
        DO 130 L=1,IST
          J = K + L
          IF (LAT(J).NE.SS(L)) GO TO 140
  130   CONTINUE
C      FOUND DUPLICATE
        GO TO 190
C      HAVENT FOUND A DUPLICATE YET
C      SEE IF THERE ARE MORE TEMPLATES TO COMPARE
  140   K = LAT(K) + K
        K = LAT(K)
        GO TO 120
C      NOT A DUPLICATE WILL ADD IT ON
  150   IF (PLAT+IST+2.LE.LLAT) GO TO 160
        CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32)
        SYSERR = .TRUE.
        GO TO 10
C      MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT
C      WORDS - PROCS LAT INDICES, LAST WORD - PTR
C      TO NEXT SUCH TEMPLATE
  160   DO 170 L=1,IST
          J = PLAT + L
          LAT(J) = SS(L)
  170   CONTINUE
        LAT(PLAT) = IST + 1
        L = PLAT
        PLAT = PLAT + IST + 2
        J = IM + SYMLEN + 5
        LAT(PLAT-1) = LAT(J)
        LAT(J) = L
C      CHECK LEVELS
        DO 180 L=1,IST
          J = FIND(SS(L))
C     FIND HEAD OF GREEN LINKS LIST AT LAT(IM)
      JR = IM + SYMLEN + 3
      JLR = -SS(L)
 210  IF(LAT(JR+1) .LE. 0) GOTO 220
      JR = LAT(JR+1)
      GOTO 210
C     HAVE TOP OF GREEN LINKS LIST AT LAT(JR)
 220  IF(LAT(JR+1) .EQ. 0) GOTO 230
      JR = IABS( LAT(JR+1) )
C     LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST
      IF(LAT(JR) .EQ. JLR) GOTO 240
      GOTO 220
C     ADD ON ENTRY TO GREEN LINKS LIST
 230  IF(PLAT + 2 .GT. LLAT) GOTO 250
      LAT(PLAT) = JLR
      LAT(PLAT+1) = 0
      LAT(JR+1) = -PLAT
      PLAT = PLAT+2
 240  IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR.
     *  INODE(J).GT.INODE(IIM)) GOTO 180
          INODE(J) = INODE(IIM) + 1
      CALL ASLEV (-J)
          IF (SYSERR .OR. ABORT) GO TO 10
  180   CONTINUE
  190 CONTINUE
      GO TO 10
  200 SYSERR = .TRUE.
      CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33)
      GO TO 10
 250  SYSERR = .TRUE.
      CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31)
      GOTO 10
      END
      SUBROUTINE CHKALL
C
C      CHKALL READS IN REFS FROM OUTUT4 AND CHECKS THEM
C      EXPANDS ALL INDIRECTS AND CHECKS THEM, IF ALL OK
C      WRITES THE EXPANDED VERSION OUT ON OUTUT3
C     TEMPLATE WRITTEN OUT CONSISTS OF
C     PREF - NO OF WORDS TO FOLLOW
C     IBR - CODE .LT.3 TO SHOW OK REF
C     REF(1) - 2*NO OF ARGS
C     IJR - LAT INDEX OF CALLED P.U.
C     REF(3) - STMT NO OF REF
C     REF(4) - CODE 0-SUBR, 1-FCN
C     REF(5 -) - ARG ENTRIES
C      FOR DIRECT REFS  IF OK WRITES THE DIRECT REF OUT ON OUTUT3
C      CHKALL WRITES END OF REFS ON OUTUT3 BEFORE RETURNING
C
      INTEGER OUTUT3, OUTUT4, DSA, PDSA, REF, PREF, PLAT, SYMLEN, FINDND
      INTEGER CHK1, CHK2
      LOGICAL ERR, SYSERR, ABORT, QP2, QBR
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, OUTUT3, OUTUT4
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CREF/ LREF, PREF, REF(100)
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /PASS/ QP2, QBR
      DATA IBR /1/, JBR /3/
C      IJK IS CALLING PGM UNIT; IJR IS PGM UNIT CALLED
      IJK = FINDND(DSA(NAME+4),L1)
   10 IF (INREF(OUTUT4)) 20, 20, 30
C      WRITE END OF REFS AND RETURN
   20 WRITE (OUTUT3) IBR, JBR, IBR
      QBR = .FALSE.
      RETURN
C      CHECK IF REF INDIRECT OR DIRECT
   30 IF (IGATT1(REF(2),4).EQ.1) GO TO 40
C      HAVE A DIRECT REF
      IJR = REF(2)
      IJR = FINDND(DSA(IJR+4),L1)
      IBAR = CHK2(IJK,IJR)
      IF (SYSERR) GO TO 20
      IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
     *    (REF(L),L=3,PREF)
      GO TO 10
C      HAVE AN INDIRECT REF
   40 K = IJK + SYMLEN + 5
      K = LAT(K)
C      NOTE HAVE FLAGGED THIS ERROR OF NO ACTUALS AT LAT(IM)
C      BEFORE IN PROC SO NOW SKIP OVER REF
      IF (K.EQ.0) GO TO 10
C      K POINTS TO ACTUALS TEMPLATE AT CALLING PGM
      L = REF(2)
      L = DSA(L+2)
      J = IJK + SYMLEN + 1
      J = LAT(J)
      IF (L.LE.1) GO TO 60
      DO 50 LL=2,L
        J = LAT(J+3)
   50 CONTINUE
   60 L = LAT(J+1)
C      L IS OFFSET IN ACTUALS TEMPLATE OF ACTUALS
C      CORRESP TO THIS DUMMY
   70 J = K + L
      IJR = LAT(J)
      QBR = .TRUE.
      IF (CHK1(IJK,IJR).NE.1) GO TO 80
      IBAR = CHK2(IJK,IJR)
      IF (SYSERR) GO TO 20
      IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
     *    (REF(L),L=3,PREF)
   80 QBR = .FALSE.
      K = LAT(K) + K
      K = LAT(K)
      IF (K) 10, 10, 70
      END
      SUBROUTINE CHK3(IDUM, IACT, IDUM8, IACT8, IE, R, NO)
C
C     CHECKS PROC ARGUMENTS FOR PROPER USAGE AND TYPE
C     IDUM LAT INDEX DUMY PROC ARG
C     IACT LAT INDEX ACTUAL PROC
C     IDUM8 USAGE DUMMY FROM DSA ATTRIBUTES
C     IACT8 USAGE ACTUAL FROM LAT ENTRY
C     IE CALLED RTNE
C     R STMT NO OF CALL
C     NO CONTAINS THE NUMBER OF PARAMETER BEING CHECKED BY THIS CALL
C
      INTEGER PLAT, R(1), SYMLEN, NO(1)
      COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
      COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C     SEPARATE OUT EXTERNAL ENTITIES
      IF (IDUM8.NE.13) GO TO 20
      L = IGATT2(IDUM,1)/8
      IF (L.NE.1) GO TO 50
C     FURTHER CHECK THAT EPLICITLY TYPED EXTERNAL ENTITIES
C     MATCH FCNS
      IF (IACT8.NE.1 .AND. IACT8.NE.6) GO TO 30
C     CHECK FCN HAS SAME TYPE ACROSS REF BNDRY
   10 L = IACT + SYMLEN + 6
      IF (MOD(IGATT2(IDUM,1),8).EQ.LAT(L)/8) GO TO 50
      CALL ERROR2(40H INCONSISTENT FCN TYPES IN REFERENCE TO , 40,
     *  LAT(IE), 1, 1, 0)
      CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
      GO TO 50
C     CHECK SUBROUTINES
   20 IF (IDUM8.EQ.6 .AND. IACT8.EQ.0) GO TO 50
C     CHECK OUT FCNS
      IF (IDUM8.EQ.5 .AND. IACT8.EQ.1) GO TO 10
C     SEPARATE OUT BASIC EXTERNALS BECAUSE THEY ARE CONSIDERED
C     TYPED BY THE FORTRAN.
      IF (IDUM8.EQ.5 .AND. IACT8.EQ.6) GO TO 40
   30 CALL ERROR2(
     *  50H INCOMPATIBLE PROCEDURE PARAMETER ASSOCIATED WITH ,50,
     *  NO, -2, 1, 0)
      CALL ERROR2(17H IN REFERENCE TO ,17, LAT(IE), 1, 0, 0)
      CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
      GO TO 50
C     CHECK BASIC EXTER HAS NOT BEEN EXPLICITLY TYPED
C     OR ELSE IT HAS TO AGREE WITH THE ACTUAL TYPE
   40 L = IACT + SYMLEN + 6
      IF (LAT(L)/8.EQ.1) GO TO 10
   50 RETURN
      END
	subroutine s5pack(a,b,n)
c	integers a(1), a(2), ...a(n) contain characters in a1 format.
c	the first byte of each integer contains the character
c	the three remaining bytes are blank. note that the calling program
c	expects a and b to be integer arrays, but we treat a and b
c	internally as character arrays with the correspondence
c	character a(4*i+1;4*i+1)=first byte of integer a(i+1)
c	s5pack(a,b,n) packs these characters into
c	elements of the integer array b in a4 format using only as many
c	elements of b as necessary.
c	The last element of b used must be padded
c	with trailing blanks. Unused elements of b are not affected.
	character *480 a
	character b
	integer n,i,k
c	write(6,1000)
c1000	format("entered s5pack")
	do 1 i=0,n-1
	b(i+1:i+1) = a(4*i+1:4*i+1)
1	continue
	k = mod(n,4)
	if(k.gt.0) then
	do 2 i=n+1,n+4-k
	b(i:i) = ' '
2	continue
	end if
c	write(6,2000)
c2000	format("leaving s5pak")
	return
	end
	subroutine s5unpk(a,b,n)
c	a(1), a(2), ... contain characters in a4 format
c	s5unpk unpacks the first n characters
c	and places them into b(1), b(2), ... b(n)
c	in a1 format.(Caller thinks a and b are integer arrays)
c	Each element of b must be padded with trailing blanks.
c	Unused elements of b are unaffected.
	integer i,n
	character *120 a
	character *480 b
	blank = 32
c	write(6,3000)
c3000	format("entering unpakc")
	do 1 i=0,n-1
	b(4*i+1:4*i+1) = a(i+1:i+1)
	b(4*i+2:4*i+2) = ' '
	b(4*i+3:4*i+3) = ' '
	b(4*i+4:4*i+4) = ' '
1	continue
400	format( a4)
c	write(6,4000)
c4000	format("leaving unpk")
	return
	end
