@HDG,P EXCHMAIN/1100
@FTN,SVI EXCHMAIN/1100
C     UNIVAC 1100 MAIN PROGRAM FOR TEXT EXCHANGE PROGRAMS.
C
C     THE FOLLOWING STATEMENT ALLOCATES SPACE FOR TAPE INPUT.
C
      INTEGER IBLOCK(1600)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER XLATE(128)
C     PFS ARE PROGRAM FILE SEARCH PACKETS FOR INTAPE AND OUTAPE
C     IF OMN ELEMENTS ON DISK ARE USED (COMPREHENSIVE PROGRAM ONLY).
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXCHXC/ XLATE
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
      DATA ELTS(1,6) /O050505050505/    @ FIELDATA BLANKS FOR INTAPE ELT
      DATA PFS(11,1) /0/ @ INTAPE SECTOR POSITION (FOR SIMPLE PROGRAM)
      DATA NWCBI /40/
      DATA PRINTR /6/, READER /5/
C
      CALL EXCH (IBLOCK)
      CALL EXIT
      END
@HDG,P EXCHBD
@FTN,SVI EXCHBD
      BLOCK DATA
C
C     BLOCK DATA FOR THE TAPE EXCHANGE PROGRAM.
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER XLATE(128)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXCHXC/ XLATE
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      DATA INTAPE /0/, OUTAPE /0/, INFILE /0/, OUFILE /0/
      DATA INTEXT /0/, INALT /0/
C
      DATA CHAR1L /1H1/
C                                                        A  U  T  H
      DATA COMD(1,1) ,COMD(2,1) ,COMD(3,1) ,COMD(4,1)  /65,85,84,72/
C                                                        C  O  M  M
      DATA COMD(1,2) ,COMD(2,2) ,COMD(3,2) ,COMD(4,2)  /67,79,77,77/
C                                                        C  O  P  Y
      DATA COMD(1,3) ,COMD(2,3) ,COMD(3,3) ,COMD(4,3)  /67,79,80,89/
C                                                        D  A  T  A
      DATA COMD(1,4) ,COMD(2,4) ,COMD(3,4) ,COMD(4,4)  /68,65,84,65/
C                                                        D  A  T  E
      DATA COMD(1,5) ,COMD(2,5) ,COMD(3,5) ,COMD(4,5)  /68,65,84,69/
C                                                        G  R  O  U
      DATA COMD(1,6) ,COMD(2,6) ,COMD(3,6) ,COMD(4,6)  /71,82,79,85/
C                                                        I  N  D  E
      DATA COMD(1,7) ,COMD(2,7) ,COMD(3,7) ,COMD(4,7)  /73,78,68,69/
C                                                        I  N  P  U
      DATA COMD(1,8), COMD(2,8), COMD(3,8), COMD(4,8)  /73,78,80,85/
C                                                        N  A  M  E
      DATA COMD(1,9), COMD(2,9), COMD(3,9), COMD(4,9)  /78,65,77,69/
C                                                        I  N  T  A
      DATA COMD(1,10),COMD(2,10),COMD(3,10),COMD(4,10) /73,78,84,65/
C                                                        K  E  Y  W
      DATA COMD(1,11),COMD(2,11),COMD(3,11),COMD(4,11) /75,69,89,87/
C                                                        L  I  M  I
      DATA COMD(1,12),COMD(2,12),COMD(3,12),COMD(4,12) /76,73,77,73/
C                                                        M  A  C  H
      DATA COMD(1,13),COMD(2,13),COMD(3,13),COMD(4,13) /77,65,67,72/
C                                                        O  P  T  I
      DATA COMD(1,14),COMD(2,14),COMD(3,14),COMD(4,14) /79,80,84,73/
C                                                        O  R  I  G
      DATA COMD(1,15),COMD(2,15),COMD(3,15),COMD(4,15) /79,82,73,71/
C                                                        O  U  T  A
      DATA COMD(1,16),COMD(2,16),COMD(3,16),COMD(4,16) /79,85,84,65/
C                                                        O  U  T  P
      DATA COMD(1,17),COMD(2,17),COMD(3,17),COMD(4,17) /79,85,84,80/
C                                                        P  R  E  D
      DATA COMD(1,18),COMD(2,18),COMD(3,18),COMD(4,18) /80,82,69,68/
C                                                        P  R  I  N
      DATA COMD(1,19),COMD(2,19),COMD(3,19),COMD(4,19) /80,82,73,78/
C                                                        Q  U  I  T
      DATA COMD(1,20),COMD(2,20),COMD(3,20),COMD(4,20) /81,85,73,84/
C                                                        R  E  A  D
      DATA COMD(1,21),COMD(2,21),COMD(3,21),COMD(4,21) /82,69,65,68/
C                                                        R  E  F  E
      DATA COMD(1,22),COMD(2,22),COMD(3,22),COMD(4,22) /82,69,70,69/
C                                                        R  E  M  O
      DATA COMD(1,23),COMD(2,23),COMD(3,23),COMD(4,23) /82,69,77,79/
C                                                        R  E  W  I
      DATA COMD(1,24),COMD(2,24),COMD(3,24),COMD(4,24) /82,69,87,73/
C                                                        S  I  T  E
      DATA COMD(1,25),COMD(2,25),COMD(3,25),COMD(4,25) /83,73,84,69/
C                                                        S  K  I  P
      DATA COMD(1,26),COMD(2,26),COMD(3,26),COMD(4,26) /83,75,73,80/
C                                                        T  E  X  T
      DATA COMD(1,27),COMD(2,27),COMD(3,27),COMD(4,27) /84,69,88,84/
C                                                        T  I  T  L
      DATA COMD(1,28),COMD(2,28),COMD(3,28),COMD(4,28) /84,73,84,76/
C                                                        U  P  D  A
      DATA COMD(1,29),COMD(2,29),COMD(3,29),COMD(4,29) /85,80,68,65/
C                                                        W  O  R  K
      DATA COMD(1,30),COMD(2,30),COMD(3,30),COMD(4,30) /87,79,82,75/
C                                                        C  O  N  T
      DATA COMD(1,31),COMD(2,31),COMD(3,31),COMD(4,31) /67,79,78,84/
C                                                        I  D  E  N
      DATA COMD(1,32),COMD(2,32),COMD(3,32),COMD(4,32) /73,68,69,78/
C                                                        I  N  C  L
      DATA COMD(1,33),COMD(2,33),COMD(3,33),COMD(4,33) /73,78,67,76/
C                                                        S  I  G  N
      DATA COMD(1,34),COMD(2,34),COMD(3,34),COMD(4,34) /83,73,71,78/
C                                                        M  A  R  G
      DATA COMD(1,35),COMD(2,35),COMD(3,35),COMD(4,35) /77,65,82,71/
      DATA IDSTEP /0/, IDTXTL /0/
      DATA INDEX /0/
      DATA INDEXS( 1),INDEXS( 2),INDEXS( 3),INDEXS( 4) /0,0,0,0/
      DATA INDEXS( 5),INDEXS( 6),INDEXS( 7),INDEXS( 8) /0,0,0,0/
      DATA INDEXS( 9),INDEXS(10),INDEXS(11),INDEXS(12) /0,0,0,0/
      DATA INDEXS(13),INDEXS(14),INDEXS(15),INDEXS(16) /0,0,0,0/
      DATA INDEXS(17),INDEXS(18),INDEXS(19),INDEXS(20) /0,0,0,0/
      DATA INDEXS(21),INDEXS(22),INDEXS(23),INDEXS(24) /0,0,0,0/
      DATA INDEXS(25),INDEXS(26)                       /0,0    /
      DATA INTOPN /0/
      DATA ITYPEI /0/
      DATA LIMIT /0/
      DATA MARGIN /180/
      DATA NCCBI /180/
      DATA NCCBO /180/
      DATA NCHCMD /0/
      DATA NCHMAX /180/
      DATA NCOMDP /35/
      DATA NCOMDT /35/
      DATA NDATAO /3591/
      DATA NERRCO /0/
      DATA NERRG /0/
      DATA NRWORK /0/
      DATA OUTOPN /0/
      DATA OPTVAL( 1),OPTVAL( 2),OPTVAL( 3),OPTVAL( 4) /0,0,0,0/
      DATA OPTVAL( 5),OPTVAL( 6),OPTVAL( 7),OPTVAL( 8) /0,0,0,0/
      DATA OPTVAL( 9),OPTVAL(10),OPTVAL(11),OPTVAL(12) /0,0,0,0/
      DATA OPTVAL(13),OPTVAL(14),OPTVAL(15),OPTVAL(16) /0,0,0,0/
      DATA OPTVAL(17),OPTVAL(18),OPTVAL(19),OPTVAL(20) /0,0,0,0/
      DATA OPTVAL(21),OPTVAL(22),OPTVAL(23),OPTVAL(24) /0,0,0,0/
      DATA OPTVAL(25),OPTVAL(26)                       /0,0    /
      DATA PHASE /1/
C     INDICATE THAT NO PREDICATES ARE DEFINED.
      DATA PRED(1,1),PRED(1,2),PRED(1,3),PRED(1,4),PRED(1,5) /0,0,0,0,0/
      DATA PRED(1,6),PRED(1,7),PRED(1,8)                     /0,0,0    /
      DATA SITE(1) /0/
      DATA TITLE(1) /32/
C     32 = ASCII BLANK
      DATA TODAY (1) /0/
      DATA TRANS /1/
