FTN4,L
      PROGRAM DXREF(3,74),24999-16246 REV.2024 800529 
C 
C     NAME:    DXREF
C     SOURCE:  24999-18246
C     RELOC:   24999-16246
C     PGMR:    G.J.S.,D.H.P 
C 
C     MODIFIED TO SELECTIVELY SEARCH FOR EXT'S, ENT'S AND 
C  CHECK FOR ARRAY OVERFLOW (300 MAX FOR BOTH). . .771117 
C 
C     MODIFIED TO OPTIONALLY DELETE ENTRY POINT LIST AND EXTERNAL 
C  REFERANCES AND TO SELECTIVELY SEARCH MODULE NAMES. .760708 
C 
C        OFTEN IT IS NECESSARY TO KNOW THINGS ABOUT A PROGRAM SUCH
C     AS ENTRY POINTS, REQUIRED EXTERNAL REFERENCES, DEFAULT TYPE,
C     PRIORITY, OR COMMON BLOCK ALLOCATION, BUT THE SOURCE IS NOT 
C     AVAILABLE.  ALL THIS INFORMATION IS CONTAINED IN THE FIRST FEW
C     RECORDS OF THE RELOCATABLE FILE, BUT IS DIFFICULT TO DECIPHER 
C     FROM A STRAIGHT OCTAL/ASCII DUMP. 
C 
C        THE CAPABILITY TO RECOVER THIS INFORMATION IS OF PARTICULAR
C     IMPORTANCE IN BUILDING OR MODIFYING LIBRARIES AND IN PLANNING 
C     GENERATOR COMMAND FILES.
C 
C        THUS WAS BORN "DXREF" WHICH IS SCHEDULED AS FOLLOWS: 
C 
C                   RU,DXREF[,NAMR][,LIST][,OPTIONS][,OPTIONS]
C 
C    WHERE:  NAMR   IS THE FILE NAME OR LU WHICH CONTAINS THE 
C                   RELOCATABLE TO BE 'XREFED'. 
C              (OR) THE BATCH FILE NAME WHICH CONTAINS THE FILE 
C                   NAMES TO BE 'XREFED'.(DEFAULT: ASK USER)
C 
C          [LIST]   OPTIONAL LIST OUTPUT LU.(DEFAULT: YOUR CRT) 
C 
C       [OPTIONS]   ANY COMBINATION OF THE FOLLOWING 2 LETTER 
C                   CODES. (ONLY 3 PER PARAMETER) 
C                   (DEFAULT: ASK USER) 
C 
C            "LI"   THIS WILL CAUSE DXREF TO ASK YOU FOR A
C                   LIST OPTION WHICH WILL ALLOW YOU TO TURN
C                   OFF LISTING OF ENTRY POINTS, EXTERNAL 
C                   REFERANCES, OR BOTH.
C 
C            "MO"   THIS WILL CAUSE DXREF TO PROMPT YOU FOR A 
C                   'FILTER' WHICH WILL ALLOW SELECTIVE LISTING 
C                   OF MODULES WITHIN A FILE. 
C 
C            "EN"   THIS WILL TELL DXREF TO ASK YOU FOR AN 'ENTRY POINT'
C                   FILTER. THIS ALLOWS SEARCHING FOR AN ENTRY POINT. 
C 
C            "EX"   AND THIS TELLS DXREF TO ASK YOU FOR AN EXTERNAL REF.
C                   FILTER. 
C 
C 
C            "AL"   THIS WILL TELL DXREF TO PROMPT YOU FOR ALL THE
C                   FILTERS MENTIONED ABOVE.
C 
C            "BA"   THIS WILL TELL DXREF TO USE THE GIVEN NAME IN THE 
C                   RUN STRING OR THE CURRENT FILE GIVEN AS THE BATCH 
C                   FILE TO BE USED AS THE INPUT FOR FILE NAMES 
C                   (SEE DESCRIPTION OF NAMR ABOVE).
C 
C            "RE"   THIS INSTRUCTS DXREF TO CONTINUE ASKING FOR THE 
C                   FILTERS WHICH WHERE ASKED FOR INITIALLY.
C 
C            "SE"   THIS TELLS DXREF TO ASK FOR ALL THE FILTERS 
C                   INITIALLY.
C 
C            "NO"   (OR 'CR')EXIT OPTION SETTING PHASE. 
C 
C     NOTE:  ALL OPTIONS CAN BE CHANGED INTERACTIVELY.  JUST TYPE 
C            'CO'(CHANGE OPTIONS) WHEN DXREF ASKS FOR FILE NAME AND 
C            YOU WILL ENTER THE 'CHANGE OPTIONS MODE'.
C            (A '?' OR 'Y' WILL GIVE A LIST OF THE OPTIONS AND
C             THEIR CURRENT STATE.  ADDITIONALLY YOU CAN 'TOGGLE' 
C             THE CURRENT STATE BYE ENTERING THE CORRESPONDING
C             MNUMONIC.)
C 
C     THE 'SE' OPTION IS USEFUL WHEN SEARCHING FOR ONE PARTICULAR 
C     MODULE, ENTRY POINT, OR EXTERNAL REFRENCE.  ALL FILTERS AND 
C     LIST OPTIONS ARE SET INITIALLY AND ARE NOT ASKED AGAIN. 
C     THEREBY ALLOWING EASY SEARCHES OF MANY FILES FOR A SPECIFIC 
C     PIECE OF INFORMATION. 
C 
C     THE SAME FILE (OR BATCH FILE) CAN BE LOOKED AT AGAIN BY ENTERING
C     A SINGLE COLON(:) INSTEAD OF A FILE NAME.  THIS ALLOWS SEARCHES 
C     THROUGH ONE PARTICULAR FILE FOR MANY DIFFERINT PIECES OF INFORMATION. 
C     A NOTE OF CAUTION HOWEVER: A DOUBLE COLON(::) WILL TERMINATE DXREF. 
C 
C***********************************************************************
C 
C        OPTIONAL PARAMETERS HAVE SPECIAL MEANINGS IN DXREF.  IF THE
C     SECURITY CODE IS SUPPLIED, AN EXCLUSIVE OPEN WILL BE ATTEMPTED, 
C     OTHERWISE A NON-EXCLUSIVE OPEN WILL BE USED.  IF THE CARTRIDGE
C     NUMBER IS NOT SPECIFIED, CARTRIDGES WILL BE SEARCHED IN THE ORDER 
C     IN WHICH THEY APPEAR IN THE CARTRIDGE DIRECTORY AND THE FIRST 
C     OCCURRENCE OF THE NAMED FILE WILL BE CROSS-REFERENCED.  IF A
C     CARTRIDGE NUMBER IS GIVEN, ONLY THAT CARTRIDGE WILL BE SEARCHED.
C     DEFAULT THE FILE TYPE, AND DXREF WILL CHECK TO SEE IF THE FILE IS 
C     TYPE 5, INDICATING A RELOCATABLE FILE.  IF NOT, THE OPERATOR WILL 
C     BE NOTIFIED AND ASKED IF HE WISHES TO CONTINUE.  IF THE FILE TYPE 
C     IS GIVEN IN THE NAMR PARAMETER, THE FILE WILL BE OPENED AS THAT 
C     TYPE AND NO TYPE CHECK WILL BE MADE.
C 
C        FILE MANAGER ERRORS WILL BE REPORTED ON THE INTERACTIVE DEVICE 
C     AND THE OPERATOR WILL BE AGAIN PROMPTED FOR THE LU#/FILE NAME.
C     THE OPERATION MAY BE TERMINATED AT THIS POINT BY ENTERING A DOUBLE
C     COLON FOR THE FILE NAME.  ORDERLY TERMINATION AT ANY OTHER TIME 
C     MAY BE ACCOMPLISHED BY SETTING THE PROGRAM'S BREAK FLAG.
C 
C 
C 
C 
      LOGICAL BATCH,FIRST,SPFILI,FILENM,ASKFIL,LMO,LEN,LEX,LLI, 
     *FILOPN,FTIME,REPEAT,ONETIM,BANAME,ENTFL,EXTFL,FMOD,FENT,FEXT, 
     *ENREC,EXREC 