C
C     TRANSLATION TABLE FROM ASCII TO HOLLERITH.  USES ASCII GRAPHICS.
C     TRANSLATES CONTROL CHARACTERS (<32) TO '$'.
C     MAY NOT BE EXACTLY CORRECT FOR ALL MACHINES.
C
      DATA XLATE(1),  XLATE(2),  XLATE(3),  XLATE(4)  /1H$,1H$,1H$,1H$/
      DATA XLATE(5),  XLATE(6),  XLATE(7),  XLATE(8)  /1H$,1H$,1H$,1H$/
      DATA XLATE(9),  XLATE(10), XLATE(11), XLATE(12) /1H$,1H$,1H$,1H$/
      DATA XLATE(13), XLATE(14), XLATE(15), XLATE(16) /1H$,1H$,1H$,1H$/
      DATA XLATE(17), XLATE(18), XLATE(19), XLATE(20) /1H$,1H$,1H$,1H$/
      DATA XLATE(21), XLATE(22), XLATE(23), XLATE(24) /1H$,1H$,1H$,1H$/
      DATA XLATE(25), XLATE(26), XLATE(27), XLATE(28) /1H$,1H$,1H$,1H$/
      DATA XLATE(29), XLATE(30), XLATE(31), XLATE(32) /1H$,1H$,1H$,1H$/
      DATA XLATE(33), XLATE(34), XLATE(35), XLATE(36) /1H ,1H!,1H",1H#/
      DATA XLATE(37), XLATE(38), XLATE(39), XLATE(40) /1H$,1H%,1H&,1H'/
      DATA XLATE(41), XLATE(42), XLATE(43), XLATE(44) /1H(,1H),1H*,1H+/
      DATA XLATE(45), XLATE(46), XLATE(47), XLATE(48) /1H,,1H-,1H.,1H//
      DATA XLATE(49), XLATE(50), XLATE(51), XLATE(52) /1H0,1H1,1H2,1H3/
      DATA XLATE(53), XLATE(54), XLATE(55), XLATE(56) /1H4,1H5,1H6,1H7/
      DATA XLATE(57), XLATE(58), XLATE(59), XLATE(60) /1H8,1H9,1H:,1H;/
      DATA XLATE(61), XLATE(62), XLATE(63), XLATE(64) /1H<,1H=,1H>,1H?/
      DATA XLATE(65), XLATE(66), XLATE(67), XLATE(68) /1H@,1HA,1HB,1HC/
      DATA XLATE(69), XLATE(70), XLATE(71), XLATE(72) /1HD,1HE,1HF,1HG/
      DATA XLATE(73), XLATE(74), XLATE(75), XLATE(76) /1HH,1HI,1HJ,1HK/
      DATA XLATE(77), XLATE(78), XLATE(79), XLATE(80) /1HL,1HM,1HN,1HO/
      DATA XLATE(81), XLATE(82), XLATE(83), XLATE(84) /1HP,1HQ,1HR,1HS/
      DATA XLATE(85), XLATE(86), XLATE(87), XLATE(88) /1HT,1HU,1HV,1HW/
      DATA XLATE(89), XLATE(90), XLATE(91), XLATE(92) /1HX,1HY,1HZ,1H[/
      DATA XLATE(93), XLATE(94), XLATE(95), XLATE(96) /1H\,1H],1H^,1H_/
      DATA XLATE(97), XLATE(98), XLATE(99), XLATE(100)/1H`,1Ha,1Hb,1Hc/
      DATA XLATE(101),XLATE(102),XLATE(103),XLATE(104)/1Hd,1He,1Hf,1Hg/
      DATA XLATE(105),XLATE(106),XLATE(107),XLATE(108)/1Hh,1Hi,1Hj,1Hk/
      DATA XLATE(109),XLATE(110),XLATE(111),XLATE(112)/1Hl,1Hm,1Hn,1Ho/
      DATA XLATE(113),XLATE(114),XLATE(115),XLATE(116)/1Hp,1Hq,1Hr,1Hs/
      DATA XLATE(117),XLATE(118),XLATE(119),XLATE(120)/1Ht,1Hu,1Hv,1Hw/
      DATA XLATE(121),XLATE(122),XLATE(123),XLATE(124)/1Hx,1Hy,1Hz,1H{/
      DATA XLATE(125),XLATE(126),XLATE(127),XLATE(128)/1H|,1H},1H~,1H$/
      END
@HDG,P EXCH/1100
@FTN,SVI EXCH/1100
      SUBROUTINE EXCH (IBLOCK)
C
C     UNIVAC 1100 INTERFACE TO COMPREHENSIVE EXCHANGE PROGRAM.
C
      INTEGER IBLOCK(1)
C
C     ALLOCATE SPACE FOR TAPE OUTPUT.
C
      INTEGER OBLOCK(800)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER XLATE(128)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXCHXC/ XLATE
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
      INTEGER AFDFLG,WORKS(474,5) @ OUTPUT CODE, WORK AREAS
      COMMON /EXEC8/ AFDFLG,WORKS
      DATA AFDFLG /1/             @ DEFAULT OUTPUT CODE = ASCII.
      DATA NWCBO /40/
      DATA WORKF  /9/
C
      CALL XHINIT
      CALL EXCHTR (IBLOCK,OBLOCK)
      RETURN
      END
@HDG,P EXCHEM/1100
@FTN,SVI EXCHEM/1100
      SUBROUTINE EXCHEM (ISTAT)
      ENTRY EXCHM2 (ISTAT,ASGSTA)
C
C     WRITE ERROR MESSAGES ASSOCIATED WITH PROGRAM FILE I/O FOR
C     UNIVAC-1100 SENSITIVE EXCHIM, EXCHOU, EXCHRT, EXCHWT.
C
C     ASGSTA IS THE ASSIGN STATUS IF A FILE COULD NOT BE ASSIGNED.
C     ASGSTA IS USED ONLY IF ISTAT = 35, WHICH IS PRODUCED ONLY BY
C     EORSRO AND EORSWO.  EXCHM2 IS THEREFORE ONLY CALLED FROM EXCHCX
C     AND EXCHOU.
C
      INTEGER ISTAT,ASGSTA
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      IF (ISTAT.GT.32) GO TO 20
      WRITE (PRINTR,10) ISTAT
10    FORMAT (//'0I/O ERROR STATUS = ',O2)
      GO TO 130
20    ISTAT=ISTAT-32
      GO TO (30,50,70,90,110), ISTAT
30    WRITE (PRINTR,40)
40    FORMAT (//'0ELEMENT NOT FOUND')
      GO TO 130
50    WRITE (PRINTR,60)
60    FORMAT (//'0EXEC I/O ERROR')
      GO TO 130
70    if (asgsta.lt.0) go to 75
      write (printr,72)
72    format (//'0File is not a program file.')
      go to 130
75    write (printr,80) asgsta
80    format (//'0File cannot be assigned, @ASG status =',o13)
      GO TO 130
90    WRITE (PRINTR,100)
100   FORMAT (//'0FILE/ELEMENT NOT OPENED')
      GO TO 130
110   WRITE (PRINTR,120)
120   FORMAT (//'0PROGRAM FILE OVERFLOW')
C
130   NERRG=MAX0(NERRG,6)
      RETURN
C
      END
@HDG,P EXCHFO/1100-FTN
@FTN,SVI EXCHFO/1100-FTN
      SUBROUTINE EXCHFO (IOP)
C
C     OPEN AND CLOSE FILES FOR UNIVAC 1100 FTN VERSION OF EXCHANGE
C     PROGRAM.
C
C     IOP LESS THAN ZERO MEANS CLOSE FILE, IOP GREATER THAN ZERO MEANS
C     OPEN FILE.  IABS(IOP) = 1 MEANS READER, = 2 MEANS PRINTER, = 3
C     MEANS WORK FILE, = 4 MEANS INFILE.  IOP = 4 IS USED ONLY BY THE
C     BOOTSTRAP PROGRAM.
C
      INTEGER IOP
C
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
C
      IF (IOP.EQ.2) THEN
        IF (PRINTR.NE.6) OPEN (UNIT=PRINTR,TYPE='APRNTA')
      END IF
      RETURN
C
      END
@HDG,P EXCHIM/1100
@FTN,SVI EXCHIM/1100
      SUBROUTINE EXCHIM
C
C     READ A COMMAND OR TEXT IMAGE FROM  1.  ALTERNATE FILE
C                                        2.  TEXT FILE
C                                        3.  INPUT FILE
C                                        4.  SYSTEM READER.
C     PUT THE HOLLERITH COMMAND IN HOLCMD,
C     PUT THE ASCII EQUIVALENT IN COMAND,
C     PUT THE NUMBER OF CHARACTERS IN NCHCMD.
C     IF A SYSTEM END-OF-FILE IS SENSED, SET NCHCMD=-1.
C
C     UNIVAC-1100 VERSION.
C     FIELDATA OR ASCII FILES OR ELEMENTS MAY BE READ.
C
      INTEGER EXCH8I
      INTEGER AFDFLG,WORKS(474,5)      @ OUTPUT CODE, WORK AREAS
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
      COMMON /EXEC8/ AFDFLG,WORKS
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
C
      DATA WORKS(1,1) /0/
      DATA WORKS(6,1),WORKS(6,2),WORKS(6,3),WORKS(6,4) /0,0,0,0/
      DATA WORKS(10,1),WORKS(10,2),WORKS(10,3),WORKS(10,4) /0,0,0,0/
C
C     DECIDE WHAT TO DO.
C
      IF (ACTION.EQ.1) GO TO 100     @ FILES OPENED BY EXCHCX
C
C     DECIDE WHICH FILE TO READ.
C     VALUES OF J ARE DETERMINED BY ARGUMENT OF EXCHCX.
C
      J=4
      IF (INALT.GT.0) GO TO 10
      J=3
      IF (INTEXT.NE.0) GO TO 10
      J=2
      IF (INFILE.NE.0) GO TO 10
      J=1
10    IF (ACTION.NE.0) GO TO 30
      N1=EXCH8I(WORKS(1,J))
      IF (N1.EQ.0) GO TO 100
      CALL EXCHEM (N1)
      WRITE (PRINTR,20)
20    FORMAT (' WHILE READING INPUT.  EOF SIMULATED.')
      GO TO 90
C
C     CLOSE AN INPUT FILE.
C
30    CALL EORSRC (WORKS(1,J))
      IF (ACTION.NE.2) GO TO 100     @ EXIT IF NOT REOPENING INCLUDE
C
C     RE-OPEN INPUT FILE, IGNORE THE STATUS.
C
      CALL EORSRO (WORKS(1,J),ELTS(1,J),VERS(1,J))
      GO TO 100
C
C     END OF FILE ON INPUT.
C
90    NCHCMD=-1
C
100   ACTION=0
      RETURN
C
      END
@HDG,P EXCHOU/1100
@FTN,SVI EXCHOU/1100
      SUBROUTINE EXCHOU (OUTPUT)
C
C     NATIVE FORMAT OUTPUT SUBPROGRAM FOR THE EXCHANGE PROGRAM.
C     THIS MODULE IS FOR THE UNIVAC 1100 SERIES OF COMPUTERS.
C     IT EXAMINES THE SYSTEM DEPENDENT INFORMATION AFTER THE UNIT
C     NUMBER ON THE 'OUTP=...' COMMAND.  IF THERE IS NO SUCH INFORMATION
C     THE OUTPUT FILE IS REWOUND.  IF THE FIRST CHARACTER IS + OUTPUT
C     CONTINUES FROM THE CURRENT POSITION (THE UNIT NUMBER MUST NOT
C     CHANGE FROM ITS PREVIOUS VALUE, BUT THIS CANNOT BE CHECKED HERE).
C     OTHERWISE THE INFORMATION IS TREATED AS AN ELEMENT/VERSION
C     SPECIFICATION.  IF AN ERROR OCCURS WHILE OPENING THE ELEMENT
C     THE FILE WILL BE REWOUND.
C
C     OUTPUT IS THE RECORD (IN ASCII) TO BE WRITTEN.
C     THE NUMBER OF CHARACTERS TO BE WRITTEN IS IN NCHOUT.
C
C     THE NEW SEQUENCE NUMBER OF THE IMAGE IS IN OUTPUT(180),
C     THE ORIGINAL SEQUENCE NUMBER IS IN OUTPUT(179).  IF OUTPUT(180)
C     IS LESS THAN ONE, THE IMAGE IS A CONTROL IMAGE.  IF OUTPUT(180)
C     IS GREATER THAN ZERO AND OUTPUT(179) IS ZERO, THE IMAGE IS A NEW
C     IMAGE.
C
      INTEGER OUTPUT(1)
      INTEGER EORSWO,EORSWW,EORSWC,EXCH8O
      INTEGER SDFF /O503011131350/     @ '*SDFF*' IN FD.
      INTEGER LABEL /O500130000000/    @ SDF LABEL ICW.
      INTEGER PLUS /1H+/
      INTEGER FDBLNK /O050505050505/   @ FIELDATA BLANK
      INTEGER BIT28 /O002000000000/    @ USED TO SET ASCII/FD BIT
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER AFDFLG,WORKS(474,5)
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXEC8/ AFDFLG,WORKS
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     DECIDE WHETHER TO OPEN, CLOSE OR WRITE.
C
      IF (IABS(ACTION).EQ.2) GO TO 140
C     IABS(ACTION)=2 MEANS START OR END OF PROGRAM.
      IF (ACTION) 40,10,60
C
C     WRITE.
C
10    ISTAT=EXCH8O(OUTPUT)
      IF (ISTAT.EQ.0) GO TO 140
      CALL EXCHEM (ISTAT)
      WRITE (PRINTR,30)
30    FORMAT (' WHILE WRITING OUTPUT FILE.')
      GO TO 140
C
C     CLOSE.
C
40    IF (WORKS(1,5).EQ.0) GO TO 140      @ PUNCH FILE.
      ISTAT=EORSWC(WORKS(1,5),5,0,1)
      IF (ISTAT.EQ.0) GO TO 140
      CALL EXCHEM (ISTAT)
      WRITE (PRINTR,50)
50    FORMAT (' WHILE CLOSING OUTPUT FILE.')
      GO TO 140
C
C     OPEN.
C
60    WORKS(1,5)=0                     @ SETUP FOR PUNCH FILE OUTPUT.
      IF (NTABDC(OUFILE).GE.32) GO TO 140   @ JUMP IF PUNCH FILE.
C     USE FIFTH ELEMENT OF FILES, ELTS, VERS.  SEE EXCHCX.
      WORKS(1,5)=FILES(1,5)
      WORKS(2,5)=FILES(2,5)
      IF (EQUAL.EQ.0.OR.EQUAL.GT.NCHCMD) GO TO 90
      IF (HOLCMD(EQUAL).NE.PLUS) GO TO 70
      ELTS(1,5)=WORKS(6,5)             @ GET CURRENT DISK ADDRESS
      GO TO 100
C
C     OPEN AN ELEMENT TO WRITE.
C
70    IF (ELTS(1,5).NE.FDBLNK) GO TO 110
      WRITE (PRINTR,80) (HOLCMD(I),I=1,NCHCMD)
80    FORMAT (//'0IMPROPER ELEMENT NAME, OPEN FILE'/(1X,80A1))
      NERRG=MAX0(NERRG,5)
90    ELTS(1,5)=0
100   ELTS(2,5)=0
110   ISTAT=EORSWO(WORKS(1,5),ELTS(1,5),VERS(1,5))
      IF (ISTAT.NE.0) GO TO 120
C     SET ASCII FLAG.
      WORKS(468,5)=AND(WORKS(468,5),COMPL(BIT28))+AFDFLG*BIT28
      ISTAT=EORSWW(WORKS(1,5),SDFF,LABEL+AFDFLG)
      IF (ISTAT.EQ.0) GO TO 140
c     We can get away with using works(3,5) here because EORSWW does
c     not set ISTAT = 35.
120   call exchm2 (istat,works(3,5))
      WRITE (PRINTR,130) (HOLCMD(I),I=1,NCHCMD)
130   FORMAT (' WHILE OPENING OUTPUT FILE.'/(1X,80A1))
C
C     RETURN
C
140   ACTION=0
      RETURN
C
      END
@HDG,P EXCHRT/1100
@FTN,SVI EXCHRT/1100
      SUBROUTINE EXCHRT (ISTAT,DBLOCK)
C
C     UNIVAC 1100.
C
C     READ A BLOCK FROM, OR REWIND, THE EXCHANGE TAPE.
C     INPUT:
C     ISTAT = 1 MEANS OPEN WITH NO REWIND.
C     ISTAT = 2 MEANS REWIND (CLOSE WITH REWIND).
C     ISTAT = 3 MEANS READ.
C     ISTAT = 4 MEANS CLOSE WITH NO REWIND.
C
C     OUTPUT:
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR WAS DETECTED.
C
C     DBLOCK IS THE RAW DATA BLOCK (EXACTLY AS IT COMES FROM THE TAPE).
C
      INTEGER DBLOCK(1)
C
      INTEGER EXCHIO,EXCHFN
      INTEGER FDBLNK /O050505050505/   @ FIELDATA BLANK
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      I=ISTAT
      ISTAT=0
      GO TO (10,60,30,110), I
C
C     OPEN INTAPE.  CONVERT UNIT NUMBER TO FD (FOR SIMPLE PROGRAM).
C
10    FILES(1,6)=EXCHFN(INTAPE)
      FILES(2,6)=FDBLNK
      PFS(10,1)=PFS(11,1)
      GO TO 110
C
C     READ A BLOCK.
C
30    I=0
40    NWORDS=2*((NDATAI+NERRCI+9+8)/9) @ NUMBER OF WORDS EXPECTED
      L=EXCHIO (FILES(1,6),16,NWORDS,DBLOCK,PFS(11,1))
      IF (L.GT.0) GO TO 50
C     ALLOW ONE END OF FILE IF TRYING TO READ LABEL.
      IF (BLKSQI.NE.0) GO TO 90
      IF (I.NE.0) GO TO 80
      IF (L.NE.-1) GO TO 90
      I=1
      GO TO 40
50    NCDBI=MIN0(NDATAI+NERRCI+9,9*L/2)
      PFS(11,1)=PFS(11,1)+(L+27)/28            @ UPDATE SECTOR ADDRESS
      GO TO 110
C
C     REWIND.
C
60    L=EXCHIO (FILES(1,6),32,NWORDS,DBLOCK,PFS(11,1))
C     IGNORE THE STATUS.
      PFS(11,1)=PFS(10,1)
      GO TO 110
C
C     I/O ERROR.
C
80    L=-1
90    L=-L
      CALL EXCHEM (L)
      WRITE (PRINTR,100) L
100   FORMAT (' WHILE READING INTAPE.')
      ISTAT=3
110   RETURN
C
      END
@HDG,P EXCHWT/1100
@FTN,SVI EXCHWT/1100
      SUBROUTINE EXCHWT (ISTAT,DBLOCK)
C
C     UNIVAC 1100.
C
C     WRITE A BLOCK ON THE EXCHANGE TAPE.
C
C     INPUT:
C     ISTAT = 1 MEANS OPEN OUTPUT WITH NO REWIND
C     ISTAT = 2 MEANS WRITE
C     ISTAT = 3 MEANS WRITE END FILE AND CLOSE WITH NO REWIND.
C
C     OUTPUT:
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT IS TO BE WRITTEN ON
C              TAPE).
      INTEGER DBLOCK(1)
C
      INTEGER EXCHIO
      INTEGER FDBLNK /O050505050505/   @ FIELDATA BLANK
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      I=ISTAT
      ISTAT=0
      GO TO (90,10,30), I
C
C     WRITE
C
10    NWORDS=2*((CCDBO+8)/9)
      IF (BLKSQO.NE.0) NWORDS=2*((NDATAO+NERRCO+9+8)/9)
      L=EXCHIO (FILES(1,7),8,NWORDS,DBLOCK,PFS(10,2))
      IF (L.LT.0) GO TO 15
      PFS(10,2)=PFS(10,2)+(L+27)/28    @ UPDATE SECTOR ADDRESS.
      GO TO 90
C
C     I/O ERROR.
C
15    L=-L
      CALL EXCHEM (L)
      WRITE (PRINTR,20)
20    FORMAT (' WHILE WRITING OUTAPE - EOF WRITTEN.')
C     NOW CLOSE OUTAPE.
C
C     CLOSE WITH NO REWIND (END FILE).
C
30    L=EXCHIO (FILES(1,7),9,NWORDS,DBLOCK,PFS(10,2))
C     IGNORE THE STATUS.
      WRITE (PRINTR,40) BLKSQO,OUTAPE
40    FORMAT (I6,23H BLOCKS WRITTEN ON TAPE,I4)
      IF (ELTS(1,7).EQ.FDBLNK) GO TO 90
      I=PFS(10,2)
      PFS(10,2)=PFS(10,2)-PFS(11,2)    @ COMPUTE ELEMENT LENGTH
      CALL PFIER (PFS(1,2),I,I)
      IF (I.EQ.0) GO TO 90
      I=I+32
      CALL EXCHEM (I)
      WRITE (PRINTR,50) OUTAPE
50    FORMAT (' WHILE TRYING TO CLOSE OUTAPE',I4,
     1'.  OUTPUT PROBABLY LOST.')
      IF (NCHCMD.LT.0) GO TO 90
      WRITE (PRINTR,60) (HOLCMD(I),I=1,NCHCMD)
60    FORMAT (1X,80A1)
      GO TO 90
90    RETURN
C
      END
@HDG,P ASMEXCH1/1100
@MASM,SI ASMEXCH1/1100,,,FTN
/.
FTN       EQU       $SS($PAR(4),1,3)='FTN'. 1 = FTN LINKAGE, 0 = FOR LINKAGE.
          AXR$.
.
.         CONVERT AN INTEGER TO LJSF FD.
.         FD=EXCHFN (INTEGER)
.         ONLY ONE WORD IS PRODUCED.
.
$(1),EXCHFN*.
          ON        1-FTN.
          SZ        A3.               FOR ADDR=IND.
          L         A1,*0,X11.        INTEGER.
          OFF.
          ON        FTN.
          L,H2      A1,0,A0.          ADDR OF INTEGER.
          L         A1,0,A1.          INTEGER.
          OFF.
          L         A3,('      ').
FNLOOP    DSL       A1,36.
          DI,U      A1,10.            PEEL OFF A DIGIT.
          A,U       A2,'0'.           CONVERT TO FD.
          DSL       A2,6.             SHIFT INTO A3.
          JNZ       A1,FNLOOP.        GET MORE DIGITS.
          S         A3,A0.            STORE FD.
          J         2-2*FTN,X11.      RETURN
/.        PERFORM I/O WITHOUT USING NTRAN.
.         I=EXCHIO (FNAME,FUNC,NWORDS,DBLOCK,DSKADR)
.           FNAME=2 WORD FD FILE NAME.
.           FUNC=8 TO WRITE, 16 TO READ, 32 TO REWIND TAPE.
.           NWORDS=NUMBER OF WORDS TO TRANSFER.
.           DBLOCK=BUFFER ADDRESS.
.           DSKADR=DISK SECTOR ADDRESS.
.         AFTER RETURN, I<0 = -IO STATUS, I>0 = WORDS TRANSFERRED.
.
$(1),EXCHIO*.
          ON        1-FTN.
          SZ        A3.               FOR ADDR=IND.
          L         A5,*4,X11.        DSKADR.
          L         A2,*1,X11.        FUNC.
          DL        A0,*0,X11.        FNAME.
          LXI       A3,*2,X11.        NWORDS.
          LXM,U     A3,*3,X11.        DBLOCK.
          OFF.
          ON        FTN.
          L,H2      A3,4,A0.          ADDR OF DSKADR.
          L         A5,0,A3.          DSKADR.
          L,H2      A3,1,A0.          ADDR OF FUNC.
          L         A2,0,A3.          FUNC.
          L,H2      A3,2,A0.          ADDR OF NWORDS.
          LXI       A3,0,A3.          NWORDS.
          LXM,H2    A3,3,A0.          DBLOCK.
          L,H2      A0,0,A0.          ADDR OF FNAME.
          DL        A0,0,A0.          FNAME.
          OFF.
          DS        A0,PKT.           STORE FNAME.
          L,U       A0,PKT.           GET PACKET ADDRESS.
          JZ        A2,TESTEQ.        TEST EQUIPMENT IF FUNC=0.
          TNE,U     A2,WEF$.          TRYING TO WRITE EOF MARK?
          J         TESTEQ.           YES, TEST EQUIPMENT.
          TE,U      A2,REW$.          TRYING TO REWIND?
          J         IO.               NO, GO DO I/O.
TESTEQ    ER        FACIL$.           GET FILE DESCRIPTION.
          L,S1      A1,PKT+6.         GET DEVICE CODE.
          JNZ       A1,ASGD.
          L         A0,(3,PKT-1).
          ER        CSF$.             ASSIGN WITH NO OPTIONS, IGNORE STATUS.
          L,U       A0,PKT.
          ER        FACIL$.           GET EQUIP CODE AGAIN.
          L,S1      A1,PKT+6.
ASGD      JZ        A2,6-6*FTN,X11.   RETURN IF FACIL & ASG ONLY.
          AN,U      A1,017.           FIRST NON-TAPE EQCODE.
          JP        A1,6-6*FTN,X11.   YES, RETURN IF NOT TAPE.
          L,U       A0,PKT.           GET I/O PACKET ADDRESS.
IO        SZ        PKT+2.
          SZ        PKT+3.
          S,S2      A2,PKT+3.         STORE FUNC.
          S         A3,PKT+4.         STORE NWORDS & DBLOCK.
          S         A5,PKT+5.         STORE DSKADR.
          ER        IOW$.             DO I/O, WAIT FOR COMPLETION.
          L,H2      A0,PKT+3.         GET NUMBER OF WORDS.
          TZ,S1     PKT+3.            TEST STATUS.
          LN,S1     A0,PKT+3.         GET -STATUS IF STATUS NOT=0.
          J         6-6*FTN,X11.      RETURN.
.
$(0)      '@ASG  '.
PKT       RES       9.                I/O PACKET.
/.        UNPACK 9-TRACK FORMAT 8-BIT CHARACTER DATA (WHICH MAY HAVE
.         BEEN READ FROM DISK OR 7-TRACK TAPE) TO ONE CHARACTER PER
.         WORD RJZF.  ALWAYS UNPACK NCH WORDS (DEFINED BY EQU).
.
.         CALL EXCHUN (BUF9T,BUFOUT)
.           BUF9T=9-TRACK FORMAT BUFFER.
.           BUFOUT=RJZF ONE CHARACTER PER WORD BUFFER.
.
NCH       EQU       180.              NUMBER OF CHARACTERS TO UNPACK.
.
$(1),EXCHUN*.
          ON        1-FTN.
          SZ        A3.               FOR ADDR=IND.
          L,U       A0,*0,X11.        BUF9T ADDRESS.
          L,U       A1,*1,X11.        BUFOUT ADDRESS.
          OFF.
          ON        FTN.
          L,H2      A1,1,A0.          BUFOUT ADDRESS.
          L,H2      A0,0,A0.          BUF9T ADDRESS.
          OFF.
          LXI,U     A0,2.             PROCESS DOUBLE WORDS OF BUF9T.
          LXI,U     A1,1.             PROCESS SINGLE WORDS OF BUFOUT.
          L,U       R1,NCH/9-1.       NUMBER OF 9 CHARACTER GROUPS.
.
GETNXT    DL        A3,0,*A0.         GET 9 8-BIT CHARACTERS.
          L,U       R2,8.             LOOP COUNTER TO PROCESS 9 CHARACTERS
NEXTCH    LDSC      A3,8.             GET 8 BITS.
          AND,U     A4,0377.          LOW ORDER 8 BITS OF A4 -> A5.
          S         A5,0,*A1.         STORE IN BUFOUT.
          JGD       R2,NEXTCH.        PEEL OFF ANOTHER 8 BITS.
          JGD       R1,GETNXT.        GET ANOTHER DOUBLE WORD.
          J         3-3*FTN,X11.      RETURN.
          END.
@HDG,P ASMEXCH2/1100
@MASM,SI ASMEXCH2/1100,,,FTN
/.
FTN       EQU       $SS($PAR(4),1,3)='FTN'. 1 = FTN LINKAGE, 0 = FOR LINKAGE.
          AXR$.
.         GET THE DATE AND STORE IT IN 'TODAY' IN /EXCHPC/,
.         ONE CHARACTER PER WORD, RIGHT JUSTIFIED, ZERO FILLED.
.         NOTE THAT THE FIELDATA NUMBERS AND THE ASCII NUMBERS
.         HAVE THE SAME VALUES.
.
$(1),XHINIT*.
          L         A2,(1,TODAY).     PLACE TO PUT THE DATE.
          ER        DATE$.            GET THE DATE FROM EXEC
          SSC       A0,12.            CONVERT DATE FROM MMDDYY TO YYMMDD
          L,U       R1,5.             LOOP COUNTER
NEXDAT    SZ        A1.
          LDSC      A0,6.             STRIP OFF ONE CHARACTER INTO A1
          S         A1,,*A2.          STORE IT IN 'TODAY' VECTOR
          JGD       R1,NEXDAT.        LOOP
.
.         STORE @XQT OPTIONS IN 'OPTVAL' VECTOR IN /EXCHPC/.
.
          L         A2,(1,OPTVAL).    PLACE TO STORE THE OPTIONS.
          ER        OPT$.             GET OPTION BITS FROM EXEC.
          LSSL      A0,10.            A OPTION -> SIGN BIT.
          L,U       A3,25.            LOOP COUNTER - 1.
OPTLOOP   SZ        A1.
          LDSC      A0,1.             SHIFT OPTION BIT INTO A1.
          S         A1,0,*A2.         STORE IN 'OPTVAL' VECTOR.
          JGD       A3,OPTLOOP.       PROCESS MORE OPTIONS.
          J         1-FTN,X11.        RETURN
.
.         DO A PROGRAM FILE SEARCH ER (PFS$).
.         CALL PFSER (PACKET,STATUS)
.
$(1),PFSER*.
 DO FTN , L         A3,A0.            SAVE CALLING SEQUENCE ADDRESS.
 DO FTN , L,H2      A0,0,A3.          GET PACKET ADDRESS.
 DO 1-FTN ,   SZ    A3.               FOR INDIRECT ADDRESSING.
 DO 1-FTN ,   L,U   A0,*0,X11.        GET PACKET ADDRESS.
          ER        PFS$.
 DO FTN , L,H2      A1,1,A3.          GET STATUS ADDRESS.
 DO FTN , S         A2,0,A1.          STORE STATUS.
 DO 1-FTN ,   S     A2,*1,X11.        STORE STATUS.
          J         3-3*FTN,X11.      RETURN.
.
.         GET THE NEXT WRITE LOCATION FOR A PROGRAM FILE.
.         CALL PFWLER (PACKET,NWL,STATUS)
.
$(1),PFWLER*.
 DO FTN , L         A3,A0.            SAVE CALLING SEQUENCE ADDRESS.
 DO FTN , L,H2      A0,0,A3.          GET PACKET ADDRESS.
 DO 1-FTN ,   SZ    A3.               FOR INDIRECT ADDRESSING.
 DO 1-FTN ,   L,U   A0,*0,X11.        GET PACKET ADDRESS.
          ER        PFWL$.            GET NEXT WRITE LOCATION.
          ON        FTN.
          L,H2      A0,1,A3.          GET WRITE LOCATION ADDRESS.
          S         A1,0,A0.          STORE WRITE LOCATION.
          L,H2      A0,2,A3.          GET STATUS ADDRESS.
          S         A2,0,A0.          STORE STATUS.
          OFF.
 DO 1-FTN ,   S     A1,*1,X11.        STORE WRITE LOCATION.
 DO 1-FTN ,   S     A2,*2,X11.        STORE STATUS.
          J         4-4*FTN,X11.
.
.         INSERT A NEW ELEMENT IN A PROGRAM FILE.
.         CALL PFIER (PACKET,NWL,STATUS)
.
$(1),PFIER*.
          ON        FTN.
          L         A3,A0.            SAVE CALLING SEQUENCE ADDRESS.
          LN,H2     A0,0,A3.          GET PACKET ADDRESS.
          L,H2      A1,1,A3.          GET WRITE LOCATION ADDRESS.
          L         A1,0,A1.          GET WRITE LOCATION.
          OFF.
          ON        1-FTN.
          SZ        A3.               FOR INDIRECT ADDRESSING.
          LN,U      A0,*0,X11.        GET PACKET ADDRESS.
          L         A1,*1,X11.        GET WRITE LOCATION.
          OFF.
          ER        PFI$.             INSERT NEW ELEMENT.
 DO FTN , L,H2      A1,2,A3.          GET STATUS ADDRESS.
 DO FTN , S         A2,0,A1.          STORE STATUS.
 DO 1-FTN ,   S     A2,*2,X11.        STORE STATUS.
          J         4-4*FTN,X11.
.
.         RETRIEVE THE SYMBIONT INDICATOR FROM NTAB$.
.         I=NTABDC(UNIT)
.
$(1),NTABDC*.
          ON        FTN.
          L,H2      A0,0,A0.          GET ARGUMENT ADDRESS.
          L         A0,0,A0.          GET UNIT NUMBER.
          L,S2      A0,F2FRT$,A0.     GET SYMBIONT INDICATOR.
          OFF.
          ON        1-FTN.
          SZ        A3.               FOR INDIRECT ADDRESSING.
          L         A0,*0,X11.        GET UNIT NUMBER.
          L,S2      A0,NTAB$,A0.      GET SYMBIONT INDICATOR.
          OFF.
          J         2-2*FTN,X11.      RETURN.
/.        PACK ONE CHARACTER PER WORD DATA INTO 9-TRACK FORMAT
.         ALWAYS USE "NCH" CHARACTERS (DEFINED BELOW).
.
.         CALL EXCHPA (BUFIN,BUF9T)
.         BUFIN IS THE INPUT BUFFER (ONE CHARACTER PER WORD)
.         BUF9T IS THE 9-TRACK FORMAT OUTPUT BUFFER
.
NCH       EQU       180.               180 CHARACTERS AT A TIME
$(1),EXCHPA*.
          ON        FTN.
          L         A3,A0.             SAVE CALLING SEQUENCE ADDRESS.
          L,H2      A0,0,A3.           GET BUFIN ADDRESS.
          L,H2      A1,1,A3.           GET BUF9T ADDRESS.
          OFF.
          ON        1-FTN.
          L,U       A1,*1,X11.         GET BUF9T ADDRESS.
          SZ        A3.                FOR INDIRECT ADDRESSING.
          L,U       A0,*0,X11.         GET BUFIN ADDRESS.
          OFF.
          LXI,U     A0,1.              INCREMENT 1 WORD EACH TIME
          LXI,U     A1,2.              INCREMENT 2 WORDS EACH TIME
          L,U       R2,0377.           8 BIT MASK
          L,U       R1,NCH/9-1.        NUMBER OF 9-CHARACTER GROUPS
.
PUTNXT    L,U       R3,8.              LOOP FOR 9 CHARACTERS
NXTOUT    LDSL      A3,8.              MAKE ROOM FOR NEXT CHARACTER
          MLU       A4,,*A0.           ADD IN NEXT CHARACTER
          S         A5,A4.             MOVE BACK INTO A4
          JGD       R3,NXTOUT.         GO ADD NEXT CHARACTER
          DS        A3,,*A1.           STORE DOUBLE WORD
          JGD       R1,PUTNXT.         NCH/9 OUTER LOOP TRAVERSALS
          J         3-3*FTN,X11.       RETURN
/.        PACK 12 CHARACTERS IN FIELDATA - FOR FILE, ELEMENT, VERSION NAMES.
.
.         CALL EXCHPN (RJASCI,FD,NCHAR)
.           RJASCI=RIGHT JUSTIFIED ASCII, ONE CHARACTER PER WORD.
.           FD=PACKED FIELDATA EQUIVALENT PRODUCED HERE.
.           NCHAR=NUMBER OF RJASCI.
.
$(1),EXCHPN*.
          ON        1-FTN.
          SZ        A3.               FOR ADDR=IND.
          L,U       A0,*0,X11.        ADDR OF RJASCI.
          L,U       A1,*1,X11.        ADDR OF FD.
          L         R1,*2,X11.        NCHAR.
          OFF.
          ON        FTN.
          L,H2      A1,2,A0.          ADDR OF NCHAR.
          L         R1,0,A1.          NCHAR.
          L,H2      A1,1,A0.          ADDR OF FD.
          L,H2      A0,0,A0.          ADDR OF RJASCI.
          OFF.
          A         A0,R1.            COMPUTE END OF
          AN,U      A0,1.              RJASCI VECTOR.
          LXI,XU    A0,-1.            PROCESS RJASCI RIGHT TO LEFT.
          L         A4,BLANKS.
          L         A5,A4.
          J         PNLT.
PNLOOP    L         A2,0,*A0.         GET RJASCI CHAR.
          L,S1      A3,AF,A2.         GET FD EQUIVALENT.
          DSL       A4,6.             TRIPLE
          LSSL      A4,6.              SHIFT
          DSL       A3,6.               RIGHT.
PNLT      JGD       R1,PNLOOP.
          DS        A4,0,A1.          STORE FD.
          J         4-4*FTN,X11.      RETURN.
/.        UNIVAC-1100 EXEC SDF INPUT ROUTINE FOR THE EXCHANGE PROGRAM.
.
.         STATUS=EXCH8I (WORK)
.         WORK IS THE 473 WORD WORK AREA REQUIRED BY EORSR.
.         STATUS IS AS FOR EORSRR EXCEPT NORMAL EOF = 0.
.
.         DEFINITIONS.
.
BANKWL    EQU       224.              WORD LENGTH OF I/O BUFFERS.
BANKSL    EQU       BANKWL//28.       SECTOR LENGTH OF I/O BUFFERS.
NX        EQUF      *0177777,*0,017.  REMOVE X REG FROM EQUFS.
.         WORK AREA
FCT       EQUF      0,A0.             SDFI WORK AREA.
EQCODE    EQUF      FCT+6,,S1.        EQUIPMENT CODE FROM FITEM$.
KEY       EQU       FCT+11.           OPEN FILE INDICATOR.
SAVX1     EQU       KEY+1.            SAVE AREA FOR X1.
SAVX11    EQU       SAVX1+1.          SAVE AREA FOR X11.
BANK1     EQU       SAVX11+1.         FIRST I/O BUFFER.
BANK2     EQU       BANK1+BANKWL.     SECOND I/O BUFFER
ETABLE    EQU       BANK2+BANKWL.     ELEMENT TABLE IF NEEDED
ETFILE    EQU       ETABLE.           ELEMENT FILE NAME.
ETELT     EQU       ETABLE+2.         ELEMENT NAME.
ETVER     EQU       ETABLE+6.         VERSION NAME.
ETETYP    EQUF      ETABLE+5,,H1.     ELEMENT TYPE.
ETELOC    EQU       ETABLE+10.        SECTOR LOCATION OF ELEMENT.
.         CALLING SEQUENCE PARAMETERS.
 DO FTN ,WORK EQUF  0,A0,H2.          WORK AREA ADDRESS.
 DO 1-FTN ,WORK EQUF *0,X11,U.        WORK AREA ADDRESS.
.         LOCAL USE OF WORK AREA.
AFD       EQUF      KEY,,S2.          ASCII/FD FLAG.
FILTYP    EQUF      KEY,,S3.          FILE TYPE
/.        SDDL DESCRIPTION OF PROCEDURE.
.
. PROCEDURE SDFASR TO READ SDF INTO ASCII, USING WORK, IMAGE, STATUS
.     THE WORK AREA CONTAINS THE FILE MODE (ELT/FILE/READ$) BY INTERPRETING
.     ELEMENT=0 MEANS FILE OR READ$, IF ELEMENT=0 THEN VERSION=0 MEANS FILE.
.     THE WORK AREA ALSO CONTAINS THE FILE CREATION TYPE (C,F,I,P,S,?) FROM A
.     TYPE 050 LABEL RECORD, IF ONE IS PRESENT.
.    LOOP
.       IF ELEMENT
.          CALL ELTR GIVING STATUS------------------------------------->(   )
.       ELSEIF FILE
.          CALL SDFR GIVING STATUS------------------------------------->(   )
.       ELSE
.          CALL READ$-------------------------------------------------->(   )
.          IF EOF
.             SET STATUS = 037
. <-----------EXITPROCEDURE
.          ELSE
.             SET ASCII / FD FLAG = ASCII
.    <--------EXITLOOP
.          ENDIF
.       ENDIF
.       IF STATUS NOT EQUAL 0
. <--------EXITPROCEDURE
.       ENDIF
.       IF RECORD TYPE = 050
.          SET FILE CREATION TYPE AND ASCII / FD FLAG FROM ICW
.    <-----CYCLE
.       ENDIF
.       IF RECORD TYPE = 042
.          SET ASCII / FD FLAG FROM ICW
.    <-----CYCLE
.       ENDIF
.       IF RECORD TYPE GREATER THAN 037
.    <-----CYCLE
.       ENDIF
.       SELECT FILE CREATION TYPE
.       CASE C OR I
.          SET ASCII / FD FLAG FROM BIT 0 OF ICW
.       CASE P
.          SET FIRST BYTE OF IMAGE FROM IMAGE SPACING IN T2 OF ICW
.          SET ASCII / FD FLAG FROM BIT 0 OF ICW
.       CASE S
.          IF S4 OF ICW NOT EQUAL ZERO
.    <--------CYCLE
.          ENDIF
.       ENDSELECT
.    <--EXITLOOP
.    ENDLOOP
.    STORE IMAGE IN ASCII, USE ASCII / FD FLAG TO DETERMINE IMAGE TYPE.
. <--EXITPROCEDURE
. ENDPROCEDURE
/.
$(1),EXCH8I* S      X11,SX11.
 DO 1-FTN , SZ      A3.               FOR INDIRECT ADDRESSING.
          L         A0,WORK.          GET WORK AREA ADDRESS.
          S         A0,WORKSV.
          L         A1,(1,0).
          S         A1,BYTE1.         BYTE LOCATION IN COMAND.
          LN,U      A1,1.
          S         A1,NCHCMD.        EOF INDICATOR.
          L,U       A1,040.           ASCII ' '.
          S         A1,COMAND.        IN CASE OF ZERO LENGTH IMAGE.
          L         A1,FCT.           FILE NAME.
          JZ        A1,READ$IN.       NO FILE NAME, USE ER AREAD$.
ELTLP.
 DO FTN , L,U       A0,WORKSV.        ADDRESS OF CALLING SEQUENCE.
          LMJ       X11,EORSRR.
 DO FTN ,$(6).
WORKSV    +         $-$.              ADDRESS OF WORK AREA.
          +         HOLCMD.           INPUT IMAGE AREA.
          +         ((180)).          MAXIMUM IMAGE LENGTH.
          +         ICW.              IMAGE CONTROL WORD.
          +         $-EXCH8I,0.       WALBACK.
 DO FTN ,$(1).
          TNE,U     A0,37.            TEST FOR EOF.
          J         EXITZ.            NORMAL EOF.
          JNZ       A0,EXITI.         ABNORMAL EOF.
          L         A0,WORKSV.        RESTORE WORK AREA ADDRESS.
          TN        ICW.              CONTROL OR DATA?
          J         GOTIMG.           DATA.
          L,S1      A1,ICW.           GET CONTROL RECORD TYPE.
          TE,U      A1,050.           LABEL RECORD?
          J         ELTLP.            NO.
          L,S3      A1,ICW.           GET FILE TYPE.
          TNZ       FILTYP.           DON'T STORE FILTYP MORE THAN ONCE.
          S         A1,FILTYP.        STORE FILE TYPE IN WORK AREA.
          J         ELTLP.            GET ANOTHER RECORD.
READ$IN   L         A0,(EXITZ,HOLCMD).
          ER        AREAD$.           READ IMAGE IN ASCII.
          TEP       A0,(1*/31).
          J         READ$IN.          SKIP INFOR.
          LSSL      A0,24.            MOVE WORD COUNT.
          J         GOTIMA.           GO PROCESS ASCII IMAGE.
GOTIMG    L         A1,FILTYP.        GET FILE TYPE.
          TE,U      A1,'C'.           CARD FILE?
          TNE,U     A1,'I'.           INPUT SYMBIONT FILE?
          J         CORIREC.          ONE OR THE OTHER.
          TNE,U     A1,'P'.           PRINT FILE?
          J         PREC.             YES.
          TE,U      A1,'X'.           FTN?
          TNE,U     A1,'F'.           FORTRAN?
          J         FREC.             YES.
          TZ,S4     ICW.              DELETED RECORD?
          J         ELTLP.            YES, GET ANOTHER RECORD.
FREC      L         A2,AFD.           GET ASCII/FD FLAG.
          J         TIM.              GO TEST IMAGE CODE.
PREC      L,S3      A1,ICW.
          LSSL      A1,6.
          A,S4      A1,ICW.           GET LINE SPACING FROM T2 OF ICW.
          L,U       A5,060.           ASCII '0'.
          TNE,U     A1,0.
          L,U       A5,053.           ASCII '+'.
          TNE,U     A1,1.
          L,U       A5,040.           ASCII ' '.
          TG,U      A1,47.            SKIP IF A1 .LE. 47
          L,U       A5,061.           ASCII '1'.
          L         A1,BYTE1.
          S         A5,COMAND,*A1.    STORE FORTRAN VERTICAL FORMAT CONTROL
          S         A1,BYTE1.         STORE INCREMENTED BYTE POINTER.
CORIREC   L         A1,ICW.
          AND,U     A1,1.             ASCII/FD FLAG IS BIT ZERO.
TIM       L         A0,ICW.
          JZ        A2,GOTIMF.        JUMP IF IMAGE FD.
GOTIMA    L         A2,(1,0).
          L         A1,BYTE1.         GET BYTE POINTER.
          SSL       A0,24.            RJ WORD COUNT.
          JZ        A0,ENDIMG.
          TG,U      A0,45.
          L,U       A0,44.            MAXIMUM CAPACITY IS 44 WORDS.
          AN,U      A0,1.
LOOPA     L,U       R1,3.             INNER LOOP COUNTER.
          L         A4,HOLCMD,*A2.    GET WORD OF 4 BYTES.
          SZ        A3.
          LDSL      A3,9.             GET ONE BYTE.
          S         A3,COMAND,*A1.
          JGD       R1,$-3.
          JGD       A0,LOOPA.
ENDIMG    L,U       A2,040.           ASCII ' '.
          S         A2,COMAND,A1.     GET READY TO STRIP OFF TRAILING BLANKS.
          LXI,XU    A1,-1.            SCAN BACKWARD.
          TNE       A2,COMAND,A1.     STRIP OFF TRAILING BLANKS.
          JMGI      A1,$-1.           LOOP FOR A WHILE.
          L,U       A2,1,A1.          INCREMENT POINTER TO MAKE COUNT.
          JNZ       A2,$+3.
          L,U       A2,1.             AT LEAST ONE BYTE.
          LXM,U     A1,0.
          S         A2,NCHCMD.        SAVE NUMBER OF CHARACTERS.
ASCHOL    L         A2,COMAND,A1.     GET ASCII CHARACTER.
          L         A2,XLATE,A2.      TRANSLATE TO HOLLERITH.
          S         A2,HOLCMD,A1.     STORE.
          JMGI      A1,ASCHOL.        LOOP FOR A WHILE.
EXITZ     SZ        A0.               INDICATE NORMAL EXIT.
EXITI     L         X11,SX11.
          J         2-2*FTN,X11.      RETURN.
GOTIMF    L         A2,(1,0).
          L         A1,BYTE1.
          SSL       A0,24.            POSITION WORD COUNT.
          JZ        A0,ENDIMG.
          TG,U      A0,30.
          L,U       A0,29.            MAXIMUM CAPACITY IS 29 WORDS.
          AN,U      A0,1.
LOOPF     L,U       R1,5.             INNER LOOP COUNTER.
          L         A4,HOLCMD,*A2.    GET ONE WORD OF 6 BYTES.
          SZ        A3.
          LDSL      A3,6.             GET ONE BYTE.
          L         A3,FA,A3.         CONVERT TO ASCII
          S         A3,COMAND,*A1.
          JGD       R1,$-4.
          JGD       A0,LOOPF.
          J         ENDIMG.
/.        UNIVAC-1100 EXEC SDF OUTPUT ROUTINE FOR THE EXCHANGE PROGRAM.
.
.         STATUS=EXCH8O (OUTPUT)
.         OUTPUT IS THE OUTPUT VECTOR, RJZF ASCII.
.         STATUS IS AS FOR EORSWW.
.
.         DEFINITIONS.
.
.         CALLING SEQUENCE PARAMETERS.
 DO FTN ,OUTPUT EQUF 0,A0,H2.         OUTPUT BUFFER ADDRESS.
 DO 1-FTN ,OUTPUT EQUF *0,X11,U.      OUTPUT BUFFER ADDRESS.
.
$(1),EXCH8O* S      X11,SX11.         SAVE X11.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
          L         A1,OUTPUT.        GET ADDR OF OUTPUT VECTOR.
          LXI,U     A1,1.             PUT IN INCREMENTOR.
          L         R1,NCHOUT.        NUMBER OF CHARACTERS OF OUTPUT.
          L         A2,AFDFLG.        ASCII=1, FD=0.
          L         A0,(1,0).         POINTER INTO OUTPUT BUFFER.
          JZ        A2,PACKF.
          J         PACKA.
. ASCII PACKING LOOP.
PACKAL    L         A5,0,*A1.         GET CHAR OF ASCII.
          LSSL      A5,27.            LJ.
          LDSL      A4,9.             ADD TO ACCUMULATING STRING.
          JGD       R2,$+3.           WORD FULL?
          S         A4,BUFOUT,*A0.    PUT WORD IN OUTPUT BUFFER.
PACKA     L         R2,LOOPCT+1.      GET LOOP COUNTER.
          JGD       R1,PACKAL.
          J         FINL.
. FIELDATA PACKING LOOP.
PACKFL    L         A3,0,*A1.         GET CHAR OF FD.
          L         A5,AF,A3.         TRANSLATE TO FD.
          LDSL      A4,6.             ADD TO ACCUMULATING STRING.
          JGD       R2,$+3.           WORD FULL?
          S         A4,BUFOUT,*A0.    PUT WORKD IN OUTPUT BUFFER.
PACKF     L         R2,LOOPCT.        GET LOOP COUNTER.
          JGD       R1,PACKFL.
. FINISH UP PACKING, ADD TRAILING BLANKS TO LAST WORD.
FINL      L         A3,R2.
          TNE       A3,LOOPCT,A2.     HOW MUCH OF LOOP IS LEFT?
          J         FIN.              NONE.
          A,U       A3,1.
          MSI       A3,SHIFT,A2.      COMPUTE SHIFT.
          L         A5,BLANKS,A2.
          LDSL      A4,0,A3.          SHIFT IN TRAILING BLANKS.
          S         A4,BUFOUT,*A0.    STORE WORD WITH TRAILING BLANKS.
FIN       TZ        WORKOUT.          PUNCH?
          J         FILE.             NO.
          LSSL      A0,18.            CONSTRUCT PUNCH$ OR APUNCH$ PKT.
          LXM,U     A0,BUFOUT.
          JNZ       A2,ASCPCH.
          ER        PUNCH$.           FD PUNCH.
          SZ        A0.               CLEAR STATUS.
          J         EXITO.
ASCPCH    ER        APUNCH$.          ASCII PUNCH.
          SZ        A0.               CLEAR STATUS.
          J         EXITO.
. FILE OUTPUT.
FILE      LSSL      A0,24.
          S         A0,ICW.           STORE ICW.
 DO FTN , L,U       A0,CALSEQ.        CALLING SEQUENCE
          LMJ       X11,EORSWW.       WRITE SDF RECORD.
 DO FTN ,$(6),CALSEQ.
          +         WORKOUT.          WORK AREA ADDRESS.
          +         BUFOUT.           OUTPUT BUFFER.
          +         ICW.              IMAGE CONTROL WORD.
          +         $-EXCH8O,0.       WKBK.
 DO FTN ,$(1).
EXITO     L         X11,SX11.         RECOVER X11.
          J         2-2*FTN,X11.      RETURN.
/.        COMMON DEFINITIONS.
.
          INFO      2 'EXCHOC',3.
$(3).
BLKSQO    RES       1.                OUTPUT BLOCK SEQUENCE.
CBLCKO    RES       180.              OUTPUT CHARACTER OUTPUT BLOCK.
CCDBO     RES       1.                CURRENT OUTPUT CHARACTER POSITION.
CPCBO     RES       1.                CURRENT POSITION IN CBLCKO.
CWDBO     RES       1.                CURRENT OUTPUT WORD POSITION.
ITYPEO    RES       1.                OUTPUT RECORD TYPE.
LASTO     RES       1.                FLAG FOR LAST BLOCK OF TAPE.
LLPRGO    RES       1.                LOCATION OF LAST PROGRAM.
L1PRGO    RES       1.                LOCATION OF FIRST PROGRAM IN BLOCK.
L1RECO    RES       1.                LOCATION OF FIRST RECORD IN BLOCK.
MODEO     RES       1.                MODE OF OUTPUT RECORD.
NCCBO     RES       1.                NUMBER OF CHARACTERS TO PACK.
NCHOUT    RES       1.                NUMBER OF CHARACTERS IN OUTPUT RECORD.
NDATAO    RES       1.                NUMBER OF DATA CHARACTERS PER BLOCK.
NERRCO    RES       1.                ERROR DETECTION CHARACTERS PER BLOCK.
NLRECO    RES       1.                PROGRAM NUMBER OF LAST RECORD OUTPUT.
NWCBO     RES       1                 WORDS NEEDED FOR NCCBO CHARACTERS.
N1RECO    RES       1.                PROGRAM NUMBER OF FIRST RECORD IN BLOCK.
OUTREC    RES       180.              SPACE FOR OUTPUT RECORD.
OUTUPD    RES       1.                ASCII U (85) IF UPDATE OK.
REMVO     RES       1.                CHARACTER REMOVED FOR COMPRESSION.
.
          INFO      2 'EXCHPC',2.
$(2).
ACTION    RES       1.                EXCHIM/EXCHOU ACTION FLAG.
CHAR1L    RES       1.                CHARACTER AFTER LINE NUMBER ON LIST.
COMAND    RES       180.              ASCII INPUT BUFFER.
COMD      RES       4*40.             COMMAND TABLE.
EQUAL     RES       1.                LOCATION OF EQUAL SIGN IN COMMAND.
HOLCMD    RES       180.              HOLLERITH INPUT BUFFER.
ICOMD     RES       1.                COMMAND INDEX.
IDCUR     RES       1.                CURRENT SEQUENCE NUMBER.
IDOPTN    RES       1.                SEQUENCE NUMBERING OPTION.
IDNBRS    RES       4.                C1,C2,STEP,START FOR SEQUENCE NUMBERS.
IDTEXT    RES       40.               TEXT TO EMIT WITH SEQUENCE NUMBERS.
IDTXTL    RES       1.                LENGTH OF TEXT TO EMIT.
INDEX     RES       1.                SUM OF INDEXS - INDEXING FLAG.
INDEXS    RES       26.               INDIVIDUAL INDEX FLAGS.
INTOPN    RES       1.                INTAPE OPEN FLAG.
LIMIT     RES       1.                LIMIT OF PRED CONTROLLED SEARCH.
LINEO     RES       1.                OUTPUT LINE NUMBER (FOR LISTING).
MARGIN    RES       1.                RIGHT MARGIN OF COMMANDS.
MODIFY    RES       1.                MODIFIER FIELD OF COMMAND.
NCHCMD    RES       1.                NUMBER OF CHARACTERS OF INPUT.
NCOMDP    RES       1.                SIZE OF PORTABLE COMMAND TABLE.
NCOMDT    RES       1.                SIZE OF TOTAL COMMAND TABLE.
NERRG     RES       1.                GLOBAL ERROR FLAG.
NERRS     RES       1.                LOCAL ERROR FLAG.
NRWORK    RES       1.                NUMBER OF CONTROL RECORDS ON WORKF.
NUMBER    RES       1.                FIRST NUMBER FROM COMMAND PARAMETER FIELD.
OPTVAL    RES       26.               ALPHABETIC OPTION SELECTIONS.
OUTOPN    RES       1.                OUTAPE OPEN FLAG.
PHASE     RES       1.                PROGRAM OPERATION PHASE.
PRED      RES       42*8.             STORED PREDICATES.
SIGNAL    RES       1.                END OF TEXT SIGNAL.  INITIALLY -.
SITE      RES       40.               SITE.
TITLE     RES       40.               TITLE.
TODAY     RES       6.                DATE.
TRANS     RES       1.                CONTROLS TRANSITION BETWEEN SEGMENTS.
VERT      RES       1.                VERTICAL SPACING CONTROL FLAG.
.
          INFO      2 'EXCHXC',4.
$(4),XLATE RES      128.              TRANSLATE TABLE ASCII -> HOLLERITH.
 DO 1-FTN ,AF EQU   XLATE.            TRANSLATE TABLE ASCII -> FD.
.
          INFO      2 'EXEC8',5.
$(5).
AFDFLG    RES       1.                FD=0, ASCII=1 OUTPUT CODE.
WORKIN    RES       474*4.            INPUT WORK AREAS.
WORKOUT   RES       474.              OUTPUT WORK AREA.
.
.         SCRATCH AREAS.
.
$(0).
BYTE1     RES       1.
ICW       RES       1.
SX11      RES       1.
BUFOUT    RES       45.               OUTPUT BUFFER.
BLANKS    '      '.                   FD BLANKS.
          +         040,040,040,040.  ASCII BLANKS.
SHIFT     +         6.                FD SHIFT.
          +         9.                ASCII SHIFT.
LOOPCT    +         5.                FD LOOP COUNTER.
          +         3.                ASCII LOOP COUNTER.
.
.         TRANSLATE TABLE FROM FIELDATA TO ASCII.
.
          ASCII
FA.
          +         '@'.
          +         '['.
          +         ']'.
          +         '#'.
          +         '^'.
          +         ' '.
          +         'A'.
          +         'B'.
          +         'C'.
          +         'D'.
          +         'E'.
          +         'F'.
          +         'G'.
          +         'H'.
          +         'I'.
          +         'J'.
          +         'K'.
          +         'L'.
          +         'M'.
          +         'N'.
          +         'O'.
          +         'P'.
          +         'Q'.
          +         'R'.
          +         'S'.
          +         'T'.
          +         'U'.
          +         'V'.
          +         'W'.
          +         'X'.
          +         'Y'.
          +         'Z'.
          +         ')'.
          +         '-'.
          +         '+'.
          +         '<'.
          +         '='.
          +         '>'.
          +         '&'.
          +         '$'.
          +         '*'.
          +         '('.
          +         '%'.
          +         ':'.
          +         '?'.
          +         '!'.
          +         ','.
          +         '\'.
          +         '0'.
          +         '1'.
          +         '2'.
          +         '3'.
          +         '4'.
          +         '5'.
          +         '6'.
          +         '7'.
          +         '8'.
          +         '9'.
          +         ''''.
          +         ';'.
          +         '/'.
          +         '.'.
          +         '"'.
          +         '_'.
.
.         ASCII -> FD TRANSLATION.
.
          ON        FTN.
          FIELDATA.
AF.
 DO 32 ,  '$'.
          ' '.
          '!'.
          '"'.
          '#'.
          '$'.
          '%'.
          '&'.
          ''''.
          '('.
          ')'.
          '*'.
          '+'.
          ','.
          '-'.
          '.'.
          '/'.
I  DO 10 , + ('0'+I-1)*/30
          ':'.
          ';'.
          '<'.
          '='.
          '>'.
          '?'.
          '@'.
I  DO 26 , + ('A'+I-1)*/30
          '['.
          '\'.
          ']'.
          '^'.
          '_'.
          '@'.
I  DO 26 , + ('A'+I-1)*/30
          '['.
          '\'.
          ']'.
          '^'.
          '_'.
          OFF.
          END.
@HDG,P EORSR/1100
@MASM,SI EORSR/1100,,,FTN
/.
.         READ ELEMENTS OR SDF FILES.
.
.         S = EORSRO (WORK,ELT,VER) OPENS AN ELEMENT OR SDF FILE.
.           THE FIRST TWO WORDS OF WORK MUST BE THE FILENAME.
.           ELT DETERMINES WHETHER A FILE OR ELEMENT IS TO BE READ.
.           IF ELT = 0, ELT IS A SCALAR AND A FILE IS TO BE READ, IN
.             WHICH CASE WORK MUST BE AT LEAST 462 WORDS AND
.             VER IS IGNORED.
.           IF ELT NOT ZERO, IT IS THE FIRST WORD OF A TWO WORD VECTOR
.             CONTAINING THE ELEMENT NAME, VER IS THE TWO WORD VERSION
.             AND WORK MUST CONTAIN AT LEAST 474 WORDS.
.           S IS THE STATUS (DECIMAL):
.             00 = NORMAL COMPLETION,
.             1 - 32 = I/O ERROR,
.             33 = ELEMENT NOT FOUND,
.             34 = EXEC I/O ERROR,
.             35 = THE FILE CANNOT BE ASSIGNED, OR THE FILE CAN BE
.                  ASSIGNED BUT ELT NOT = ZERO AND THE FILE IS NOT A
.                  PROGRAM FILE.  IF THE FILE CANNOT BE ASSIGNED THE
.                  CSF$ STATUS IS RETURNED IN WORK(3).  IF THE FILE CAN
.                  BE ASSIGNED, WORK(3) IS NON-NEGATIVE.
.
.         S = EORSRR (WORK,IMAGE,MAXLEN,ICW) READS SDF FILE OR ELEMENT.
.           WORK IS AS FOR EORSRO (MUST NOT BE CHANGED BY USER),
.           IMAGE IS THE PLACE THE USER DESIRES THE IMAGE TO BE PLACED,
.           MAXLEN IS THE MAXIMUM NUMBER OF WORDS OF IMAGE TO BE
.             DELIVERED TO THE USER.  THE ACTUAL NUMBER OF WORDS
.             DELIVERED IS PART OF THE ICW.  IMAGE IS NOT SPACE FILLED,
.             BUT MAY BE TRUNCATED IF MAXLEN IS LESS THAN THE ACTUAL
.             RECORD SIZE.
.           ICW IS THE SDF IMAGE CONTROL WORD (SEE PRM VOLUME 3).
.           S IS AS FOR EORSRO, PLUS TWO MORE POSSIBLE VALUES:
.             36 = FILE OR ELEMENT NOT OPENED,
.             37 = END OF FILE ENCOUNTERED.
.
.         CALL EORSRC (WORK) STOPS ANYNCHRONOUS I/O AND
.           RELEASES THE ASSOCIATION OF WORK AND THE FILE OR ELEMENT.
.
/.        DEFINITIONS.
          AXR$.                       REGISTERS, ETC.
FTN       EQU       $SS($PAR(4),1,3)='FTN'. 1 = FTN LINKAGE, 0 = FOR LINKAGE.
BANKWL    EQU       224.              WORD LENGTH OF I/O BUFFERS.
BANKSL    EQU       BANKWL//28.       SECTOR LENGTH OF I/O BUFFERS.
NX        EQUF      *0177777,*0,017.  REMOVE X REG FROM EQUFS.
.         WORK AREA
FCT       EQUF      0,X1.             SDFI WORK AREA.
EQCODE    EQUF      FCT+6,,S1.        EQUIPMENT CODE FROM FACIL$.
KEY       EQU       FCT+11.           OPEN FILE INDICATOR.
FILELT    EQUF      KEY,,S1.          0=FILE, 1=ELT.
ASCFD     EQUF      KEY,,S2.          ASCII/FD CODE
SAVX1     EQU       KEY+1.            SAVE AREA FOR X1.
SAVX11    EQU       SAVX1+1.          SAVE AREA FOR X11.
 DO FTN ,SAVA3 EQUF SAVX1+1,,H1.      SAVE AREA FOR A3.
BANK1     EQU       SAVX11+1.         FIRST I/O BUFFER.
BANK2     EQU       BANK1+BANKWL.     SECOND I/O BUFFER
ETABLE    EQU       BANK2+BANKWL.     ELEMENT TABLE IF NEEDED
ETFILE    EQU       ETABLE.           ELEMENT FILE NAME.
ETELT     EQU       ETABLE+2.         ELEMENT NAME.
ETVER     EQU       ETABLE+6.         VERSION NAME.
ETETYP    EQUF      ETABLE+5,,H1.     ELEMENT TYPE.
ETELOC    EQU       ETABLE+10.        SECTOR LOCATION OF ELEMENT.
.         CALLING SEQUENCE PARAMETERS.
          ON        1-FTN.            ASSEMBLE IF FTN=0.
WORK      EQUF      *0,X11,U.         FCT ADDRESS.
ELT       EQUF      *1,X11.           FIRST WORD OF ELEMENT.
VER       EQUF      *2,X11.           VERSION NAME.
IMAGE     EQUF      *1,X11,U.         ADDRESS OF IMAGE.
MAXLEN    EQUF      *2,X11.           MAXIMUM WORDS OF IMAGE.
ICW       EQUF      *3,X11.           IMAGE CONTROL WORD.
          OFF.
          ON        FTN.              ASSEMBLE IF FTN=1.
WORK      EQUF      0,A3,H2.          FCT ADDRESS.
ELT       EQUF      1,A3,H2.          FIRST WORD OF ELEMENT.
VER       EQUF      2,A3,H2.          FIRST WORD OF VERSION.
IMAGE     EQUF      1,A3,H2.          ADDRESS OF IMAGE.
MAXLEN    EQUF      2,A3,H2.
ICW       EQUF      3,A3,H2.
          OFF.
.         RETURNS
RETO      EQUF      4*(1-FTN),X11.    RETURN FROM EORSRO.
RETR      EQUF      5*(1-FTN),X11.    RETURN FROM EORSRR.
RETC      EQUF      2*(1-FTN),X11.    RETURN FROM EORSRC.
.
/.        S = EORSRO (WORK,ELT,VER)
.
$(1),EORSRO*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET CALLING SEQUENCE ADDRESS.
          L         A0,WORK.          ADDR OF FCT.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            SETUP FCT POINTER.
          S         X11,SAVX11.       SAVE X11.
          ER        FACIL$.           IS FILE OPEN?
          L         A1,EQCODE.
          JNZ       A1,GOTFILE.       JUMP IF DEVICE CODE.
          DL        A0,('@ASG,A      ').
          DS        A0,BANK1.
          DL        A0,FCT.           GET FILE NAME.
          DS        A0,BANK1+2.
          L,U       A0,BANK1.         USE I/O BUFFER FOR CSF$ IMAGE.
          LXI,U     A0,4.             LENGTH OF CSF$ IMAGE.
          ER        CSF$.             TRY TO ASSIGN FILE.
          JN        A0,NOFILE.        ERROR EXIT.
GOTFILE   SZ        R2.               INDICATE ASSIGNABLE FILE.
          L,U       A0,R$.            SETUP I/O PACKET FOR SDFI.
          S,S2      A0,FCT+3.         FUNCTION CODE = R$.
          SZ,S1     FCT+3.            STATUS (T2 WOULD BE PSR SENSITIVE).
          L,U       A0,BANKWL.        I/O BUFFER WORD LENGTH.
          S,H1      A0,FCT+4.
          L,U       A0,BANK2.
          LXI,U     A0,BANK1.
          S         A0,FCT+6.         I/O BUFFER ADDRESSES.
          L,U       A0,BANKSL.        I/O BUFFER SECTOR LENGTH.
          S,H1      A0,FCT+7.
          L,U       A0,1.
          S,H1      A0,FCT+8.         INCREMENTOR FOR BT.
          S,H1      A0,FCT+9.         INCREMENTOR FOR BT.
          SZ        KEY.              CLEAR OPEN, TYPE.
 DO 1-FTN , DL      A0,ELT.           GET ELEMENT NAME.
 DO FTN   , L       A0,ELT.           GET ADDRESS OF ELEMENT NAME.
 DO FTN   , DL      A0,0,A0.          GET ELEMENT NAME.
          JZ        A0,NOELT.         JUMP IF SDF FILE DESIRED.
.         SETUP PFS$ PACKET.
          DS        A0,ETELT.         STORE ELEMENT NAME.
 DO 1-FTN , DL      A0,VER.           GET VERSION.
 DO FTN   , L       A0,VER.           GET ADDRESS OF VERSION.
 DO FTN   , DL      A0,0,A0.          GET VERSION.
          DS        A0,ETVER.         STORE ELEMENT VERSION.
          DL        A0,FCT.
          DS        A0,ETFILE.        STORE FILE NAME.
          L,U       A0,1.             SYMBOLIC ELEMENTS.
          S         A0,ETETYP.        STORE ELEMENT TYPE.
          S         A0,FILELT.        INDICATE ELT.
          L,U       A0,ETABLE.        ADDRESS OF PFS$ PACKET.
          ER        PFS$.             DO PROGRAM FILE SEARCH.
          JNZ       A2,PFS$ERR.       JUMP IF ERROR.
          L         A0,ETELOC.        GET ELEMENT LOCATION.
NOELT     S         A0,FCT+5.         SECTOR ADDRESS (ZERO IF FILE).
          L,U       A0,FCT.           GET FCT ADDRESS INTO A0.
          LMJ       X11,SDFIO$.       OPEN FILE.
          J         SDFIO$ERR.        ERROR RETURN.
          SZ        A5.               NORMAL RETURN.
          L,U       A0,'OPN'.
          S         A0,KEY.           INDICATE WORK OPEN.
SDFIO$ERR L         A0,A5.            GET STATUS.
EXITO     L         X11,SAVX11.       RECOVER X11.
          L         X1,SAVX1.         RECOVER X1.
          J         RETO.             RETURN.
NOFILE    L,U       A2,3.
          S         A0,R2.            STORE CSF$ STATUS.
PFS$ERR   L,U       A0,32,A2.         SHIFT PFS$ ERROR CODES.
          S         R2,FCT+2.         WORK(3) = ASSIGN STATUS OR ZERO.
          J         EXITO.
/.        S = EORSRR (WORK,IMAGE,MAXLEN,ICW)
.
$(1),EORSRR*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET ADDRESS OF CALLING SEQUENCE.
          L         A0,WORK.          GET FCT ADDRESS.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            PUT FCT ADDRESS IN X1.
          S         X11,SAVX11.       SAVE X11.
 DO FTN   , S       A3,SAVA3.         MUST SAVE A3 TO STORE ICW AFTER SAVING X11
          L,H2      A1,KEY.           IS FILE OPEN?
          TE,U      A1,'OPN'.
          J         EORSR$NOT.        JUMP IF NOT OPEN.
          L         A1,IMAGE.
          S,H2      A1,FCT+8.         STORE IMAGE ADDRESS.
 DO 1-FTN , L       A1,MAXLEN.        GET MAXIMUM IMAGE LENGTH.
 DO FTN   , L       A1,MAXLEN.        GET ADDRESS OF MAXIMUM IMAGE LENGTH.
 DO FTN   , L       A1,0,A1.          GET MAXIMUM IMAGE LENGTH.
          S,H2      A1,FCT+7.         STORE MAXIMUM IMAGE LENGTH.
          LMJ       X11,SDFI$.        READ (NOTE A0 = FCT ADDRESS).
          J         SDFI$ERR.         ERROR.
          J         SDFI$EOF.         EOF.
          L         A1,FCT+10.        GET ICW.
          SZ        A0.               NORMAL RETURN IF STATUS = 0.
          J         EXITR.
EORSR$NOT L,U       A0,36.            NOT OPEN.
          J         EXITR.
SDFI$EOF  L,U       A5,37.            STATUS CODE FOR EOF.
SDFI$ERR  L         A0,A5.            GET STATUS FROM SDFI.
EXITR     L         X11,SAVX11.       RECOVER X11.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO 1-FTN , S       A1,ICW.           STORE ICW.
 DO FTN   , L       A3,SAVA3.         RECOVER CALLING SEQUENCE ADDRESS.
 DO FTN   , L       A2,ICW.           GET ICW ADDRESS.
 DO FTN   , S       A1,0,A2.          STORE ICW.
          DSL       A1,30.
          SSL       A2,6.
          TE,U      A1,042.           ASCII/FD SWITCH?
          TNE,U     A1,050.           LABEL?
          S         A2,ASCFD.         YES, REMEMBER ASCII/FD CODE.
          L         X1,SAVX1.         RECOVER X1.
          J         RETR.             RETURN.
/.        CALL EORSRC (WORK)
.
$(1),EORSRC*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET ADDRESS OF CALLING SEQUENCE.
          L         A0,WORK.          GET FCT ADDRESS.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            PUT FCT ADDRESS IN X1.
          L,H2      A1,KEY.
          TE,U      A1,'OPN'.         IS FILE OPEN?
          J         EXITC.            NO, SIMPLY EXIT.
          SZ        KEY.
          S         X11,SAVX11.       SAVE X11.
          LMJ       X11,SDFIC$.       CLOSE SDF I/O.
          L         X11,SAVX11.       RECOVER X11.
EXITC     L         X1,SAVX1.         RECOVER X1.
          J         RETC.             RETURN.
          END.
@HDG,P EORSW/1100
@MASM,SI EORSW/1100,,,FTN
/.
.         WRITE ELEMENTS OR SDF FILES.
.
.         S = EORSWO (WORK,ELT,VER) OPENS AN ELEMENT OR SDF FILE.
.           THE FIRST TWO WORDS OF WORK MUST BE THE FILENAME.
.           ELT DETERMINES WHETHER A FILE OR ELEMENT IS TO BE WRITTEN.
.             IF THE SECOND WORD OF ELT = ZERO, THE FIRST WORD IS THE STARTING
.             SECTOR ADDRESS OF THE FILE TO BE WRITTEN, WORK MUST BE 466
.             WORDS, AND VER IS IGNORED.  IF THE SECOND WORD OF ELT IS NOT ZERO,
.             AN ELEMENT IS TO BE WRITTEN, THE ELEMENT NAME IS CONTAINED IN THE
.             TWO WORDS OF ELT, AND WORK MUST BE 474 WORDS.
.           S IS THE STATUS (DECIMAL):
.             00 = NORMAL COMPLETION,
.             1 - 32 = I/O ERROR,
.             33 = ELEMENT NOT FOUND,
.             34 = EXEC I/O ERROR,
.             35 = FILE NOT ASSIGNABLE, IN WHICH CASE WORK(3) CONTAINS
.                  THE @ASG STATUS, OR ELT NOT = ZERO AND THE FILE IS
.                  NOT A PROGRAM FILE, IN WHICH CASE WORK(3) = 0.
.             37 = PROGRAM FILE OVERFLOW.
.           IF THE FILE IS NOT ASSIGNED, IT WILL BE ASSIGNED WITH NO OPTIONS.
.
.         S = EORSWW (WORK,IMAGE,ICW) WRITES SDF FILE OR ELEMENT.
.           WORK IS AS FOR EORSWO (MUST NOT BE CHANGED BY USER),
.           IMAGE IS THE LOCATION OF THE IMAGE TO BE WRITTEN,
.           ICW IS THE SDF IMAGE CONTROL WORD (SEE PRM VOLUME 3).
.           S IS AS FOR EORSWO, PLUS ONE MORE POSSIBLE VALUE:
.             36 = FILE OR ELEMENT NOT OPENED,
.
.         S = EORSWC (WORK,CYCLIM,HICYCLE,NCYCLE) STOPS ANYNCHRONOUS I/O AND
.           RELEASES THE ASSOCIATION OF WORK AND THE FILE OR ELEMENT.
.           CYCLIM IS THE MAXIMUM NUMBER OF CYCLES TO BE RETAINED FOR THE
.             ELEMENT OR FILE.  IT SHOULD BE AT LEAST 1 PLUS THE DIFFERENCE
.             BETWEEN THE LARGEST AND SMALLEST VALUES SUPPLIED IN S4 AND S6
.             OF ANY ICW.  IF ZERO HAS BEEN USED FOR THOSE FIELDS, A DEFAULT
.             OF 5 IS RECOMMENDED FOR CYCLIM.
.           HICYCL IS THE MAXIMUM VALUE SUPPLIED IN S4 OR S6 OF ANY ICW.  IF
.             EVERY ICW CONTAINED ZERO IN THESE FIELDS, A DEFAULT VALUE OF
.             ZERO IS RECOMMENDED.
.           NCYCLE IS THE NUMBER OF CYCLES THE USER CLAIMS ARE CONTAINED IN
.             THE ELEMENT OR FILE WRITTEN.  THIS IS THE MINIMUM VALUE THE
.             USER COULD HAVE SPECIFIED FOR CYCLIM.  IF S4 AND S6 OF EVERY
.             ICW WRITTEN CONTAINED ZERO, A DEFAULT VALUE OF 1 IS RECOMMENDED.
.           S IS AS FOR EORSWW.
.
.         IF YOU WANT TO CHANGE THE ELEMENT TYPE, IT IS IN S3 OF WORK(468).
.         IF YOU WANT TO CHANGE THE ELEMENT SUBTYPE, IT IS IN S1 OF WORK(472).
.         IF YOU WANT TO CHANGE THE DATE OF CREATION, IT IS IN WORK(474),
.           THE FORMAT IS AS FROM TDATE$ SHIFTED CIRCURLARLY 18 BITS.
.         THE DEFAULT ELEMENT TYPE IS SYMBOLIC, THE DEFAULT ELEMENT SUBTYPE
.         IS UNTYPED, THE DEFAULT DATE AND TIME IS THE CURRENT DATE AND TIME.
.         CHANGES MUST BE MADE BETWEEN CALLING EORSWO AND EORSWC.
/.        DEFINITIONS.
          AXR$.                       REGISTERS, ETC.
FTN       EQU       $SS($PAR(4),1,3)='FTN'. 1 = FTN LINKAGE, 0 = FOR LINKAGE.
BANKWL    EQU       224.              WORD LENGTH OF I/O BUFFERS.
BANKSL    EQU       BANKWL//28.       SECTOR LENGTH OF I/O BUFFERS.
NX        EQUF      *0177777,*0,017.  REMOVE X REG FROM EQUFS.
.         WORK AREA
FCT       EQUF      0,X1.             SDFO WORK AREA.
EQCODE    EQUF      FCT+6,,S1.        EQUIPMENT CODE FROM FACIL$.
KEY       EQU       FCT+11.           OPEN FILE INDICATOR.
FILELT    EQUF      KEY,,S1.          0=FILE, 1=ELT.
ASCFD     EQUF      KEY,,S2.          ASCII/FD CODE
SAVX1     EQU       KEY+1.            SAVE AREA FOR X1.
SAVX11    EQU       SAVX1+1.          SAVE AREA FOR X11.
 DO FTN ,SAVA3 EQUF SAVX1+1,,H1.      SAVE AREA FOR A3.
BANK1     EQU       SAVX11+1.         FIRST I/O BUFFER.
BANK2     EQU       BANK1+BANKWL.     SECOND I/O BUFFER
ETABLE    EQU       BANK2+BANKWL.     ELEMENT TABLE IF NEEDED
ETFILE    EQU       ETABLE.           ELEMENT FILE NAME.
ETELT     EQU       ETABLE+2.         ELEMENT NAME.
ETVER     EQU       ETABLE+6.         VERSION NAME.
ETETYP    EQUF      ETABLE+5,,H1.     ELEMENT TYPE.
ETCYCL    EQU       ETABLE+8.
ETELEN    EQUF      ETABLE+9,,H2.     ELEMENT LENGTH.
ETELOC    EQU       ETABLE+10.        SECTOR LOCATION OF ELEMENT.
ETEDAT    EQU       ETABLE+11.        TIME AND DATE.
.         CALLING SEQUENCE PARAMETERS.
          ON        1-FTN.            ASSEMBLE IF FTN=0.
WORK      EQUF      *0,X11,U.         FCT ADDRESS.
ELT       EQUF      *1,X11.           FIRST WORD OF ELEMENT.
VER       EQUF      *2,X11.           VERSION NAME.
IMAGE     EQUF      *1,X11,U.         ADDRESS OF IMAGE.
ICW       EQUF      *2,X11.           IMAGE CONTROL WORD.
CYCLIM    EQUF      *1,X11.           CYCLE LIMIT.
HICYCL    EQUF      *2,X11.           HIGHEST CYCLE NUMBER.
NCYCLE    EQUF      *3,X11.           NUMBER OF CYCLES.
          OFF.
          ON        FTN.              ASSEMBLE IF FTN=1.
WORK      EQUF      0,A3,H2.          FCT ADDRESS.
ELT       EQUF      1,A3,H2.          FIRST WORD OF ELEMENT NAME.
VER       EQUF      2,A3,H2.          FIRST WORD OF VERSION
IMAGE     EQUF      1,A3,H2.          ADDRESS OF IMAGE.
ICW       EQUF      2,A3,H2.          IMAGE CONTROL WORD.
CYCLIM    EQUF      1,A3,H2.          CYCLE LIMIT.
HICYCL    EQUF      2,A3,H2.          HIGHEST CYCLE NUMBER.
NCYCLE    EQUF      3,A3,H2.          NUMBER OF CYCLES.
          OFF.
.         RETURNS
RETO      EQUF      4*(1-FTN),X11.    RETURN FROM EORSWO.
RETW      EQUF      4*(1-FTN),X11.    RETURN FROM EORSWW.
RETC      EQUF      5*(1-FTN),X11.    RETURN FROM EORSWC.
.
/.        S = EORSWO (WORK,ELT,VER)
.
$(1),EORSWO*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET CALLING SEQUENCE ADDRESS.
          L         A0,WORK.          ADDR OF FCT.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            SETUP FCT POINTER.
          S         X11,SAVX11.       SAVE X11.
          ER        FACIL$.           IS FILE OPEN?
          L         A1,EQCODE.
          JNZ       A1,FILASGD.       JUMP IF FILE ASG'D.
          L         A0,('@ASG  ').
          S         A0,ETFILE-1.
          DL        A0,FCT.
          DS        A0,ETFILE.        BUILD '@ASG  FILE'
          L,U       A0,ETFILE-1.
          LXI,U     A0,3.
          ER        CSF$.             ASSIGN FILE, IGNORE STATUS.
          JN        A0,NOFILE.        ERROR EXIT.
FILASGD   SZ        R2.               SIMULATE GOOD CSF$ STATUS.
          L,U       A0,W$.            SETUP I/O PACKET FOR SDFO.
          S,S2      A0,FCT+3.         FUNCTION CODE = R$.
          SZ,S1     FCT+3.            STATUS (T2 WOULD BE PSR SENSITIVE).
          L,U       A0,BANKWL.        I/O BUFFER WORD LENGTH.
          S,H1      A0,FCT+4.
          L,U       A0,BANK2.
          LXI,U     A0,BANK1.
          S         A0,FCT+6.         I/O BUFFER ADDRESSES.
          L,U       A0,BANKSL.        I/O BUFFER SECTOR LENGTH.
          S,H1      A0,FCT+7.
          L,U       A0,1.
          S,H1      A0,FCT+8.         INCREMENTORS FOR BT IN SDFO.
          S,H1      A0,FCT+9.
          SZ        KEY.              CLEAR OPEN, TYPE.
 DO 1-FTN , DL      A1,ELT.           GET ELEMENT NAME.
 DO FTN   , L       A1,ELT.           GET ADDRESS OF ELEMENT NAME.
 DO FTN   , DL      A1,0,A1.          GET ELEMENT NAME.
.         SETUP PFWL$ PACKET.
          DS        A1,ETELT.         STORE ELEMENT NAME.
          JZ        A2,NOELT.         JUMP IF SDF FILE DESIRED.
 DO 1-FTN , DL      A0,VER.           GET VERSION.
 DO FTN   , L       A0,VER.           GET ADDRESS OF VERSION.
 DO FTN   , DL      A0,0,A0.          GET VERSION.
          DS        A0,ETVER.         STORE ELEMENT VERSION.
          DL        A0,FCT.
          DS        A0,ETFILE.        STORE FILE NAME.
          L,U       A0,ETABLE.        ADDRESS OF PFWL$ PACKET.
          ER        PFWL$.            GET WRITE LOCATION.
          JNZ       A2,PFWL$ERR.      JUMP IF ERROR.
          L,U       A0,1.
          S         A0,ETETYP.        STORE ELEMENT TYPE=SYMBOLIC.
          S         A0,FILELT.        INDICATE ELT.
          SZ        ETEDAT.           USE CURRENT DATE AND TIME.
          SZ        ETELEN.           LENGTH IS ZERO NOW.
          S         A1,ETELOC.        STORE WRITE LOCATION IN ELT PKT.
NOELT     S         A1,FCT+5.         SECTOR ADDRESS (ZERO IF FILE).
          L,U       A0,FCT.           GET FCT ADDRESS INTO A0.
          LMJ       X11,SDFOO$.       OPEN FILE.
          L,U       A0,'OPN'.
          S         A0,KEY.           INDICATE WORK OPEN.
          SZ        A0.               INDICATE NORMAL STATUS.
EXITO     L         X11,SAVX11.       RECOVER X11.
          L         X1,SAVX1.         RECOVER X1.
          J         RETO.             RETURN.
NOFILE    L,U       A2,3.             GENERATE ERROR 35.
          S         A0,R2.            SAVE CSF$ STATUS.
PFWL$ERR  L,U       A0,32,A2.         SHIFT PFWL$ ERROR CODES.
          S         R2,FCT+2.         STORE @ASG STATUS IN WORK(3).
          J         EXITO.
/.        S = EORSWW (WORK,IMAGE,ICW)
.
$(1),EORSWW*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET CALLING SEQUENCE ADDRESS.
          L         A0,WORK.          GET FCT ADDRESS.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            PUT FCT ADDRESS IN X1.
          S         X11,SAVX11.       SAVE X11.
          L,H2      A1,KEY.           IS FILE OPEN?
          TE,U      A1,'OPN'.
          J         EORSW$NOT.        JUMP IF NOT OPEN.
          L         A1,IMAGE.
          S,H2      A1,FCT+8.         STORE IMAGE ADDRESS.
          L         A1,ICW.
 DO FTN   , L       A1,0,A1.
          S         A1,FCT+10.        STORE ICW.
          DSL       A1,30.
          SSL       A2,6.
          TE,U      A1,042.           ASCII/FD SWITCH?
          TNE,U     A1,050.           LABEL?
          S         A2,ASCFD.         YES, REMEMBER ASCII/FD CODE.
          LMJ       X11,SDFO$.        WRITE (NOTE A0 = FCT ADDRESS).
          J         SDFO$ERR.         ERROR.
          SZ        A0.               CLEAR ERROR STATUS.
          J         EXITW.
EORSW$NOT L,U       A5,36.            NOT OPEN.
SDFO$ERR  L         A0,A5.            GET STATUS FROM SDFO.
EXITW     L         X11,SAVX11.       RECOVER X11.
          L         X1,SAVX1.         RECOVER X1.
          J         RETW.             RETURN.
/.        S = EORSWC (WORK,CYCLIM,HICYCL,NCYCLE)
.
$(1),EORSWC*.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,A0.            GET CALLING SEQUENCE ADDRESS.
          L         A0,WORK.          GET FCT ADDRESS.
          S         X1,SAVX1**NX,A0.  SAVE X1.
          S         A0,X1.            PUT FCT ADDRESS IN X1.
          S         X11,SAVX11.       SAVE X11.
 DO FTN   , S       A3,SAVA3.         MUST SAVE A3 AFTER SAVING X11.
          L,H2      A1,KEY.
          SZ        KEY.              MARK WORK AREA CLOSED.
          TE,U      A1,'OPN'.         IS FILE OPEN?
          J         EORSWC$NOT.       NO, RETURN ERROR STATUS.
          LMJ       X11,SDFOC$.       CLOSE FILE / ELT
          J         SDFOC$ERR.        ERROR RETURN.
          TNZ       ETELT+1.          FILE OR ELEMENT?
          J         EORSWC$F.         FILE.
          L         A1,FCT+5.         GET NEXT SECTOR ADDRESS.
          ANU       A1,ETELOC.        COMPUTE ELEMENT LENGTH.
          SM        A2,ETELEN.        STORE IN ELT TABLE.
          L         X11,SAVX11.       RECOVER X11.
 DO 1-FTN , SZ      A3.               FOR ADDR=IND.
 DO FTN   , L       A3,SAVA3.         RECOVER CALLING SEQUENCE ADDRESS.
          L         A0,CYCLIM.        CYCLE LIMIT.
 DO FTN   , L       A0,0,A0.
          LSSL      A0,12.
 DO 1-FTN , A       A0,HICYCL.        HIGH CYCLE.
 DO FTN   , L       A2,HICYCL.        HIGH CYCLE ADDRESS.
 DO FTN   , A       A0,0,A2.          HIGH CYCLE.
          LSSL      A0,12.
 DO 1-FTN , A       A0,NCYCLE.        NUMBER OF CYCLES.
 DO FTN   , L       A2,NCYCLE.        ADDRESS OF NUMBER OF CYCLES.
 DO FTN   , A       A0,0,A2.          NUMBER OF CYCLES.
          S         A0,ETCYCL.        STORE CYCLE WORD.
          LN,U      A0,ETABLE.        A0 = - ELEMENT TABLE ADDRESS.
          ER        PFI$.             INSERT ELEMENT.
          L         A0,A2.            GET STATUS.
          JZ        A0,PFI$OK.        JUMP IF NO ERROR.
          L,U       A5,32,A2.         SHIFT STATUS CODES.
SDFOC$ERR L         A0,A5.            GET STATUS FROM PFI$ OR SDFOC$.
PFI$OK    L         X11,SAVX11.       RECOVER X11.
          L         X1,SAVX1.         RECOVER X1.
          J         RETC.             RETURN.
EORSWC$F  SZ        A0.               SET STATUS ZERO FOR FILE CLOSED OK.
          J         PFI$OK.
EORSWC$NOT L,U      A0,36.            USE S = 36 IF WORK NOT OPEN.
          J         PFI$OK.
          END.
@HDG,P EXCHAH
@FTN,SVI EXCHAH
      SUBROUTINE EXCHAH (RECORD,NCHAR)
C
C     CONVERT A RECORD MADE OF INTEGERS REPRESENTING ASCII CHARACTERS TO
C     HOLLERITH FORMAT.
C     THIS PROGRAM IS NOT MACHINE SENSITIVE.
C
C     RECORD IS THE RECORD TO BE CONVERTED.  THE HOLLERITH IS STORED
C     IN RECORD ALSO
      INTEGER RECORD(1)
C
C     NCHAR IS THE NUMBER OF CHARACTERS TO BE CONVERTED
C
      INTEGER XLATE(128)
      COMMON /EXCHXC/ XLATE
C
C
      DO 10 I=1,NCHAR
      J=RECORD(I)
10    RECORD(I)=XLATE(J+1)
      RETURN
      END
@HDG,P EXCHSL
@FTN,SVI EXCHSL
      SUBROUTINE EXCHSL
C
C     LOAD THE SEGMENT NECESSARY BEFORE THE COMPUTED GO TO ON TRANS.
C
C     EACH OF EXCHC1 THROUGH EXCHC9 SHOULD BE IN A SEPARATE
C     SEGMENT.
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      RETURN
      END
@HDG,P EXCHTR
@FTN,SVI EXCHTR
      SUBROUTINE EXCHTR (IBLOCK,OBLOCK)
C
C     TRANSFER FROM ONE COMMAND PROCESSING ROUTINE TO ANOTHER.
C
      INTEGER IBLOCK(1), OBLOCK(1)
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     OPEN READER AND PRINTER, FLAG WORKF TO BE OPENED BY EXCHC4.
C
      CALL EXCHFO (1)
      CALL EXCHFO (2)
      WORKF=-IABS(WORKF)
C
10    IF (TRANS.LE.0) RETURN
      CALL EXCHSL
C     LOAD THE SEGMENT CONTAINING THE SUBROUTINE NEEDED FOR TRANS.
      GO TO (11,12,13,14,15,16,17,18,19), TRANS
C     COMMAND PARSER
11    CALL EXCHC1 (IBLOCK,OBLOCK)
      GO TO 10
C     IDENT, INDEX, OPTION, PREDICATE, SITE, TITLE
12    CALL EXCHC2
      GO TO 10
C     OPEN INTAPE AND OUTAPE FOR -N, COPY, NAME, SKIP, UPDATE.
13    CALL EXCHC3 (IBLOCK,OBLOCK)
      GO TO 10
C     COPY AND SKIP COMMANDS, CONTROL RECORD UPDATE.
14    CALL EXCHC4 (IBLOCK)
      GO TO 10
C     COPY CONTROL RECORDS FROM INTAPE OR COMMAND TO OUTAPE.
15    CALL EXCHC5 (IBLOCK,OBLOCK)
      GO TO 10
C     COPY TEXT FROM INTAPE TO OUTAPE
16    CALL EXCHC6 (IBLOCK,OBLOCK)
      GO TO 10
C     TEXT COMMAND
17    CALL EXCHC7 (IBLOCK,OBLOCK)
      GO TO 10
C     ERROR MESSAGES
18    CALL EXCHC8
      GO TO 10
C     QUIT
19    CALL EXCHC9 (IBLOCK,OBLOCK)
      GO TO 10
      END
@HDG,P EXCHGB
@FTN,SVI EXCHGB
      SUBROUTINE EXCHGB (ISTAT,DBLOCK)
C
C     READ A BLOCK FROM THE EXCHANGE TAPE.
C     IGNORE THE ERROR CONTROL SEGMENT.
C     CHECK THE BLOCK SEQUENCE NUMBER.
C     CONVERT THE NUMBERS AT THE HEAD OF THE BLOCK.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 1 IF THE BLOCK SEQUENCE NUMBER IS WRONG.
C     ISTAT = 2 IF THE BLOCK IS TOO SHORT TO CONTAIN THE BLOCK HEADER,
C               OR IF L1PRGI OR L1RECI POINTS OUTSIDE OF THE BLOCK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT COMES FROM THE TAPE).
      INTEGER DBLOCK(1)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
C
C
C     READ A BLOCK FROM INTAPE.
C
      BLKSQI=BLKSQI+1
      ISTAT=3
      CALL EXCHRT (ISTAT,DBLOCK)
      IF (ISTAT.NE.0) GO TO 160
C
C     GET INFORMATION OUT OF THE BLOCK HEADER.
C
      CCDBI=NERRCI
      CWDBI=NWCBI*(CCDBI/NCCBI)+1
      CPCBI=MOD(CCDBI,NCCBI)
      CALL EXCHUN (DBLOCK(CWDBI),CBLCKI)
      DO 110 JUMP=1,9
      CCDBI=CCDBI+1
      CPCBI=CPCBI+1
      IF (CCDBI.GT.NCDBI) GO TO 130
      IF (CPCBI.LE.NCCBI) GO TO 10
      CWDBI=CWDBI+NWCBI
      CPCBI=1
      CALL EXCHUN (DBLOCK(CWDBI),CBLCKI)
10    GO TO (20,30,40,50,60,70,80,90,100), JUMP
20    NEWBLK=256*CBLCKI(CPCBI)
      GO TO 110
30    NEWBLK=NEWBLK+CBLCKI(CPCBI)
      GO TO 110
40    LASTI=CBLCKI(CPCBI)
      GO TO 110
50    L1PRGI=256*CBLCKI(CPCBI)
      GO TO 110
60    L1PRGI=L1PRGI+CBLCKI(CPCBI)
      GO TO 110
70    N1RECI=256*CBLCKI(CPCBI)
      GO TO 110
80    N1RECI=N1RECI+CBLCKI(CPCBI)
      GO TO 110
90    L1RECI=256*CBLCKI(CPCBI)
      GO TO 110
100   L1RECI=L1RECI+CBLCKI(CPCBI)
110   CONTINUE
C
C     CHECK THE BLOCK SEQUENCE NUMBER.
C
      IF (BLKSQI.EQ.NEWBLK) GO TO 150
      ISTAT=1
      WRITE (PRINTR,120) NEWBLK,BLKSQI
120   FORMAT (//26H0BLOCK SEQUENCE NUMBER WAS,I5,18H, SHOULD HAVE BEEN,I
     15//)
      BLKSQI=NEWBLK
      GO TO 160
C
C     FORMAT ERROR
C
130   ISTAT=2
      GO TO 160
C
C     CHECK L1PRGI AND L1RECI.
C
150   IF (L1PRGI.GT.NCDBI) GO TO 130
      IF (L1RECI.GT.NCDBI) GO TO 130
      ISTAT=0
160   RETURN
C
      END
@HDG,P EXCHGR
@FTN,SVI EXCHGR
      SUBROUTINE EXCHGR (ISTAT,DBLOCK,RECORD)
C
C     GET A RECORD FROM THE EXCHANGE TAPE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 1 IF THE BLOCK SEQUENCE NUMBER IS WRONG.
C     ISTAT = 2 IF THE BLOCK FORMAT IS WRONG (SEE GETBLK).
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C     ISTAT = 4 IF THE ACTUAL LENGTH OF THE RECORD IS GREATER THAN THE
C               SPACE ALLOWED BY THE USER.  (POSITION IS STILL OK).
C     ISTAT = 5 IF THE RECORD TYPE CANNOT BE DETERMINED.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT COMES FROM THE TAPE).
      INTEGER DBLOCK(1)
C
C     RECORD = THE USERS RECORD AREA.
      INTEGER RECORD(1)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
C
C     THE FIRST CHARACTER OF THE RECORD SEPARATES DATA RECORDS FROM
C     CONTROL RECORDS.  NON-ZERO IS THE GROUP COUNT FOR DATA RECORDS.
C
      ISTAT=0
      NCHACT=0
10    JUMP=1
      GO TO 260
20    NG=CBLCKI(CPCBI)
      IF (NG.EQ.0) GO TO 90
      IF (NG.NE.255) GO TO 30
C
C     END OF SHORT TAPE BLOCK.
C
      CCDBI=NCDBI
      GO TO 10
C
C     UNPACK (IF MODEI.EQ.0) OR COPY (IF MODEI.NE.0) A DATA RECORD TO
C     THE USER RECORD AREA.
C
30    ITYPEI=0
      IF (MODEI.EQ.0) GO TO 40
      NCHACT=NCHACT+1
      IF (NCHACT.LE.NCHMAX) RECORD(NCHACT)=NG
40    IG=0
50    JUMP=2
      GO TO 260
60    NR=CBLCKI(CPCBI)
      IF (MODEI.EQ.0) GO TO 70
      NCHACT=NCHACT+1
      IF (NCHACT.LE.NCHMAX) RECORD(NCHACT)=NR
      GO TO 160
70    IR=0
C     PUT REMVI INTO THE USER RECORD NR TIMES.
80    IF (IR.GE.NR) GO TO 160
      NCHACT=NCHACT+1
      IF (NCHACT.LE.NCHMAX) RECORD(NCHACT)=REMVI
      IR=IR+1
      GO TO 80
C
C     THE NEXT RECORD IS A CONTROL RECORD.  FIND OUT WHAT KIND.
C
90    JUMP=3
      GO TO 260
100   ITYPEI=CBLCKI(CPCBI)
      IF (ITYPEI.LT.65) GO TO 250
C     65 = ASCII  A
      IF (ITYPEI.GT.90) GO TO 250
C     90 = ASCII  Z
      I=ITYPEI-64
C             A   B   C   D   E   F   G   H   I   J   K   L   M   N   O
      GO TO (160,160,160,160,290,160,160,160,160,220,160,160,160,160,160
     1,110,160,220,160,160,160,160,160,160,160,160), I
C       P   Q   R   S   T   U   V   W   X   Y   Z
C
C     P - PROGRAM HEADER
C
C     CONVERT THE NEXT HEADER ADDRESS AND THE PROGRAM NUMBER
110   REMVI=32
C     RESET THE REMOVED CHARACTER TO ASCII BLANK.
      JUMP=4
      GO TO 260
120   L1PRGI=256*CBLCKI(CPCBI)
      JUMP=5
      GO TO 260
130   L1PRGI=L1PRGI+CBLCKI(CPCBI)
      JUMP=6
      GO TO 260
140   N1RECI=256*CBLCKI(CPCBI)
      JUMP=7
      GO TO 260
150   N1RECI=N1RECI+CBLCKI(CPCBI)
C
C     A - AUTHOR
C     B - BIBLIOGRAPHIC REFERENCE
C     C - COMMENTS
C     D - DATA TYPE
C     G - GROUPS
C     I - INCLUDE TEXT REQUEST
C     K - KEYWORDS
C     M - MACHINE
C     O - ORIGINATING SITE
C     S - UPDATING SITE
C     FHLNQTUVWXYZ - UNSPECIFIED TYPES
C
160   JUMP=8
      GO TO 260
170   NC=CBLCKI(CPCBI)
      IF (ITYPEI.NE.0) GO TO 180
      IF (MODEI.EQ.0) GO TO 180
      NCHACT=NCHACT+1
      IF (NCHACT.LE.NCHMAX) RECORD(NCHACT)=NC
C     COPY NC CHARACTERS TO THE USER RECORD AREA.
180   IC=0
      JUMP=9
190   IF (IC.GE.NC) IF (ITYPEI) 240,210,240
      GO TO 260
200   NCHACT=NCHACT+1
      IF (NCHACT.LE.NCHMAX) RECORD(NCHACT)=CBLCKI(CPCBI)
      IC=IC+1
      GO TO 190
210   IG=IG+1
      IF (IG-NG) 50,240,240
C
C     J - UPDATING AND END OF INPUT TEXT SIGNAL.
C     R - CHANGE REMOVED CHARACTER.
C
220   JUMP=10
      GO TO 260
230   RECORD(1)=CBLCKI(CPCBI)
      NCHACT=1
      IF (ITYPEI.EQ.82) REMVI=RECORD(1)
C     82 = ASCII R
C
C     RETURN TO THE USER PROGRAM.
C
240   IF (NCHACT.GT.NCHMAX) ISTAT=4
      GO TO 290
C
C     CONTROL RECORD TYPE CANNOT BE DETERMINED.
C
250   ISTAT=5
      GO TO 290
C
C     GET A CHARACTER FROM CBLOCK.  UNPACK A NEW BLOCK IF NECESSARY.
C     READ MORE TAPE IF NECESSARY.
C
260   CPCBI=CPCBI+1
      CCDBI=CCDBI+1
      IF (CCDBI.LE.NCDBI) GO TO 270
      CALL EXCHGB (ISTAT,DBLOCK)
      IF (ISTAT) 290,260,290
270   IF (CPCBI.LE.NCCBI) GO TO 280
      CWDBI=CWDBI+NWCBI
      CPCBI=1
      CALL EXCHUN (DBLOCK(CWDBI),CBLCKI)
280   GO TO (20,60,100,120,130,140,150,170,200,230), JUMP
290   RETURN
C
      END
@HDG,P EXCHNP
@FTN,SVI EXCHNP
      SUBROUTINE EXCHNP (ISTAT,DBLOCK)
C
C     SET POINTERS TO READ THE NEXT PROGRAM HEADER FROM THE EXCHANGE
C     TAPE.
C     THIS MODULE IS MACHINE INSENSITIVE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 7 IF THERE ARE NO MORE PROGRAM HEADERS IN THE FILE.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT COMES FROM THE TAPE).
      INTEGER DBLOCK(1)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      IF (IABS(NRWORK)*WORKF.GT.0) REWIND WORKF
      NRWORK=MIN0(NRWORK,0)
      ISTAT=0
      IF (CCDBI.GE.NCDBI) IF (LASTI-76) 20,30,20
C
C     CHECK FOR END OF FILE OR LAST HEADER IN THE BLOCK.
C
10    IF (L1PRGI.EQ.0) IF (LASTI-76) 20,30,20
C     76 = ASCII L
C
C     NEITHER END OF FILE NOR LAST HEADER IN THE BLOCK.
      CCDBI=L1PRGI-1
      I=NWCBI*(CCDBI/NCCBI)+1
      IF (I.NE.CWDBI) CALL EXCHUN (DBLOCK(I),CBLCKI)
      CWDBI=I
      CPCBI=MOD(CCDBI,NCCBI)
      GO TO 40
C
C     NO MORE HEADERS IN THIS BLOCK.
C
20    CALL EXCHGB (ISTAT,DBLOCK)
      IF (ISTAT) 40,10,40
C
C     END OF FILE.
C
30    ISTAT=7
C
40    RETURN
C
      END
@HDG,P EXCHPB
@FTN,SVI EXCHPB
      SUBROUTINE EXCHPB (ISTAT,DBLOCK)
C
C     WRITE A BLOCK ONTO THE EXCHANGE TAPE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT IS TO BE WRITTEN ONTO
C              TAPE).
      INTEGER DBLOCK(1)
C     WORK = THE NINE STRUCTURE CHARACTERS OF THE BLOCK.
      INTEGER WORK(9)
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
C
C     PUT ERROR RECOVERY AND TABLE OF CONTENTS NUMBERS INTO BLOCK.
C
      BLKSQO=BLKSQO+1
      WORK(1)=BLKSQO/256
      WORK(2)=MOD(BLKSQO,256)
      WORK(3)=LASTO
      WORK(4)=L1PRGO/256
      WORK(5)=MOD(L1PRGO,256)
      WORK(6)=N1RECO/256
      WORK(7)=MOD(N1RECO,256)
      WORK(8)=L1RECO/256
      WORK(9)=MOD(L1RECO,256)
C
      CPCBO=MOD(NERRCO,NCCBO)
      CWDBO=(NERRCO/NCCBO)*NWCBO
      CALL EXCHUN (DBLOCK(CWDBO+1),CBLCKO)
C
      DO 10 I=1,9
      CPCBO=CPCBO+1
      IF (CPCBO.LE.NCCBO) GO TO 10
      CALL EXCHPA (CBLCKO,DBLOCK(CWDBO+1))
      CWDBO=CWDBO+NWCBO
      CALL EXCHUN (DBLOCK(CWDBO+1),CBLCKO)
      CPCBO=1
10    CBLCKO(CPCBO)=WORK(I)
      CALL EXCHPA (CBLCKO,DBLOCK(CWDBO+1))
C
C     WRITE THE DATA BLOCK ON TAPE.
C
      ISTAT=2
      CALL EXCHWT (ISTAT,DBLOCK)
C
C     CLOSE THE OUTPUT TAPE IF LASTO=76 (ASCII L).
C
      IF (LASTO.NE.76) GO TO 20
      ISTAT=3
      CALL EXCHWT (ISTAT,DBLOCK)
      GO TO 30
C
C     COMPUTE POINTERS FOR NEXT BLOCK OUT.
C
20    L1PRGO=0
      LLPRGO=0
      N1RECO=0
      L1RECO=0
      CCDBO=NERRCO+10
      CWDBO=NWCBO*((CCDBO-1)/NCCBO)+1
      CPCBO=MOD(CCDBO-1,NCCBO)+1
C
30    RETURN
C
      END
@HDG,P EXCHPR
@FTN,SVI EXCHPR
      SUBROUTINE EXCHPR (ISTAT,DBLOCK,RECORD)
C
C     WRITE A RECORD ONTO THE EXCHANGE TAPE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C     ISTAT = 4 IF A SINGLE TEXT STRING EXCEEDS 255 CHARACTERS, OR A
C             TEXT RECORD CONTAINS MORE THAN 254 GROUPS.
C     ISTAT = 5 IF THE RECORD TYPE CANNOT BE DETERMINED.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT IS TO BE WRITTEN ONTO
C              TAPE).
      INTEGER DBLOCK(1)
C
C     RECORD = THE USERS RECORD AREA.
      INTEGER RECORD(1)
C
      INTEGER GC,RC(255),CC(255)
C     GC = GROUP COUNT, RC = REMOVED COUNT, CC = CHARACTER COUNT
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
C
      ISTAT=0
      INCHAR=0
C
C     DETERMINE THE RECORD TYPE.
C
      IF (NCHOUT.NE.255) GO TO 10
      ITYPEO=255
      GO TO 70
10    IF (N1RECO.EQ.0) N1RECO=NLRECO
      IF (L1RECO.EQ.0) L1RECO=CCDBO-NERRCO
      IF (ITYPEO.NE.0) GO TO 30
C
C     DATA RECORD.
C
      IF (MODEO.NE.0) GO TO 170
C     COMPRESS THE RECORD.
      CALL EXCHSC (RECORD,NCHOUT,REMVO,GC,RC,CC,255)
      IF (GC.GE.255) GO TO 210
      IG=0
C     OUTPUT THE GROUP COUNT.
      CBLCKO(CPCBO)=GC
      JUMP=1
      GO TO 230
20    IG=IG+1
      IF (IG.GT.GC) GO TO 250
      NC=CC(IG)
      INCHAR=INCHAR+RC(IG)
C     OUTPUT REMOVED CHARACTER COUNT.
      CBLCKO(CPCBO)=RC(IG)
      JUMP=2
      GO TO 230
C
C     THE USER SAYS HE HAS A CONTROL RECORD TO WRITE.  FIND OUT
C     WHAT KIND.
C
30    IF (ITYPEO.LT.65) GO TO 220
C     65 = ASCII A
      IF (ITYPEO.GT.90) GO TO 220
C     90 = ASCII  Z
      I=ITYPEO-64
C             A  B  C  D  E  F  G  H  I  J   K  L  M  N  O  P  Q  R   S
      GO TO (40,40,40,40,50,40,40,40,40,200,40,40,40,40,40,60,40,200,40,
     140,40,40,40,40,40,40), I
C      T  U  V  W  X  Y  Z
C
C     A - AUTHOR
C     B - BIBLIOGRAPHIC REFERENCE
C     C - COMMENTS
C     D - DATA TYPE
C     G - GROUPS
C     I - INCLUDE TEXT REQUEST
C     K - KEYWORDS
C     M - MACHINE TYPE
C     O - ORIGINATING SITE
C     S - UPDATING SITE
C     FHLNQTUVWXYZ - UNSPECIFIED TYPES
C
40    IF (NCHOUT-255) 100,100,210
C
C     END OF FILE.
C
50    IF (NERRCO+NDATAO+7-CCDBO) 70,80,80
C
C     P - PROGRAM HEADER.
C
60    IF (NCHOUT.GT.255) GO TO 210
      REMVO=32
C     RESET REMOVED CHARACTER TO ASCII BLANK.
      IF (MOD(NLRECO,10).NE.9) IF (NDATAO+NERRCO-CCDBO) 70,80,80
      IF (CCDBO.EQ.NERRCO+10) GO TO 80
C
C     END OF SHORT TAPE BLOCK.
C
70    CBLCKO(CPCBO)=255
      CALL EXCHPA (CBLCKO,DBLOCK(CWDBO))
      CALL EXCHPB (ISTAT,DBLOCK)
      IF (ISTAT+LASTO+IABS((ITYPEO-80)*(ITYPEO-69)).NE.0) GO TO 250
C     69 = ASCII E
C     80 = ASCII P
      L1RECO=CCDBO-NERRCO
80    IF (LLPRGO.EQ.0) GO TO 90
C     LINK THIS PROGRAM HEADER TO THE PREVIOUS ONE IN THIS BLOCK.
      CALL EXCHPA (CBLCKO,DBLOCK(CWDBO))
      NC=MOD(LLPRGO+1,NCCBO)
      NW=((LLPRGO+1)/NCCBO)*NWCBO
      CALL EXCHUN (DBLOCK(NW+1),CBLCKO)
      CBLCKO(NC+1)=CCDBO/256
      IF (NC+1.LT.NCCBO) GO TO 85
      CALL EXCHPA (CBLCKO,DBLOCK(NW+1))
      NW=NW+NWCBO
      CALL EXCHUN (DBLOCK(NW+1),CBLCKO)
      NC=-1
85    CBLCKO(NC+2)=MOD(CCDBO,256)
      CALL EXCHPA (CBLCKO,DBLOCK(NW+1))
      CALL EXCHUN (DBLOCK(CWDBO),CBLCKO)
C     UPDATE TABLE OF CONTENTS POINTERS
90    LLPRGO=CCDBO
      IF (L1PRGO.EQ.0) L1PRGO=CCDBO-NERRCO
      NLRECO=NLRECO+1
      IF (N1RECO.EQ.0) N1RECO=NLRECO
100   CBLCKO(CPCBO)=0
      JUMP=3
      GO TO 230
110   CBLCKO(CPCBO)=ITYPEO
      JUMP=4
      GO TO 230
120   IF (ITYPEO.NE.69) GO TO 130
C     69 = ASCII E
      LASTO=76
      GO TO 70
130   IF (ITYPEO.NE.80) GO TO 170
C     80 = ASCII P
      CBLCKO(CPCBO)=0
      JUMP=5
      GO TO 230
140   CBLCKO(CPCBO)=0
      JUMP=6
      GO TO 230
150   CBLCKO(CPCBO)=NLRECO/256
      JUMP=7
      GO TO 230
160   CBLCKO(CPCBO)=MOD(NLRECO,256)
      JUMP=8
      GO TO 230
C
170   NC=NCHOUT
180   CBLCKO(CPCBO)=NC
      IC=0
      JUMP=9
C     PUT OUT TEXT STRING LENGTH IF NOT 'R' OR 'J' RECORD.
      IF (ITYPEO.EQ.82) GO TO 190
      IF (ITYPEO.EQ.74) GO TO 190
      IF (ITYPEO.NE.0.OR.MODEO.EQ.0) GO TO 230
190   IF (IC.GE.NC) IF (ITYPEO+IABS(MODEO)) 250,20,250
      INCHAR=INCHAR+1
      IC=IC+1
      CBLCKO(CPCBO)=RECORD(INCHAR)
      GO TO 230
C
C     J - UPDATING AND END OF TEXT SIGNAL.
C     R - CHANGE REMOVED CHARACTER.
C
200   NCHOUT=1
      IF (ITYPEO.EQ.82) REMVO=RECORD(1)
C     82 = ASCII R
      GO TO 100
C
C     RECORD TOO LONG.
C
210   ISTAT=4
      GO TO 250
C
C     UNKNOWN CONTROL RECORD TYPE.
C
220   ISTAT=5
      GO TO 250
C
C     INCREMENT THE OUTPUT BUFFER POINTERS.  PACK A CHARACTER BLOCK
C     IF NECESSARY.  WRITE A TAPE BLOCK IF NECESSARY.
C
230   CPCBO=CPCBO+1
      CCDBO=CCDBO+1
      IF (CPCBO.LE.NCCBO) GO TO 240
      CALL EXCHPA (CBLCKO,DBLOCK(CWDBO))
      CWDBO=CWDBO+NWCBO
      CPCBO=1
      IF (CCDBO.LT.NERRCO+NDATAO+10) GO TO 240
      CALL EXCHPB (ISTAT,DBLOCK)
      IF (ISTAT.NE.0) GO TO 250
240   GO TO (20,180,110,120,140,150,160,170,190), JUMP
250   RETURN
C
      END
@HDG,P EXCHSC
@FTN,SVI EXCHSC
      SUBROUTINE EXCHSC (INPIMG,IMGLEN,REMOVE,GC,RC,SC,MAXSL)
C
C     SCAN THE INPUT IMAGE AND COUNT CONSECUTIVE OCCURRENCES OF THE
C     DATA TO BE REMOVED.  DIVIDE DATA INTO GROUPS CONSISTING OF
C     STRINGS OF DATA TO BE REMOVED FOLLOWED BY STRINGS OF SIGNIFICANT
C     DATA.  THE NUMBER OF SUCH GROUPS IS RECORDED IN GC, AND THE
C     REMOVED DATA COUNT AND SIGNIFICANT DATA COUNT FOR EACH GROUP
C     ARE RECORDED IN RC() AND SC() RESPECTIVELY.  MAXSL IS THE
C     MAXIMUM STRING LENGTH WHICH WILL BE PLACED IN RC() OR SC().
C
      INTEGER INPIMG(1),IMGLEN,REMOVE,GC,RC(1),SC(1),MAXSL
C
C     RC AND SC MUST BE AT LEAST (IMGLEN-1)//3.
C
      GC=1
      SC(1)=0
      RC(1)=0
      MODE=-1
      INPLEN=IABS(IMGLEN)
C
C     IDENTIFY DATA GROUPS.
C
      DO 110 I=1,INPLEN
      IF (MODE) 40,60,90
C
C     MODE.LT.0 MEANS WORKING ON A STRING OF REMOVE.
C
40    IF (INPIMG(I).EQ.REMOVE) GO TO 50
C     SWITCH TO SIGNIFICANT DATA SCAN.
      MODE=1
      SC(GC)=1
      GO TO 110
C     CONTINUE REMOVE SCAN
50    RC(GC)=RC(GC)+1
      IF (RC(GC)-MAXSL) 110,95,110
C
C     MODE = 0 MEANS WORKING ON A SIGNIFICANT DATA STRING FOLLOWED BY
C     ONE OCCURRENCE OF REMOVE.  CHANGE TO REMOVE MODE IF ANOTHER REMOVE
C     OCCURS OR BACK TO DATA MODE IF NOT.
C
60    IF (INPIMG(I).EQ.REMOVE) GO TO 80
C     SINGLE REMOVE EMBEDDED IN SIGNIFICANT DATA STRING - IGNORE IT.
      MODE=1
      IF (SC(GC).GE.MAXSL-2) GO TO 70
      SC(GC)=SC(GC)+2
      GO TO 110
C     FULL GROUP
70    GC=GC+1
      RC(GC)=1
      SC(GC)=1
      GO TO 110
C     SWITCH TO REMOVE MODE.
80    GC=GC+1
      SC(GC)=0
      RC(GC)=2
      MODE=-1
      GO TO 110
C
C     MODE.GT.0 MEANS WORKING ON A STRING OF SIGNIFICANT DATA.
C
90    IF (INPIMG(I).EQ.REMOVE) GO TO 100
      SC(GC)=SC(GC)+1
      IF (SC(GC).NE.MAXSL) GO TO 110
C     FULL GROUP
      MODE=-1
95    IF (I.GE.INPLEN) GO TO 120
      GC=GC+1
      RC(GC)=0
      SC(GC)=0
      GO TO 110
100   MODE=0
110   CONTINUE
120   RETURN
C
      END
@HDG,P EXCHTP
@FTN,SVI EXCHTP
      SUBROUTINE EXCHTP (RECORD,LINEI)
C
C     MATERIALIZE INCLUDES IF INALT IS NON-ZERO.
C     CALL EXCHTW TO WRITE RECORDS ON THE NATIVE FORMAT FILE
C     AND THE PRINTER IF LISTING IS REQUESTED.
C     LINEI IS THE LINE NUMBER FROM THE INPUT MODULE, OR ZERO FOR
C     NEW TEXT.
C
      INTEGER RECORD(1),LINEI
C
C     *****     LOCAL VARIABLES     ************************************
C
C COPY    DENOTES WHETHER COPYING TEXT, SEARCHING FOR TARGET, OR
C         SKIPPING TEXT NOT TO BE INCLUDED.
      INTEGER COPY
C DASH    CONTAINS '-' IN HOLLERITH.
      INTEGER DASH
C ENDMRK  HOLDS THE END SENTINEL.
      INTEGER ENDMRK(40)
C NCHEND  IS THE NUMBER OF CHARACTERS IN ENDMRK.
      INTEGER NCHEND
C NCHSAV  SAVES NCHCMD BECAUSE EXCHIM CLOBBERS NCHCMD.
      INTEGER NCHSAV
C NCHTAR  IS THE NUMBER OF CHARACTERS IN TARGET.
      INTEGER NCHTAR
C STAR    CONTAINS '*' IN HOLLERITH.
       INTEGER STAR
C TARGET  IS THE SEARCH TARGET (INCLUDE BLOCK IDENTITY).
      INTEGER TARGET(40)
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     LOCAL DATA     ***************************************
C
      DATA DASH /1H-/, STAR /1H*/
C
C     *****     PROCEDURES     *****************************************
C
      LINEO=LINEO+1
      IF (OUFILE+OPTL.EQ.0.AND.(OPTS.EQ.0.OR.PHASE.LT.4)) GO TO 190
      RECORD(180)=LINEO
      RECORD(179)=LINEI
      COPY=-1
C     COPY=-1 MEANS NOT COPYING INCLUDED TEXT.
      IF (ITYPEO.EQ.0) GO TO 110
C     PROCESS INCLUDE RECORD.
      DO 10 I=1,NCHOUT
10    RECORD(NCHOUT+4-I)=RECORD(NCHOUT+1-I)
C     INSERT '-I '.
      RECORD(1)=45
      RECORD(2)=73
      RECORD(3)=32
      NCHOUT=NCHOUT+3
      IF (INALT*(OUFILE+OPTI).EQ.0) GO TO 110
C     STORE SEARCH TARGET
      NCHTAR=MIN0(NCHOUT,40)
      DO 20 I=1,NCHTAR
20    TARGET(I)=RECORD(I)
C     STORE COMAND AND NCHCMD (EXCHC6 STILL NEEDS THEM).
      NCHSAV=NCHCMD
      DO 30 I=1,NUMBER
30    OUTREC(I)=COMAND(I)
      COPY=0
C     COPY=0 MEANS SKIPPING MODULE ON INALT FILE.
      INALT=IABS(INALT)
      NEOF=0
40    CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 130
      IF (NCHCMD.LT.2) GO TO 40
      IF (COMAND(1).NE.45) GO TO 40
C     45 = ASCII -
      IF (COMAND(2).EQ.45) GO TO 130
      IF (COMAND(2).NE.73.AND.COMAND(2).NE.105) GO TO 40
C     73 = ASCII I, 105 = ASCII LOWER CASE I.
C     COMPARE IMAGE WITH SEARCH TARGET.
      IF (MIN0(NCHCMD,40).NE.NCHTAR) GO TO 60
      DO 50 I=2,NCHTAR
      K=COMAND(I)
      IF (K.GT.96 .AND. K.LT.123) K=K-32
      IF (TARGET(I).NE.K) GO TO 60
50    CONTINUE
      NEOF=3
C     PREVENT SEARCH LOOP.
      COPY=1
C     COPY=1 MEANS COPYING INCLUDED TEXT.
60    CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 130
C     STORE END OF INCLUDE MODULE SIGNAL.
      NCHEND=MIN0(40,NCHCMD)
      DO 70 I=1,NCHEND
70    ENDMRK(I)=COMAND(I)
      IF (COPY.EQ.0) GO TO 80
      CHAR1L=DASH
      NCHOUT=NCHTAR
      DO 75 I = 1,NCHOUT
75    COMAND(I)=TARGET(I)
      COMAND(180)=LINEO
      COMAND(179)=LINEI
C     GO PRINT TARGET.
      CALL EXCHTW (COMAND,-1)
      GO TO 120
C     COPY OR SKIP UNTIL ENDMRK SEEN AGAIN.
80    CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 130
C     BODY OF INCLUDE MAY NOT CONTAIN EOF IF EXCHIM CANNOT DETECT EOF.
C     TEST FOR ENDMRK
      DO 90 I=1,NCHEND
      IF (ENDMRK(I).NE.COMAND(I)) IF (COPY) 100,80,100
90    CONTINUE
      IF (COPY) 140,40,140
C     OUTPUT TEXT RECORD.
100   COMAND(180)=LINEO
      COMAND(179)=LINEI
      NCHOUT=NCHCMD
      CALL EXCHTW (COMAND,OPTI)
      GO TO 120
C     OUTPUT TEXT RECORD.
110   CALL EXCHTW (RECORD,1)
120   IF (COPY) 190,190,80
C     WE ONLY GET HERE WITH COPY .GE. 0.
130   NEOF=NEOF+1
      ACTION=2
C     ACTION = 2 MEANS REOPEN INALT.
      CALL EXCHIM
      IF (NEOF.LT.2) GO TO 40
140   INALT=-IABS(INALT)
      NCHCMD=1
      IF (COPY.GT.0) GO TO 170
C     PROCESS TARGET AS THOUGH IT WERE TEXT.
      NCHOUT=NCHTAR
C     SAVE TARGET FOR ERROR MESSAGE.
      DO 150 I=1,NCHTAR
150   COMAND(I)=TARGET(I)
      CALL EXCHTW (COMAND,1)
      CALL EXCHAH (TARGET,NCHTAR)
      WRITE (PRINTR,160) (TARGET(I),I=1,NCHTAR)
160   FORMAT (//47H0SEARCH TARGET CANNOT BE FOUND ON INCLUDE FILE./(1X,8
     10A1))
      NERRS=MAX0(NERRS,3)
C
C     RESTORE COMAND AND NCHCMD (EXCHC6 STILL NEEDS THEM).
C
170   NCHCMD=NCHSAV
      DO 180 I=1,NUMBER
180   COMAND(I)=OUTREC(I)
C
190   CHAR1L=STAR
      RETURN
C
      END
@HDG,P EXCHTW
@FTN,SVI EXCHTW
      SUBROUTINE EXCHTW (RECORD,OPTION)
C
C     WRITE RECORD ON THE NATIVE FORMAT OUTPUT FILE BY CALLING
C     EXCHOU.  WRITE RECORD ON THE PRINTER IF LISTING REQUESTED.
C     RECORD(179) IS THE LINE NUMBER FROM THE INPUT MODULE, OR ZERO FOR
C     NEW TEXT.
C     IF OPTION = ZERO, WRITE TO FILE ONLY.
C     IF OPTION .GT. ZERO, WRITE TO FILE AND LISTING.
C     IF OPTION .LT. ZERO, WRITE TO LISTING ONLY.
C
      INTEGER RECORD(1),OPTION
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     PROCEDURES     *****************************************
C
      LINEI=RECORD(179)
      IF (OPTION.LT.0) GO TO 130
C
C     INSERT IDENTIFICATION IF REQUESTED.
C
      IF (IDCOL2.LT.IDCOL1) GO TO 120
      IF (IDTXTL+IDSTEP.EQ.0) GO TO 120
      IF (NCHOUT.GE.IDCOL2) GO TO 20
      J=IDCOL2-1
C     FILL END OF RECORD WITH BLANKS IF NCHOUT .LT. IDCOL2
      DO 10 I=NCHOUT,J
10    RECORD(I+1)=32
C     32 = ASCII BLANK.
20    NCHOUT=MAX0(NCHOUT,IDCOL2)
      N=-1
      IF (LINEI.EQ.0) GO TO 40
      IF (IDOPTN.NE.73) GO TO 40
C     73 = ASCII I.  IDENTIFY ONLY FROM INTAPE.
      N=(LINEI-1)*IDSTEP+IDSTRT
      GO TO 70
40    IF (IDOPTN.NE.79) GO TO 50
C     79 = ASCII O.  IDENTIFY ONLY TO OUTAPE.
      N=(LINEO-1)*IDSTEP+IDSTRT
      GO TO 70
50    IF (IDOPTN.NE.67.AND.IDOPTN.NE.70) GO TO 70
C     67 = ASCII C, 70 = ASCII F.  IDENTIFY EVERYTHING.
      N=IDCUR
70    IF (N.LT.0) GO TO 120
      IF (IDTXTL.EQ.0) GO TO 100
      J=MIN0(IDCOL2,IDTXTL+IDCOL1-1)
      K=1
      DO 80 I=IDCOL1,J
      RECORD(I)=IDTEXT(K)
80    K=K+1
100   IF (IDSTEP.EQ.0) GO TO 120
      IDCUR=IDCUR+IDSTEP
      K=IDCOL2
110   RECORD(K)=MOD(N,10)+48
      N=N/10
      K=K-1
      IF (N.EQ.0) GO TO 120
      IF (K.GE.IDCOL1) GO TO 110
C
C     OUTPUT RECORD.
C
120   IF (OUFILE.NE.0) CALL EXCHOU (RECORD)
      IF (OPTION.EQ.0) GO TO 220
130   IF (OPTL.NE.0) GO TO 140
      IF (PHASE.LT.4.OR.OPTS.EQ.0) GO TO 220
140   CALL EXCHAH (RECORD,NCHOUT)
      IF (OPTV+VERT.NE.0) GO TO 200
      IF (PHASE.NE.8) GO TO 180
      IF (LINEI.EQ.0) GO TO 160
      WRITE (PRINTR,150) LINEI,LINEO,CHAR1L,(RECORD(I),I=1,NCHOUT)
150   FORMAT (1X,2I5,A1,3X,105A1/(6H  CONT,9X,105A1))
      GO TO 220
160   WRITE (PRINTR,170) LINEO,CHAR1L,(RECORD(I),I=1,NCHOUT)
170   FORMAT (5H  NEW,I6,A1,3X,105A1/(6H  CONT,9X,105A1))
      GO TO 220
180   WRITE (PRINTR,190) LINEO,CHAR1L,(RECORD(I),I=1,NCHOUT)
190   FORMAT (1X,I5,A1,3X,110A1/(6H  CONT,4X,110A1))
      GO TO 220
200   WRITE (PRINTR,210) (RECORD(I),I=1,NCHOUT)
210   FORMAT (132A1)
220   RETURN
C
      END
@HDG,P EXCHC1
@FTN,SVI EXCHC1
      SUBROUTINE EXCHC1 (IBLOCK,OBLOCK)
C
C     COMMAND DECODER AND FORMAT VERIFIER.  SOME COMMANDS ARE ALSO
C     COMPLETELY PROCESSED HERE.
C
C     IBLOCK AND OBLOCK ARE TAPE I/O BLOCKS.
C
      INTEGER IBLOCK(1),OBLOCK(1)
C
C
C     *****     LOCAL VARIABLES     ************************************
C
C ALLOW   TABLE TO DETERMINE WHETHER A COMMAND IS ALLOWED.  VALUES ARE
C         SUMS OF PERMITTED VALUES OF PHASE.
C         1 = INITIALIZATION, 2 = BETWEEN PROGRAMS, 4 = INSERTING,
C         8 = UPDATING.
C         ALSO STORED IN THIS TABLE ARE FLAGS INDICATING WHETHER A
C         PARAMETER STRING MAY BE ENTIRELY ABSENT (NO EQUAL SIGN), OR
C         MAY BE VOID (EQUAL SIGN IS LAST CHARACTER).
C         32 = PARAMETER MAY BE VOID, 64 = PARAMETER MAY BE ABSENT.
      INTEGER ALLOW(35)
C BLANK   A CONSTANT.  1H .
      INTEGER BLANK
C DATE    IS THE DATE FROM UPDA=, DATE=, ORIG=.
      INTEGER DATE(3)
C DAYS    TABLE OF DAYS PER MONTH TO VERIFY DATE FIELDS.
      INTEGER DAYS(12)
C I       IS USED FREELY AS AN INDEX.
C J       IS USED FREELY AS AN INDEX.
C JUMP    USED TO CONTROL COMMUNICATION WITH AN INTERNAL SUBROUTINE.
C K       IS USED FREELY AS AN INDEX.
C KDATE   IS THE INDEX OF THE DATE COMMAND IN THE COMMAND TABLE (COMD).
C KQUIT   IS THE INDEX OF THE QUIT COMMAND IN THE COMMAND TABLE (COMD).
C KTEXT   IS THE INDEX OF THE TEXT COMMAND IN THE COMMAND TABLE (COMD).
C N       IS USED FREELY AS AN INDEX.
C NCNREC  IS THE NUMBER OF CONSECUTIVE NON RECOGNIZED COMMANDS.
C ND      IS USED DURING ANALYSIS OF DATES TO HOLD THE DAY NUMBER.
C NM      IS USED DURING ANALYSIS OF DATES TO HOLD THE MONTH NUMBER.
C NY      IS USED DURING ANALYSIS OF DATES TO HOLD THE YEAR NUMBER.
C TVAL    A VECTOR OF VALUES FOR TRANS.  INDEXED BY ICOMD.
      INTEGER TVAL(35)
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     LOCAL EQUIVALENCE     **********************************
C
      EQUIVALENCE (DATE(1),NY), (DATE(2),NM), (DATE(3),ND)
C
C     *****     DATA STATEMENTS     ************************************
C
      DATA ALLOW(1),ALLOW(2),ALLOW(3),ALLOW(4) /12,12,3,4/
      DATA ALLOW(5),ALLOW(6),ALLOW(7),ALLOW(8) /15,12,35,15/
      DATA ALLOW(9),ALLOW(10),ALLOW(11),ALLOW(12) /3,3,12,15/
      DATA ALLOW(13),ALLOW(14),ALLOW(15),ALLOW(16) /12,47,4,3/
      DATA ALLOW(17),ALLOW(18),ALLOW(19),ALLOW(20) /3,79,15,79/
      DATA ALLOW(21),ALLOW(22),ALLOW(23),ALLOW(24) /15,12,36,67/
      DATA ALLOW(25),ALLOW(26),ALLOW(27),ALLOW(28) /47,3,76,47/
      DATA ALLOW(29),ALLOW(30),ALLOW(31),ALLOW(32) /15,3,12,47/
      DATA ALLOW(33),ALLOW(34),ALLOW(35) /47,12,1/
      DATA BLANK /1H /
      DATA DAYS(1),DAYS(2),DAYS(3),DAYS(4),DAYS(5) /31,0,31,30,31/
      DATA DAYS(6),DAYS(7),DAYS(8),DAYS(9),DAYS(10) /30,31,31,30,31/
      DATA DAYS(11),DAYS(12) /30,31/
      DATA KDATE /5/
      DATA KQUIT /20/
      DATA KTEXT /27/
      DATA TVAL(01),TVAL(02),TVAL(03),TVAL(04),TVAL(05) /5,5,3,5,1/
      DATA TVAL(06),TVAL(07),TVAL(08),TVAL(09),TVAL(10) /5,2,1,3,1/
      DATA TVAL(11),TVAL(12),TVAL(13),TVAL(14),TVAL(15) /5,1,5,2,5/
      DATA TVAL(16),TVAL(17),TVAL(18),TVAL(19),TVAL(20) /1,1,2,1,9/
      DATA TVAL(21),TVAL(22),TVAL(23),TVAL(24),TVAL(25) /1,5,5,1,2/
      DATA TVAL(26),TVAL(27),TVAL(28),TVAL(29),TVAL(30) /3,5,2,3,1/
      DATA TVAL(31),TVAL(32),TVAL(33),TVAL(34),TVAL(35) /5,2,1,5,1/
C
C     *****     PROCEDURES     *****************************************
C
C     GO GET AN IMAGE FROM THE INPUT FILE OR THE SYSTEM READER.
C     ECHO IT IF THE E OPTION IS SET.  DETERMINE WHETHER IT IS A CHANGE
C     TO CONTROL RECORDS, A COMMENT, OR LOOKS LIKE A COMMAND.
C
10    NCNREC=0
20    ACTION=0
      IF (NCHCMD.LT.0) GO TO 220
      CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 220
      IF (OPTE.EQ.0) GO TO 27
      WRITE (PRINTR,23) (HOLCMD(I),I=1,NCHCMD)
23    FORMAT (1X,80A1)
      CHAR1L=0
27    NCHCMD=MIN0(NCHCMD,MARGIN)
      IF (PHASE.LT.4) SIGNAL=45
C     45 = ASCII -
      IF (COMAND(1).NE.45) GO TO 50
C     45 = ASCII -.  REQUEST TO CHANGE CONTROL RECORD.
      IF (PHASE.LT.4) GO TO 40
      WRITE (PRINTR,30) (HOLCMD(I),I=1,NCHCMD)
30    FORMAT (//62H0CHANGE TO CONTROL RECORDS NOT ALLOWED DURING INSERT
     1OR UPDATE/1X,80A1)
      NERRG=MAX0(NERRG,2)
      GO TO 200
40    ICOMD=0
      EQUAL=2
      TRANS=3
      GO TO 370
50    IF (COMAND(1).NE.42) GO TO 70
C     42 = ASCII *.  COMMENT RECORD.  JUST ECHO IT.
      NCHCMD=MAX0(NCHCMD,2)
      WRITE (PRINTR,60) (HOLCMD(I),I=2,NCHCMD)
60    FORMAT (A1,1H*,78A1/(1X,80A1))
      GO TO 10
C
C     SQUASH OUT BLANKS UNTIL 4 SIGNIFICANT CHARACTERS OR A COMMA OR
C     EQUAL SIGN ARE FOUND.  LOOK UP THE WORD IN THE COMMAND NAME TABLE.
C
70    EQUAL=0
      DO 80 I=1,NCHCMD
      IF (COMAND(I).EQ.32) GO TO 80
C     32 = ASCII BLANK
      EQUAL=EQUAL+1
      ICOMD=COMAND(I)
C     CONVERT LOWER CASE LETTERS TO UPPER CASE.
      IF (ICOMD.GT.96 .AND. ICOMD.LT.123) ICOMD=ICOMD-32
C     ABOVE STATEMENT CONVERTS TO UPPER CASE.
      COMAND(I)=32
      COMAND(EQUAL)=ICOMD
      IF (EQUAL.GE.4) GO TO 90
      IF (ICOMD.EQ.61) GO TO 90
C     61 = ASCII =.
      IF (ICOMD.EQ.44) GO TO 90
C     44 = ASCII ,.
80    CONTINUE
      IF (EQUAL.EQ.0) GO TO 185
90    DO 110 ICOMD=1,NCOMDT
      DO 100 K=1,EQUAL
      IF (COMAND(K).NE.COMD(K,ICOMD)) GO TO 110
100   CONTINUE
      IF (EQUAL.EQ.4) GO TO 130
      IF (COMD(EQUAL+1,ICOMD).EQ.32) GO TO 130
C     32 = ASCII BLANK.
110   CONTINUE
C
C     UNRECOGNIZED COMMAND.
C
120   ICOMD=0
C
C     LOOK FOR AN EQUAL SIGN.  SET THE VARIABLE NAMED EQUAL TO ZERO IF
C     THERE IS NONE, OR TO THE COLUMN CONTAINING THE FIRST NON-BLANK
C     CHARACTER FOLLOWING THE EQUAL SIGN.
C
130   MODIFY=0
140   DO 150 I=EQUAL,NCHCMD
      K=COMAND(I)
      IF (K.EQ.61) GO TO 160
C     61 = ASCII =.
      IF (MODIFY.NE.0) GO TO 150
C     USE FIRST MODIFIER.
      IF (K.EQ.44) GO TO 160
C     44 = ASCII ,.
150   CONTINUE
      EQUAL=0
      GO TO 170
160   I=I+1
      EQUAL=I
      IF (I.GT.NCHCMD) GO TO 170
      IF (COMAND(I).EQ.32) GO TO 160
C     32 = ASCII BLANK
      IF (K.NE.44) GO TO 170
C     44 = ASCII ,.
      MODIFY=COMAND(I)
C     CONVERT LOWER CASE LETTERS TO UPPER CASE.
      IF (MODIFY.GT.96 .AND. MODIFY.LT.123) MODIFY=MODIFY-32
C     CONVERT TO UPPER CASE.
      GO TO 140
170   IF (K.NE.61) EQUAL=0
C     61 = ASCII =.
      IF (ICOMD.EQ.0) GO TO 180
      IF (ICOMD.GT.NCOMDP) GO TO 180
      IF (EQUAL.GT.NCHCMD) GO TO 175
      IF (EQUAL.NE.0) GO TO 230
      IF (ALLOW(ICOMD)/64.NE.0) GO TO 230
175   IF (MOD(ALLOW(ICOMD)/32,2).EQ.0) GO TO 690
C     PARAMETER STRING MAY BE VOID - SIMULATE ONE BLANK.
      NCHCMD=NCHCMD+1
      EQUAL=NCHCMD
      COMAND(NCHCMD)=32
C     32 = ASCII BLANK
      HOLCMD(NCHCMD)=BLANK
      GO TO 230
C
C     GIVE UNRECOGNIZED COMMANDS TO USER VIA EXCHCX.
C
180   CALL EXCHCX (0)
C     IF ICOMD NOT EQUAL ZERO, EXCHCX RECOGNIZED A COMMAND.
      IF (ICOMD.NE.0) GO TO 730
185   WRITE (PRINTR,190) (HOLCMD(I),I=1,NCHCMD)
190   FORMAT (//21H0UNRECOGNIZED COMMAND/(1X,80A1))
      NERRG=MAX0(NERRG,5)
200   CHAR1L=0
      NCNREC=NCNREC+1
      IF (NCNREC.LE.20) GO TO 20
      WRITE (PRINTR,210)
210   FORMAT (//36H0MORE THAN 20 UNRECOGNIZED COMMANDS,/41H PROGRAM ASSU
     1MES TEXT COMMAND IS MISSING.)
      GO TO 270
C
C     END OF FILE - SIMULATE A QUIT COMMAND.
C
220   ICOMD=KQUIT
C
C     RECOGNIZED COMMAND - SEE IF IT IS PERMITTED AT THIS TIME.
C
230   IF (MOD(ALLOW(ICOMD)/PHASE,2).EQ.0) GO TO 240
      TRANS=TVAL(ICOMD)
C             1   2   3   4   5   6   7   8   9   10  11  12  13  14  15
      GO TO (730,730,730,730,300,730,730,370,730,370,730,370,730,730,300
     1,370,370,730,370,730,370,730,730,350,730,370,370,730,300,370,730,7
     230,370,730,370), ICOMD
C       16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
C     32  33  34  35
C
C     THE COMMAND IS NOT ALLOWED AT THIS TIME.
C
240   WRITE (PRINTR,250) (HOLCMD(I),I=1,NCHCMD)
250   FORMAT (//55H0COMMAND NOT ALLOWED AT THIS TIME - PROBABLY MISPLACE
     1D./1X,80A1)
      NERRG=MAX0(NERRG,5)
      CHAR1L=0
C     DECIDE WHETHER TO SKIP TEXT
260   IF (ICOMD.NE.KTEXT) GO TO 10
      IF (EQUAL.NE.0) GO TO 10
270   WRITE (PRINTR,280)
280   FORMAT (//15H0SKIPPING TEXT.)
290   CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 220
      IF (NCHCMD.LT.2) GO TO 290
      IF (COMAND(1).NE.SIGNAL) GO TO 290
      IF (COMAND(2).EQ.SIGNAL) GO TO 10
      IF (NCHCMD.LT.3) GO TO 290
      IF (COMAND(2).NE.61) GO TO 290
C     61 = ASCII =
      SIGNAL=COMAND(3)
      GO TO 290
C
C     THE FOLLOWING COMMANDS MUST HAVE A PARAMETER STRING.
C     DATE=YYMMDD
C     ORIGIN=YYMMDD SITE
C     UPDATE=YYMMDD SITE
C     IF THE ORIGIN OR UPDATE COMMAND DOES NOT BEGIN WITH A DATE
C     THE DATE SUPPLIED BY THE DATE COMMAND WILL BE USED.
C
300   IF (EQUAL+5.GT.NCHCMD) GO TO 700
      I=EQUAL
      DO 310 J=1,3
      DATE(J)=0
      DO 310 K=1,2
      N=COMAND(I)-48
      IF (N.LT.0) GO TO 320
      IF (N.GT.9) GO TO 320
      DATE(J)=10*DATE(J)+N
310   I=I+1
      IF (NM.EQ.0) GO TO 320
      IF (NM.GT.12) GO TO 320
      IF (ND.LE.0) GO TO 320
      DAYS(2)=28
      IF (MOD(NY,4).EQ.0) DAYS(2)=29
      IF (NY.EQ.0) DAYS(2)=28
      IF (ND.LE.DAYS(NM)) GO TO 440
320   IF (ICOMD.EQ.KDATE) GO TO 700
      IF (TODAY(1).EQ.32) GO TO 700
      I=MIN0(NCHCMD+6,180)
      NCHCMD=I
      J=I-6
      IF (COMAND(EQUAL-1).EQ.32) EQUAL=EQUAL-1
C     32 = ASCII BLANK
      IF (J.LT.EQUAL) GO TO 700
330   COMAND(I)=COMAND(J)
      HOLCMD(I)=HOLCMD(J)
      J=J-1
      I=I-1
      IF (J.GE.EQUAL) GO TO 330
      DO 340 I=1,6
      COMAND(I+EQUAL-1)=TODAY(I)
340   HOLCMD(I+EQUAL-1)=TODAY(I)
      CALL EXCHAH (HOLCMD(EQUAL),6)
      WRITE (PRINTR,345) (HOLCMD(I),I=1,NCHCMD)
345   FORMAT (//34H0CURRENT DATE INSERTED IN COMMAND./(1X,80A1))
      NERRG=MAX0(NERRG,1)
      GO TO 440
C
C     REWIND INTAPE
C
350   IF (INTAPE.EQ.0) GO TO 680
      IF (INTOPN.NE.0) GO TO 360
      I=1
C     OPEN INTAPE IF NOT ALREADY OPEN.  DO NOT CHECK EXCH LABEL.
      CALL EXCHRT (I,IBLOCK)
C     IGNORE STATUS
360   I=2
      CALL EXCHRT (I,IBLOCK)
      INTOPN=0
      GO TO 725
C
C     THE FOLLOWING COMMANDS MUST HAVE A PARAMETER STRING WHICH
C     BEGINS WITH A NUMBER FOLLOWED BY A BLANK.
C
C     INCLUDE FILE = NUMBER SYSTEM DEPENDENT DATA
C     INPUT FILE = NUMBER SYSTEM DEPENDENT DATA
C     INTAPE = NUMBER SYSTEM DEPENDENT DATA
C     LIMIT = NUMBER
C     MARGIN = NUMBER
C     OUTAPE = NUMBER SYSTEM DEPENDENT DATA
C     OUTPUT FILE = NUMBER SYSTEM DEPENDENT DATA
C     PRINTER = NUMBER
C     READER = NUMBER
C     SKIP = NUMBER
C     TEXT = NUMBER SYSTEM DEPENDENT DATA (PARAMETER IS OPTIONAL)
C     WORK = NUMBER
C
370   NUMBER=0
      IF (EQUAL.EQ.0) GO TO 440
      DO 410 J=EQUAL,NCHCMD
      IF (COMAND(J).EQ.32) GO TO 420
C     32 = ASCII BLANK
      N=COMAND(J)-48
C     48 = ASCII ZERO
      IF (N.GE.0) GO TO 400
380   WRITE (PRINTR,390) (HOLCMD(I),I=1,NCHCMD)
390   FORMAT (//52H0PARAMETER MUST BEGIN WITH INTEGERS.  NOT PROCESSED./
     11X,80A1)
      NERRG=MAX0(NERRG,5)
      CHAR1L=0
      GO TO 260
400   IF (N.GT.9) GO TO 380
410   NUMBER=10*NUMBER+N
      EQUAL=NCHCMD+1
      GO TO 440
420   EQUAL=J
430   EQUAL=EQUAL+1
      IF (EQUAL.LE.NCHCMD) IF (COMAND(EQUAL)-32) 440,430,440
C     32 = ASCII BLANK
C
C     PRELIMINARY FORMAT CHECKING IS COMPLETE
C
440   J=ICOMD+1
C             0  1   2  3  4  5   6  7  8   9  10 11  12 13 14  15  16
      GO TO (740,10,10,10,10,450,10,10,470,10,570,10,590,10,10,730,600,6
     120,10,630,10,640,10,10,10,10,725,490,10,660,650,10,10,480,10,595),
     2J
C     17 18  19 20  21 22 23 24 25  26  27 28  29  30 31 32  33 34  35
C
C     DATE=YYMMDD
C
450   DO 460 I=1,6
460   TODAY(I)=COMAND(EQUAL+I-1)
      GO TO 10
C
C     INPUT FILE = NUMBER SYSTEM DEPENDENT DATA.
C
470   I=INFILE
      J=1
      GO TO 500
C
C     INCLUDE = NUMBER SYSTEM DEPENDENT DATA.
C
480   I=INALT
      J=3
      INALT=IABS(INALT)
      GO TO 500
C
C     TEXT
C
490   I=INTEXT
      J=2
      IF (EQUAL.EQ.0) GO TO 560
C
C     OPEN AN INPUT FILE.
C
500   IF (NUMBER.EQ.0) GO TO 505
      IF (NUMBER.EQ.OUFILE) GO TO 710
      IF (NUMBER.EQ.OUTAPE) GO TO 710
505   IF (J.EQ.2) GO TO 510
      ACTION=-1
C     ACTION = -1 MEANS CLOSE FILE.
      IF (I.NE.0) CALL EXCHIM
510   IF (J-2) 520,530,540
520   INFILE=NUMBER
      GO TO 550
530   INTEXT=NUMBER
      GO TO 550
540   INALT=NUMBER
550   IF (NUMBER.EQ.0) GO TO 560
C     STORE SYSTEM DEPENDENT INFORMATION FROM COMMAND
      CALL EXCHCX (J+1)
      ACTION=1
C     ACTION = 1 MEANS OPEN FILE.
      CALL EXCHIM
      ACTION=2
C     ACTION = 2 MEANS REWIND
      IF (J.EQ.3) CALL EXCHIM
      INALT=-IABS(INALT)
560   ACTION=0
C     ACTION = 0 MEANS READ TEXT
      GO TO 730
C
C     INTAPE = NUMBER SYSTEM DEPENDENT INFORMATION
C
570   IF (INTOPN.EQ.0) GO TO 580
C     CLOSE THE INPUT TAPE, IGNORE STATUS.
      I=4
      CALL EXCHRT (I,IBLOCK)
      INTOPN=0
580   INTAPE=NUMBER
C     STORE SYSTEM DEPENDENT INFORMATION FROM COMMAND
      IF (INTAPE.NE.0) CALL EXCHCX (6)
      GO TO 725
C
C     LIMIT = NUMBER
C
590   LIMIT=NUMBER
      GO TO 10
C
C     MARGIN = NUMBER
C
C     MINIMUM MARGIN IS 60
595   MARGIN=MAX0(NUMBER,60)
      GO TO 10
C
C     OUTAPE = NUMBER SYSTEM DEPENDENT INFORMATION
C
600   IF (OUTOPN.EQ.0) GO TO 610
C     WRITE AND END-OF-FILE MARK ON OUTAPE.
      ITYPEO=69
C     69 = ASCII E
      CALL EXCHPR (I,OBLOCK,OBLOCK)
C     IGNORE STATUS
      OUTOPN=0
      PHASE=1
610   OUTAPE=NUMBER
      OUTUPD=MODIFY
C     STORE SYSTEM DEPENDENT INFORMATION FROM COMMAND
      IF (OUTAPE.NE.0) CALL EXCHCX (7)
      GO TO 730
C
C     OUTPUT =  NUMBER SYSTEM DEPENDENT INFORMATION
C
620   ACTION=-1
C     ACTION = -1 MEANS CLOSE FILE
      IF (OUFILE.NE.0) CALL EXCHOU (OUTREC)
      OUFILE=NUMBER
      IDCUR=IDSTRT
      IF (OUFILE.EQ.0) GO TO 730
C     STORE SYSTEM DEPENDENT INFORMATION FROM COMMAND.
      CALL EXCHCX (5)
      ACTION=1
C     ACTION = 1 MEANS OPEN FILE.
      CALL EXCHOU (OUTREC)
      GO TO 730
C
C     PRINTER = NUMBER.
C
630   CALL EXCHFO (-2)
      PRINTR=NUMBER
      CALL EXCHFO (2)
      GO TO 10
C
C     READER = NUMBER.
C
640   IF (INFILE.NE.0) GO TO 670
      CALL EXCHFO (-1)
      READER=NUMBER
      CALL EXCHCX (1)
      CALL EXCHFO (1)
      GO TO 10
C
C     WORK = NUMBER
C
650   IF (WORKF.GT.0) CALL EXCHFO (-3)
      WORKF=NUMBER
C     WORKF IS NOT OPENED HERE, IT IS OPENED IN EXCHC4.
      GO TO 10
C
C     UPDATE
C
C     DECIDE WHETHER TO START UPDATE BY COPYING CONTROL RECORDS OR
C     SIMPLY TO OUTPUT THE UPDATE COMMAND.
660   IF (PHASE.GE.4) TRANS=5
      GO TO 730
C
C     ERROR MESSAGES.
C
670   NUMBER=3
C     MESSAGE 3 - COMMAND MAY NOT APPEAR IN INPUT FILE.
      GO TO 720
680   NUMBER=4
C     MESSAGE 4 - INTAPE IS NOT DEFINED.
      GO TO 720
690   NUMBER=12
C     MESSAGE 12 - NO PARAMETER STRING.
      GO TO 720
700   NUMBER=13
C     MESSAGE 13 - IMPROPER DATE.
      GO TO 720
710   NUMBER=31
C     MESSAGE 31 - INPUT, INCLUDE OR TEXT = OUTAPE OR OUTPUT.
C
C     RETURN TO ERROR MESSAGE SEGMENT.
C
720   TRANS=8
      GO TO 740
c
c     Indicate the WORK file is empty.
c
725   if (nrwork.le.0 .or. workf.le.0) go to 730
      REWIND WORKF
      NRWORK=0
C
C     IF WE NEED A NEW SEGMENT, RETURN TO EXCHTR, ELSE LOOP.
C
730   IF (TRANS.EQ.1) GO TO 10
740   RETURN
C
      END
@HDG,P EXCHCX/1100
@FTN,SVI EXCHCX/1100
      SUBROUTINE EXCHCX (REASON)
C
C     PROCESS COMMANDS NOT RECOGNIZED BY EXCHC1, OR PERFORM USER
C     PROCESSING OF SYSTEM DEPENDENT INFORMATION FROM INPUT, TEXT,
C     INCLUDE, OUTPUT, INTAPE, AND OUTAPE COMMANDS.
C     UNIVAC-1100 VERSION.
C
C     IF THE COMMAND IS 'ASCII', SET OUTPUT MODE TO ASCII;
C     IF THE COMMAND IS 'FIELDATA', SET OUTPUT MODE TO FIELDATA
C
      INTEGER REASON
C
C     REASON=0 FOR UNRECOGNIZED COMMAND.
C     REASON=1 BEFORE OPENING READER.
C     REASON=2 BEFORE OPENING INFILE.
C     REASON=3 BEFORE OPENING INTEXT.
C     REASON=4 BEFORE OPENING INALT.
C     REASON=5 BEFORE OPENING OUFILE.
C     REASON=6 BEFORE OPENING INTAPE.
C     REASON=7 BEFORE OPENING OUTAPE.
C
C     *****     EXTERNAL FUNCTIONS     *********************************
C
      INTEGER EORSRO
      INTEGER EXCHFN
C
C     *****     LOCAL VARIABLES     ************************************
C
C BLANK   CONTAINS A HOLLERITH BLANK.
      INTEGER BLANK
C BYPASS  IS A BYPASS (040) ICW.
      INTEGER BYPASS
C DUMMY   IS USED TO ACCESS A WORD REFERENCED BY ITS ADDRESS.
      INTEGER DUMMY(1)
C FDBLNK  IS 6 BLANKS IN FIELDATA CODE.
      INTEGER FDBLNK
C I       IS USED AS AN INDEX AND TEMPORARY VARIABLE.
      INTEGER I
C ICW     IS A FD/ASCII SWITCH ICW (042).
      INTEGER ICW
C IEOF    CONTAINS O77 IS S1 AND ZERO ELSEWHERE - EOF ICW.
      INTEGER IEOF
C IOPN    IS '@@@OPN' IN FIELDATA CODE.
      INTEGER IOPN
C J       IS USED AS AN INDEX AND TEMPORARY VARIABLE.
      INTEGER J
C N       IS USED AS AN INDEX AND TEMPORARY VARIABLE.
      INTEGER N
C PLUS    CONTAINS A HOLLERITH PLUS SIGN.
      INTEGER PLUS
C RHW     CONTAINS O777777 - MASK TO GET RIGHT HALFWORD.
      INTEGER RHW
C SLASH   CONTAINS A HOLLERITH SLASH.
      INTEGER SLASH
C
C KNAME AND NAMET ARE USED TO PROVIDE TEMPORARY COMPATIBILITY OF
C THE INSERT COMMAND WITH PREVIOUS VERSIONS OF THE PROGRAM.
C
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      INTEGER AFDFLG,WORKS(474,5)
      INTEGER FILES(2,7),ELTS(2,7),VERS(2,7),PFS(12,2)
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      COMMON /EXEC8/ AFDFLG,WORKS
      COMMON /EXEC8A/ FILES,ELTS,VERS,PFS
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     LOCAL DATA     *****************************************
C
C     PUT COMMANDS INTO COMD AFTER NCOMDP.  THE POSITION OF THIS
C     DATA IN COMD MUST BE CHANGED IF NCOMDP IS CHANGED.
C
C                                                        A  S  C  I
      DATA COMD(1,36),COMD(2,36),COMD(3,36),COMD(4,36) /65,83,67,73/
C                                                        F  I  E  L
      DATA COMD(1,37),COMD(2,37),COMD(3,37),COMD(4,37) /70,73,69,76/
C
      DATA NCOMDT /37/
C
      DATA SLASH /1H//
      DATA RHW /O7777777/              @ RIGHT HALFWORD MASK
      DATA PLUS /1H+/
      DATA IOPN /O000000242523/        @ '@@@OPN' IN FIELDATA
      DATA IEOF /O770000000000/        @ EOF ICW
      DATA ICW /O420000000000/         @ ASCII/FD SWITCH ICW
      DATA FDBLNK /O050505050505/      @ FD BLANK
      DATA BYPASS /O400000000000/      @ BYPASS ICW
      DATA BLANK /1H /
C
C     *****     PROCEDURES     *****************************************
C
      IF (REASON.NE.0) GO TO 40
      IF (ICOMD.EQ.0) GO TO 220
      J=ICOMD-NCOMDP
      IF (AFDFLG.EQ.2-J) GO TO 220
      AFDFLG=2-J
      IF (AND(WORKS(12,5),RHW).NE.IOPN) GO TO 220     @ NOT OPEN
      ISTAT=EORSWW(WORKS(1,5),0,ICW+AFDFLG)
      IF (ISTAT.EQ.0) GO TO 220
      CALL EXCHEM (ISTAT)
      WRITE (PRINTR,30) (HOLCMD(I),I=1,NCHCMD)
30    FORMAT (' WHILE WRITING OUTPUT FILE'/(1X,80A1))
      GO TO 220
C
C     STORE SYSTEM DEPENDENT INFORMATION FROM COMMAND.
C
40    FILES(1,REASON)=EXCHFN(NUMBER)
      FILES(2,REASON)=FDBLNK
      IF (HOLCMD(EQUAL).EQ.PLUS) IF (REASON-5) 110,220,220
      ELTS(1,REASON)=FDBLNK
      ELTS(2,REASON)=FDBLNK
      IF (EQUAL.GT.NCHCMD.OR.EQUAL.EQ.0) GO TO 100
      VERS(1,REASON)=FDBLNK
      VERS(2,REASON)=FDBLNK
      IF (HOLCMD(EQUAL).EQ.SLASH) GO TO 100
      J=EQUAL+12
      DO 50 I=EQUAL,J
      IF (I.GT.NCHCMD) GO TO 60
      IF (HOLCMD(I).EQ.SLASH) GO TO 60
      IF (HOLCMD(I).EQ.BLANK) GO TO 60
50    CONTINUE
      I=J
60    J=I-EQUAL
      CALL EXCHPN (COMAND(EQUAL),ELTS(1,REASON),J)
      K=EQUAL+J
      IF (K.GT.NCHCMD) GO TO 100
      IF (HOLCMD(K).NE.SLASH) GO TO 100
70    K=K+1
      IF (HOLCMD(K).EQ.BLANK) GO TO 70
      J=K+12
      DO 80 I=K,J
      IF (I.GT.NCHCMD) GO TO 90
      IF (HOLCMD(I).EQ.BLANK) GO TO 90
80    CONTINUE
      I=J
90    J=I-K
      CALL EXCHPN (COMAND(K),VERS(1,REASON),J)
100   IF (REASON-5) ,220,170
C
C     OPEN INPUT.
C
C     IF THE ENTRY IN NTAB$ INDICATES THE UNIT IS ASSOCIATED WITH
C     A SYMBIONT UNIT THE FILE IS READ USING READ$.
C
C     IF THE UNIT IS NOT ASSOCIATED WITH A SYMBIONT FILE THE SYSTEM
C     DEPENDENT INFORMATION IS EXAMINED.  IF THERE IS NONE, THE UNIT
C     IS ASSUMED TO BE ASSOCIATED WITH AN SDF FILE, AND THE FILE IS
C     READ FROM THE BEGINNING (SECTOR ZERO IF DISK).  IF THE SYSTEM
C     DEPENDENT INFORMATION BEGINS WITH A + SIGN, THE FILE IS READ
C     FROM THE CURRENT POSITION.  OTHERWISE, THE SYSTEM DEPENDENT
C     INFORMATION IS TREATED AS A FILE/ELEMENT SPECIFICATION.
C
110   WORKS(1,REASON)=0
      IF (NTABDC(NUMBER).GE.32) GO TO 150   @ CHECK DEVICE CODE.
      WORKS(1,REASON)=FILES(1,REASON)
      WORKS(2,REASON)=FILES(2,REASON)
      IF (EQUAL.EQ.0.OR.EQUAL.GT.NCHCMD) GO TO 140
      IF (HOLCMD(EQUAL).NE.PLUS) GO TO 120
      N=AND(WORKS(10,REASON),RHW)      @ BUFFER IMAGE LOCATOR
      IF (WORKS(6,REASON)+N.EQ.0) GO TO 140
      I=223-(N-AND(WORKS(7,REASON),RHW))    @ REMAINING SPACE
      I=MOD(I,28)                      @ REM SPACE IN SECTOR OR EOF
      N=N-LOC(DUMMY)+1                 @ CHANGE N FROM ADDR TO SUBSCR.
C     IF EOF ICW (S1=077) CHANGE TO BYPASS ICW (S1=040, S2=LENGTH).
      IF (AND(DUMMY(N),IEOF).EQ.IEOF) DUMMY(N)=BYPASS+2**24*I
      GO TO 220
C
C     OPEN AN SDF ELEMENT TO READ
C
120   IF (ELTS(1,REASON).NE.FDBLNK) GO TO 150
      WRITE (PRINTR,130) (HOLCMD(I),I=1,NCHCMD)
130   FORMAT (//'0NO ELEMENT NAME, TREAT AS FILE.'/(1X,80A1))
      NERRG=MAX0(NERRG,5)
140   ELTS(1,REASON)=0
150   N=EORSRO(WORKS(1,REASON),ELTS(1,REASON),VERS(1,REASON))
      IF (N.EQ.0) GO TO 220
      call exchm2 (n,works(3,reason))
      WRITE (PRINTR,160) (HOLCMD(I),I=1,NCHCMD)
160   FORMAT (' WHILE OPENING INPUT ELEMENT OR FILE.  NOT OPENED.'/(1X,8
     10A1))
      GO TO 220
C
C     OPEN INTAPE OR OUTAPE.
C
C     ASSIGN FILE IF NOT ASSIGNED
170   CALL EXCHIO (FILES(1,REASON),0,0,0,0)
      PFS(10,REASON-5)=0
      PFS(11,REASON-5)=0
      IF (EQUAL.GT.NCHCMD.OR.EQUAL.EQ.0) GO TO 220
      DO 180 I=1,2
      PFS(I,REASON-5)=FILES(I,REASON)
      PFS(I+2,REASON-5)=ELTS(I,REASON)
180   PFS(I+6,REASON-5)=VERS(I,REASON)
      PFS(6,REASON-5)=2**18*7          @ OMN ELEMENT
      IF (REASON.GT.6) GO TO 200
C
C     OPEN INTAPE ELEMENT.
C
      CALL PFSER (PFS(1,1),I)
      IF (I.EQ.0) GO TO 220
      I=I+32
      call exchm2 (i,0)
      WRITE (PRINTR,190) (HOLCMD(I),I=1,NCHCMD)
190   FORMAT (' WHILE OPENING INTAPE.  NOT OPENED.'/(1X,80A1))
      INTAPE=0
      GO TO 220
C
C     OPEN OUTAPE ELEMENT.
C
200   CALL PFWLER (PFS(1,2),PFS(11,2),I)
      PFS(10,2)=PFS(11,2)
      IF (I.EQ.0) GO TO 220
      I=I+32
      call exchm2 (i,0)
      WRITE (PRINTR,210) (HOLCMD(I),I=1,NCHCMD)
210   FORMAT (' WHILE TRYING TO OPEN OUTAPE.  NOT OPENED.'/(1X,80A1))
      OUTAPE=0
      ELTS(1,7)=FDBLNK
C
220   RETURN
C
      END
@HDG,P EXCHC2
@FTN,SVI EXCHC2
      SUBROUTINE  EXCHC2
C
C     PROCESS IDENT, INDEX, OPTION, PRED, SITE AND TITLE COMMANDS.
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      DATA KINDE /32/
      DATA KOPTI /14/
      DATA KSITE /25/
C
C     FIGURE OUT WHICH COMMAND GOT US HERE.
C
      IF (ICOMD-KOPTI) 60,150,10
10    IF (ICOMD.NE.KINDE) IF (ICOMD-KSITE) 200,260,270
C
C     ANALYZE IDENTIFY=C1,C2,STEP,START,TEXT
C     WHERE C1, C2, STEP AND START ARE INTEGERS.
C     STORE C1 IN IDCOL1, C2 IN IDCOL2, STEP IN IDSTEP,
C     START IN IDSTRT, TEXT IN IDTEXT, AND THE NUMBER OF
C     CHARACTERS OF TEXT IN IDTXTL.  IF AN ERROR OCCURS,
C     STORE ZERO IN IDSTEP AND IDTXTL.
C     IF ANY PARAMETER IS OMITTED, THE CORRESPONDING VALUE IS ZERO.
C
C     STORE THE MODIFIER IN IDOPTN.
C     IF THE I MODIFIER IS SELECTED, SEQUENCE NUMBERS ARE
C     PRODUCED ONLY FOR IMAGES FROM INTAPE.  IF THE O MODIFIER
C     IS SELECTED, SEQUENCE NUMBERS ARE PRODUCED FOR ALL IMAGES
C     WRITTEN ON OUTAPE, BUT NOT FOR INCLUDED TEXT.  IF THE F
C     MODIFIER IS SELECTED, SEQUENCE NUMBERS DERIVED FROM THE POSITION
C     OF IMAGES WITH RESPECT TO THE BEGINNING OF THE MODULE ARE
C     PRODUCED FOR ALL IMAGES OUTPUT.  IF THE C MODIFIER IS SPECIFIED,
C     SEQUENCE NUMBERS DERIVED FROM THE POSITION OF THE IMAGES WITH
C     RESPECT TO THE BEGINNING OF THE OUTPUT FILE ARE PRODUCED FOR
C     ALL IMAGES OUTPUT.  IF NONE OF THE I, F, OR C MODIFIERS ARE
C     SPECIFIED, THE O MODIFIER IS ASSUMED.
C
C     IF IDSTEP = ZERO, SEQUENCE NUMBERS ARE NOT PRODUCED.
C     IF IDTXTL = ZERO, TEXT IS NOT EMITTED.
C     IF IDCOL1 .GT. IDCOL2, NEITHER SEQUENCE NUMBERS NOR TEXT ARE
C     EMITTED.
C
C     CONVERT C1,C2,STEP,START
C
      IDOPTN=MODIFY
      IF (IDOPTN.NE.67.AND.IDOPTN.NE.70.AND.IDOPTN.NE.73) IDOPTN=79
C     70 = ASCII F, 73 = ASCII I, 79 = ASCII O.
      DO 40 J=1,4
      NUMBER=0
20    IF (EQUAL.GT.NCHCMD) GO TO 40
      IF (COMAND(EQUAL).EQ.44) GO TO 30
C     44 = ASCII ,
      I=COMAND(EQUAL)-48
      IF (I.LT.0) GO TO 350
      IF (I.GT.9) GO TO 350
      NUMBER=10*NUMBER+I
      EQUAL=EQUAL+1
      GO TO 20
30    EQUAL=EQUAL+1
40    IDNBRS(J)=NUMBER
      IDCUR=IDSTRT
      IDCOL1=MAX0(1,MIN0(IDCOL1,178))
      IDCOL2=MIN0(IDCOL2,178)
C
C     STORE TEXT.
C
      IDTXTL=MAX0(MIN0(NCHCMD+1-EQUAL,40),0)
      IF (IDTXTL.EQ.0) GO TO 330
      DO 50 J=1,IDTXTL
      IDTEXT(J)=COMAND(EQUAL)
50    EQUAL=EQUAL+1
      GO TO 330
C
C     INDEX = PARAMETER STRING
C
60    J=0
      IF (COMAND(EQUAL).NE.45) GO TO 70
C     45 = ASCII -
      J=-1
      EQUAL=EQUAL+1
70    N=0
      DO 80 I=1,26
80    INDEXS(I)=0
90    IF (EQUAL.GT.NCHCMD) GO TO 130
      I=COMAND(EQUAL)-64
      IF (I.EQ.-32) GO TO 120
C     32 = ASCII BLANK.
      IF (I.GE.32) I=I-32
C     CONVERT TO UPPER CASE.
      IF (I.LE.0) GO TO 100
      IF (I.LE.26) GO TO 110
100   N=EQUAL
      GO TO 120
110   INDEXS(I)=1
120   EQUAL=EQUAL+1
      GO TO 90
130   INDEX=0
      DO 140 I=1,26
      INDEXS(I)=IABS(INDEXS(I)+J)
140   INDEX=INDEX+INDEXS(I)
      IF (MODIFY.EQ.76) INDEX=-INDEX
C     76 = ASCII L.
      IF (N) 340,330,340
C
C     OPTION = PARAMETER STRING
C
150   IF (MODIFY.NE.0) GO TO 170
      DO 160 I=1,26
160   OPTVAL(I)=0
170   IF (EQUAL.EQ.0.OR.EQUAL.GT.NCHCMD) GO TO 330
      I=1
      IF (MODIFY.EQ.67) I=0
C     67 = ASCII C.
      N=0
      DO 190 J=EQUAL,NCHCMD
      K=COMAND(J)
      IF (K.GE.96) K=K-32
C     CONVERT TO UPPER CASE.
      IF (K.EQ.32) GO TO 190
C     32 = ASCII BLANK
      IF (K.LT.65) GO TO 180
      IF (K.GT.90) GO TO 180
C     PROCESS ALPHABETIC OPTIONS.
      OPTVAL(K-64)=I
      GO TO 190
180   N=J
190   CONTINUE
      IF (N) 330,330,340
C
C     PROCESS PRED = ID REC A/X MASK STRING
C       WHERE ID = PREDICATE IDENTIFIER (A-H),
C       REC = CONTROL RECORD TYPE TO WHICH PREDICATE IS APPLICABLE,
C       A/X = A TO ALLOW MATCH IN ANY POSITION, X TO REQUIRE MATCH
C             IN EXACT POSITION,
C       MASK = A SINGLE CHARACTER USED TO INDICATE POSITIONS OF THE
C              TEXT OF A RECORD THAT ARE NOT TO BE EXAMINED.
C       STRING = A STRING OF TEXT TO BE COMPARED TO THE TEXT OF
C                CONTROL RECORDS.
C
C     THE PREDICATES ARE STORED IN PRED(*,N) WHERE N IS 1 FOR
C     PREDICATE A, ETC.
C
C     PRED(1,*)=LENGTH OF STRING + 3
C     PRED(1,*)=STRING LENGTH+3, OR ZERO IF PREDICATE UNDEFINED.
C     PRED(2,*)=TRUTH VALUE (USED DURING EXAMINATION OF COPY COMMAND).
C     PRED(3,*)=RECORD TYPE.
C     PRED(4,*)=A/X
C     PRED(5,*)=MASK CHARACTER.
C     PRED(6..42,*)=STRING.
C
200   IF (EQUAL.NE.0) GO TO 240
C     LIST ALL ACTIVE PREDICATES.
      DO 230 I=1,8
      IF (PRED(1,I).EQ.0) GO TO 230
      J=PRED(1,I)+1
      COMAND(1)=I+64
      DO 210 K=2,J
210   COMAND(K)=PRED(K+1,I)
      CALL EXCHAH (COMAND,J)
      WRITE (PRINTR,220) (COMAND(K),K=1,J)
220   FORMAT (6H PRED=,42A1)
230   CONTINUE
      GO TO 330
C     SAVE PREDICATE IF VALID.
240   IF (NCHCMD.LE.EQUAL+3) GO TO 370
      J=COMAND(EQUAL)
      IF (J.GT.96) J=J-32
C     CONVERT TO UPPER CASE.
      IF (J.LT.65) GO TO 360
C     65 = ASCII A
      IF (J.GT.72) GO TO 360
C     72 = ASCII H
      NUMBER=J-64
      PRED(1,NUMBER)=0
      EQUAL=EQUAL+1
      J=COMAND(EQUAL)
      IF (J.GT.96) J=J-32
C     CONVERT TO UPPER CASE.
      IF (J.GT.90) GO TO 360
C     90 = ASCII Z
      IF (J.LT.65) GO TO 360
C     65 = ASCII A
      IF (J.EQ.82) GO TO 360
C     82 = ASCII R
      PRED(3,NUMBER)=J
      EQUAL=EQUAL+1
      J=COMAND(EQUAL)
      IF (J.GT.96) J=J-32
C     CONVERT TO UPPER CASE.
      IF (J.NE.65.AND.J.NE.88) GO TO 360
C     65 = ASCII A, 88 = ASCII X
      PRED(4,NUMBER)=J
      EQUAL=EQUAL+1
      PRED(1,NUMBER)=MIN0(NCHCMD-EQUAL+3,40)
      I=4
      DO 250 J=EQUAL,NCHCMD
      I=I+1
      IF (I.GT.42) GO TO 330
      K=COMAND(J)
      IF (K.GT.96) K=K-32
C     CONVERT TO UPPER CASE.
250   PRED(I,NUMBER)=K
      GO TO 330
C
C     SITE = SITE NAME
C
260   JUMP=1
      GO TO 280
C
C     TITLE = OUTPUT TAPE TITLE
C
270   JUMP=2
280   K=EQUAL
      IF (K.EQ.0) K=NCHCMD+1
      DO 320 I=1,40
      IF (K.GT.NCHCMD) GO TO 290
      J=COMAND(K)
      K=K+1
      GO TO 300
290   J=32
C     32 = ASCII BLANK.
300   IF (JUMP.EQ.2) GO TO 310
      SITE(I)=J
      GO TO 320
310   TITLE(I)=J
320   CONTINUE
C
C     RETURN TO COMMAND DECODER.
C
330   TRANS=1
      GO TO 390
C
C     ERROR MESSAGES
C
340   NUMBER=14
C     MESSAGE 14 - UNRECOGNIZED CHARACTER IGNORED.
      EQUAL=N
      GO TO 380
350   IDSTEP=0
      IDTXTL=0
360   NUMBER=17
C     MESSAGE 17 - UNRECOGNIZED CHARACTER - COMMAND NOT PROCESSED.
      GO TO 380
370   NUMBER=30
C     MESSAGE 30 - COMMAND IS INCOMPLETE.
C
380   TRANS=8
C
390   RETURN
C
      END
@HDG,P EXCHC3
@FTN,SVI EXCHC3
      SUBROUTINE EXCHC3 (IBLOCK,OBLOCK)
      INTEGER IBLOCK(1),OBLOCK(1)
C
C     MAKE SURE THE INPUT TAPE IS OPEN BEFORE STARTING THE
C     COPY, SKIP OR UPDATE COMMANDS, OR CONTROL RECORD UPDATES.
C
C     OPEN THE INPUT TAPE IF IT IS DEFINED BEFORE STARTING THE
C     NAME COMMAND.
C
C     OPEN THE OUTPUT TAPE IF IT IS DEFINED BEFORE STARTING
C     COPY, NAME OR UPDATE COMMANDS.
C
C ID      IS USED TO CONSTRUCT THE OUTPUT LABEL.
      INTEGER ID(8)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C                                    E  X  C  H
      DATA ID(1),ID(2),ID(3),ID(4) /69,88,67,72/
C                                    A  N  G  E
      DATA ID(5),ID(6),ID(7),ID(8) /65,78,71,69/
      DATA KNAME /9/
      DATA KSKIP /26/
C
C     OPEN INTAPE IF NECESSARY
C
      IF (INTOPN.NE.0) GO TO 70
      IF (INTAPE.EQ.0) IF (ICOMD-KNAME) 300,80,300
      IF (INTAPE.EQ.OUTAPE) GO TO 360
      CALL EXCHRH (ISTAT,IBLOCK)
      IF (ISTAT.NE.0) GO TO 310
      INTOPN=1
C     COPY THE LABEL TO A SAVE AREA.
      DO 10 I=1,180
10    LABELI(I)=CBLCKI(I)
      CALL EXCHAH (CBLCKI(13),138)
      WRITE (PRINTR,20)
20    FORMAT (25H0INPUT LABEL INFORMATION.)
      WRITE (PRINTR,30) (CBLCKI(I),I=13,104)
30    FORMAT (14H TAPE WRITTEN ,6A1,10H, TITLE = ,40A1/
     1        20H ORIGINALLY WRITTEN ,6A1,4H BY ,40A1)
      IF (LABELI(105).NE.0) WRITE (PRINTR,40) (CBLCKI(I),I=105,150)
40    FORMAT (13H LAST UPDATE ,6A1,4H BY ,40A1)
      WRITE (PRINTR,50) NDATAI
50    FORMAT (28H DATA CHARACTERS PER BLOCK =,I6)
      IF (NERRCI.NE.0) WRITE (PRINTR,60) NERRCI
60    FORMAT (40H ERROR CORRECTION CHARACTERS PER BLOCK =,I6)
      CHAR1L=0
      CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 290
70    IF (ICOMD.EQ.KSKIP) GO TO 270
C
C     OPEN OUTAPE IF NECESSARY
C
80    IF (ICOMD.EQ.0) GO TO 90
      IF (ICOMD.LT.KNAME) GO TO 100
90    IF (INTAPE*OUTAPE.EQ.0) GO TO 100
      IF (OUTUPD.NE.85) GO TO 370
C     85 = ASCII U.
100   IF (OUTOPN.NE.0) GO TO 240
      IF (OUTAPE.EQ.0) GO TO 240
C     CONSTRUCT THE OUTPUT LABEL.
      IF (TODAY(1).EQ.0) GO TO 340
      IF (INTOPN.EQ.0) GO TO 160
      DO 110 I=1,180
110   CBLCKO(I)=LABELI(I)
      IF (TITLE(1).EQ.32) GO TO 130
C     32 = ASCII BLANK
      DO 120 I=1,40
120   CBLCKO(I+18)=TITLE(I)
130   IF (OUTUPD.NE.85) GO TO 220
C     85 = ASCII U.
      IF (SITE(1).EQ.0) GO TO 350
      DO 140 I=1,6
140   CBLCKO(I+104)=TODAY(I)
      DO 150 I=1,40
150   CBLCKO(I+110)=SITE(I)
      GO TO 220
160   IF (TITLE(1).EQ.32) GO TO 330
C     32 = ASCII BLANK
      IF (SITE(1).EQ.0) GO TO 350
      IF (INTAPE*OUTAPE.EQ.0) GO TO 170
      IF (INTAPE.EQ.OUTAPE) GO TO 360
170   DO 180 I=1,8
180   CBLCKO(I)=ID(I)
      DO 190 I=1,40
      CBLCKO(I+18)=TITLE(I)
190   CBLCKO(I+64)=SITE(I)
      DO 200 I=1,6
200   CBLCKO(I+58)=TODAY(I)
      DO 210 I=105,180
210   CBLCKO(I)=0
220   CALL EXCHWH (ISTAT,OBLOCK)
      IF (ISTAT.NE.0) GO TO 320
      OUTOPN=1
      CBLCKO(1)=CBLCKO(105)
      CALL EXCHAH (CBLCKO(13),138)
      WRITE (PRINTR,230)
      WRITE (PRINTR,30) (CBLCKO(I),I=13,104)
230   FORMAT (26H0OUTPUT LABEL INFORMATION.)
      IF (CBLCKO(1).NE.0) WRITE (PRINTR,40) (CBLCKO(I),I=105,150)
      WRITE (PRINTR,50) NDATAO
      IF (NERRCO.NE.0) WRITE (PRINTR,60) NERRCO
      CHAR1L=0
240   IF (ICOMD-KNAME) 250,260,280
C
C     COPY
C
250   TRANS=4
      MODEI=1-MIN0(1,OUFILE+OPTL)
      IF (ICOMD.EQ.0) MODEI=0
      GO TO 390
C
C     NAME
C
260   TRANS=5
      IF (NRWORK.EQ.0) PHASE=4
      GO TO 390
C
C     SKIP
C
270   TRANS=4
      GO TO 390
C
C     UPDATE
C
280   TRANS=5
      MODEI=0
      GO TO 390
C
C     ERROR MESSAGES
C
290   NUMBER=1
C     MESSAGE 1 - I/O ERROR READING INTAPE.
      EQUAL=ISTAT
      GO TO 380
300   NUMBER=4
C     MESSAGE 4 - INTAPE NOT DEFINED.
      GO TO 380
310   NUMBER=5
C     MESSAGE 5 - UNABLE TO OPEN INTAPE.
      EQUAL=ISTAT
      GO TO 380
320   NUMBER=6
C     MESSAGE 6 - UNABLE TO OPEN OUTAPE.
      EQUAL=ISTAT
      GO TO 380
330   NUMBER=7
C     MESSAGE 7 - TITLE NOT PROVIDED FOR OUTAPE.
      GO TO 380
340   NUMBER=8
C     MESSAGE 8 - DATE NOT SUPPLIED.
      GO TO 380
350   NUMBER=9
C     MESSAGE 9 - SITE NOT SUPPLIED.
      GO TO 380
360   NUMBER=10
C     MESSAGE 10 - INTAPE = OUTAPE.
      GO TO 380
370   NUMBER=11
C     MESSAGE 11 - U MODIFIER OF OUTAPE COMMAND NOT SELECTED.
380   TRANS=8
C
C     RETURN TO TRANSITION PROGRAM
C
390   RETURN
C
      END
@HDG,P EXCHRH
@FTN,SVI EXCHRH
      SUBROUTINE EXCHRH (ISTAT,DBLOCK)
C
C     READ THE HEADER LABEL FROM THE EXCHANGE TAPE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C     ISTAT = 6 IF THE FIRST EIGHT CHARACTERS OF THE LABEL ARE
C               NOT EQUAL EXCHANGE.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT COMES FROM THE TAPE).
      INTEGER DBLOCK(1)
      INTEGER ID(8)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
C
C                  E           X           C           H
      DATA ID(1) /69/, ID(2) /88/, ID(3) /67/, ID(4) /72/
C                  A           N           G           E
      DATA ID(5) /65/, ID(6) /78/, ID(7) /71/, ID(8) /69/
C
C     OPEN THE INPUT TAPE.
C
      ISTAT=1
      CALL EXCHRT (ISTAT,DBLOCK)
      IF (ISTAT.NE.0) GO TO 25
C
C     READ A BLOCK.
C
      NDATAI=171
      NERRCI=0
      BLKSQI=0
      ISTAT=3
      CALL EXCHRT (ISTAT,DBLOCK)
      IF (ISTAT.NE.0) GO TO 25
C
C     FIND OUT IF IT IS A PROPER LABEL.
C
      CALL EXCHUN (DBLOCK,CBLCKI)
      DO 10 I=1,8
      IF (CBLCKI(I).NE.ID(I)) GO TO 20
10    CONTINUE
C
C     GET READY TO READ THE REST OF THE TAPE.
C
      CCDBI=NCDBI
      NDATAI=256*CBLCKI(9)+CBLCKI(10)
      NERRCI=256*CBLCKI(11)+CBLCKI(12)
      LASTI=0
      L1PRGI=0
      ISTAT=0
      GO TO 30
C
C     NOT A LABEL.
C
20    ISTAT=6
C
C     CLOSE INTAPE WITH NO REWIND IF LABEL NOT OK.
25    I=4
      CALL EXCHRT (I,DBLOCK)
C
30    RETURN
C
      END
@HDG,P EXCHWH
@FTN,SVI EXCHWH
      SUBROUTINE EXCHWH (ISTAT,DBLOCK)
C
C     WRITE A HEADER ONTO THE EXCHANGE TAPE.
C
C     ISTAT = 0 IF EVERYTHING IS OK.
C     ISTAT = 3 IF AN I/O ERROR OCCURRED.
C     ISTAT = 6 IF THE FIRST EIGHT CHARACTERS OF THE LABEL TO BE
C               WRITTEN ARE NOT EQUAL EXCHANGE.
C
C     DBLOCK = THE RAW DATA BLOCK (EXACTLY AS IT IS TO BE WRITTEN ONTO
C              TAPE).
      INTEGER DBLOCK(1)
      INTEGER ID(8)
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C                  E           X           C           H
      DATA ID(1) /69/, ID(2) /88/, ID(3) /67/, ID(4) /72/
C                  A           N           G           E
      DATA ID(5) /65/, ID(6) /78/, ID(7) /71/, ID(8) /69/
C
C     MAKE SURE IT IS A PROPER LABEL.
C
      DO 10 I=1,8
      IF (CBLCKO(I).NE.ID(I)) GO TO 30
10    CONTINUE
C
C     OPEN THE OUTPUT TAPE.
C
      ISTAT=1
      CALL EXCHWT (ISTAT,DBLOCK)
      IF (ISTAT.NE.0) GO TO 40
C
C     CONVERT THE NUMBER OF DATA CHARACTERS AND THE NUMBER OF ERROR
C     CONTROL CHARACTERS
C
      CBLCKO(9)=NDATAO/256
      CBLCKO(10)=MOD(NDATAO,256)
      CBLCKO(11)=NERRCO/256
      CBLCKO(12)=MOD(NERRCO,256)
C
C     INSERT TODAYS DATE
C
      DO 20 I=1,6
20    CBLCKO(I+12)=TODAY(I)
C
C     WRITE THE BLOCK ON TAPE.
C
      BLKSQO=0
      CALL EXCHPA (CBLCKO,DBLOCK)
      CCDBO=180
      ISTAT=2
      CALL EXCHWT (ISTAT,DBLOCK)
C
C     GET READY TO WRITE THE REST OF THE FILE.
C
      L1PRGO=0
      LLPRGO=0
      N1RECO=0
      NLRECO=0
      L1RECO=0
      LASTO=0
      CCDBO=NERRCO+10
      CWDBO=NWCBO*((CCDBO-1)/NCCBO)+1
      CPCBO=MOD(CCDBO-1,NCCBO)+1
      GO TO 40
C
C     NOT A PROPER LABEL.
C
30    ISTAT=6
C
40    RETURN
C
      END
@HDG,P EXCHC4
@FTN,SVI EXCHC4
      SUBROUTINE EXCHC4 (IBLOCK)
      INTEGER IBLOCK(1)
C
C     PROCESS SKIP COMMAND, CONTROL RECORD UPDATE, PERFORM
C     COPY COMMAND FORMAT VERIFICATION, DECIDE WHICH PROGRAMS TO COPY.
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      DATA KCOPY /3/
C
C     ARE WE STARTING OR CONTINUING?
C
C     ICOMD.EQ.0  MEANS  CHANGE A CONTROL RECORD
C     ICOMD.GT.0  MEANS  SKIP OR COPY COMMAND BEGIN
C     ICOMD.EQ.-1 MEANS  CONTINUE COPY = NUMBERS
C     ICOMD.EQ.-2 MEANS  CONTINUE COPY = PREDICATE EXPRESSION
      NEWP=0
      IF (ITYPEI.EQ.80) VERT=0
C     80 = ASCII P.  WE NEED THIS TEST HERE AS WELL AS TESTING ITYPEO
C     IN EXCHC5 BECAUSE WE DO NOT ALWAYS WRITE CONTROL RECORDS ON
C     THE WORK FILE.
      IF (ICOMD.EQ.0) GO TO 190
C     ICOMD=0 MEANS CHANGING A CONTROL RECORD.
      IF (ICOMD+1) 290,170,10
10    IF (ICOMD.EQ.KCOPY) GO TO 30
C
C     SKIP COMMAND.
C
      IF (INTOPN.LT.0) GO TO 430
      if (modify.eq.70) number=number+n1reci-1
c     70 = ASCII F.
      IF (NUMBER+1-N1RECI) 540,430,20
20    CALL EXCHNP (ISTAT,IBLOCK)
      IF (ISTAT.NE.0) IF (ISTAT-7) 440,460,440
      CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 440
      IF (ITYPEI.EQ.69) GO TO 460
C     69 = ASCII E.
      IF (N1RECI-NUMBER) 20,20,430
C
C     COPY COMMAND FORMAT VERIFICATION.
C
30    IF (COMAND(EQUAL).LT.48) GO TO 180
C     48 = ASCII ZERO
      IF (COMAND(EQUAL).GT.57) GO TO 180
C     57 = ASCII NINE
C
C     COPY = LIST OF PROGRAM NUMBERS SEPARATED BY DASHES AND COMMAS.
C     CONVERT THE NUMBERS AND STORE THEM IN COMAND.  IF THE NUMBER
C     IS PRECEEDED BY A DASH, STORE THE NEGATIVE OF THE NUMBER.
C
      ICOMD=-1
      I=0
      J=44
C     44 = ASCII COMMA
40    I=I+1
      NUMBER=COMAND(EQUAL)-48
C     48 = ASCII ZERO
      IF (NUMBER.LT.0) GO TO 480
      IF (NUMBER.GT.9) GO TO 480
      COMAND(I)=NUMBER
50    EQUAL=EQUAL+1
      IF (EQUAL.GT.NCHCMD) GO TO 60
      NUMBER=COMAND(EQUAL)-48
C     48 = ASCII ZERO
      IF (NUMBER.LT.0) GO TO 60
      IF (NUMBER.GT.9) GO TO 480
      COMAND(I)=10*COMAND(I)+NUMBER
      GO TO 50
60    IF (I.NE.1) IF (COMAND(I)-IABS(COMAND(I-1))) 490,490,70
70    IF (J.EQ.45) COMAND(I)=-COMAND(I)
C     45 = ASCII DASH
      IF (EQUAL.GT.NCHCMD) GO TO 90
      J=COMAND(EQUAL)
      IF (J.EQ.32 .OR. J.EQ.46) GO TO 90
C     32 = ASCII BLANK, 46 = ASCII PERIOD.
      IF (J.NE.44.AND.J.NE.45) GO TO 480
C     44 = ASCII COMMA, 45 = ASCII DASH
80    EQUAL=EQUAL+1
      IF (COMAND(EQUAL)-32) 40,80,40
C     32 = ASCII BLANK
90    NUMBER=I
C     FOR THE REST OF THIS COMMAND, EQUAL IS THE POINTER TO THE
C     POSITION IN COMAND CURRENTLY BEING EXAMINED.
      EQUAL=-1
100   EQUAL=EQUAL+1
      IF (EQUAL.GE.NUMBER) GO TO 470
      IF (IABS(COMAND(EQUAL+1)).LT.N1RECI) GO TO 100
      IF (EQUAL.EQ.0) GO TO 120
      WRITE (PRINTR,110) N1RECI,(HOLCMD(I),I=1,NCHCMD)
110   FORMAT (//44H0MODULES PRECEDING CURRENT INTAPE POSITION (,I5,13H)
     1NOT COPIED./(1X,80A1))
      NERRG=MAX0(NERRG,5)
120   IF (COMAND(EQUAL+1).GT.0) GO TO 130
      EQUAL=EQUAL-1
      COMAND(EQUAL+1)=N1RECI
130   IF (NRWORK.GT.0) GO TO 420
C     IF CONTROL RECORDS MODIFIED, ASSUME PROGRAM IS TO BE COPIED.
C
C     PROCESS COPY = LIST OF NUMBERS
C
140   EQUAL=EQUAL+1
C     GO COPY THE PROGRAM IF IT IS THE RIGHT ONE.
150   IF (INTOPN.LT.0) GO TO 430
      IF (COMAND(EQUAL)-N1RECI) 170,420,160
C     SKIP TO DESIRED PROGRAM
160   CALL EXCHNP (ISTAT,IBLOCK)
      IF (ISTAT.NE.0) IF (ISTAT-7) 440,460,440
      CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 440
      IF (ITYPEI-69) 150,460,150
C     69 = ASCII E
170   IF (EQUAL.GE.NUMBER) GO TO 430
      IF (COMAND(EQUAL+1).GE.0) GO TO 140
      COMAND(EQUAL)=IABS(COMAND(EQUAL))+1
      IF (COMAND(EQUAL)+COMAND(EQUAL+1).LE.0) GO TO 420
      EQUAL=EQUAL+1
      GO TO 170
C
C     COPY = SELECTION STRING OR CHANGE CONTROL RECORD.
C
180   ICOMD=-2
      IF (NRWORK.GT.0) GO TO 420
C     IF CONTROL RECORDS MODIFIED, ASSUME PROGRAM IS TO BE COPIED.
      NRWORK=-1
C
C     DETERMINE NEED TO OPEN WORK FILE.
C
190   IF (IABS(INDEX)+OUTAPE+OUFILE*OPTC+OPTL*OPTA.EQ.0)
     1IF (ICOMD) 290,430,290
      IF (WORKF.EQ.0) GO TO 500
      I=IABS(WORKF)
      IF ((I-INTAPE)*(I-OUTAPE)*(I-OUFILE).EQ.0) GO TO 510
      IF (WORKF.GT.0) GO TO 200
      WORKF=I
      CALL EXCHFO (3)
200   IF (ICOMD.NE.0) GO TO 280
C
C     CHANGE CONTROL RECORD.
C
      if (itypei*(itypei-69)*(itypei-73).eq.0) go to 520
c     69 = ascii E, 73 = ascii I.
      if (nrwork.eq.0) go to 210
      if (itypei.eq.80) go to 520
c     80 = ascii P
210   IF (NUMBER-NRWORK-1) 530,220,410
220   NCHACT=NCHCMD+1-EQUAL
      IF (NCHACT.GT.0) GO TO 230
      NCHACT=1
      INTREC(1)=32
C     32 = ASCII BLANK
      GO TO 425
230   DO 240 I=1,NCHACT
240   INTREC(I)=COMAND(EQUAL+I-1)
      GO TO 425
C
C     COPY = SELECTION EXPRESSION.
C
C     SKIP TO NEXT PROGRAM.
250   IF (INTOPN.LT.0) GO TO 430
      if (itypei.eq.69) go to 460
c     69 = ASCII E.
      do 260 i = 1, 8
260   pred(2,i)=0
      if (itypei.ne.80) go to 265
c     If the current record is a new program, don't skip it (we haven't
c     processed it yet).
      if (nrwork.gt.0 .and. workf.gt.0) rewind workf
      nrwork=min0(nrwork,0)
      newp=0
      go to 320
265   CALL EXCHNP (ISTAT,IBLOCK)
      IF (ISTAT.NE.0) IF (ISTAT-7) 440,460,440
      nxnewp=0
270   CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 440
      IF (ITYPEI.NE.80) GO TO 310
C     80 = ASCII P
      NEWP=nxnewp
c     Set NEWP non-zero when all control records for a module have been
c     seen.
      GO TO 320
280   NRWORK=MAX0(NRWORK,0)
290   DO 300 I=1,8
300   PRED(2,I)=0
c     NEWP is non-zero when all control records have been read.
310   if (itypei*(itypei-69)*(itypei-73).eq.0) newp=1
C     69 = ASCII E, 73 = ASCII I.
320   nxnewp=1
      if (icomd.eq.0) if (newp) 520,210,520
      IF (LIMIT.EQ.0) GO TO 340
      IF (N1RECI.LE.LIMIT) GO TO 340
      WRITE (PRINTR,330) LIMIT
330   FORMAT (7H LIMIT=,I6,9H REACHED.)
      GO TO 430
340   IF (NEWP.EQ.0) GO TO 360
      CALL EXCHLX
C     EXCHTP PRESERVES 'NUMBER' WORDS OF 'COMAND'.
      NUMBER=NCHCMD
      IF (MODIFY.EQ.73) IF (COMAND(180)) 450,420,415
C     73 = ASCII I.
      IF (MODIFY.EQ.80) IF (COMAND(180)) 450,420,425
C     80 = ASCII P.
      IF (MODIFY.EQ.83) IF (COMAND(180)) 450,250,425
C     83 = ASCII S.
      IF (MODIFY.EQ.88) IF (COMAND(180)) 450,250,415
C     88 = ASCII X.
      IF (COMAND(180)) 450,250,420
C     CONTROL RECORD.  EVALUATE ACTIVE PREDICATES WHICH ARE STILL FALSE.
360   I=1
      DO 400 NUMBER=1,8
      IF (PRED(1,NUMBER).EQ.0) GO TO 400
      IF (PRED(2,NUMBER).NE.0) GO TO 400
      IF (PRED(3,NUMBER).NE.ITYPEI) GO TO 390
      NM=PRED(1,NUMBER)-3
      IF (.NOT.(NCHACT.GT.0)) GO TO 390
      DO 385 L = 1, NCHACT
      DO 380 J = 1, NM
C
C     DO NOT TEST CHARACTER IN CONTROL RECORD IF MASK CHARACTER FOUND
C     IN PREDICATE.
      IF (PRED(J+5,NUMBER).EQ.PRED(5,NUMBER)) GO TO 380
      IF (.NOT.(J+L-1.GT.NCHACT)) GO TO 370
C
C     NO MORE CHARACTERS, IMPLICITLY PAD CONTROL RECORD WITH BLANKS.
      K=32
      GO TO 375
C     USE CHARACTER FROM CONTROL RECORD.
370   K=INTREC(J+L-1)
C
C     CONVERT LOWER CASE LETTERS TO UPPER CASE.
      IF (K.GT.96 .AND. K.LT.123) K=K-32
C
C     TEST FOR A MATCH ON A SINGLE CHARACTER.
C     IF THERE IS NO MATCH, AND THE SEARCH MODE IS 'A' (65), SHIFT THE
C     PATTERN.  IF THE SEARCH MODE IS X, TERMINATE THE SEARCH.
375   IF (PRED(J+5,NUMBER).NE.K) IF (PRED(4,NUMBER)-65) 390,385,390
380   CONTINUE
C
C     FOUND A MATCH IN CONTROL RECORD AND PREDICATE.
      PRED(2,NUMBER)=1
      GO TO 400
385   CONTINUE
390   I=0
400   CONTINUE
      IF (I.NE.0) newp=1
      IF (NRWORK.LT.0) GO TO 270
C     AT LEAST ONE FALSE PREDICATE.  WRITE THE CONTROL RECORD ON WORKF.
410   WRITE (WORKF) ITYPEI,NCHACT,(INTREC(J),J=1,NCHACT)
      NRWORK=NRWORK+1
      GO TO 270
C
C     GO COPY THE CONTROL RECORDS ASSOCIATED WITH A PROGRAM.
C
415   ICOMD=-3
C     RETURN TO EXCHC1 AFTER COPYING MODULE.
420   TRANS=5
      GO TO 570
C
C     RETURN TO THE COMMAND PROCESSOR.
C
425   TRANS=1
C     REMEMBER CONTROL RECORDS ON WORKF.
      GO TO 570
430   TRANS=1
      IF (ICOMD+1) 560,570,570
C
C     ERROR MESSAGES.
C
440   NUMBER=1
C     MESSAGE 1 - I/O ERROR.
      EQUAL=ISTAT
      GO TO 550
450   NUMBER=-COMAND(180)
C     MESSAGES GENERATED BY EXCHLX
      GO TO 550
460   IF (INTOPN.LT.0) GO TO 430
      INTOPN=-1
      EQUAL=NUMBER
      NUMBER=15
C     MESSAGE 15 - END OF FILE ENCOUNTERED ON INPUT TAPE.
      GO TO 550
470   NUMBER=16
C     MESSAGE 16 - ALL MODULES PRECEDE CURRENT POSITION.
      GO TO 550
480   NUMBER=17
C     MESSAGE 17 - UNRECOGNIZED CHARACTER
      GO TO 550
490   NUMBER=18
C     MESSAGE 18 - PROGRAM NUMBERS NOT IN ORDER.
      GO TO 550
500   NUMBER=19
C     MESSAGE 19 - WORK FILE NOT DEFINED.
      GO TO 550
510   NUMBER=20
C     MESSAGE 20 - WORK = INTAPE OR OUTAPE OR OUFILE.
      GO TO 550
520   EQUAL=NUMBER
      NUMBER=21
C     MESSAGE 21 - CONTROL RECORD NOT PRESENT
      GO TO 550
530   NUMBER=22
C     MESSAGE 22 - CONTROL RECORD CHANGE REQUESTS NOT IN ORDER.
      GO TO 550
540   NUMBER=29
C     MESSAGE 29 - BACKWARD SKIP IGNORED.
C
C     RETURN TO THE ERROR MESSAGE PROCESSOR.
C
550   TRANS=8
      IF (ICOMD.EQ.0) GO TO 570
C
C     DON'T CLAIM THAT CONTROL RECORDS REMAIN ON WORKF.
C
560   IF (WORKF.GT.0 .AND. NRWORK.GT.0) REWIND WORKF
      NRWORK=MIN0(NRWORK,0)
C
C     RETURN TO TRANSITION PROGRAM.
C
570   RETURN
C
      END
@HDG,P EXCHLX
@FTN,SVI EXCHLX
      SUBROUTINE EXCHLX
C
C     EVALUATE THE LOGICAL EXPRESSION ON THE COPY COMMAND.
C
C     THE CONTENT SELECTED COPY OPERATION IS CONTROLLED BY THE PREDICATE
C     STATEMENTS, LIMIT STATEMENT, AND THE COPY STATEMENT OF THE FORM
C     COPY=LOGICAL EXPRESSION.  THE LOGICAL EXPRESSION CONSISTS OF THE
C     EIGHT PRIMARY SYMBOLS A-H, THE NULL PRIMARY SYMBOL N, THE BINARY
C     OPERATORS + - * / AND PARENEHESES.  THE PRIMARY SYMBOLS A-H ARE
C     LABELS USED TO DISTINGUISH PREDICATES SUPPLIED BY PREDICATE
C     STATEMENTS.  THE NULL PRIMARY SYMBOL N IS A LABEL TO DESIGNATE THE
C     NULL PREDICATE, WHICH IS ALWAYS FALSE.  THE OPERATORS + - * / ARE
C     THE BINARY LOGICAL OPERATIONS   OR, OR NOT, AND, AND NOT
C     RESPECTIVELY.  THE OPERATORS * / HAVE EQUAL PRIORITY AND ARE
C     PERFORMED BEFORE THE OPERATORS + -, WHICH ALSO HAVE EQUAL
C     PRIORITY.  THE RELATIVE PRIORITY MAY BE CHANGED BY USING
C     PARENTHESES.
C
C     WHEN PROCESSING OF A PROGRAM BEGINS, ALL PREDICATES ARE INITIALLY
C     FALSE.  AS EACH CONTROL RECORD IS EXAMINED, THE TRUTH OF ALL
C     FALSE PREDICATES IS DETERMINED.  ONCE TRUE, A PREDICATE REMAINS
C     TRUE.  THUS A TRUE PREDICATE IS ONE WHICH IS TRUE AT ANY TIME, AND
C     A FALSE PREDICATE IS ONE WHICH IS NEVER TRUE.  WHEN ALL ACTIVE
C     PREDICATES ARE TRUE, OR WHEN ALL CONTROL RECORDS FOR A PROGRAM
C     HAVE BEEN EXAMINED, THE LOGICAL EXPRESSION FROM THE COPY COMMAND
C     IS EVALUATED.  IF THE EXPRESSION IS TRUE, THE PROGRAM IS COPIED.
C     IF THE EXPRESSION IS FALSE, THE PROGRAM IS SKIPPED.  THIS PROCESS
C     CONTINUES UNTIL THE END OF THE FILE IS REACHED, OR THE PROGRAM
C     NUMBER WHICH APPEARS ON THE LIMIT COMMAND IS PROCESSED.
C
C     THE SYNTAX RULES FOR THE LOGICAL EXPRESSION ARE EXPRESSED IN THE
C     TABLE BELOW.  INITIALLY, THE PREVIOUS TOKEN IS (, AND ) IS
C     APPENDED TO THE END OF THE LOGICAL EXPRESSION.
C
C     PREVIOUS  I                 CURRENT TOKEN                   I
C      TOKEN    I + - * / I PRIMARY I    (    I    )    I  ELSE   I
C     ----------I---------I---------I---------I---------I---------I
C      + - * /  I  ERROR  I   OK    I   OK    I  ERROR  I  ERROR  I
C      PRIMARY  I   OK    I  ERROR  I  ERROR  I   OK    I  ERROR  I
C         (     I  ERROR  I   OK    I   OK    I   OK    I  ERROR  I
C         )     I   OK    I  ERROR  I  ERROR  I   OK    I  ERROR  I
C     ----------I---------I---------I---------I---------I---------I
C
C     CONVERSION FROM INFIX TO SUFFIX NOTATION IS PERFORMED USING
C     A STACK AND THE PRECEDENCE TABLE BELOW.  TOS MEANS TOP-OF-STACK,
C     HOI MEANS HEAD-OF-INPUT.  THE STACK INITIALLY CONTAINS (.
C
C                  TOS       HOI
C      TOKEN   I  INDEX  I  INDEX  I
C     ---------I---------I---------I
C       + -    I    2    I    1    I
C       * /    I    4    I    3    I
C     PRIMARY  I    6    I    5    I
C        (     I    0    I    7    I
C        )     I   N/A   I    0    I
C     ---------I---------I---------I
C
C     WHEN THE TOS INDEX IS LESS THAN THE HOI INDEX, THE INPUT TOKEN IS
C     PUSHED ONTO THE STACK.  WHEN THE TOS INDEX IS GREATER THAN THE HOI
C     INDEX, THE TOP ENTRY OF THE STACK IS EVALUATED (IF IT IS A PRIMARY
C     SYMBOL), OR PERFORMED (IF IT IS AN OPERATOR), AND THE RESULT
C     PLACED IN THE SUFFIX LIST.  THEN THE RELATION OF THE TOS INDEX TO
C     THE HOI INDEX IS RE-EXAMINED.  WHEN THE TOS INDEX IS EQUAL TO THE
C     HOI INDEX, THE TOP ENTRY OF THE STACK IS DELETED.
C
C     *****     INTERNAL VARIABLES     *********************************
C
C CHTAB   RECOGNIZED CHARACTERS.  INTERNAL PROCESSES USE THE INDEX
C         INTO CHTAB.
C COLTAB  CONVERTS INDEX OF CHTAB INTO COLUMN INDEX FOR SYNTAX.
C HOI     CONVERTS INDEX OF CHTAB INTO HEAD-OF-INPUT PRECEDENCE.
C INFIX   IS THE CURRENT POSITION IN THE INFIX.
C IPREV   IS THE SYNTAX TABLE COLUMN INDEX OF THE PREVIOUS TOKEN.
C ISTACK  IS THE CURRENT STACK INDEX.
C ISUFIX  IS THE CURRENT SUFFIX INDEX.
C SYNTAX  CONTAINS THE SYNTAX RULES.
C TOS     CONVERTS INDEX OF CHTAB INTO TOP-OF-STACK PRECEDENCE.
C
      INTEGER CHTAB(15),COLTAB(15),HOI(15),SYNTAX(4,4),TOS(15)
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     DATA STATEMENTS     ************************************
C
C                                                    A  B  C  D
      DATA CHTAB( 1),CHTAB( 2),CHTAB( 3),CHTAB( 4) /65,66,67,68/
C                                                    E  F  G  H
      DATA CHTAB( 5),CHTAB( 6),CHTAB( 7),CHTAB( 8) /69,70,71,72/
C                                                    N  +  -  *
      DATA CHTAB( 9),CHTAB(10),CHTAB(11),CHTAB(12) /78,43,45,42/
C                                                    /  (  )
      DATA CHTAB(13),CHTAB(14),CHTAB(15)           /47,40,41   /
C                                                       A B C D
      DATA COLTAB( 1),COLTAB( 2),COLTAB( 3),COLTAB( 4) /2,2,2,2/
C                                                       E F G H
      DATA COLTAB( 5),COLTAB( 6),COLTAB( 7),COLTAB( 8) /2,2,2,2/
C                                                       N + - *
      DATA COLTAB( 9),COLTAB(10),COLTAB(11),COLTAB(12) /2,1,1,1/
C                                                       / ( )
      DATA COLTAB(13),COLTAB(14),COLTAB(15)            /1,3,4  /
C                                                   A B C D E
      DATA HOI( 1),HOI( 2),HOI( 3),HOI( 4),HOI( 5) /5,5,5,5,5/
C                                                   F G H N +
      DATA HOI( 6),HOI( 7),HOI( 8),HOI( 9),HOI(10) /5,5,5,5,1/
C                                                   - * / ( )
      DATA HOI(11),HOI(12),HOI(13),HOI(14),HOI(15) /1,3,3,7,0/
C                 CURRENT TOKEN IS +-*/.  NEXT TOKEN IS  +-*/ P ( )
      DATA SYNTAX(1,1),SYNTAX(1,2),SYNTAX(1,3),SYNTAX(1,4) /1,0,0,1/
C                 CURRENT TOKEN IS PRIM.  NEXT TOKEN IS  +-*/ P ( )
      DATA SYNTAX(2,1),SYNTAX(2,2),SYNTAX(2,3),SYNTAX(2,4) /0,2,2,0/
C                 CURRENT TOKEN IS (.     NEXT TOKEN IS  +-*/ P ( )
      DATA SYNTAX(3,1),SYNTAX(3,2),SYNTAX(3,3),SYNTAX(3,4) /1,0,0,0/
C                 CURRENT TOKEN IS ).     NEXT TOKEN IS  +-*/ P ( )
      DATA SYNTAX(4,1),SYNTAX(4,2),SYNTAX(4,3),SYNTAX(4,4) /0,2,2,0/
C                                                   A B C D E
      DATA TOS( 1),TOS( 2),TOS( 3),TOS( 4),TOS( 5) /6,6,6,6,6/
C                                                   F G H N +
      DATA TOS( 6),TOS( 7),TOS( 8),TOS( 9),TOS(10) /6,6,6,6,2/
C                                                   - * / ( )
      DATA TOS(11),TOS(12),TOS(13),TOS(14),TOS(15) /2,4,4,0,0/
C
C     *****     PROCEDURES     *****************************************
C
C     COMAND IS USED FOR INFIX, STACK AND SUFFIX.  UPON COMPLETION,
C     COMAND(180) CONTAINS -1 IF AN ERROR OCCURRED, 0 IF THE VALUE
C     OF THE EXPRESSION IS FALSE AND +1 IF THE VALUE OF THE
C     EXPRESSION IS TRUE.
C
      ISTACK=NCHCMD+2
      COMAND(ISTACK)=14
      ISUFIX=181
      IPREV=3
      COMAND(NCHCMD+1)=41
      INFIX=EQUAL-1
C
C     GET A CHARACTER FROM INFIX.  LOOK UP IN CHTAB.  CHECK SYNTAX.
C
10    IF (INFIX.GT.NCHCMD) GO TO 180
      INFIX=INFIX+1
      J=COMAND(INFIX)
      IF (J.EQ.32) GO TO 10
C     32 = ASCII BLANK - IGNORE IT.
      IF (J.GT.96) J=J-32
C     CONVERT TO UPPER CASE.
      DO 20 I=1,15
      IF (CHTAB(I).EQ.J) GO TO 30
20    CONTINUE
      GO TO 230
30    J=COLTAB(I)
      IF (SYNTAX(IPREV,J)-1) 40,190,200
C
C     CONVERT INFIX TO SUFFIX
C
40    IPREV=J
50    J=COMAND(ISTACK)
      IF (TOS(J)-HOI(I)) 60,70,80
C     PUSH INFIX ONTO STACK
60    ISTACK=ISTACK+1
      COMAND(ISTACK)=I
      GO TO 10
C     DELETE TOP OF STACK
70    ISTACK=ISTACK-1
      IF (ISTACK.GT.NCHCMD+1) GO TO 10
      IF (INFIX-NCHCMD) 220,220,250
C     IF TOS IS PRIMARY, PUT ITS VALUE INTO SUFFIX.
C     IF TOS IS OPERATOR, DO OPERATION ON TWO LAST ENTRIES IN SUFFIX.
80    IF (J-9) 90,100,130
C     PRIMARY IS SYMBOL A-H
90    IF (PRED(1,J).EQ.0) GO TO 210
      J=PRED(2,J)
      GO TO 110
C     NULL PREDICATE
100   J=0
110   ISUFIX=ISUFIX-1
120   COMAND(ISUFIX)=J
      ISTACK=ISTACK-1
      GO TO 50
C     OPERATOR
130   J=J-9
      ISUFIX=ISUFIX+1
      GO TO (140,150,160,170), J
C             +   -   *   /
140   J=MIN0(COMAND(ISUFIX)+COMAND(ISUFIX-1),1)
      GO TO 120
150   J=MIN0(COMAND(ISUFIX)+1-COMAND(ISUFIX-1),1)
      GO TO 120
160   J=COMAND(ISUFIX)*COMAND(ISUFIX-1)
      GO TO 120
170   J=COMAND(ISUFIX)*(1-COMAND(ISUFIX-1))
      GO TO 120
C
180   COMAND(180)=-23
C     MESSAGE 23 - TOO MANY (
      GO TO 240
190   COMAND(180)=-24
C     MESSAGE 24 - MISSING PRIMARY
      GO TO 240
200   COMAND(180)=-25
C     MESSAGE 25 - MISSING OPERATOR
      GO TO 240
210   EQUAL=CHTAB(J)
      CALL EXCHAH (EQUAL,1)
      COMAND(180)=-26
C     MESSAGE 26 - REFERENCE TO UNDEFINED PREDICATE.
      GO TO 250
220   COMAND(180)=-27
C     MESSAGE 27 - TOO MANY )
      GO TO 240
230   COMAND(180)=-28
C     MESSAGE 28 - UNRECOGNIZED CHARACTER
C
240   EQUAL=INFIX
250   RETURN
C
      END
@HDG,P EXCHC5
@FTN,SVI EXCHC5
      SUBROUTINE EXCHC5 (IBLOCK,OBLOCK)
      INTEGER IBLOCK(1),OBLOCK(1)
C
C     COPY CONTROL RECORDS FROM INTAPE TO OUTAPE, OUTPUT FILE,
C     AND INDEX IF SELECTED.  COPY RECORDS FROM WORKF FIRST, IF ANY.
C     CREATE CONTROL RECORDS DEMANDED BY COMMANDS.
C
C     THE FOLLOWING COMMANDS GENERATE A CONTROL RECORD CONSISTING OF
C     THE PARAMETER STRING.
C
C     AUTHOR
C     COMMENT
C     CONTROL (ITYPEO SET FROM MODIFY)
C     DATA TYPE
C     GROUPS
C     INSERT
C     KEYWORDS
C     MACHINE
C     ORIGIN
C     REFERENCES
C     REMOVE   (FIRST CHARACTER OF PARAMETER STRING ONLY)
C     SIGNAL   (FIRST CHARACTER OF PARAMETER STRING ONLY)
C     UPDATE
C
C     IF UPDATE OCCURS WHEN PHASE NOT YET EQUAL 8, ALL CONTROL RECORDS
C     ARE FIRST COPIED AS THOUGH A COPY COMMAND WERE PENDING, AND A
C     CONTROL RECORD IS CREATED FOR THE UPDATE COMMAND.
C
C     *****     LOCAL VARIABLES     ************************************
C
C BLANK   CONTAINS A HOLLERITH BLANK.
      INTEGER BLANK
C C1      IS USED FOR VERTICAL FORMAT CONTROL DURING INDEX PRINTING.
      INTEGER C1
C COL1    THE FIRST COLUMN OF TEXT OF A CONTROL RECORD.  DERIVED FROM
C         EQUAL FOR COMMANDS, AND 5 FOR CONTROL RECORDS FROM INTAPE.
      INTEGER COL1
C I,J     USED FREELY AS INDICES.
      INTEGER I,J
C KCONT   THE INDEX IN COMD OF THE CONTROL COMMAND.
      INTEGER KCONT
C KNAME   IS THE INDEX IN COMD OF THE NAME COMMAND.
      INTEGER KNAME
C KTEXT   THE INDEX IN COMD OF THE TEXT COMMAND.
      INTEGER KTEXT
C KUPDA   THE INDEX IN COMD OF THE UPDATE COMMAND.
      INTEGER KUPDA
C LIST    CONTAINS THE WORD LIST IN ASCII.  USED FOR THE A OPTION.
      INTEGER LIST(4)
C NM      IS THE INDEX OF THE INPUT CONTROL RECORD BEING PROCESSED.
      INTEGER NM
C NOUT    IS THE INDEX OF THE OUTPUT CONTROL RECORD BEING PROCESSED.
      INTEGER NOUT
C NY      IS THE PROGRAM NUMBER.  IT IS THE NUMBER FROM INTAPE IF
C         OUTAPE IS NOT DEFINED, ELSE IT IS THE NUMBER FOR OUTAPE.
      INTEGER NY
C ONE     CONTAINS A HOLLERITH 1.
      INTEGER ONE
C REASON  REASON FOR COPYING A CONTROL RECORD.  1 = COPY COMMAND
C         PENDING.  2 = UPDATE COMMAND AND PHASE NOT YET EQUAL 8.
C         3 = COMMAND.
      INTEGER REASON
C RI      CONTAINS THE INDEX IN COMD OF THE COMMAND THAT PRODUCES A
C         GIVEN RECORD TYPE.  RI IS SUBSCRIPTED BY (ITYPEO-64).
      INTEGER RI(26)
C RT      IS THE RECORD TYPE GENERATED BY A CONTROL STATEMENT.
      INTEGER RT(34)
C STAR    CONTAINS A HOLLERITH STAR.
      INTEGER STAR
C ZERO    CONTAINS A HOLLERITH ZERO.
      INTEGER ZERO
C
C     *****     COMMON VARIABLES     ***********************************
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
C     *****     LOCAL VARIABLE DATA     ********************************
C
      DATA BLANK /1H /
C                                            L  I  S  T
      DATA LIST(1),LIST(2),LIST(3),LIST(4) /76,73,83,84/
C
      DATA KCONT /31/
      DATA KNAME /9/
      DATA KTEXT /27/
      DATA KUPDA/29/
      DATA ONE /1H1/
C                                                      A  B  C  D  E  F
      DATA RI( 1),RI( 2),RI( 3),RI( 4),RI( 5),RI( 6) / 1,22, 2, 4,20,31/
C                                                      G  H  I  J  K  L
      DATA RI( 7),RI( 8),RI( 9),RI(10),RI(11),RI(12) / 6,31,-1,34,11,31/
C                                                      M  N  O  P  Q  R
      DATA RI(13),RI(14),RI(15),RI(16),RI(17),RI(18) /13,31,15, 9,31,23/
C                                                      S  T  U  V  W  X
      DATA RI(19),RI(20),RI(21),RI(22),RI(23),RI(24) /29,31,31,31,31,31/
C                                                      Y  Z
      DATA RI(25),RI(26)                             /31,31            /
C                                                     A  C     D     G
      DATA RT(1), RT(2), RT(3), RT(4), RT(5), RT(6) /65,67, 0,68, 0,71/
C                                                           P     K
      DATA RT(7), RT(8), RT(9), RT(10),RT(11),RT(12)/ 0, 0,80, 0,75, 0/
C                                                     M     O
      DATA RT(13),RT(14),RT(15),RT(16),RT(17),RT(18)/77, 0,79, 0, 0, 0/
C                                                              B  R
      DATA RT(19),RT(20),RT(21),RT(22),RT(23),RT(24)/ 0, 0, 0,66,82, 0/
C                                                                 S
      DATA RT(25),RT(26),RT(27),RT(28),RT(29),RT(30)/ 0, 0, 0, 0,83, 0/
C                                                              J
      DATA RT(31),RT(32),RT(33),RT(34)              /-1, 0, 0,74/
C
      DATA STAR /1H*/
      DATA ZERO /1H0/
C
C     *****     PROCEDURES     *****************************************
C
      REASON=1
      NY=N1RECI
      IF (ICOMD.LE.-2 .AND. ITYPEI.EQ.80) NY=NY-1
C     ICOMD .LE. -2 MEANS PREDICATE-CONTROLLED COPY, 80 = ASCII P.
C     IF BOTH CONDITIONS ABOVE ARE TRUE, THE CURRENT MODULE HAS NO TEXT.
      IF (PHASE.EQ.4) NY=0
C     NY IS USED IN THIS REGION FOR THE PROGRAM NUMBER.  (IT IS PRINTED
C     IN THE INDEX).
      IF (ICOMD.LE.0) GO TO 10
      IF (PHASE.GE.4) GO TO 100
      IF (ICOMD.EQ.KNAME) GO TO 10
      IF (ICOMD.NE.KUPDA) GO TO 100
      REASON=2
      PHASE=8
10    IF (NRWORK.GT.0) REWIND WORKF
      NM=0
      NOUT=0
20    NM=NM+1
      IF (NM.LE.NRWORK) GO TO 60
30    IF (ITYPEI*(ITYPEI-69)*(ITYPEI-73).EQ.0) GO TO 230
C     69 = ASCII E, 73 = ASCII I.
      IF (NOUT.EQ.0) GO TO 40
      IF (ITYPEI.EQ.80) GO TO 230
C     80 = ASCII P.
      IF (NCHACT.NE.1) GO TO 40
      IF (INTREC(1).EQ.32) GO TO 220
C     32 = ASCII BLANK.  DELETE BLANK CONTROL RECORDS.
40    ITYPEO=ITYPEI
      NCHOUT=NCHACT
      DO 50 J=1,NCHOUT
50    OUTREC(J+5)=INTREC(J)
      GO TO 70
60    READ (WORKF) ITYPEO,NCHOUT,(OUTREC(J+5),J=1,NCHOUT)
      IF (NCHOUT.NE.1) GO TO 70
      IF (NM.EQ.1) GO TO 70
      IF (OUTREC(6).EQ.32) GO TO 200
C     32 = ASCII BLANK.  DELETE BLANK CONTROL RECORDS.
70    NOUT=NOUT+1
      J=RI(ITYPEO-64)
      DO 80 I=1,4
80    OUTREC(I)=COMD(I,J)
      OUTREC(5)=61
C     61 = ASCII =
      COL1=5
      IF (J.NE.KCONT) GO TO 130
      COL1=7
C     CONTROL,*=...  MOVE UP TWO CHARACTERS AND INSERT ITYPEO.
      DO 90 I=1,NCHOUT
90    OUTREC(NCHOUT+8-I)=OUTREC(NCHOUT+6-I)
      OUTREC(5)=44
C     44 = ASCII COMMA.
      OUTREC(6)=ITYPEO
      OUTREC(7)=61
C     61 = ASCII =
      GO TO 130
100   IF (ICOMD.EQ.KTEXT) GO TO 240
      COL1=EQUAL-1
      NCHOUT=NCHCMD-COL1
      NRWORK=NRWORK+1
C     NRWORK IS USED HERE AS THE SEQUENCE OF THE CONTROL RECORD.
      ITYPEO=RT(ICOMD)
      IF (ITYPEO.GT.0) GO TO 110
C     PROCESS CONTROL,TYPE=TEXT COMMAND.
      ITYPEO=MODIFY
      IF (RI(ITYPEO-64).NE.KCONT) GO TO 320
110   NOUT=NRWORK
      REASON=3
      DO 120 I=1,NCHCMD
120   OUTREC(I)=COMAND(I)
130   IF (ITYPEO.EQ.74) SIGNAL=OUTREC(COL1+1)
C     74 = ASCII J.
      IF (ITYPEO.EQ.80) VERT=0
C     80 = ASCII P
      IF (ITYPEO.NE.68) GO TO 150
C     68 = ASCII D
      IF (OPTA*OPTL*(1-OPTV).EQ.0) GO TO 150
      DO 140 J=1,4
      I=OUTREC(J+COL1)
      IF (I.GT.96 .AND. I.LT.123) I=I-32
C     CONVERT TO UPPER CASE.
      IF (I.NE.LIST(J)) GO TO 150
140   CONTINUE
      VERT=1
C     GENERATE CONTROL (JCL) RECORDS - EXCHCG MAY BE SYSTEM SENSITIVE.
150   CALL EXCHCG (OUTREC(COL1+1))
      IF (OUTOPN.EQ.0) GO TO 160
      CALL EXCHPR (ISTAT,OBLOCK,OUTREC(COL1+1))
      IF (ISTAT.NE.0) GO TO 340
      NY=NLRECO
160   NCHOUT=NCHOUT+COL1
C     TELL EXCHOU THE CONTROL RECORD SEQUENCE NUMBER.
      OUTREC(180)=-NOUT
      IF (OPTC*OUFILE.NE.0) CALL EXCHOU (OUTREC)
C     PRINT THE INDEX IF SELECTED.
      IF (INDEX.LE.0.AND.OPTL.EQ.0.AND.(PHASE.LT.4.OR.OPTS.EQ.0)) GO TO
     1190
      IF (INDEXS(ITYPEO-64).EQ.0) GO TO 190
      C1=BLANK
C     DOUBLE SKIP FOR PROGRAM HEADER (P).
      IF (ITYPEO.EQ.80) C1=ZERO
      IF (OPTV+VERT.NE.0) GO TO 170
      IF (OPTL.EQ.0.AND.(PHASE.LT.4.OR.OPTS.EQ.0)) GO TO 170
      IF (CHAR1L.NE.ONE) C1=ONE
      CHAR1L=ONE
170   CALL EXCHAH (OUTREC,NCHOUT)
      WRITE (PRINTR,180) C1,NY,NOUT,(OUTREC(N),N=1,NCHOUT)
180   FORMAT (A1,2I5,1H*,(3X,105A1))
190   IF (REASON.EQ.3) GO TO 310
200   IF (NM-NRWORK) 20,210,220
210   REWIND WORKF
      NRWORK=0
      GO TO 30
220   CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT) 330,30,330
230   IF (REASON.EQ.2) GO TO 300
240   IF (OUFILE.EQ.0) GO TO 260
      DO 250 I=1,4
250   OUTREC(I)=COMD(I,KTEXT)
      OUTREC(180)=0
      NCHOUT=0
C     TELL EXCHCG ALL CONTROL RECORDS HAVE BEEN PROCESSED.
      CALL EXCHCG (OUTREC)
      NCHOUT=4
      ACTION=2-OPTC-OPTC
C     ACTION = 2 MEANS START OF PROGRAM.
      CALL EXCHOU (OUTREC)
260   IF (OPTV+VERT.NE.0) GO TO 280
      IF (OPTL.EQ.0.AND.(PHASE.LT.4.OR.OPTS.EQ.0)) GO TO 280
      IF (OUTOPN.NE.0) NY=NLRECO
      I=BLANK
      IF (CHAR1L.NE.ONE) I=ONE
      WRITE (PRINTR,270) I,NY
270   FORMAT (A1,I5,1H*,8X,4HTEXT/)
280   CHAR1L=STAR
      NRWORK=MIN0(NRWORK,0)
      IF (IDOPTN.NE.67) IDCUR=IDSTRT
C     67 = ASCII C
      IF (ICOMD.EQ.KTEXT) GO TO 290
C
C     WORKING ON A COPY STATEMENT, OR COPYING A MODULE BECAUSE CONTROL
C     RECORDS HAD BEEN CHANGED, AND A 'NAME' COMMAND WAS SUBMITTED.
C
      TRANS=6
      GO TO 370
C
C     WORKING ON A TEXT STATEMENT.
C
290   TRANS=7
      GO TO 370
C
C     WORKING ON AN UPDATE STATMENT.
C
300   NRWORK=NOUT
      GO TO 100
C
C     WRITING A SINGLE CONTROL RECORD.
C
310   TRANS=1
      GO TO 370
C
C     ERROR MESSAGES.
C
320   NUMBER=17
C     MESSAGE 17 - UNRECOGNIZED CHARACTER.
      GO TO 360
330   NUMBER=1
      GO TO 350
340   NUMBER=2
350   EQUAL=ISTAT
360   TRANS=8
C
C     RETURN TO TRANSITION PROGRAM.
C
370   RETURN
C
      END
@HDG,P EXCHCG
@FTN,SVI EXCHCG
      SUBROUTINE EXCHCG (RECORD)
C
C     USE RECORD(1-NCHOUT) AND ITYPEO TO GENERATE JCL.
C     WHEN NCHOUT=0, ALL CONTROL IMAGES HAVE PREVIOUSLY BEEN PROCESSED.
C     THIS IS THE PORTABLE VERSION.  IT DOES NOT DO ANYTHING.
C
      INTEGER RECORD(1)
C
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
C
      RETURN
      END
@HDG,P EXCHC6
@FTN,SVI EXCHC6
      SUBROUTINE EXCHC6 (IBLOCK,OBLOCK)
      INTEGER IBLOCK(1),OBLOCK(1)
C
C     COPY THE PROGRAM TEXT FROM INTAPE TO OUTAPE.
C
      INTEGER KNAME,ONE,SVHCMD(180)
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
      DATA KNAME /9/
      DATA ONE /1H1/
C
      LINEO=0
      NERRS=0
C     SAVE COMMAND IN CASE WE GO SEARCHING FOR INCLUDED TEXT.
      DO 5 I = 1,NCHCMD
5     SVHCMD(I)=HOLCMD(I)
      IF (ITYPEI*(ITYPEI-73).NE.0) GO TO 165
C     73 = ASCII I.  IF WE GET HERE WITHOUT TEXT OR INCLUDE, WE HAVE
C     A VOID MODULE.
      IF (OPTL+OUTAPE+OUFILE.NE.0) GO TO 10
      CALL EXCHNP (ISTAT,IBLOCK)
      IF (ISTAT.EQ.7) GO TO 220
      IF (ISTAT) 250,160,250
10    MODEO=MODEI
      ITYPEO=0
      NBC=OPTL+OUFILE
      IF (INDEX.GT.0) NBC=1
20    NCHOUT=NCHACT
      ITYPEO=ITYPEI
      IF (OUTOPN.EQ.0) GO TO 120
      CALL EXCHPR (ISTAT,OBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 260
C
C     CHECK WHETHER WE CAN DO A BLOCK COPY (WORD-BY-WORD
C     INSTEAD OF BYTE-BY-BYTE).  WE CAN DO A BLOCK COPY IF
C     WE ARE NOT DOING A LISTING, NOT CREATING AN OUTPUT
C     FILE AND NOT PRINTING THE INDEX.  ALSO, THE INPUT AND
C     OUTPUT CHARACTER POSITIONS MUST BE THE SAME.  IF THE
C     PROGRAM IS SMALL ENOUGH TO BE ENTIRELY CONTAINED IN BOTH
C     THE INPUT AND OUTPUT BLOCKS, THEN IT IS ENOUGH THAT THE
C     CURRENT POSITION IN THE BYTE BUFFER BE THE SAME.
C     WE CAN'T DO A BLOCK COPY IF THE CURRENT PROGRAM IS THE
C     LAST ONE, AND IT ENDS IN THIS BLOCK BECAUSE WE DON'T
C     KNOW THE LOCATION OF THE END-OF-FILE RECORD.
C
      IF (NBC.NE.0) GO TO 120
      IF (CPCBI+1.NE.CPCBO) GO TO 120
      IF (LASTI.EQ.76.AND.L1PRGI.EQ.0) GO TO 120
C     WE DON'T KNOW WHERE TO STOP WHEN NEXT PROG IS EOF.
      IF (L1PRGI.EQ.0) GO TO 25
      IF (NERRCO+NDATAO+9-CCDBO.GE.L1PRGI+NERRCI-CCDBI) GO TO 30
25    IF (CCDBI+1.NE.CCDBO) GO TO 120
      IF (NERRCO.NE.NERRCI.OR.NDATAO.NE.NDATAI) GO TO 120
C     WE CAN DO A BLOCK COPY (WORD-BY-WORD INSTEAD OF BYTE-BY-BYTE).
C     FIRST COPY REMAINING BYTES IN CBLCKI TO CBLCKO.
30    LI=L1PRGI+NERRCI-1
      IF (L1PRGI.NE.0) GO TO 40
      LI=NERRCI+NDATAI+9
      IF (LASTI.EQ.76) LI=L1RECI+NERRCI-1
40    IF (CPCBI.GE.NCCBI) GO TO 50
      IF (CCDBI.GE.LI) GO TO 160
      CPCBI=CPCBI+1
      CBLCKO(CPCBO)=CBLCKI(CPCBI)
      CPCBO=CPCBO+1
      CCDBI=CCDBI+1
      CCDBO=CCDBO+1
      GO TO 40
C     PACK COPIED BYTES.
50    CALL EXCHPA (CBLCKO,OBLOCK(CWDBO))
      CPCBO=1
      CPCBI=0
      CWDBO=CWDBO+NWCBO
      CWDBI=CWDBI+NWCBI
C     NOW COPY WORDS TO THE END OF THE CURRENT PROGRAM
60    IF (CCDBO.LT.NERRCO+NDATAO+10) GO TO 70
      IF (N1RECO.EQ.0) N1RECO=NLRECO
      IF (L1RECO.EQ.0) L1RECO=L1RECI
      CALL EXCHPB (ISTAT,OBLOCK)
      IF (ISTAT.NE.0) GO TO 260
70    IF (CCDBI.LT.LI) GO TO 80
      IF (L1PRGI.NE.0) GO TO 100
      CALL EXCHGB (ISTAT,IBLOCK)
      IF (ISTAT.NE.0) GO TO 250
      GO TO 30
80    NW=NWCBI*((LI-CCDBI)/NCCBI)
      IF (NW.EQ.0) GO TO 100
      DO 90 I=1,NW
      OBLOCK(CWDBO)=IBLOCK(CWDBI)
      CWDBO=CWDBO+1
90    CWDBI=CWDBI+1
100   CCDBO=CCDBO+LI-CCDBI
      CCDBI=LI
      IF (L1PRGI.EQ.0.AND.LASTI.NE.76) GO TO 60
      CPCBI=MOD(LI,NCCBI)
      CPCBO=MOD(CCDBO-1,NCCBO)+1
      CALL EXCHUN (IBLOCK(CWDBI),CBLCKI)
      IF (CPCBI.EQ.0) GO TO 160
      DO 110 I=1,CPCBI
110   CBLCKO(I)=CBLCKI(I)
      GO TO 160
C
C     END OF BLOCK COPY CODE.
C
120   CALL EXCHTP (INTREC,LINEO)
160   CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 250
      IF (ITYPEI*(ITYPEI-73).EQ.0) GO TO 20
C     73 = ASCII I.
165   IF (OPTL.NE.0) GO TO 180
      IF (INDEX.LE.0) GO TO 195
      WRITE (PRINTR,170) LINEO
170   FORMAT (I9,14H IMAGES COPIED)
      GO TO 200
180   WRITE (PRINTR,190)
190   FORMAT (1H1)
195   CHAR1L=ONE
200   IF (OUFILE.EQ.0) GO TO 210
      OUTREC(1)=SIGNAL
      OUTREC(2)=SIGNAL
      NCHOUT=2
      OUTREC(180)=0
      ACTION=OPTC+OPTC-2
C     ACTION = -2 MEANS END OF PROGRAM.
      CALL EXCHOU (OUTREC)
210   IF (ITYPEI.EQ.69) GO TO 220
C     69 = ASCII E
C
C     RETURN TO THE COPY CONTROL SEGMENT.
C
      DO 215 I=1,NCHCMD
215   HOLCMD(I)=SVHCMD(I)
      IF (ICOMD.EQ.-3) GO TO 240
C     ICOMD=-3 MEANS COPY,I OR COPY,X AND TRUE EXPRESSION VALUE.
      TRANS=4
      IF (ICOMD.NE.KNAME) GO TO 280
C     MODULE COPIED BECAUSE CONTROL RECORDS CHANGED, THEN 'NAME'
C     COMMAND SUBMITTED.  GO PROCESS 'NAME' COMMAND.
      TRANS=5
      PHASE=4
      GO TO 280
C
C     END OF FILE ON INPUT TAPE.
C
220   IF (INTOPN.LT.0) GO TO 240
      WRITE (PRINTR,230) (SVHCMD(I),I=1,NCHCMD)
230   FORMAT (//39H0END OF FILE ENCOUNTERED ON INPUT TAPE./(1X,80A1))
      INTOPN=-1
C
C     RETURN TO THE COMMAND DECODER.
C
240   TRANS=1
      GO TO 280
C
C     ERROR MESSAGES.
C
250   NUMBER=1
C     MESSAGE 1 - I/O ERROR READING INTAPE.
      GO TO 270
260   NUMBER=2
C     MESSAGE 2 - I/O ERROR WRITING OUTAPE.
270   TRANS=8
      EQUAL=ISTAT
C
C     RETURN TO THE TRANSITION PROGRAM.
C
280   IF (NERRS.EQ.0) GO TO 300
      WRITE (PRINTR,290) NERRS,(SVHCMD(I),I=1,NCHCMD)
290   FORMAT (//39H0MAXIMUM ERROR SEVERITY DURING COPY WAS,I2,1H./
     1(1X,80A1))
      NERRG=MAX0(NERRS,NERRG)
300   RETURN
C
      END
@HDG,P EXCHC7
@FTN,SVI EXCHC7
      SUBROUTINE EXCHC7 (IBLOCK,OBLOCK)
      INTEGER IBLOCK(1),OBLOCK(1)
      INTEGER D1,D2,D3,EDIT,ONE,PLUS,STAR,TXDISK(40)
C
C     PROCESS THE TEXT COMMAND.
C
C MSG     IS USED TO PRINT A MESSAGE.
      INTEGER MSG(6,2)
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
      DATA ONE /1H1/, PLUS /1H+/, STAR /1H*/
      DATA MSG(1,1),MSG(2,1),MSG(3,1) /1HI,1HN,1HS/
      DATA MSG(4,1),MSG(5,1),MSG(6,1) /1HE,1HR,1HT/
      DATA MSG(1,2),MSG(2,2),MSG(3,2) /1HU,1HP,1HD/
      DATA MSG(4,2),MSG(5,2),MSG(6,2) /1HA,1HT,1HE/
C
      LINEI=1
      LINEO=0
      NERRS=0
      INEND=0
      CHAR1L=STAR
C
C     SAVE SYSTEM DEPENDENT INFO FROM TEXT COMMAND
C
      K=EQUAL
      IF (K.EQ.0) K=NCHCMD+1
      DO 20 I=1,40
      IF (K.GT.NCHCMD) GO TO 10
      J=COMAND(K)
      K=K+1
      GO TO 20
10    J=32
C     32 = ASCII BLANK.
20    TXDISK(I)=J
      IF (INTOPN.LE.0) ITYPEI=0
C
C     MAIN PROCESSING LOOP
C
60    EDIT=0
70    CALL EXCHIM
      IF (NCHCMD.LT.0) GO TO 80
C     NCHCMD.LT.0 MEANS END OF FILE.
      IF (NCHCMD.LT.2) GO TO 100
      IF (COMAND(1).NE.SIGNAL) GO TO 100
      IF (COMAND(2).EQ.SIGNAL) GO TO 80
      IF (COMAND(2).EQ.73) GO TO 370
      IF (COMAND(2).EQ.105) GO TO 370
C     73,105 = ASCII I - REQUEST TO INCLUDE TEXT.
      IF (NCHCMD.LT.3) GO TO 100
      IF (COMAND(2).NE.61) GO TO 100
C     61 = ASCII =
      SIGNAL=COMAND(3)
      GO TO 70
C     END OF TEXT FILE.
80    IF (INTEXT.EQ.0) GO TO 90
      ACTION=-1
C     ACTION = -1 MEANS CLOSE FILE
      CALL EXCHIM
      INTEXT=0
      NCHCMD=0
90    NCHCMD=MIN0(NCHCMD,0)
      IF (PHASE.NE.8) GO TO 660
      IF (INEND) 660,630,660
100   IF (PHASE.EQ.8) IF (COMAND(1)-SIGNAL) 110,480,110
110   IF (EDIT.EQ.0) GO TO 450
C
C     PARTIAL LINE EDITOR.
C     INVOKED BY -LINE$ WHERE LINE IS THE LINE NUMBER TO BE EDITED.
C     EDIT IS CONTROLLED BY N1,N2 /STRING1/STRING2/ WHERE / DENOTES
C     THE FIRST NON-BLANK CHARACTER AFTER N2.  N1 AND N2 ARE COLUMN
C     LIMITS UNDER WHICH TO PERFORM THE EDITING.  N1 AND ,N2 ARE
C     OPTIONAL.  IF N1 IS NOT SPECIFIED, COLUMN 1 IS USED AS THE LEFT
C     LIMIT.  IF ,N2 IS NOT SPECIFIED, THE END OF THE IMAGE IS
C     ASSUMED AS THE RIGHT LIMIT, AND THE IMAGE SIZE CAN CHANGE.  WHEN
C     STRING1 IS FOUND, IT IS REPLACED BY STRING2, WITH SHIFTING TAKING
C     PLACE AS NECESSARY (BETWEEN N1 AND N2) TO ACCOUNT FOR DIFFERENT
C     LENGTHS OF STRING1 AND STRING2.  THE THIRD DELIMITER IS
C     OPTIONAL, IN WHICH CASE THE REMAINDER OF (N1,N2) IS CLEARED
C     AFTER STRING2 IS INSERTED.
C
      IF (INEND.NE.0) GO TO 240
C     CONVERT COLUMN NUMBERS.
      NBR1=0
      NBR2=0
      I=0
120   I=I+1
      IF (I.GT.NCHCMD) GO TO 130
      J=COMAND(I)
      IF (J.EQ.44) GO TO 150
C     44 = ASCII COMMA
      IF (J.LT.48) GO TO 160
C     48 = ASCII ZERO
      IF (J.GT.57) GO TO 160
C     57 = ASCII NINE
      NBR1=10*NBR1+J-48
      GO TO 120
130   WRITE (PRINTR,140) LINEI,I,(HOLCMD(I),I=1,NCHCMD)
140   FORMAT (//8H0AT LINE,I6,35H, EDIT CONTROL FORMAT ERROR, COLUMN,I6/
     1(1X,80A1))
      NERRS=2
      GO TO 70
150   I=I+1
      IF (I.GT.NCHCMD) GO TO 130
      J=COMAND(I)
      IF (J.LT.48) GO TO 160
C     48 = ASCII ZERO
      IF (J.GT.57) GO TO 160
C     57 = ASCII NINE
      NBR2=10*NBR2+J-48
      GO TO 150
C     SCAN FOR DELIMITER
160   IF (J.NE.32) GO TO 170
C     32 = ASCII BLANK
      I=I+1
      J=COMAND(I)
      GO TO 160
170   D1=I
      NBR1=MIN0(NBR1,180)
      NBR2=MIN0(NBR2,180)
      IF (NBR1.EQ.0) NBR1=1
      IF (NBR2.EQ.0) GO TO 180
      IF (NBR2.LT.NBR1) GO TO 130
180   I=I+1
      IF (I.GT.NCHCMD) GO TO 130
      IF (COMAND(I).NE.J) GO TO 180
      D2=I
      D3=0
190   I=I+1
      IF (I.GT.NCHCMD) GO TO 200
      IF (COMAND(I).NE.J) GO TO 190
      D3=I
C     LOOK FOR SEARCH STRING (STRING1)
200   NUMBER=D2-D1-1
      J=NBR1
      IF (NUMBER.EQ.0) GO TO 260
      NY=NBR2
      IF (NY.EQ.0) NY=NCHACT
210   DO 220 I=1,NUMBER
      IF (I+J-1.GT.NY) GO TO 240
      IF (INTREC(I+J-1).NE.COMAND(I+D1)) GO TO 230
220   CONTINUE
      GO TO 260
230   J=J+1
      GO TO 210
240   WRITE (PRINTR,250) LINEI,(HOLCMD(I),I=1,NCHCMD)
250   FORMAT (//8H0AT LINE,I6,27H, NO FIND ON SEARCH STRING./(1X,80A1))
      NERRS=2
      GO TO 70
C     FOUND SEARCH STRING.  REPLACE WITH UPDATE STRING.
260   CHAR1L=PLUS
      IF (D3.NE.0) GO TO 300
C     NO THIRD DELIMITER.   REPLACE REST OF REGION.
      NY=NBR2
      IF (NY.EQ.0) NY=180
      D2=D2+1
      IF (D2.GT.NCHCMD) GO TO 280
      DO 270 I=D2,NCHCMD
      INTREC(J)=COMAND(I)
      J=J+1
      IF (J.GT.NY) GO TO 280
270   CONTINUE
280   IF (NBR2.NE.0) GO TO 290
      NCHACT=J-1
      GO TO 70
290   IF (J.GT.NBR2) GO TO 70
      INTREC(J)=32
C     32 = ASCII BLANK
      J=J+1
      GO TO 290
C     WE HAVE A THIRD DELIMITER.  REPLACE ONLY THE SEARCH STRING.
C     SHIFT THE REST OF THE REGION AS NECESSARY.
300   NUMBER=(D3-D2)-(D2-D1)
      IF (NUMBER) 310,350,330
C     SHIFT LEFT
310   I=J+D2-D1-1
      NY=MIN0(NBR2,NCHACT)
      IF (NY.EQ.0) NY=NCHACT
320   IF (I.GT.NY) GO TO 350
      INTREC(I+NUMBER)=INTREC(I)
C     NOTE - NUMBER .LT. 0 HERE
      INTREC(I)=32
C     32 = ASCII BLANK
      I=I+1
      GO TO 320
C     RIGHT SHIFT
330   I=NBR2
      IF (I.EQ.0) I=MIN0(NCHACT+NUMBER,180)
      NY=J+NUMBER
340   IF (I.LT.NY) GO TO 350
      INTREC(I)=INTREC(I-NUMBER)
      I=I-1
      GO TO 340
C     NO SHIFT NEEDED.
350   IF (NBR2.EQ.0) NCHACT=MIN0(NCHACT+NUMBER,180)
      IF (NBR2.GE.NCHACT) NCHACT=MIN0(NCHACT+NUMBER,NBR2)
      NY=NBR2
      IF (NY.EQ.0) NY=NCHACT
C     MOVE UPDATE STRING (STRING2).
360   D2=D2+1
      IF (D2.GE.D3) GO TO 70
      INTREC(J)=COMAND(D2)
      J=J+1
      IF (J-NY) 360,360,70
C
C     REQUEST TO INCLUDE TEXT.  -I IN COLUMNS 1 AND 2.
C
370   IF (EDIT.EQ.0) GO TO 390
      WRITE (PRINTR,380) (HOLCMD(I),I=1,NCHCMD)
380   FORMAT (//49H0REQUEST TO INCLUDE TEXT NOT ALLOWED DURING EDIT./(1X
     1,80A1))
      NERRS=2
      GO TO 70
390   ITYPEO=73
C     73 = ASCII I
      IF (NCHCMD.GE.4) GO TO 410
      WRITE (PRINTR,400) (HOLCMD(I),I=1,NCHCMD)
400   FORMAT (//45H0NO TARGET STRING ON REQUEST TO INCLUDE TEXT./(1X,80A
     11))
      NERRS=2
      GO TO 70
410   DO 420 I=4,NCHCMD
      IF (COMAND(I).NE.32) GO TO 430
420   CONTINUE
C     CONVERT TO UPPER CASE.  WE NEVER EXIT THE ABOVE LOOP AT THE BOTTOM
430   K=0
      DO 440 J=I,NCHCMD
      IF (COMAND(J).GT.95) COMAND(J)=COMAND(J)-32
      K=K+1
440   COMAND(K)=COMAND(J)
      NCHCMD=K
      GO TO 460
C
C     TEXT RECORD.
C
450   ITYPEO=0
460   NCHOUT=NCHCMD
      IF (OUTOPN.EQ.0) GO TO 470
      MODEO=0
      CALL EXCHPR (ISTAT,OBLOCK,COMAND)
      IF (ISTAT.NE.0) GO TO 770
470   CALL EXCHTP (COMAND,0)
      GO TO 70
C
C     APPARENT CHANGE CONTROL COMMAND
C
480   IF (INEND.EQ.0) GO TO 510
490   WRITE (PRINTR,500) (HOLCMD(I),I=1,NCHCMD)
500   FORMAT (//58H0ATTEMPT TO CHANGE OUTSIDE FILE, NEW TEXT APPENDED AT
     1 END./(1X,80A1))
      NERRS=1
      GO TO 70
510   NUMBER=1
      NBR1=0
      EDIT=0
      I=1
520   I=I+1
      IF (I.GT.NCHCMD) GO TO 600
      J=COMAND(I)
      IF (J.EQ.32) GO TO 600
C     32 = ASCII BLANK
      IF (EDIT.NE.0) GO TO 530
C     EDIT CONTROL MUST BE BLANK AFTER $.
      IF (J.EQ.44) GO TO 570
C     44 = ASCII COMMA
      IF (J.EQ.36) GO TO 560
C     36 = ASCII $
      IF (J.LT.48) GO TO 530
C     48 = ASCII ZERO
      IF (J.LE.57) GO TO 550
C     57 = ASCII 9
530   WRITE (PRINTR,540) I,(HOLCMD(I),I=1,NCHCMD)
540   FORMAT (//36H0CHANGE CONTROL FORMAT ERROR, COLUMN,I3/1X,80A1)
      NERRS=2
      GO TO 60
550   NBR1=10*NBR1+J-48
      GO TO 520
560   IF (NBR1.EQ.0) GO TO 530
      EDIT=1
      NBR1=NBR1-1
      GO TO 520
570   NUMBER=2
      NBR2=0
580   I=I+1
      IF (I.GT.NCHCMD) GO TO 590
      J=COMAND(I)
      IF (J.EQ.32) GO TO 590
C     32 = ASCII BLANK
      IF (IABS(J-44).EQ.1) GO TO 590
C     43 = ASCII +, 45 = ASCII -
      IF (J.LT.48) GO TO 530
C     48 = ASCII ZERO
      IF (J.GT.57) GO TO 530
C     57 = ASCII 9
      NBR2=10*NBR2+J-48
      GO TO 580
590   IF (NBR2.LT.NBR1) GO TO 530
      NBR1=NBR1-1
600   IF (NBR1.GE.LINEI-1) GO TO 620
      WRITE (PRINTR,610) (HOLCMD(I),I=1,NCHCMD)
610   FORMAT (//30H0CHANGE CONTROL SEQUENCE ERROR/1X,80A1)
      NERRS=2
      GO TO 60
620   IF (NCHCMD.LE.0) GO TO 630
      IF (LINEI.LE.NBR1) GO TO 630
      IF (NUMBER.EQ.1) GO TO 70
C     SKIP INTAPE UNTIL NBR2 IS SKIPPED.
      MODEI=1
      IF (LINEI.GE.NBR2) MODEI=0
      IF (LINEI-NBR2) 650,650,70
C     COPY FROM INTAPE UNTIL NBR1 COPIED.
630   MODEO=MODEI
      NCHOUT=NCHACT
      ITYPEO=ITYPEI
      IF (OUTAPE.EQ.0) GO TO 640
      CALL EXCHPR (ISTAT,OBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 770
640   CALL EXCHTP (INTREC,LINEI)
      MODEI=0
      IF (OPTL+OPTS+OUFILE.NE.0) GO TO 650
      IF (LINEI.EQ.NBR1) GO TO 650
      MODEI=1
650   CALL EXCHGR (ISTAT,IBLOCK,INTREC)
      IF (ISTAT.NE.0) GO TO 760
      LINEI=LINEI+1
      IF (ITYPEI.EQ.0.OR.ITYPEI.EQ.73) GO TO 620
C     73 = ASCII I
      INEND=1
      IF (NCHCMD.LE.0) GO TO 660
      I=NBR2
      IF (NUMBER.EQ.1) I=NBR1
      IF (LINEI-I) 490,490,70
660   IF (NERRS.EQ.0) GO TO 675
      J=1
      IF (PHASE.EQ.8) J=2
      WRITE (PRINTR,670) (MSG(I,J),I=1,6),NERRS
670   FORMAT (//31H0MAXIMUM ERROR SEVERITY DURING ,6A1,4H WAS,I2,1H.)
675   NERRG=MAX0(NERRG,NERRS)
      IF (OPTL+OPTS.NE.0) GO TO 690
      IF (OUTAPE+OUFILE.EQ.0) LINEO=0
      IF (INDEX.GT.0) WRITE (PRINTR,680) LINEO
680   FORMAT (I9,14H IMAGES COPIED)
      GO TO 710
690   WRITE (PRINTR,700)
700   FORMAT (1H1)
      CHAR1L=ONE
710   IF (OUFILE.EQ.0) GO TO 720
      OUTREC(1)=SIGNAL
      OUTREC(2)=SIGNAL
      NCHOUT=2
      OUTREC(180)=0
      ACTION=OPTC+OPTC-2
C     ACTION = -2 MEANS END OF PROGRAM.
      CALL EXCHOU (OUTREC)
720   IF (ITYPEI.NE.69) GO TO 750
C     69 = ASCII E
C
C     END OF FILE ON INPUT TAPE (UPDATE MODE).
C
      IF (INTOPN.LT.0) GO TO 750
      DO 730 I=1,40
730   HOLCMD(I+1)=TXDISK(I)
      HOLCMD(1)=32
      IF (TXDISK(1).NE.32) HOLCMD(1)=61
C     32 = ASCII BLANK, 61 = ASCII =
      CALL EXCHAH (HOLCMD,41)
      WRITE (PRINTR,740) (HOLCMD(I),I=1,41)
740   FORMAT (//39H0END OF FILE ENCOUNTERED ON INPUT TAPE./5H TEXT,41A1)
      INTOPN=-1
C
C     RETURN TO THE COMMAND DECODER.
C
750   TRANS=1
      GO TO 790
C
C     ERROR MESSAGES.
C
760   NUMBER=1
      GO TO 780
770   NUMBER=2
780   EQUAL=ISTAT
      TRANS=8
C
C     RETURN TO THE TRANSITION PROGRAM.
C
790   PHASE=2
      IF (OUTOPN.EQ.0) PHASE=1
      RETURN
C
      END
@HDG,P EXCHC8
@FTN,SVI EXCHC8
      SUBROUTINE EXCHC8
C
C     PRINT ERROR MESSAGES.
C
C     ARRAY S CONTAINS THE SEVERITY FOR EACH MESSAGE
      INTEGER S(31)
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
C
      DATA S(01),S(02),S(03),S(04),S(05),S(06),S(07) /9,9,5,6,6,6,6/
      DATA S(08),S(09),S(10),S(11),S(12),S(13),S(14) /6,6,6,5,5,5,1/
      DATA S(15),S(16),S(17),S(18),S(19),S(20),S(21) /0,4,5,5,6,6,2/
      DATA S(22),S(23),S(24),S(25),S(26),S(27),S(28) /2,5,5,5,5,5,5/
      DATA S(29),S(30),S(31)                         /4,5,5        /
C
C             1  2  3   4   5   6   7   8   9   10  11  12  13  14  15
      GO TO (10,30,200,220,240,260,280,300,320,340,360,380,400,420,440,4
     160,480,500,520,540,560,580,600,620,640,660,680,700,720,740,751),
     2NUMBER
C     16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
10    WRITE (PRINTR,20) EQUAL
20    FORMAT (//6H0ERROR,I2,29H WHILE TRYING TO READ INTAPE.)
      GO TO 50
30    WRITE (PRINTR,40) EQUAL
40    FORMAT (//6H0ERROR,I2,30H WHILE TRYING TO WRITE OUTAPE.)
50    GO TO (60,80,100,120,140,160), EQUAL
60    WRITE (PRINTR,70)
70    FORMAT (22H BLOCK SEQUENCE ERROR.)
      GO TO 180
80    WRITE (PRINTR,90)
90    FORMAT (20H BLOCK IS TOO SHORT.)
      GO TO 180
100   WRITE (PRINTR,110)
110   FORMAT (11H I/O ERROR.)
      GO TO 180
120   WRITE (PRINTR,130)
130   FORMAT (18H RECORD TOO LARGE.)
      GO TO 180
140   WRITE (PRINTR,150)
150   FORMAT (21H UNKNOWN RECORD TYPE.)
      GO TO 180
160   WRITE (PRINTR,170)
170   FORMAT (25H FIRST BLOCK NOT A LABEL.)
      GO TO 760
180   WRITE (PRINTR,190) (HOLCMD(I),I=1,NCHCMD)
190   FORMAT (30H PROGRAM EXECUTION TERMINATED./1X,80A1)
      INFILE=0
C
C     RETURN TO QUIT SEGMENT.
C
      TRANS=9
      GO TO 800
C
200   WRITE (PRINTR,210)
210   FORMAT (//38H0COMMAND MAY NOT APPEAR IN INPUT FILE.)
      GO TO 760
220   WRITE (PRINTR,230)
230   FORMAT (//20H0INTAPE NOT DEFINED.)
      GO TO 760
240   WRITE (PRINTR,250)
250   FORMAT (//23H0UNABLE TO OPEN INTAPE.)
      GO TO 10
260   WRITE (PRINTR,270)
270   FORMAT (//23H0UNABLE TO OPEN OUTAPE.)
      GO TO 30
280   WRITE (PRINTR,290)
290   FORMAT (//36H0TITLE NOT PROVIDED FOR OUTPUT TAPE.)
      GO TO 760
300   WRITE (PRINTR,310)
310   FORMAT (//19H0DATE NOT SUPPLIED.)
      GO TO 760
320   WRITE (PRINTR,330)
330   FORMAT (//19H0SITE NOT SUPPLIED.)
      GO TO 760
340   WRITE (PRINTR,350) INTAPE
350   FORMAT (//29H0INTAPE AND OUTAPE BOTH EQUAL,I4)
      GO TO 760
360   WRITE (PRINTR,370)
370   FORMAT (//43H0U MODIFIER OF OUTAPE COMMAND NOT SELECTED.)
      GO TO 760
380   WRITE (PRINTR,390)
390   FORMAT (//38H0COMMAND MUST HAVE A PARAMETER STRING.)
      GO TO 760
400   WRITE (PRINTR,410)
410   FORMAT (//27H0COMMAND HAS IMPROPER DATE.)
      GO TO 760
420   WRITE (PRINTR,430) EQUAL
430   FORMAT (//33H0UNRECOGNIZED CHARACTER IN COLUMN,I3,9H IGNORED.)
      GO TO 780
440   WRITE (PRINTR,450)
450   FORMAT (//39H0END OF FILE ENCOUNTERED ON INPUT TAPE.)
      IF (ICOMD) 780,560,780
460   WRITE (PRINTR,470) N1RECI
470   FORMAT (//56H0ALL SPECIFIED MODULES PRECEDE CURRENT INTAPE POSITIO
     1N (,I5,2H).)
      GO TO 760
480   WRITE (PRINTR,490) EQUAL
490   FORMAT (//33H0UNRECOGNIZED CHARACTER IN COLUMN,I3,1H.)
      GO TO 760
500   WRITE (PRINTR,510)
510   FORMAT (//29H0MODULE NUMBERS NOT IN ORDER.)
      GO TO 760
520   WRITE (PRINTR,530)
530   FORMAT (//23H0WORK FILE NOT DEFINED.)
      GO TO 760
540   WRITE (PRINTR,550)
550   FORMAT (//40H0WORK = INTAPE OR OUTAPE OR OUTPUT FILE.)
      GO TO 760
560   WRITE (PRINTR,570) EQUAL
570   FORMAT (//15H0CONTROL RECORD,I4,13H NOT PRESENT.)
      GO TO 760
580   WRITE (PRINTR,590)
590   FORMAT (//55H0CONTROL RECORD CHANGE REQUESTS NOT IN ASCENDING ORDE
     1R.)
      GO TO 760
600   WRITE (PRINTR,610)
610   FORMAT (//12H0TOO MANY (.)
      GO TO 760
620   WRITE (PRINTR,630) EQUAL
630   FORMAT (//37H0MISSING PRIMARY SYMBOL BEFORE COLUMN,I3,1H.)
      GO TO 760
640   WRITE (PRINTR,650) EQUAL
650   FORMAT (//31H0MISSING OPERATOR BEFORE COLUMN,I3,1H.)
      GO TO 760
660   WRITE (PRINTR,670) EQUAL
670   FORMAT (//34H0REFERENCE TO UNDEFINED PREDICATE ,A1,1H.)
      GO TO 760
680   WRITE (PRINTR,690) EQUAL
690   FORMAT (//30H0TOO MANY ) DETECTED IN COLUMN,I3,1H.)
      GO TO 760
700   WRITE (PRINTR,710) EQUAL
710   FORMAT (//33H0UNRECOGNIZED CHARACTER IN COLUMN,I3,1H.)
      GO TO 760
720   WRITE (PRINTR,730) N1RECI
730   FORMAT (//21H0INTAPE POSITIONED AT,I5,25H.  BACKWARD SKIP IGNORED.
     1)
      GO TO 780
740   WRITE (PRINTR,750)
750   FORMAT (//23H0COMMAND IS INCOMPLETE.)
      GO TO 760
751   WRITE (PRINTR,752)
752   FORMAT (//66H0INPUT, INCLUDE OR TEXT MAY NOT BE MADE EQUAL TO OUTA
     1PE OR OUTPUT.)
760   WRITE (PRINTR,770)
770   FORMAT (23H COMMAND NOT PROCESSED.)
780   WRITE (PRINTR,790) (HOLCMD(I),I=1,NCHCMD)
790   FORMAT ((1X,80A1))
C
C     RETURN TO COMMAND PROCESSSOR.
C
      CHAR1L=0
      NERRS=MAX0(S(NUMBER),NERRS)
      NERRG=MAX0(NERRG,NERRS)
      TRANS=1
C
C     RETURN TO TRANSITION PROGRAM.
C
800   RETURN
C
      END
@HDG,P EXCHC9
@FTN,SVI EXCHC9
      SUBROUTINE EXCHC9 (IBLOCK,OBLOCK)
      INTEGER IBLOCK(1),OBLOCK(1)
C
C     PROCESS EXPLICIT QUIT COMMANDS AND IMPLICIT QUIT COMMANDS DUE TO
C     ERRORS.
C
      INTEGER NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,NWCBI,
     1        NCCBI,CPCBI,CBLCKI(180),CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2        ITYPEI,MODEI,REMVI,LABELI(180),INTREC(180)
      INTEGER BLKSQO,CBLCKO(180),CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,LLPRGO,
     1        L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,NLRECO,
     2        NWCBO,N1RECO,OUTREC(180),OUTUPD,REMVO
      INTEGER ACTION,CHAR1L,COMAND(180),COMD(4,40),EQUAL,HOLCMD(180),
     1        ICOMD,IDCUR,IDOPTN,IDNBRS(4),IDTEXT(40),IDTXTL,INDEX,
     2        INDEXS(26),INTOPN,LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,
     3        NCOMDT,NERRG,NERRS,NRWORK,NUMBER,OPTVAL(26),OUTOPN,PHASE,
     4        PRED(42,8),SIGNAL,SITE(40),TITLE(40),TODAY(6),TRANS,VERT
      INTEGER IDCOL1,IDCOL2,IDSTEP,IDSTRT
      INTEGER OPTA,OPTC,OPTE,OPTI,OPTL,OPTS,OPTV
      INTEGER INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,INALT,
     1        WORKF
      COMMON /EXCHIC/ NDATAI,NERRCI,BLKSQI,LASTI,L1PRGI,N1RECI,L1RECI,
     1       NWCBI,NCCBI,CPCBI,CBLCKI,CCDBI,CWDBI,NCDBI,NCHMAX,NCHACT,
     2       ITYPEI,MODEI,REMVI,LABELI,INTREC
      COMMON /EXCHOC/ BLKSQO,CBLCKO,CCDBO,CPCBO,CWDBO,ITYPEO,LASTO,
     1       LLPRGO,L1PRGO,L1RECO,MODEO,NCCBO,NCHOUT,NDATAO,NERRCO,
     2       NLRECO,NWCBO,N1RECO,OUTREC,OUTUPD,REMVO
      COMMON /EXCHPC/ ACTION,CHAR1L,COMAND,COMD,EQUAL,HOLCMD,ICOMD,
     1       IDCUR,IDOPTN,IDNBRS,IDTEXT,IDTXTL,INDEX,INDEXS,INTOPN,
     2       LIMIT,LINEO,MARGIN,MODIFY,NCHCMD,NCOMDP,NCOMDT,NERRG,NERRS,
     3       NRWORK,NUMBER,OPTVAL,OUTOPN,PHASE,PRED,SIGNAL,SITE,TITLE,
     4       TODAY,TRANS,VERT
      COMMON /EXCHUC/ INTAPE,OUTAPE,INFILE,OUFILE,PRINTR,READER,INTEXT,
     1       INALT,WORKF
      EQUIVALENCE (IDNBRS(1),IDCOL1),(IDNBRS(2),IDCOL2)
      EQUIVALENCE (IDNBRS(3),IDSTEP),(IDNBRS(4),IDSTRT)
      EQUIVALENCE (OPTVAL(1),OPTA),(OPTVAL(3),OPTC),(OPTVAL(5),OPTE)
      EQUIVALENCE (OPTVAL(9),OPTI),(OPTVAL(12),OPTL),(OPTVAL(19),OPTS)
      EQUIVALENCE (OPTVAL(22),OPTV)
      DATA KQUIT /20/
C
      IF (INFILE.EQ.0) GO TO 10
      IF (MODIFY.NE.82) GO TO 5
C     82 = ASCII R
      ACTION=2
C     ACTION = 2 MEANS REWIND INFILE.
      CALL EXCHIM
5     ACTION=-1
C     ACTION = -1 MEANS CLOSE FILE.
      CALL EXCHIM
      INFILE=0
      NCHCMD=0
      GO TO 50
10    IF (OPTC*OUFILE.EQ.0) GO TO 20
      ACTION=0
      NCHOUT=4
      CALL EXCHOU (COMD(1,KQUIT))
20    ACTION=-1
C     ACTION = -1 MEANS CLOSE FILE.
      IF (OUFILE.NE.0) CALL EXCHOU (OUTREC)
      IF (OUTOPN.EQ.0) GO TO 30
C     WRITE AN END-OF-FILE RECORD ON THE OUTPUT TAPE.
      ITYPEO=69
C     69 = ASCII E
      CALL EXCHPR (ISTAT,OBLOCK,OUTREC)
C     CLOSE THE INPUT TAPE.
30    IF (INTOPN.EQ.0) GO TO 40
      ISTAT=4
      CALL EXCHRT (ISTAT,OBLOCK)
C
C     RETURN TO MAIN PROGRAM.
C
40    TRANS=0
      IF (NERRG.NE.0) WRITE (PRINTR,45) NERRG
45    FORMAT (//27H0MAXIMUM ERROR SEVERITY WAS,I2,1H.)
      GO TO 60
C
C     RETURN TO THE COMMAND DECODER.
C
50    TRANS=1
60    RETURN
C
      END
@HDG,P EXCHMAP
@MAP,SI EXCHMAP,EXCH
SEG  MAIN
     IN  EXCHMAIN,EXCHBD
SEG  EXCH$C1*,(MAIN)
     IN  EXCHC1,EXCHCX
SEG  EXCH$C2*,(MAIN)
     IN  EXCHC2
SEG  EXCH$C3*,(MAIN)
     IN  EXCHC3,EXCHRH,EXCHWH
SEG  EXCH$C4*,(MAIN)
     IN  EXCHC4,EXCHLX
SEG  EXCH$C5*,(MAIN)
     IN  EXCHC5,EXCHCG
SEG  EXCH$C6*,(MAIN)
     IN  EXCHC6
SEG  EXCH$C7*,(MAIN)
     IN  EXCHC7
SEG  EXCH$C8*,(MAIN)
     IN  EXCHC8
SEG  EXCH$C9*,(MAIN)
     IN  EXCHC9
END