C 
      DIMENSION ILUST(128),IB(2),IFILT(6),NAM(64),IDCB(144),
     *LFNBUF(21)
      INTEGER TTY,SECURE,CARTDG,ERROR,OPTION,TYPE,OK,RTYPE, 
     *FNAME(4),BLOCK(64),DCB(144),PBUF(10),ENTS(3,300), 
     *EXTS(3,300),SUPFLG,OPFLG,BREG,AREG, 
     *ENFLT(6),EXFLT(6),ENSKP,EXSKP,BLOCK4, 
     *BLOCK2,BLOCK7,BLOCK8,BLOCK9,BLOC18,LEMA(3),EMASZ, 
     *BLOCK6,PBUF4,PBUF5,PBUF6,PBUF7,BAFILE(4), 
     *BASEC,BACART,BATYPE 
      EQUIVALENCE (LENGTH,BREG),(ENTS,ILUST), 
     *(BLOCK(4),BLOCK4),(IB(2),BREG),(IB(1),REG,AREG),
     *(BLOCK(2),BLOCK2),(BLOCK(7),BLOCK7),(BLOCK(8),BLOCK8),
     *(BLOCK(9),BLOCK9),(BLOCK(18),BLOC18),(BLOCK(6),BLOCK6), 
     *(PBUF(4),PBUF4),(PBUF(5),BLOC5),(PBUF(6),PBUF6),
     *(PBUF(7),PBUF7) 
      DATA ENFLT/0,2*2H::/,EXFLT/0,2*2H::/,ONETIM/.TRUE./ 
      DATA BATCH/.FALSE./,FIRST/.TRUE./,SPFILI/.FALSE./ 
      DATA ISTRC/1/,ASKFIL/.TRUE./,LLI/.FALSE./,LMO/.FALSE./, 
     *LEN/.FALSE./,LEX/.FALSE./,FILENM/.FALSE./,FILOPN/.FALSE./,
     *FTIME/.FALSE./,REPEAT/.FALSE./,FNAME(4)/2H  /,
     *BAFILE/2HNO,2H F,2HIL,2HE /,BANAME/.FALSE./,INITA/300/, 
     *FMOD/.FALSE./,FENT/.FALSE./,FEXT/.FALSE./ 
C 
C  STANDARD LU SETUP FOR INTERACTIVE AND LIST DEVICES.
C 
      TTY = LOGLU(LUTRUE) 
      CALL GETST(DCB,-80,ILOG)
      ITTY = TTY + 400B 
      LP = TTY
      ISKIP = 0 
      OPFLG = 0 
      LINES = 0 
      ASSIGN 90 TO JRTN 
      ASSIGN 95 TO KRTN 
C 
C  DECODE THE TURN ON STRING
C 
      DO 90 I=1,4 
      IF(NAMR(PBUF,DCB,ILOG,ISTRC))90,10
 10   ITYPE = IAND(PBUF4,3) 
      GO TO (20,50,60,60),I 
 20   IF(ITYPE .LE. 1)GO TO 40
      FILENM = .TRUE. 
      DO 30 J=1,3 
      FNAME(J) = PBUF(J)
 30   CONTINUE
      SECURE = PBUF5
      CARTDG = PBUF6
      TYPE = PBUF7
      GO TO JRTN
 40   FNAME = PBUF
      FILENM = .FALSE.
      GO TO JRTN
C 
C  CHECK FOR LIST DEVICE
C 
 50   IF(ITYPE .EQ. 1)LP = PBUF 
      GO TO 90
C 
C  CHECK FOR FILTERS
C 
 60   IF(ITYPE .LE. 1)GO TO 90
      LOOP = 3
  70  DO 80 J=1,LOOP
      IF(PBUF(J) .EQ. 2HLO)LLI = .NOT. LLI
      IF(PBUF(J) .EQ. 2HMO)LMO = .NOT. LMO
      IF(PBUF(J) .EQ. 2HEN)LEN = .NOT. LEN
      IF(PBUF(J) .EQ. 2HEX)LEX = .NOT. LEX
      IF(PBUF(J) .EQ. 2HRE)REPEAT = .NOT. REPEAT
      IF(PBUF(J) .EQ. 2HSE)FTIME = .NOT. FTIME
      IF(PBUF(J) .EQ. 2HBA)BATCH = .NOT. BATCH
      IF(PBUF(J) .NE. 2HAL)GO TO 80 
      LLI = .TRUE.
      LMO = .TRUE.
      LEN = .TRUE.
      LEX = .TRUE.
 80   CONTINUE
      IF(.NOT. LMO)IFILT = 0
      IF(.NOT. LEN)ENFLT = 0
      IF(.NOT. LEX)EXFLT = 0
      OPFLG = 0 
      ASKFIL = .TRUE. 
      IF(PBUF .EQ. 2HNO)ASKFIL = .FALSE.
      IF(LLI.OR.LMO.OR.LEN.OR.LEX.OR.FTIME)OPFLG = 1
      IF(OPFLG .EQ. 1)ASKFIL = .FALSE.
 90   CONTINUE
C 
C  SAVE BATCH FILE NAME IN ITS PROPER PLACE 
C 
      IF(BATCH .AND. FILENM)GO TO 132 
C 
C CHECK IF WE ASK FOR FILTERS ? 
C 
  95  IF(.NOT.ASKFIL)GO TO 115
C 
 100  WRITE(TTY,110)
 110  FORMAT(" FILTER OPTIONS ? _") 
      REG = REIO(1,ITTY,PBUF,10)
      IF(BREG .EQ. 0)GO TO 115
      IF(PBUF .NE. 2HLL .AND. PBUF .NE. 2HLI)GO TO 112
      CALL CODE(BREG*2) 
      READ(PBUF,*)LP,LP 
 112  LOOP = BREG 
      LCHK = IOR(IAND(PBUF,77400B),40B) 
      IF(LCHK .NE. 1H? .AND. LCHK .NE. 1HY)GO TO 70 
 114  ASSIGN 95 TO KRTN 
      WRITE(TTY,120)LP,LLI,LMO,LEN,LEX,REPEAT,FTIME,BATCH,BAFILE  
 120  FORMAT(/" ENTER ANY SEQUENCE OF THE FOLLOWING 2 LETTER CODES"/
     #6X"STATE"/
     #"  LIST = "I3/
     #"  LO - ("L1") ASK FOR LISTING OPTIONS"/
     #"  MO - ("L1") ASK FOR FILTERING BY MODULE NAME"/ 
     #"  EN - ("L1") ASK FOR FILTERING BY ENTRY POINT NAME"/
     #"  EX - ("L1") ASK FOR FILTERING BY EXTERNAL REFERANCE"/
     #"  RE - ("L1") REPEAT FILTER QUESTIONS AS SET ABOVE"/ 
     #"  SE - ("L1") SET ALL FILTERS INITIALLY ONLY"/ 
     #"  BA - ("L1") "4A2"WILL BE USED AS BATCH FILE"/
     #"  AL - ASK FOR ALL FILTERS"/ 
     #"  NO - (OR 'CR') LEAVE FILTER OPTIONS AS IS"// 
     #"  NOTE: ANY CODE ENTERED WILL TOGGLE CURRENT STATE"/)
      GO TO 100 
C 
C  CHECK FOR DEFAULT, LU, OR FILE NAME. 
C 
  115 NAMCNT = 0
      IF(BATCH .AND. BANAME)GO TO 142 
      IF (FNAME .LE. 0) GO TO 202 
      IF (FNAME .LE. 255) GO TO 220 
      IF (FILENM)GO TO 220
      GO TO 202 
C 
C COPY BATCH DCB TO NEW ONE AND READ BATCH FILE 
C 
125   DO 130 J=1,16 
      IDCB(J) = DCB(J)
130   CONTINUE
      ASSIGN 137 TO KRTN
C 
C  SAVE BATCH FILE NAMR 
C 
 132  DO 135 J=1,4
      BAFILE(J) = FNAME(J)
 135  CONTINUE
      BASEC = SECURE
      BACART= CARTDG
      BATYPE= TYPE
      BANAME= .TRUE.
      GO TO KRTN
C 
C   RESTORE BATCH FILE NAME TO FNAME
C 
 142  DO 145 J=1,4
      FNAME(J) = BAFILE(J)
 145  CONTINUE
      SECURE = BASEC
      CARTDG = BACART 
      TYPE   = BATYPE 
      FIRST  = .TRUE. 
      GO TO 220 
C 
C 
 137  SPFILI = .FALSE.
      BATCH = .TRUE.
      FIRST = .TRUE.
      FILOPN = .FALSE.
      CALL RWNDF(IDCB,IERR) 
      OK = 0
      WRITE(TTY,140)
140   FORMAT("/DXREF: SUPPRESS FILE NAME REPORTING ? _")
      READ(TTY,410)OK 
      IF(OK .EQ. 1HY)SPFILI = .TRUE.
C 
C  READ NEXT RECORD FROM BATCH FILE 
C 
150   CALL READF(IDCB,IERR,BLOCK,15,LENGTH) 
      IF(IERR .LT. 0)GO TO 160
      BREG = LENGTH * 2 
C 
C GET OUT IF EOF FOUND
C 
      IF(LENGTH .LT. 0)GO TO 175
      IF(.NOT.FIRST)CALL CLOSE(DCB) 
      FIRST = .FALSE. 
      OPFLG = 0 
      GO TO 215 
C 
C  PROCESS READF ERROR
C 
160   WRITE(TTY,170)IERR
170   FORMAT("/DXREF:  READF ERROR "I3" IN BATCH FILE") 
C 
C  EOF OR READ PROBLEM IN BATCH FILE
C 
175   BATCH = .FALSE. 
      CALL CLOSE(IDCB)
      GO TO 185 
C 
C  COME HERE ON 'BREAK' 
C 
180   FMOD = .FALSE.
      IFTIME = 0
      IF(REPEAT)OPFLG = 1 
      IF(.NOT. BATCH)GO TO 200
 185  CALL CLOSE(DCB) 
      FILOPN = .FALSE.
      GO TO 202 
C 
C  ASK OPERATOR FOR INPUT LU/FILE NAME AND PARSE. 
C 
 200  IF(BATCH)GO TO 150
 202  IF(ONETIM)WRITE(TTY,205)
 205  FORMAT("/DXREF: ('CO' => CHANGE OPTIONS: '::' TO STOP)")
      ONETIM = .FALSE.
      WRITE (TTY,210) 
210   FORMAT ("/DXREF: ENTER INPUT FILE NAME (LU): _")
      REG=REIO (1,ITTY,BLOCK,-20) 
      IF(BREG.EQ.1.AND.BLOCK.EQ.1H:.AND.FILOPN)GO TO 220
      IF(BREG.EQ.1.AND.BLOCK.EQ.1H:.AND.BATCH)GO TO 137 
      IF(BREG.NE.1. OR.BLOCK.NE.1H:)GO TO 206 
      WRITE(TTY,203)
 203  FORMAT(" NO FILE CURRENTLY OPEN") 
      GO TO 202 
 206  FILENM = .FALSE.
      BATCH = .FALSE. 
      IF(BREG.EQ.2.AND.BLOCK.EQ.2HCO)GO TO 114
C 
C  CHECK FOR TERMINATE REQUEST
C 
      IF (BLOCK .EQ. 2H::) GO TO 850
      IF (BLOCK .EQ. 2H/E .AND. BREG .EQ. 2) GO TO 850
      IF (BREG .EQ. 0) GO TO 850
      CALL CLOSE(DCB) 
 215  FILOPN = .FALSE.
      ISTRC = 1 
      CALL NAMR(PBUF,BLOCK,BREG,ISTRC)
      ASSIGN 220 TO JRTN
      ITYPE = IAND(PBUF4,3) 
      GO TO 20
 220  IF(FNAME .EQ. 0)GO TO 850 
      IF(FILOPN)CALL RWNDF(DCB) 
      IF(OPFLG.EQ.1)GO TO 240 
      GO TO 370 
C 
C  ASK FOR LIST OPTION AND SPECIAL SEARCH OPTIONS 
C 
240   OPFLG = 0 
      IF(REPEAT)OPFLG = 1 
      IF(FTIME)GO TO 250
      IF(.NOT. LLI)GO TO 280
250   WRITE(TTY,260)
260   FORMAT("/DXREF: LIST OPTION : ENT, EXT, BOTH, OR NONE _") 
      READ(TTY,270)SUPFLG 
270   FORMAT(A2)
      IF(FTIME)GO TO 290
280   IF(.NOT. LMO)GO TG 310
290   WRITE(TTY,300)
300   FORMAT("/DXREF: ENTER MODULE NAME FILTER" 
     #6X"( - = DON'T CARE):  _")
      CALL FILTR(TTY,IFILT,LIFILT)
      IF(FTIME)GO TO 320
310   IF(.NOT. LEN)GO TO 340
320   WRITE(TTY,330)
330   FORMAT("/DXREF: ENTER ENTRY POINT NAME FILTER"
     *" ( - = DON'T CARE):  _") 
      CALL FILTR(TTY,ENFLT,LENFLT)
      IF(FTIME)GO TO 350
340   IF(.NOT. LEX)GO TO 370
350   WRITE(TTY,360)
360   FORMAT("/DXREF: ENTER EXTERNAL NAME FILTER" 
     *4X"( - = DON'T CARE):  _")
      CALL FILTR(TTY,EXFLT,LEXFLT)
C 
C  OPEN THE FILE AND CHECK ITS TYPE & CARTRIDGE.
C 
370   FTIME = .FALSE. 
      IF(FNAME.LE.255)GO TO 480 
C 
C  IF SEC. CODE GIVEN, OPEN EXCLUSIVELY 
C 
      OPTION = 1
      IF (SECURE .NE. 0) OPTION = 0 
      IF(FILOPN)GO TO 450 
      CALL OPEN (DCB,ERROR,FNAME,OPTION,SECURE,CARTDG)
      IF (ERROR .LT. 0) GO TO 430 
      FILOPN = .TRUE. 
      IF(CARTDG.GT.0)GO TO 390
      CALL LOCF(DCB,IDUM,IDUM,IDUM,IDUM,IDUM,JLU) 
      CALL FSTAT(ILUST) 
      DO 380 JK=1,31
      JJ = (JK-1)*4 + 1 
      IF(JLU.NE.ILUST(JJ))GO TO 380 
      CARTDG = ILUST (JJ + 2) 
      GO TO 390 
380   CONTINUE
C 
C  FILE IS NOW OPEN.  CHECK IF IN BATCH 
C 
390   IF(BATCH .AND. FIRST)GO TO 125
      IF(ERROR.EQ.TYPE.OR.ERROR.EQ.5)GO TO 450
C 
C  IGNORE FILE IF NOT TYPE 5 OR NOT EXPLICITLY STATED (BATCH) 
C 
      IF(.NOT.BATCH) GO TO 395
      ASSIGN 200 TO IRTN
      LTYPE = ERROR 
      WRITE(TTY,392)
 392  FORMAT("FILE NOT PROCESSED")
      GO TO 460 
C 
C  IF NOT IN BATCH AND FILE TYPE NOT 5 OR SUPPLIED
C  ASK IF WE CAN USE AS BATCH FILE. 
C 
395   WRITE(TTY,400) FNAME,ERROR
400   FORMAT("/DXREF:  FILE ",4A2," IS TYPE ",I5,".  OK TO USE AS"
     #" BATCH FILE ? _")
      READ (TTY,410) OK 
410   FORMAT(A1)
      IF(OK.EQ.1HY)GO TO 125
C 
C  IF NOT BATCH FILE, HOW ABOUT 'DXREFING' IT.
C 
      WRITE(TTY,420)
420   FORMAT("/DXREF:  OK TO PROCESS THEN ? _") 
      READ (TTY,410) OK 
      IF(OK.EQ.1HY)GO TO 450
      GO TO 200 
430   WRITE (TTY,440) ERROR,FNAME 
440   FORMAT (" FMGR ERROR ",I4," OPENING ",4A2,".")
      GO TO 200 
 450  NAMCNT = 0
      INITA = 300 
      LTYPE = ERROR 
      ASSIGN 480 TO IRTN
C 
C  CHECK IF WE'RE SUPPRESSING FILE NAME REPORTING 
C 
      IF(SPFILI)GO TO 480 
460   CALL CODE 
      WRITE (LFNBUF,470) FNAME,SECURE,CARTDG,LTYPE
      IACRT = -1
      CALL ASCII(CARTDG,IACRT)
      IF(IACRT .EQ. 2H  )GO TO 465
      LFNBUF(16) = 2H:
      LFNBUF(17) = 2H 
      LFNBUF(18) = IACRT
 465  IF (TTY .EQ. LP)GO TO 468 
      IF(LINES .GT. 1)CALL EXEC(3,LP+1100B,-1)
      CALL EXEC(2, LP,LFNBUF,21)
468   CALL EXEC(2,TTY,LFNBUF,21)
470   FORMAT (" * FILE NAME:   ",4A2,":",I5,":",I5,":",I5)
      LINES = 1 
      GO TO IRTN
C 
C  GET AN INPUT RECORD. 
C 
480   IF (IFBRK(IDUMMY) .NE. 0) GO TO 180 
      IF (FNAME .LE. 255) GO TO 490 
      CALL READF (DCB,ERROR,BLOCK,64,LENGTH)
      IF(ERROR .GE. 0)GO TO 500 
      WRITE(TTY,485)ERROR,FNAME 
 485  FORMAT("/DXREF:  READF ERROR "I3" IN "4A2)
      GO TO 200 
490   REG=EXEC (1,300B+FNAME,BLOCK,64)
C 
C  CHECK FOR EOF
C 
      ICHK = IAND(240B,AREG)
      IF(ICHK.NE.0)GO TO 200
500   IF (LENGTH .NE. -1) GO TO 510 
      IFTIME = 0
      GO TO 200 
C 
C  SKIP ZERO(0) LENGTH RECORD 
C 
510   IF (LENGTH .EQ. 0) GO TO 480
C 
C  CHECK FOR "DBL" (DATA BLOCK) RECORD. 
C 
      RTYPE=IAND (BLOCK2,160000B) 
      IF (RTYPE .EQ. 60000B) GO TO 480
C 
C  CHECK FOR "NAM" RECORD.
C 
      IF(RTYPE.NE.20000B.AND.ISKIP.EQ.0)GO TO 480 
      IF (RTYPE .NE. 20000B) GO TO 560
      NAMCNT=NAMCNT+1 
      ENTFL = .FALSE. 
      EXTFL = .FALSE. 
      ISKIP = -1
C 
C   FILTER MODULES FOR SELECTIVE LISTING
C 
      IF(IFILT .EQ. 0)GO TO 520 
      CALL NAMCK(BLOCK4,5,IFILT,LIFILT,ISKIP) 
      IF(ISKIP.EQ.0)GO TO 480 
520   BLOCK=(BLOCK/256) 
C 
C SAVE NAME INFO FOR LATER PRINT OUT
C 
      DO 530 I=1,BLOCK
      NAM(I) = BLOCK(I) 
530   CONTINUE
      FMOD = .TRUE. 
      FENT = .TRUE. 
      FEXT = .TRUE. 
      ENREC= .FALSE.
      EXREC= .FALSE.
      IF (NAM .LT. 18)NAM(18) = 20040B
      LNPROG=BLOCK7 
      NBPALL=BLOCK8 
      NCMMON=BLOCK9 
      LSTENT=1
      LSTEXT=1
      DO 550 I=1,INITA
      DO 540 J=1,3
      ENTS(J,I)=20040B
      EXTS(J,I)=20040B
540   CONTINUE
550   CONTINUE
      GO TO 480 
C 
C  CHECK FOR "ENT" RECORD.
C 
560   IF (RTYPE .NE. 40000B) GO TO 600
      IF(ENTFL)GO TO 480
      IF(.NOT.ENREC) FENT = .FALSE. 
      ENREC = .TRUE.
      NUMBER=IAND(BLOCK2,17B) 
      DO 590 I=1,NUMBER 
      ISUBSC=4*I
      IF(ENFLT .EQ. 0)GO TO 570 
      CALL NAMCK(BLOCK(ISUBSC),5,ENFLT,LENFLT,ENSKP)
      IF(ENSKP .EQ. 0)GO TO 590 
570   IF(SUPFLG.EQ.2HEX.OR.SUPFLG.EQ.2HNO)GO TO 585 
      DO 580 J=1,3
      ENTS(J,LSTENT)=BLOCK(J-1+ISUBSC)
      IF (J .EQ. 3) ENTS(J,LSTENT)=IOR(IAND(ENTS(J,LSTENT),177400B),40B)
580   CONTINUE
      LSTENT=LSTENT+1 
      FENT = .TRUE. 
C 
C  CHECK FOR ARRAY OVERFLOW 
C 
      IF(LSTENT .LT. 300)GO TO 590
      ENTFL = .TRUE.
      GO TO 830 
585   FENT = .TRUE. 
590   CONTINUE
      GO TO 480 
C 
C  CHECK FOR "EXT" RECORD.
C 
600   IF (RTYPE .NE. 100000B) GO TO 640 
      IF(EXTFL)GO TO 480
      IF(.NOT.EXREC) FEXT = .FALSE. 
      EXREC = .TRUE.
      NUMBER=IAND(BLOCK2,37B) 
      DO 630 I=1,NUMBER 
      ISUBSC=4+3*(I-1)
      IF(EXFLT .EQ. 0)GO TO 610 
      CALL NAMCK(BLOCK(ISUBSC),5,EXFLT,LEXFLT,EXSKP)
      IF(EXSKP .EQ. 0)GO TO 630 
610   IF (SUPFLG.EQ.2HEN.OR.SUPFLG.EQ.2HNO)GO TO 625
      DO 620 J=1,3
      EXTS(J,LSTEXT)=BLOCK(J-1+ISUBSC)
      IF (J .EQ. 3) EXTS(J,LSTEXT)=IOR(IAND(EXTS(J,LSTEXT),177400B),40B)
620   CONTINUE
      LSTEXT=LSTEXT+1 
      FEXT = .TRUE. 
C 
C  CHECK FOR ARRAY OVERFLOW 
C 
      IF(LSTEXT .LT. 300)GO TO 630
      EXTFL = .TRUE.
      GO TO 830 
625   FEXT = .TRUE. 
630   CONTINUE
      GO TO 480 
C 
C  CHECK FOR "EMA" RECORD.
C 
640   IF (RTYPE .NE. 140000B) GO TO 645 
      BLOCK6 = IOR(40B,IAND(BLOCK6,77400B)) 
      DO 642 I=1,3
      LEMA(I) = BLOCK(I+3)
642   CONTINUE
      MSEGSZ = IAND(BLOCK7,13B) 
      EMASZ = IAND(BLOCK2,17777B) 
      GO TO 480 
C 
C  CHECK FOR "END" RECORD.
C 
645   IF (RTYPE .NE. 120000B) GO TO 810 
      LSTENT=LSTENT-1 
      LSTEXT=LSTEXT-1 
      CALL ALPHD(ENTS,LSTENT) 
      CALL ALPHD(EXTS,LSTEXT) 
      NLINES=4
      IF (LSTENT .GT. NLINES) NLINES=LSTENT 
      IF (LSTEXT .GT. NLINES) NLINES=LSTEXT 
C 
C CHECK TO SEE IF WE SKIP PRINTOUT
C 
C  SET THE 'PRINT OUT FLAG' FALSE FOR THE FOLLOWING CONDITIONS
C 
C     1. IF NO RECORD OF THAT TYPE FOUND
C        AND
C     2. A FILTER WAS SPECIFIED  => FLAG = .FALSE.
C 
      IF(.NOT.ENREC .AND. ENFLT .NE. 0)FENT = .FALSE. 
      IF(.NOT.EXREC .AND. EXFLT .NE. 0)FEXT = .FALSE. 
      IF(FMOD .AND. FENT .AND. FEXT)GO TO 650 
      GO TO 480 
650   IF(IFTIME .GT. 0)GO TO 680
      IFTIME = 1
      IF(.NOT.SPFILI)GO TO 660
      ASSIGN 660 TO IRTN
      GO TO 460 
660   WRITE(LP,670) 
670   FORMAT(/3X,"MODULE",37X,"ENTRY PTS",5X,"EXTERNALS"/,
     *3X,"------",37X,"---------",5X,"---------"  ) 
680   WRITE (LP,690) NAMCNT,(NAM(I),I=4,6),(NAM(J),J=10,17),
     *(NAM(K),K=18,NAM) 
690   FORMAT (1X,I3,2X,3A2,",",I3,",",I5,",",I1,",",I4,4(",",I2), 
     *2(/12X,30A2)) 
      LINES = LINES + 6 
      IF(NAM .GT. 48)LINES = LINES + 1
      DO 770 I=1,NLINES 
      L = 2H *
      IF (LSTEXT .LT. I .AND. LSTENT .LT. I)L=20040B
      IF (IFBRK(IDUMMY) .NE. 0) GO TO 180 
      IF (LNPROG .EQ. 0) GO TO 710
      WRITE (LP,700)LNPROG,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L
700   FORMAT (11X"PROGRAM LENGTH (IN WORDS)=",I5,A2,4X,3A2,2X,A2,4X,
     #3A2,2X,A2)
      LNPROG=0
      LINES = LINES + 1 
      GO TO 770 
710   IF (NCMMON .EQ. 0) GO TO 730
      WRITE (LP,720)NCMMON,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L
720   FORMAT (21X,"WORDS IN COMMON="I5,A2,4X,3A2,2X,A2,4X,3A2,2X,A2)
      NCMMON=0
      LINES = LINES + 1 
      GO TO 770 
730   IF (NBPALL .EQ. 0) GO TG 745
      WRITE (LP,740)NBPALL,L,(ENTS(J,I),J=1,3),L,(EXTS(K,I),K=1,3),L
 740  FORMAT(16X"BASE PAGE ALLOCATION="I5,A2,4X,3A2,2X,A2,4X,3A2,2X,A2) 
      NBPALL=0
      LINES = LINES + 1 
      GO TO 770 
745   IF (EMASZ .EQ. 0) GO TO 750 
      WRITE(LP,748)LEMA,MSEGSZ,EMASZ,L,(ENTS(J,I),J=1,3),L, 
     $(EXTS(K,I),K=1,3),L 
748   FORMAT(5X"EMA BLOCK "3A2"(MSEG="I2")="I5" PAGES"A2,4X,3A2,2X,A2,
     $4X,3A2,2X,A2) 
      EMASZ=0 
      LINES = LINES + 1 
      GO TO 770 
750   IF (LSTEXT .LT. I .AND. LSTENT .LT. I)GO TO 770 
      WRITE (LP,760) ((ENTS(J,I),J=1,3),(EXTS(K,I),K=1,3))
      LINES = LINES + 1 
760   FORMAT (43X,"*",4X,3A2,3X,"*",4X,3A2,3X,"*")
770   CONTINUE
C 
C  SET INITIALIZE COUNTER TO ONLY WHAT WAS USED 
C 
      INITA = NLINES
C 
C  AND RESET 'FOUND' FLAGS
C 
      FMOD = .FALSE.
      LINES = LINES + 2 
      IF(LSTENT.EQ.0.AND.LSTEXT.EQ.0)GO TO 790
      WRITE (LP,780)
780   FORMAT (13X,30("* "),/) 
      GO TO 480 
790   WRITE(LP,800) 
800   FORMAT(/) 
      GO TO 480 
C 
C  UNDEFINED RECORD TYPE INDICATED HERE.
C 
810   WRITE (LP,820) BLOCK2 
820   FORMAT (" RECORD TYPE ",K6," NOT PROCESSED.") 
      GO TO 480 
830   WRITE(TTY,840)ENTFL,EXTFL 
      GO TO 480 
840   FORMAT(" ENT("L1") OR EXT("L1") ARRAY OVERFLOW (300 MAX)")
C 
C  ORDERLY DEPARTURE. 
C 
850   CALL CLOSE (DCB)
      IF(BATCH)CALL CLOSE (IDCB)
      IF(LINES .GT. 0 .AND. LP .NE. TTY)CALL EXEC(3,LP+1100B,-1)
      WRITE (TTY,860 )
860   FORMAT ("$END DXREF.")
      END 
      SUBROUTINE FILTR(TTY,IFILT,LEN) 
     +,24999-16246 REV.2024 791009
      DIMENSION IB(2),IFILT(6)
      INTEGER TTY,BREG,AREG 
      EQUIVALENCE (IB(2),BREG),(IB(1),REG,AREG) 
C 
C INITIALIZE IFILT
C 
      DO 100 I=1,6
      IFILT(I) = 2H-- 
100   CONTINUE
C 
      REG = REIO(1,TTY+400B,IFILT,-12)
      LEN = BREG
      IODD = (BREG/2)+1 
      IF(MOD(BREG,2).NE.0)IFILT(IODD)=IOR(IFILT(IODD),55B)
C 
      DO 110 I=1,IODD 
      IF(IFILT(I) .NE. 2H--)RETURN
110   CONTINUE
      IFILT = 0 
      RETURN
      END 
      SUBROUTINE ASCII(BINARY,IA) 
     +,            REV.1929 790720
C 
C     THIS ROUTINE PERFORMS TWO(2) FUNCTIONS: 
C 
C     1. CHECK THE CONTENTS OF A WORD TO ENSURE BOTH BYTES
C        ARE UPPER CASE PRINTING ASCII, IF EITHER BYTE FAILS
C        TWO ASCII BLANKS (20040B) WILL BE SENT BACK TO THE 
C        CALLER.  THIS MODE IS INVOKED BY SETTING THE SECOND
C        PARAMETER TO -1 WHEN CALLED. 
C 
C     2. GIVEN A BINARY VALUE. CHECK FOR UPPER AND LOWER CASE 
C        PRINTING ASCII, IF NOT, SET THE OFFENDING BYTE TO AN 
C        ASCII BLANK. 
C 
      INTEGER BINARY,RBYTE
      RBYTE = IAND(BINARY,377B) 
      LBYTE = IAND(BINARY,77400B) 
      IF(IA .NE. -1)GO TO 10
      IF(RBYTE .LT. 40B .OR. RBYTE .GT. 137B)GO TO 5
      IF(LBYTE .LE. 20000B .OR. LBYTE .GE. 60000B)GO TO 5 
      IA = BINARY 
      RETURN
5     IA = 20040B 
      RETURN
10    IF(RBYTE.LT.40B.OR.RBYTE.GT.176B)RBYTE = 40B
      IF(LBYTE.LT.20000B)LBYTE = 20000B 
      IF(LBYTE.GE. 77400B)LBYTE = 20000B
      IA = IOR(LBYTE,RBYTE) 
      RETURN
      END 
      END$
ASMB,R,B,L,C
      NAM ALPHD,7             REV.1939 790928 
* DOES AN ALPHABETIC SORT ON 3-WORD FIELD IN (NAMES) IFILE FIELDS LONG. 
* (A BUBBLE SORT METHOD IS USED.) 
* CALLED FROM FTN BY:  CALL ALPHA(NAMES,IFILE)
      ENT ALPHD 
      EXT .ENTR 
NAMES BSS 1 
IFILE BSS 1 
ALPHD NOP 
      JSB .ENTR     ESTABLISH ADDRESSES 
      DEF NAMES 
      LDA IFILE,I    SET -NUMBER OF NAMES 
      CMA,INA         AS COUNTER
      STA CNTR1 
* 
*     LOOP1 SETS ADDRESSES AND POINTERS FOR FIRST FIELD 
*     CHECKS FOR END OF SORT
* 
LOOP1 EQU * 
      LDA CNTR1      SET NEW INDEX
      ADA IFILE,I     INTO NAME ARRAY 
      MPY D3         (3 WORDS/NAME) 
      ADA NAMES 
      STA ADDR1      SAVE THE ADDRESS 
      STA PNTR1       AND AS A POINTER
      LDA CNTR1 
      CPA D0         CHECK FOR NONE LEFT
      JMP OUT        OR ZERO INITIALLY
      INA 
      SZA,RSS 
      JMP OUT        DONE !!! 
      STA CNTR2        CNTR2=CNTR1 + 1
* 
*     LOOP2 SETS ADDRESSES AND POINTERS FOR SECOND FEILD
* 
LOOP2 EQU * 
      LDA CNTR2     COMPUTE ADDRESS OF
      ADA IFILE,I    SECOND FIELD 
      MPY D3
      ADA NAMES 
      STA ADDR2 
      STA PNTR2 
      LDA DM3       SET UP COUNTER FOR FIELD
      STA CNTR3      COMPARISION
      LDA ADDR1 
LOOP3 EQU *         START THE COMPARISION 
      LDB ADDR2,I 
      CMB,INB       NAME1 - NAME2 < 0 ? 
      ADB A,I 
      INA           NEXT WORD OF NAME1
      ISZ ADDR2     NEXT WORD OF NAME2
      SSB           NAME1 < NAME2 ? 
      JMP END2      PROPER ORDER
      SZB           SAME ?
      JMP SWTCH     NO, SWITCH IT.
      ISZ CNTR3     IF FIRST WORDS =
      JMP LOOP3     CONTINUE LOOP 
      JMP END2      ALL FIELDS ARE =. 
SWTCH EQU * 
      LDA DM3       SET UP FOR 3 WORD 
      STA CNTR4      SWITCH 
      LDA ADDR1     1ST NAME
      STA PNTR1     SAVE FOR LOOP 
LOOP4 EQU * 
      LDA PNTR1,I   START SWAP LOOP 
      LDB PNTR2,I 
      SWP 
      STA PNTR1,I 
      STB PNTR2,I 
      ISZ PNTR1     BUMP ADDRESS FOR NAME1
      ISZ PNTR2     BUMP ADDRESS FOR NAME2
      ISZ CNTR4     DONE? 
      JMP LOOP4     NO
END2 EQU *          YES 
      ISZ CNTR2     DONE WITH LOOP2 
      JMP LOOP2       NOPE. 
      ISZ CNTR1     ALL DONE
      JMP LOOP1 
OUT   EQU *         YES, GET OUT
      JMP ALPHD,I 
CNTR1 BSS 1 
CNTR2 BSS 1 
CNTR3 BSS 1 
CNTR4 BSS 1 
PNTR1 BSS 1 
PNTR2 BSS 1 
ADDR1 BSS 1 
ADDR2 BSS 1 
D0    DEC 0 
DM3   DEC -3
D3    DEC 3 
A     EQU 0 
      END 
ASMB,R,B,L,C
      NAM COMMA,7   REV A 751031
* 
*  FRI  31 OCT 75   WRITTEN BY DONALD H. POTTENGER  REV A 
* 
      ENT COMMA 
      EXT .ENTR 
*      THIS SUBROUTINE, GIVEN AN ADDRESS AND LENGTH OF A BUFFER,
*  WILL CHECK FOR IMBEDDED COLONS AND REPLACE THEM WITH COMMAS
*  FOR THE SYSTEM PARSE ROUTINE.  THIS HAS OBVIOUS ADVANTAGES 
*  FOR THE USER WHO IS USED TO USING COLONS AS DELIMITERS AS IN 
*  THE FILE MANAGER NAMR PARAMATERS.
* 
*     THE BUFFER CAN BE ANY LENGTH AND SHOULD SPECIFY 
*  THE NUMBER OF CHARACTERS IN THE BUFFER.
* 
BUFAD NOP           BUFFER ADDRESS
BUFLA NOP           BUFFER LENGTH 
COMMA NOP           WHERE IT ALL BEGINS 
      JSB .ENTR     GO GET THE ADDRESSES
      DEF BUFAD       OF THE PARAMATERS 
      LDA BUFLA,I   HOW ABOUT THE LENGTH? 
      CLE,ERA       IS IT AN ODD CHARACTER COUNT? 
      SEZ           NO,  ITS ALL READY TO GO
      INA           YES, INCREASE THE WORD COUNT BY ONE 
      CMA,INA       LET'S MAKE IT NEG. FOR COUNTING 
      STA BUFL      AND SAVE IT 
      SZA,RSS       IS IT A ZERO LENGTH BUFFER? 
      JMP COMMA,I   WELL GET THE HECK OUT OF HERE THEN. 
START LDA BUFAD,I   ORIGINAL NAME HUH ? 
      STA TEMP      LET'S GET A WORD AND GET ON WITH IT 
      AND M177        HOW ABOUT THE LOW BYTE? 
      CPA LOCOL         A COLON?
      JMP LFIX      YES, GO MAKE IT A COMMA 
PAR1  LDA TEMP      NO, PREPARE TO CONTINUE 
      AND M774      THIS TIME LOOK AT THE HI BYTE 
      CPA HICOL       A COLON?
      JMP HFIX      YES, GO MAKE IT A COMMA 
      JMP TERM1     NO, LETS SAVE WHAT WE HAVE AND GO ON
LFIX  LDA TEMP      GET ORIGINAL WORD 
      ADA M16       MAKE THAT COLON A COMMA 
      STA TEMP        AND SAVE
      JMP PAR1+1    GO CHECK HI BYTE
HFIX  LDA TEMP      GET PRESENT VALUE 
      ADA M7000     MAKE THE HI BYTE COLON A COMMA
      RSS              AND SAVE IN ORIGINAL BUFFER
TERM1 LDA TEMP      LETS GET THE CURRENT VALUE
      STA BUFAD,I     AND SAVE IN ORIGINAL BUFFER 
      ISZ BUFAD     INCREMENT THE BUFFER ADDRESS
      ISZ BUFL      ANY MORE WORDS? 
      JMP START     YES, HERE WE GO AGIAN 
      JMP COMMA,I   NOPE, LETS GET OUT!!
      SKP 
* 
*     CONSTANTS AND STORAGE 
* 
BUFL  NOP 
TEMP  NOP 
M177  OCT 177 
M774  OCT 77400 
LOCOL OCT 72
HICOL OCT 35000 
M16   OCT -16 
M7000 OCT -7000 
      END 
ASMB,R,L
*   1730 HRS   THU  14 JUN 79 
      NAM NAMCK,7 REV. 1924  790614 CHECK FILE NAME 
      ENT NAMCK 
      EXT .ENTR 
* 
*     THIS SUBROUTINE RETURNS A FLAG (0,-1) TO DL DEPENDING 
*  ON HOW A GIVEN STRING(KNOWN AS THE FILTER) COMPARES TO ANOTHER 
*  STRING(KNOWN AS THE FILE NAME).
* 
*     CALLING SEQUENCE: 
* 
*                   CALL NAMCK(IBUF,ICHAR,JBUF,JCHAR,IFLAG) 
* 
*     WHERE:
*           IBUF = THE FILE NAME TO BE CHECKED
*           ICHAR= NO. OF CHARACTERS IN IBUF
*           JBUF = SMALLER BUFFER CONTAINING SEARCH FILTER
*           JCHAR= NO. OF CHARCTERS IN JBUF 
*           IFLAG= -1 IF STRING FOUND; 0 IF NOT FOUND 
* 
*     VARIABLE DEFINITION:
* 
*             BADDR = BYTE ADDRES FOR INPUT BUFFER
*             SADDR = BYTE ADDRES FOR INPUT FILTER BUFFER 
*             ICNT  = -(NUMBER CHARACTERS IN SOURCE BUFFER) 
*             JCNT  = -(NUMBER CHARACTERS LEFT IN SEARCH FILTER)
*             STGCT = CHAR. COUNT IN CURRENT STRING CHECK BUFFER
*             Y-REG = CHECK STRING BUFFER ADDRESS 
* 
* 
IBUF  NOP           FILE NAME BUFFER
ICHAR NOP           NO. OF CHAR. IN IBUF
JBUF  NOP           FILTER STRING 
JCHAR NOP           NO. OF CHAR. IN JBUF
IFLAG NOP          IFLAG SET TO -1 IF STRING FOUND
NAMCK NOP           ENTRY POINT 
      JSB .ENTR 
      DEF IBUF
      CLA           CLEAR 
      STA STGCT      CURRENT STRING COUNTER 
      STA PLSFG      RESET PLUS FLAG
      CCA           SET OUTER CMPAR LOOP
      STA OUTLG      TO ONE TIME
      LDA ICHAR,I   GET FILE NAME BUFFER LGTH.
      CMA,INA       SET NEG.
      STA ICNT      AND SAVE LOCAL
      LDA JCHAR,I   GET THE FILTER LENGTH 
      CMA           MAKE NEGITIVE 
      STA JCNT      SAVE COUNTER (-1) 
      LDA IBUF
      RAL 
      STA BADDR     SAVE AS BYTE ADDRESS
      LDB JBUF
      RBL 
      STB SADDR     SAVE THE BYTE ADD. FOR FILTER 
NXBT  ISZ JCNT      CHECK FOR END OF FILTER BUFFER
      RSS 
      JMP DONE      DONE THEN 
      LBT           GET THE NEXT FILTER CHAR. 
      CPA APLUS     CHECK FOR PLUS
      JMP PLUS
      CPA AMINS     CHECK FOR '-'S
      JMP MINUS 
      LDA STGCT     CHECK FOR BEGINNING 
      SZA            OF A STRING
      JMP NX.1
      LDY SADDR       YES, SO SAVE FILTER BUFFR ADD. IN Y 
      LDX BADDR       AND THE SOURCE BUFFR ADD. IN X
NX.1  ISZ STGCT      BUMP STRING COUNTER
      ADA ICNT      CHECK FOR POSSIBLE STRING CHECK 
      SSA,RSS        OVER RUN 
      JMP DONE      IF ABOUT TO OVER RUN-GO CHECK 
      JMP NXBT      GO GET NEXT BYTE
      SPC 2 
* 
MINUS ISZ BADDR     BUMP SOURCE STRING BUFFER POINTER 
      LDA STGCT    CHECK IF STRING CHECK PENDING
      SZA 
      JMP MIN.1     YES, SO GO DO IT
      ISZ SADDR      BUMP FILTER BUFFER ADD TOO.
      ISZ ICNT      ANY CHARATERS LEFT ?
      JMP NXBT       YES, SO GET NECT BYTE
      JMP EXFND     NO, SO EXIT FOUND 
      SPC 1 
MIN.1 STB SADDR      SAVE THE FILTER BUFFER POINTER 
      LDA PLSFG     CHECK FOR "+" FLAG
      SZA,RSS        SET ?
      JMP MIN.2     YES 
      LDA ICNT      FORM OUTER LOOP COUNTER 
      ADA STGCT      OUTLG = ICNT + STGCT 
      SSA,RSS       SEE IF LEGAL LOOP COUNTER 
      JMP EXNFD      NO, SEE EXIT NOT FOUND 
      STA OUTLG     OK, SAVE
MIN.2 JSB CHECK     GO CHECK STRING 
      INA           BUMP SOURCE BUFFER
      STA BADDR      ADDRESS
      LDB SADDR 
      CLA           RESET THE '"+"' 
      STA PLSFG      FLAG 
      CMA             AND THE OUTER 
      STA OUTLG        LOOP COUNTER 
      LDA ICNT
      INA 
      JMP NXT       GO CLEAN UP 
      SPC 1 
PLUS  STB SADDR     SAVE FILTER BUFFER POINTER
      LDA STGCT     SEE IF CURRENT STRING 
      SZA            TO PROCESS 
      JMP PL.1      YES 
      STB PLSFG     NO, SET '"+"' HAS OCCURED FLAG
      JMP NXBT      NO, SO JUST GET NEXT BYTE 
PL.1  LDA PLSFG     CHECK FOR '"+"' FLAG
      SZA,RSS 
      JMP PL.2      FLAG NOT SET SO SET TO ONE TIME 
* 
      LDA ICNT      SET OUTER LOOP COUNTER
      ADA STGCT     TO CHECK ALL OF BUFFER
      ADA M1
      SSA,RSS       CHECK IF 1 CMPAR WILL DO. 
PL.2  CCA           YES, SO SET OUTER LOOP TO -1
      STA OUTLG      SAVE OUTER LOOP COUNTER
      JSB CHECK 
      STA PLSFG     SET '"+"' FLAG NON ZERO 
      JMP CONT
* 
* CHECK STRING
* 
CHECK NOP            ENTER CHECK ROUTINE HERE 
AGAIN CXA           GET SOURCE BUFFER ADD. FROM X-REG.
      CYB           GET FILTER ADD. FROM Y-REG. 
      CBT STGCT     CMPAR STRING
      JMP CHECK,I   RETURN TO CALLER
      NOP 
      ISZ OUTLG     SEE IF WE ARE DONE
      RSS           NO, 
      JMP EXNFD     YES, GO SET NOT FOUND FLAG
* 
      ISX           BUMP SOURCE BUFFER ADDRESS
      ISZ ICNT       AND SOURCE CHAR. COUNT 
      JMP AGAIN      AND GO AGAIN 
* 
EXNFD CLA 
      STA IFLAG,I 
      JMP NAMCK,I   AND RETURN
* 
CONT  STA BADDR      SAVE THE SOURCE BUFFER ADD.
      LDB SADDR     RESTORE FILTER BUFFER POINTER 
      LDA ICNT       UPDATE CHAR COUNT
NXT   ADA STGCT 
      SSA,RSS 
      JMP EXCHK 
      STA ICNT
      CLA           RESET THE STRING
      STA STGCT      COUNTER
      LDA JCNT
      SSA 
      JMP NXBT
      JMP EXFND 
* 
EXCHK LDA JCNT
      SSA 
      JMP EXNFD 
* 
EXFND CCA 
      STA IFLAG,I 
      JMP NAMCK,I 
* 
DONE  LDA STGCT     CEHCK IF PENDING STRING 
      SZA,RSS 
      JMP EXFND     NO, SO JUST EXIT FOUND
      LDA PLSFG     CHECK FOR PLUS FLAG 
      SZA,RSS 
      JMP DN.1
      LDA ICNT
      STA OUTLG     SAVE LOOP COUNTER 
      ADA STGCT     CHECK FOR ILLEGAL STRING LENGTH 
      SZA,RSS        CHECK FOR ZERO 
      JMP *+3       IF STGCT + ICNT <= 0
      SSA,RSS       AND NEGITIVE NUMBER 
      JMP EXNFD     PLUS NUMBER: NO GOOD
DN.1  JSB CHECK     YES, SO GO CHECK STRING 
      JMP EXFND      STRING FOUND 
* 
* CONSTANTS AND STORGE
PLSFG NOP        PLUS FLAG SET
BADDR NOP           SOURCE STRING ADD. POINTER
SADDR NOP           FILTER STRING ADD. POINTER
OUTLG NOP           OUTER LOOP COUNTER
ICNT  NOP           SOURCE CHAR. COUNT
JCNT  NOP           FILTER CHAR. COUNT
STGCT NOP           CURRENT STRING COUNTER
M1    DEC -1
AMINS OCT 55
APLUS OCT 53
      END 
                                                                                                                                                                                                                                                          