ASMB,L
      NAM DLRP  
.CBT  RPL 105766B 
      END 
ASMB,R,L,Z,Q
        HED DL MAIN 
* 
*     NAME:   DL
*     SOURCE: 24999-18244 
*     RELOC:  24999-16244 
*     PGMR:   D.H.P.
* 
      IFZ 
      NAM DL,3,74 24999-16245 REV.1940 791001  RTE-IVA (& RTE-III)
      XIF 
* 
      IFN 
      NAM DL,3,74 24999-16244 REV.2024 800605 RTE-IVB 
      XIF 
* 
*  THE PURPOSE OF THIS PROGRAM IS TO DETERMINE THE LENGHT OF AVAILABLE
*  BACKGROUND AND PASS THE LENGTH TO DLSUB WHICH DOES ALL THE WORK. 
*  AVAILABLE BACKGROUND IS USED FOR STORAGE OF THE FILE NAMES USED IN DL. 
* 
*  ASSEMBLE WITH 'Z' OPTION FOR RTE-IVA (AND RTE-III) 
*  ASSEMBLE WITH 'N' OPTION FOR RTE-IVB 
* 
      EXT EXEC,COR.A,DLSUB
      IFN 
      EXT $CL1,$CL2,FG.LU,.ENTR,$DATC 
      ENT IFGLU 
      XIF 
* 
* MAIN ENTRY POINT FOR DL 
* 
* SET FOR TOTAL BACKGROUND SWAPPING (USED IN RTE-3 ONLY)
DL    JSB EXEC
      DEF *+3 
      DEF D22 
      DEF D3
* 
      LDA XEQT      GET ID SEGMENT ADDRESS
* 
* GET BACKGROUND ADDRESS
      JSB COR.A     GO GET FIRST WORD AVAIL BACK GND
      STA BDEF      A = FWA BACKGROUND
* 
* CALCULATE AVAILABLE BACKGROUND
      CMA,INA       A = FWABK 
      ADA BKLWA     A = BKLWA -  FWABK
      STA LGTH      BACKGROUND LENGTH 
* 
* CHECK IF ENOUGH ROOM
* 
      ADA M128      MAKE SURE A SECTOR WILL FIT 
      SSA,RSS 
      JMP DL.1
      STA LGTH      SEND NEGATIVE LENGTH TO DLSUB 
      JMP DL.5      AND DO IT NOW 
* 
DL.1  EQU * 
      IFZ 
      LDA TATSD    GET # TRACKS ON SYS DISC 
      ADA M1       MINUS 1
      STA LTRAK   SAVE
      XIF 
      IFN 
      LDA $CL2    GET STARTING SECTOR OF CL 
      ADA D2    BUMP TO MSC SECTOR
      STA ISEC
      XIF 
      JSB EXEC    READ SECTOR WITH MSC
      DEF DL.4
      DEF D1    READ
      DEF D2    LU 2
      DEF BDEF,I    BUFFER
      DEF D128
      IFN 
      DEF $CL1    TRACK FOR SESSION 
      DEF ISEC    SECTOR FOR SESSION
      XIF 
      IFZ 
      DEF LTRAK 
      DEF D0
      XIF 
* 
DL.4  LDA BDEF
      ADA D126
      LDA A,I 
      IFN 
      LDB $DATC 
      ADB M2000 
      SSB 
      JMP DL.41 
      SZA,RSS 
      JMP DL.41     MSC IS '0'
      XOR DCMSK 
      INA 
      XIF 
DL.41 STA MSC 
* 
* GO TO MAIN PORTION OF DL
DL.5  JSB DLSUB     CALL DLSUB(FWAM,LGTH) 
      DEF *+4 
BDEF  NOP 
      DEF LGTH
      DEF MSC 
      SKP 
* 
* 
*  TERMINATE DL     THEN TERMINATE
      JSB EXEC
      DEF *+2 
      DEF D6
      IFN 
* 
* GIVE FORTRAN INTERFACE FOR FG.LU ROUTINE. 
* 
SESLU NOP 
SYSLU NOP 
L3    NOP 
BUF   NOP 
IFGLU NOP 
      JSB .ENTR 
      DEF SESLU 
      JSB FG.LU 
      DEF RTNFG 
      DEF SESLU,I 
      DEF SYSLU,I 
      DEF L3,I
      DEF BUF,I 
RTNFG JMP IFGLU,I 
      XIF 
* 
D0    DEC 0 
D1    DEC 1 
D2    DEC 2 
D3    DEC 3 
D6    DEC 6 
D22   DEC 22
D126  DEC 126 
D128  DEC 128 
M1    DEC -1
M128  DEC -128
M2000 DEC -2000 
DCMSK DEC 31178 
LGTH  NOP           LENGTH OF UNUSED BACKGROUND 
MSC   NOP           MASTER SECURITY CODE
ISEC  NOP           SECTOR OF MSC 
LTRAK NOP           DIRECTORY TRK OF LU 2 (RTE-IVA) 
XEQT  EQU 1717B     ADDRESS OF CURRENT ID SEG.
TATSD EQU 1756B     NO. OF TRKS. ON SYSTEM DISC.
BKLWA EQU 1777B     ADDRESS OF LWAM 
* 
A     EQU 0 
      END DL
FTN4,L
      SUBROUTINE DLSUB(NAMES,LGTH,MSC)
     +,            REV.2024 800605 RTE-IVB
C---- 
C   THIS PROGRAM LISTS ALL OR SELECTED FILE NAMES.
C  TO USE TYPE  ON,DL,(P1),(P2),(P3),(P4),(P5),(P6) 
C 
C  # (P1)= FILE NAMR FILTER MAY INCLUDE SECURITY,CART.,TYPE 
C 
C    (P2)= LIST UNIT (DEFAULT YOUR CONSOLE)[:SF = SHORT FORM] 
C                                          [:LF = LONG FORM](DEFAULT) 
  
C     P3   IS USED TO INVOKE SPECIAL LISTING OPTIONS TO DL. 
C 
C  J (P3)= 'OF' LIST OFF. DO NOT LIST FILES.
C  F (P3)= 'EN' LIST END OF DIRECTORY # FILES GIVEN BY 'P4' 
C  I (P3)= 'OP' LIST ONLY FILES THAT ARE OPEN 
C  L (P3)= 'PU' LIST FILES THAT HAVE BEEN PURGED
C  T
C 
C     P4   IS PRIMARILY USED TO DETERMINE THE OUTPUT FORMAT 
C          OF DL.  IT ALSO INVOKES SOME SPECIAL OPTIONS.
C 
C  J (P4)=  NUMBER OF FILES TO BE LISTED IF P3 IS 'EN'(DEFAULT ALL) 
C  C (P4)= 'HE' TO HAVE AN EXPANDED HEADING PRINTED.
C  R (P4)= 'FC' TO HAVE NUMBER OF FILES PRINTED 
C  I (P4)= 'BO' TO HAVE HEADING AND FILE INFO PRINTED 
C *F (P4)= 'SC' TO SCAN ALL SECURITY CODES ON A GIVEN PLATTER 
C *  (P4)= 'PU' TO PURGE ALL FILES LISTED 
C *  (P4)= 'DI' GIVES DIRECTORY TRACK, SECTOR, AND WORD OF THE FILE 
C    (P4)= 'DS' GIVES DISC USAGE SUMMARY OF ALL DISCS QUARRIED.FILE 
C 
C *  NOT ALLOWED IF SHORT FORM REQUESTED. 
C 
C     P5   REVERSE FILTER FLAGS 
C 
C    (P5)= 'RF' REVERSE FILE NAME FILTER
C    (P5)= 'RS' REVERSE SECURITY CODE FILTER
C    (P5)= 'RT' REVERSE FILE TYPE FILTER
C    (P5)= 'RA' REVERSE ALL FILTERS 
C 
C    (P6)= 'AL' CHECK ALL CARTRIDGES MOUNTED IN THE SYSTEM
C 
C  #  THE FILE NAME FILTER HAS BEEN ENHANCED IN DL TO ALLOW A SEARCH
C  FOR A STRING OF CHARACTERS ANYWHERE IN THE FILE NAME. FOR FURTHER
C  EXPLAINATION OF THIS FEATURE SEE THE DOCUMENTATION FILE ON 'DL'. 
C 
C     ADDITONAL PROBLEMS NOT TO BE RESOLVED:
C 
C  WHEN ASKING FOR OPEN FILES ONLY (P4 ='OP') THE NUMBER OF EXTENTS 
C  WILL NOT BE SHOWN.  ANY OTHER TYPE OF LISTING WILL SHOW THE EXTENTS
C  HOWEVER.  THIS IS BECAUSE FMGR DOES NOT KEEP OPEN FLAGS ON EXTENTS,
C  ONLY ON THE MAIN FILE. 
C-------------------------------------------------------------------
C 
C 
C 
C 
      LOGICAL HEAD,RECRD,FGO,SGO,TGO,FFLAG,SFLAG,TFLAG,ENORPU 
      LOGICAL SLSW,SFFLG,SKEXT,NOSC 
C 
      INTEGER SUPFLG,CRNAME(3),CRLOOP,COLON,LBUFF(40) 
C 
C 
C 
      DIMENSION NAMES(4,1),IDCB(144),ICLST(4,64),LPROG(8,3) 
      DIMENSION IBUFF(16,8),JBUFF(10),ITIME(6),IMSC(5),LACR(3)
      DIMENSION IBTRK(6),ISCBUF(144),IB(2),IC(3),IFILT(6) 
C 
      EQUIVALENCE (IB(1),REG),(IBREG,IB(2)),(ITIME(1),ITIME1) 
C 
C  SAVE SOME MEMORY.
C 
      EQUIVALENCE(ISCBUF,IDCB)
      EQUIVALENCE(JBUFF(1),JBUF1),(JBUFF(2),JBUF2),(JBUFF(3),JBUF3),
     #           (JBUFF(4),JBUF4),(JBUFF(5),JBUF5),(JBUFF(6),JBUF6),
     #           (JBUFF(7),JBUF7),(JBUFF(8),JBUF8),(JBUFF(9),JBUF9),
     #           (JBUFF(10),JBUF10),(LACR(3),LACR3) 
      EQUIVALENCE(IC(3),ICSUB3),(ICLST(1,1),ICLST1),(LPROG(1,1),LPROG1) 
      EQUIVALENCE(IBUFF(4,1),IBUF41),(IBUFF(6,1),IBUF61), 
     #           (IBUFF(7,1),IBUF71),(IBUFF(8,1),IBUF81), 
     #           (IBUFF(9,1),IBUF91),(IBUFF(10,1),IBU101),
     #           (IBUFF(5,1),IBUF51),(IBUFF,LBUFF)
      DATA IC/177400B,377B,2H::/,IDISK/1/,TBLK/0.0/,LPROG/24*2H  /
      DATA IPURG/0/,IFILT/6*0/,ITYPE/-1/,REG/0.0/,IVETO/0/
      DATA ISKPSC/0/,SUPFLG/0/,ISTRC/1/,JCR/0/,IPCNT/0/ 
      DATA JCRIF/0/,JFILT/0/,COLON/2H::/,IOP/0/,IP/0/ 
      DATA RECRD/.TRUE./,FGO/.TRUE./,SGO/.TRUE./,TGO/.TRUE./
      DATA FFLAG/.TRUE./,SFLAG/.TRUE./,TFLAG/.TRUE./,NOSC/.TRUE./ 
      DATA LACR /2*2H  ,-1/,SLSW/.FALSE./,MINUS/1H-/,SFFLG/.FALSE./ 
C 
C  SET UP INPUT AND OUTPUT UNITS AND
C  INITIALIZE VARIABLES 
C 
      LUIN = LOGLU(ISES)
      WRITE(LUIN,150) 
150   FORMAT(" /DL - REV 2024") 
C 
      IF(LGTH .LT. 0)GO TO 1280 
      IDIM2 = LGTH/4
      IPL = 1 
      ICL = 3 
      IMESS = 0 
C 
C  SET UP DEFAULT ASSIGNMENTS 
C 
      ASSIGN  820 TO IPNTH
      ASSIGN 1110 TO IRTN 
      ASSIGN 1060 TO IPNTX
      ASSIGN 1100 TO IOPNT
      ASSIGN 1140 TO IPNT 
      ASSIGN 1160 TO IPNT0
      LUINE = LUIN + 400B 
C 
C  GET THE TURN ON STRING 
C 
      CALL GETST(IDCB,-60,ILOG) 
C 
C IF NO PARAMETERS WHERE PASSED JUST ASK FOR THE FILTER 
C 
4     IF(IDCB .NE. 2H?? .AND. IDCB .NE. 2HHE)GO TO 5
      IF(ILOG .NE. 2)GO TO 5
      WRITE(LUIN,15)
15    FORMAT(/
     +" ENTER: Namr filter[,List dev.,List opt.,Special opt.,Reverse "
     +"filter,ALL]"// 
     +" WHERE: List opt. is    ,Special opt. is"6X",Reverse filter is,"/
     +7X"'OF' LIST OFF    ,'HE' EXPAND HEADING  ,'RF' Rev. NAME FILTER"/
     +7X"'OP' OPEN FILES  ,'FC' FILE CNT & SIZE ,'RS' Rev. SC FILTER"/
     +7X"'PU' PURGED FILES,'BO' BOTH 'HE' & 'FC','RT' Rev. TYPE FILTER"/
     +24X",'SC' SCAN SEC CODE   ,'RA' Rev. ALL FILTERS"/
     +24X",'PU' PURGE FILES"/ 
     +24X",'DI' DIRCT. LOCATION"/ 
     +24X",'DS' DISC USAGE SUMMARY"/
     +7X"'EN' END OF DIR. , # OF FILES TO LIST"// 
     +7X" ALL PARAMETERS OPTIONAL (EXCEPT NAMR FILTER)"/) 
      GO TO 6 
5     IF(ILOG .NE. 0)GO TO 20 
6     WRITE(LUIN,10)
10    FORMAT(" ENTER FILE NAMR FILTER : _") 
      REG = REIO(1,LUINE,IDCB,-60)
      ILOG = IBREG
      IF(ILOG .EQ. 0)RETURN 
      GO TO 4 
20    IF(NAMR(JBUFF,IDCB,ILOG,ISTRC))140,30 
30    IPCNT = IPCNT + 1 
      GO TO(40,90,100,110,120,135),IPCNT
40    IPTYPE = IAND(JBUF4,3)
      IF(IPTYPE .EQ. 0)GO TO 80 
      IST = ISTRC - 1 
      I = 1 
      CALL STGFD(IDCB,IST,COLON,1,I,IFLGTH) 
      IF(I .NE. 0)GO TO 50
      IFLGTH = IST - 1
      IF(ILOG .EQ. IST)IFLGTH = IST 
      GO TO 60
50    IFLGTH = IFLGTH - 1 
60    IWD = IFLGTH/2 + 1
      IF(IWD .GT. 6)IWD = 6 
      DO 70 I=1,IWD 
      IFILT(I) = IDCB(I)
70    CONTINUE
80    IPTYPE = ISOL8(JBUF4,2,3) 
      IF(IPTYPE .EQ. 0)ISKPSC = -1
C 
C  SET UP THE 'NO SEC. CODE' LIST OPTION. 
C  IF THE USER SPECIFIED A SEC. CODE. 
C  LET HIM SEE WHAT HE SPECIFIED. 
C 
      IF(ISKPSC .NE. -1)NOSC = .FALSE.
      IPFIL = JBUF5 
      JCR = JBUF6 
C 
C  MASTER SEC. CODE GIVEN IN 4TH SUB PARAM. 
C  WILL OVER RIDE THE 'NOSC' FLAG 
C 
      IF(JBUF8 .EQ. MSC)NOSC = .FALSE.
      IPTYPE = ISOL8(JBUF4,6,7) 
      IF(IPTYPE .GT. 0)ITYPE = JBUF7
      GO TO 20
90    IPTYPE = IAND(JBUF4,3)
      IF(IPTYPE .EQ. 1)LUOUT = JBUFF
      IF(JBUF5 .EQ. 2HSF)SFFLG = .TRUE. 
      IF(JBUF5 .EQ. 2HLF)SFFLG = .FALSE.
      IF(JBUF6 .EQ. 2HNO)NOSC  = .TRUE. 
      GO TO 20
100   JFILT = JBUFF 
      GO TO 20
110   JCRIF = JBUFF 
      GO TO 20
120   DO 130 I=1,3
      IF(JBUFF(I) .EQ. 2HRF)FGO = .FALSE. 
      IF(JBUFF(I) .EQ. 2HRS)SGO = .FALSE. 
      IF(JBUFF(I) .EQ. 2HRT)TGO = .FALSE. 
      IF(JBUFF(I) .NE. 2HRA)GO TO 130 
      FGO = .FALSE. 
      SGO = .FALSE. 
      TGO = .FALSE. 
130   CONTINUE
      GO TO 20
135   IF(JBUFF .EQ. 2HAL)IOP = 1
140   IF(JFILT .EQ. 2HOF)SUPFLG = 1 
      ENORPU = (JFILT .EQ. 2HEN) .OR. (JFILT .EQ. 2HPU) 
      IF(LUOUT.EQ.0)LUOUT = LUIN
      LUPAG=IOR(LUOUT,1100B)
      IF(.NOT. SFFLG .AND. .NOT.NOSC)GO TO 155  
C 
C  SET PRINT STATEMENT PER 'NOSC' FLAG
C 
      ASSIGN  821 TO IPNTH
      ASSIGN 1061 TO IPNTX
      ASSIGN 1101 TO IOPNT
      ASSIGN 1141 TO IPNT 
      ASSIGN 1161 TO IPNT0
      IF(JCRIF.NE.2HPU.AND.JCRIF.NE.2HDI.AND.JCRIF.NE.2HSC)GO TO 155
      WRITE(LUIN,145) 
145   FORMAT(" OPTION NOT AVAILABLE TO YOU")  
      GO TO 170 
C 
C  WHO'S MOUNTED
C 
155   CALL FSTAT(ICLST,256,0,IOP) 
C 
C  GOING TO PURGE OR LIST SECURITIES ONLY ??
C 
      IF(JFILT.EQ.2HEN)GO TO 260
      IF(JCRIF.EQ.2HSC)GO TO 240
      IF(JCRIF.NE.2HPU)GO TO 260
      WRITE(LUIN,160) 
160   FORMAT(" **** CAUTION ****"/" YOU ARE ABOUT TO PURGE ALL FILES "
     $"LISTED WITH THIS PROGRAM"/" DO YOU WANT TO PROCEED ? _") 
      CALL REIO(1,LUINE,NHUH,-2)
      IF(NHUH.EQ.2HYE)GO TO 190 
170   WRITE(LUIN,180) 
      GO TO 1270
180   FORMAT(" DL ABORTED") 
C 
C CHECK IF VETO OPTION WANTED 
C 
190   WRITE(LUIN,200 )
200   FORMAT(" VETO OPTION ? _")
      CALL REIO(1,LUINE,NHUH,-2)
      IF(NHUH .EQ. 2HYE)IVETO = 1 
      WRITE(LUIN,210) 
210   FORMAT(" ENTER MASTER SECURITY CODE: _")
      ISTRC = 1 
      REG = REIO(1,LUIN,IMSC,-10) 
      CALL NAMR(JBUFF,IMSC,IBREG,ISTRC) 
      IF(JBUFF.EQ.MSC)GO TO 230 
      WRITE(LUIN,220) 
      GO TO 170 
220   FORMAT(" ILLEGAL MASTER SECURITY CODE") 
230   IPURG = 99
      IF(IVETO .EQ. 1)GO TO 260 
240   IF(JCR.NE.0)GO TO 260 
      WRITE(LUIN,250) 
250   FORMAT(" YOU MUST SPECIFY A CARTRIDGE FOR THIS OPTION _") 
      ISTRC = 1 
      REG = REIO(1,LUINE,IMSC,-10)
      CALL NAMR(JBUFF,IMSC,IBREG,ISTRC) 
      JCR = JBUFF 
      GO TO 240 
C 
C  CHECK FOR # OF CARTRIDGES MOUNTED
C 
260   JBUFF = 0 
      DO 270 NUMCT=1,31 
      IF(ICLST(1,NUMCT).EQ.0) GO TO 280 
270   CONTINUE
C 
C  SET # OF CARTRIDGES AND CHECK FOR CARTRIDGE WANTED 
C 
280   LU= ICLST1
      NUMCT=NUMCT-1 
      IF(JCR.EQ.0)GO TO 320 
      IF(JCR.GT.0)GO TO 290 
      ICL = 1 
      JCR = -JCR
C 
C  FIND THE LU NUMBER OF THE CARTRIDGE WANTED 
C 
290   DO 300 KCKNT=1,NUMCT
      IF(ICLST(ICL,KCKNT).NE.JCR)GO TO 300
      LU=ICLST(1,KCKNT) 
      JCR=ICLST(3,KCKNT)
      IDISK=KCKNT 
      GO TO 320 
300   CONTINUE
      LUCR = 2HCR 
      IF(ICL .EQ. 1)LUCR = 2HLU 
      WRITE(LUIN,310)LUCR,JCR 
310   FORMAT(1X,A2" = ",I5," IS NOT MOUNTED") 
      GO TO 1270
320   IF(JCR.NE.0)NUMCT = 1 
      GO TO 340 
330   NUMCT = IPL -1
      JCRIF = 2HFC
      HEAD = .FALSE.
      ISKPSC = 0
C 
C  START LOOP FOR EACH CARTRIDGE
C 
340   IF(JCRIF .NE. 2HDS)GO TO 342
      CALL JULIA(ITIME) 
      IF(IFILT .NE. 0)GO TO 346 
      IFLGTH = 2
      IFILT = 40B 
346   WRITE(LUOUT,344)ITIME 
 344  FORMAT(/16X"DISC CARTRIDGE UTILAZATION SUMMARY  "6A2/ 
     #/25X"AVAILABLE"10X, 
     #"A F T E R  P A C K"/3X,"CRN   LU LABEL  SCT/  BLKS/ DIR."
     #"  %USED   BLKS/ DIR.  %USED  NEXT  LAST  DIR"/ 
     #19X"TRK"9X"ENT."16X"ENT."10X"TRK   TRK  TRK"/ 
     #2X,77("-")) 
342   DO 1240 CRLOOP=1,NUMCT
      IF(SLSW)CALL IFGLU(LU,MINUS,0,IDCB) 
      SLSW = .FALSE.
      ISKIP=32767 
      IF(IPL.EQ.1)GO TO 350 
      IPFIL = ISCBUF(CRLOOP)
      GO TO 740 
C 
C  GET LU # OF CARTRIDGE WANTED 
C 
350   IF(CRLOOP.EQ.1)GO TO 360
      LU=ICLST(1,IDISK) 
C 
C  SET SECTOR FOR PERIPHERAL OR SYSTEM DISC 
C 
C  GET THE LAST TRACK THE FMGR HAS IN THE CURRENT CARTRIDGE.
C 
360   ITRAK=ICLST(2,IDISK)
      IDISK=IDISK+1 
      LTRAK = ITRAK 
370   ISEC=0
      IBLK=0
C 
C  GET FILE DIRECTORY INFORMATION.
C 
      CALL EXEC(100001B,LU,IBUFF,128,ITRAK,ISEC)
      GO TO 1300
C 
C SKIP THE INITIALIZE STUFF IF WE ARE DOING THE 'SC' TRICK
C 
375   IF(IPL.GT.1)GO TO 470 
      IF(ISKIP.NE.32767)GO TO 540 
C 
C SAVE CR NAME & NUMBER 
C 
      DO 390 JJ=1,3 
      CRNAME(JJ) = IBUFF(JJ,1)
      LACR(JJ) = 2H 
390   CONTINUE
      CRNAME = IAND(CRNAME,77777B)
      ICR = IBUF41
      LACR3 = -1
C 
C CHECK FOR BAD TRACKS AND RECORD THEM
C 
      DO 400 IJK=1,6
      IKL=IJK+10
      IF(IBUFF(IKL,1).EQ.0)GO TO 410
      IBTRK(IJK)=IBUFF(IKL,1) 
400   CONTINUE
      IBTCT=6 
      GO TO 420 
410   IBTCT=IJK-1 
420   ISPT=IBUF71 
      LDTRK = IBUF81
      NXTTRK = IBU101 
C 
C  COMPUTE TOTAL NUMBER OF TRACKS FOR LU
C 
      TNTKS = LDTRK-IBUF51
C 
C  GET THE NUMBER OF AVAILABLE TRACKS 
C 
      TREM=IBUF81-IBU101
      ISREM=0 
C 
C  IF ON SECTOR ZERO SUBTRACT ONE TRACK 
C 
      IF(IBUF61.EQ.0) GO TO 430 
      TREM=TREM-1 
C 
C  COMPUTE AVAILABLE SECTORS
C 
      ISREM=IBUF71-IBUF61 
C 
C  COMPUTE TOTAL BLKS AVAILABLE 
C 
430   BREM=((TREM*ISPT)+ISREM)/2
C 
C  GET TOTAL # BLKS FOR LU AND COMPUTE % USED AREA
C 
      TNBLKS = (TNTKS*ISPT)/2 
      PCUSED = ((TNBLKS-BREM)/TNBLKS) * 100.0 
C 
C  GET NUMBER OF DIRECTORY TRACKS AND COMPUTE THE NUMBER OF 
C  DIRECTORY ENTRIES AVAILABLE
C 
      IDTRK=-IBUF91 
      IDENT=IDTRK*ISPT*4-1
C 
C  LOCK OUTPUT DEVICE 
C 
440   IF(LUIN.EQ.LUOUT) GO TO 460 
      IREG=LURQ(100001B,LUOUT,1)
      IF(IREG.EQ.0)GO TO 460
C 
C LOCK UNSUCCESSFUL, SO REPORT
C 
      IF (IMESS .EQ. 0)WRITE (LUIN,450) LUOUT 
450   FORMAT (1X"WAITING FOR LU# "I3) 
C 
      IMESS = 1 
      CALL EXEC(12,0,2,0,-3)
      IF(IFBRK(IDMMY))1270,440,440
460   CALL ASCII(ICR,LACR3) 
      IF(LACR3 .EQ. 20040B)CALL CNUMD(ICR,LACR) 
      HEAD=(JCRIF.EQ.2HHE).OR.(JCRIF.EQ.2HBO).OR.(JCRIF.EQ.2HSC)
      IF(HEAD.EQ..FALSE.)GO TO 500
C 
C GET THE TIME FROM THE REAL-TIME CLOCK.
C 
470   CALL JULIA(ITIME) 
C 
C  PRINT THE HEADING
C 
      WRITE(LUOUT,480)ITIME 
      IF(IPL .GT. 1)GO TO 500 
      IF(IPURG.EQ.99)GO TO 520
480   FORMAT(67X,6A2) 
      WRITE(LUOUT,490)CRNAME,LACR,LU,IBUF71,IBUF51,IBU101,
     #IBUF61,ITRAK,IDTRK,BREM,PCUSED
490   FORMAT(1X,31("*"),5X,3A2,5X,31("*")/
     #32X,"CR=",3A2," LU=",I3// 
     #30X,"SECTORS/TRACK = ",I3/
     #" 1ST TRACK ="I4,2X"NEXT TRACK ="I4,10X,"NEXT SECTOR = ",I3/
     #18X,"LAST TRACK ="I4,11X,"DIR TRACKS = ",I3// 
     #28X,"BLOCKS AVAILABLE = ",I6,2X,F6.2,"% USED")
      GO TO 540 
500   IF(IPURG.EQ.99)WRITE(LUOUT,510) 
510   FORMAT("**** FILES PURGED ON ***")
      IF(IPURG.EQ.99)GO TO 470
      IF(SUPFLG.GT.0)GO TO 540
      IF(JCRIF .EQ. 2HDS)GO TO 540
      IF(NUMCT .GT. 1)GO TO 540 
520   WRITE(LUOUT,530)CRNAME,LACR,LU
530   FORMAT(/25X,5("*"),5X,3A2,5X,5("*")/30X,"CR=",3A2," LU=",I3/) 
540   JVAR=2
      IFILE=1 
      IUSED=0 
      IASEC=0 
      ICCNT = 0 
      IF(JCRIF.EQ.0)ISKIP=0 
C 
C  START THE LOOP TO GET FILES. 
C 
550   DO 710 J=JVAR,8 
C 
C  RECORD USED SECTORS OF PURGED FILES
C 
      IF(IBUFF(1,J).EQ.0) GO TO 730 
      IF(IBUFF(1,J).GT.0) GO TO 560 
      IASEC = IASEC+IBUFF(7,J)
      IF(JFILT .NE. 2HPU)GO TO 700
560   IF(JFILT.EQ.2HEN.AND.ISKIP.EQ.32767) GO TO 690
C 
      IF(JFILT.EQ.2HEN)GO TO 660
C 
C   FILTER FILES FOR SELECTIVE LISTING
C 
      IF(IFILT.EQ.0)GO TO 570 
      CALL NAMCK(IBUFF(1,J),6,IFILT,IFLGTH,IFLAG) 
      FFLAG = .NOT. FGO 
      IF(IFLAG .LT. 0)FFLAG = FGO 
570   IF(ISKPSC.LT.0)GO TO 580
      SFLAG = .NOT. SGO 
      IF(IPFIL.EQ.IBUFF(9,J))SFLAG = SGO
580   IF(ITYPE.EQ.-1) GO TO 590 
      TFLAG = .NOT. TGO 
      IF(ITYPE.EQ.IBUFF(4,J))TFLAG = TGO
590   RECRD = FFLAG .AND. SFLAG .AND. TFLAG 
      IF(RECRD)600,690
600   IF(JCRIF.NE.2HSC)GO TO 640
      ISCBUF(IPL) = IBUFF(9,J)
      IF(IPL.EQ.1)GO TO 620 
      DO 610 IPF=1,IPL-1
      IF(ISCBUF(IPF).EQ.IBUFF(9,J))GO TO 690
610   CONTINUE
620   IPL = IPL+1 
C 
C CHECK FOR ARRAY OVERFLOW
C 
      IF(IPL .LE. 144)GO TO 640 
      IPL = IPL - 1 
      WRITE(LUIN,630)IPL
630   FORMAT(" /DL : MORE THAN "I4" SECURITY CODES")
      GO TO 170 
640   IF(JFILT.NE.2HOP)GO TO 670
      DO 650 JK=1,7 
      IF(IBUFF(JK+9,J).NE.0)GO TO 670 
650   CONTINUE
      GO TO 690 
C 
C  RECORD FILE NAMES AND INCREAMENT COUNTERS. 
C 
660   ISKIP = ISKIP-1 
      IF(ISKIP.GE.0)GO TO 690 
670   IF(JFILT .EQ. 2HPU .AND. IBUFF(1,J) .GT. 0)GO TO 690
      DO 680 K=1,3
      NAMES(K,IFILE)=IBUFF(K,J) 
680   CONTINUE
C 
C  SAVE TRACK AND SECTOR OF THE FILE
C 
      KTRAK=(LTRAK-ITRAK)*2048
      KTRAK=IOR(KTRAK,(J-1)*256)
      NAMES(4,IFILE)=IOR(KTRAK,ISEC)
      IFILE=IFILE+1 
      IF(IFILE.GT.IDIM2)GO TO 1210
      IF(IBUFF(1,J) .EQ. -1)GO TO 700 
690   ICCNT=ICCNT+1 
700   IUSED=IUSED+1 
710   CONTINUE
C 
C  RESET TRACK AND SECTOR FOR THE NEXT EIGHT FILES. 
C 
      JVAR=1
      IBLK=IBLK+1 
      IF(IBLK.LE.ISPT/2-1) GO TO 720
      IF(ITRAK .EQ. LDTRK)GO TO 730 
      ITRAK=ITRAK-1 
      IBLK=IBLK-ISPT/2
720   ISEC=IBLK*14-((IBLK*14)/ISPT)*ISPT
      CALL EXEC(1,LU,IBUFF,128,ITRAK,ISEC)
      GO TO 550 
C 
C  COMPUTE DIRECTORY ENTRIES AVAILABLE, BLKS AVAILABLE AFTER PACK,
C  AND DIRECTORY ENTRIES AVAILABLE AFTER PACK 
C 
730   IF(JFILT.NE.2HEN.OR.ISKIP.NE.32767)GO TO 750
      ISKIP = ICCNT - JCRIF 
740   ITRAK = LTRAK 
      GO TO 370 
750   IFILE=IFILE-1 
      IDUN=IDENT-IUSED
      ABLK=BREM+(IASEC/2) 
C 
C  COMPUTE USED AFTER PACK
C 
      PCUAPK = ((TNBLKS-ABLK)/TNBLKS) * 100.0 
      IADUN=IDENT-ICCNT 
      IF(JCRIF .NE. 2HDS)GO TO 758
      IF(BREM .EQ. ABLK)GO TO 755 
      WRITE(LUOUT,756)LACR,LU,CRNAME,ISPT,BREM,IDUN,PCUSED,ABLK,IADUN,
     #PCUAPK,NXTTRK,LTRAK,IDTRK 
      GO TO 790 
755   WRITE(LUOUT,757)LACR,LU,CRNAME,ISPT,BREM,IDUN,PCUSED,NXTTRK,
     #LTRAK,IDTRK 
756   FORMAT( 
     #1X,3A2,I4,1X,3A2,I4,I7,"/",I5,F7.2,I7,"/",I5,F7.2,I6,I6,2X,I3)
757   FORMAT( 
     #1X,3A2,I4,1X,3A2,I4,I7,"/",I5,F7.2,2X,18("-"),I6,I6,2X,I3)
 758  IF(HEAD.EQ..FALSE.)GO TO 790
      WRITE(LUOUT,760)IDUN
760   FORMAT(23X,"DIRECTORY ENTRIES AVAILABLE = ",I5/)
      IF(BREM.NE.ABLK)WRITE(LUOUT,770)ABLK,PCUAPK 
770   FORMAT(23X,"BLOCKS AVAILABLE AFTER PACK = ",I6,2X,F6.2"% USED") 
      IF(IDUN.NE.IADUN)WRITE(LUOUT,780)IADUN
780   FORMAT(17X,"DIRECTORY ENTRIES AVAILABLE AFTER PACK = ",I5/) 
C 
C  PRINT ANY BAD TRACKS!!!
C 
      IF(IBTCT.GT.0)WRITE(LUOUT,800)(IBTRK(IJK),IJK=1,IBTCT)
800   FORMAT(30X,"BAD TRACK LIST"/6(35X,I3/)) 
790   IF(IFBRK(IDUMY))1250,810
810   IF(IFILE.EQ.0) GO TO 1240 
      IF(JCRIF.EQ.2HSC .AND. JFILT .NE. 2HEN)GO TO 330
      IF(IPL .GT. 1)GO TO 815 
      IF(NUMCT.GT.1 .AND. (.NOT.HEAD))WRITE(LUOUT,530)CRNAME,LACR,LU
815   IF(SUPFLG.GT.0)GO TO 830
      IF(SFFLG)GO TO 825
      WRITE(LUOUT,IPNTH)
820   FORMAT(3X,"NAME",3X,"TYPE",2X,"BLKS\LU EXT  RECLEN",
     #3X,"SECURITY",3X,"TRACK",2X,"SECTOR  OPEN TO")
821   FORMAT(3X,"NAME",3X,"TYPE",2X,"BLKS\LU EXT  RECLEN",
     #3X,"TRACK",2X,"SECTOR  OPEN TO")
C 
C  IF JFILT = 'EN' OR 'PU' SKIP THE SORT
C 
 825  IF (ENORPU)GO TO 830
C 
C  ALPHABETIZE THE FILES
C 
      CALL ALPHA(NAMES,IFILE,IXCNT) 
C 
C  START LOOP TO PRINT THE FILE NAMES.
C 
C  CHECK FOR SHORT FORM REQUEST 
C 
830   IF(.NOT. SFFLG)GO TO 839
C 
C  SET INITIAL POINTERS, LOOP SIZE, AND INDEXES 
C 
      LK = 2
      LFILE = IFILE - IXCNT 
      INDEX = LFILE/8 
      LEXTRA= MOD(LFILE,8)
      LOOP = INDEX
      IF(LEXTRA .GT. 0)LOOP = LOOP + 1
       DO 831 JK=1,40 
       LBUFF(JK) = 20040B 
831    CONTINUE 
C 
C  START LOOP TO PRINT FILES IN THE SHORT FORM
C 
      LNDEX = 0 
       DO 837 JK=1,LOOP 
       LXCNT = LEXTRA 
       LNDEX = LNDEX + 1
       JNDEX = 0
C 
C  START INNER LOOP TO GET THE NAME WE WANT BASED ON 'JNDEX'
C 
        DO 835 IF=LNDEX,IFILE 
        SKEXT = .FALSE. 
        JF = IF - 1 
        ICNT = 0
        IF(LXCNT .GE. 0) ICNT = 1 
        IF(IF .EQ. 1)GO TO 833
C 
C  CHECK FOR EXTENT 
C 
        IF((NAMES(1,JF) .EQ. NAMES(1,IF)) .AND. 
     +     (NAMES(2,JF) .EQ. NAMES(2,IF)) .AND. 
     +     (NAMES(3,JF) .EQ. NAMES(3,IF)))SKEXT = .TRUE.
C 
C  SET JNDEX TO RECORD FIRST NAME AFTER ANY EXTENTS 
C 
        IF(IF .NE. LNDEX)GO TO 832
        JNDEX = INDEX + ICNT -1 
        IF(SKEXT) LNDEX = LNDEX + 1 
C 
 832    IF(SKEXT .AND. JFILT .NE. 2HEN)GO TO 835
        JNDEX = JNDEX + 1 
        IF(JNDEX .NE. INDEX+ICNT)GO TO 835
        JNDEX = 0 
 833    LXCNT = LXCNT - 1 
C 
C  RECORD THE FILE NAME IN THE OUTPUT BUFFER
C 
         DO 834 NA=1,3
         LBUFF(NA+LK) = NAMES(NA,IF)
834      CONTINUE 
        IF(LBUFF(LK+1) .EQ. -1)LBUFF(LK+1) = 2H-- 
        LREC = LK + 3 
        LK = LK + 4 
        IF(LXCNT.EQ.0.AND.JK.EQ.LOOP)GO TO 837
        IF(LK .LT. 32)GO TO 835 
        CALL EXEC(2,LUOUT,LBUFF,LREC) 
        LK = 2
835    CONTINUE 
837   CONTINUE
      IF(LK .NE. 2)CALL EXEC(2,LUOUT,LBUFF,LK-1)
      GO TO 1230
839   KFILE = 0 
      DO 1180 K=1,IFILE 
      IEXN =-1
C 
C  GET TRACK AND SECTOR OF THE FILE.
C 
      IWORK=NAMES(4,K)
      ITRAK=LTRAK-(IWORK/2048)
      KI=1+IAND(IWORK,3400B)/256
      ISEC=IAND(IWORK,177B) 
      IF(K .EQ. 1)GO TO 840 
      IF(ITRAK .NE. ILTRK)GO TO 840 
      IF(ISEC .NE. ILSEC)GO TO 840
      GO TO 860 
C 
C  GET FILE AND INFORMATION ON IT.
C 
840   CALL EXEC(1,LU,IBUFF,128,ITRAK,ISEC)
850   ILTRK = ITRAK 
      ILSEC = ISEC
860   IEXCK = IAND(200B,IWORK)
      IF(.NOT. ENORPU)GO TO 870 
      IF(IBUFF(4,KI).EQ.0)GO TO 900 
      IEXCK=IBUFF(6,KI)/256 
C 
C  CHECK FOR EXTENTS
C 
870   IF(IEXCK)900,900,880
880   IF(JBUF1.EQ.0) GO TO 890
      IF((JBUF1.NE.IBUFF(1,KI)).OR.(JBUF2.NE.IBUFF(2,KI)) 
     #.OR.(JBUF3.NE.IBUFF(3,KI))) GO TO 1000
C 
C  RECORD EXTENT NUMBER AND CALCULATE NECESSARY INFORMATION 
C  IF IT IS EXTENT ZERO.
C 
      IF(ENORPU)GO TO 900 
890   IEXN = ISOL8(IBUFF(6,KI),8,15)
      IF(IEXN.GT.ITEMP)ITEMP=IEXN 
      IF(ENORPU)GO TO 910 
      IF(IEXN)1170,910,1170 
900   IF(JBUF1.NE.0)GO TO 1000
910   IF(IBUFF(8,KI).EQ.0) IBUFF(8,KI)=128
      IF(NOSC)IBUFF(9,KI)=20040B
      CALL ASCII(IBUFF(9,KI),IP)
      IF(IBUFF(1,KI) .EQ. -1)IBUFF(1,KI) = 2H-- 
      IBUFF(7,KI)=IBUFF(7,KI)/2 
      IBUFF(6,KI)=IAND(177B,IBUFF(6,KI))
      IF(JFILT.EQ.2HEN.OR.JCRIF.NE.2HDI)GO TO 920 
      IBUFF(8,KI) = (KI-1)*16 
      IBUFF(5,KI) = ITRAK 
      IBUFF(6,KI) = ISEC
920   IF(K.EQ.IFILE.AND.ENORPU)K=K+1
C 
C  CHECK TO SEE IF FILE IS OPEN TO ANYONE.
C 
      IF(LPROG1.EQ.2H  )GO TO 940 
      DO 930 LC=1,3 
      LPROG(1,LC)=20040B
930   CONTINUE
940   DO 970 JJ=1,7 
      IF(IBUFF(JJ+9,KI).EQ.0)GO TO 970
      IKEY = IGET(1657B) - 1
      IOFSET = IAND(377B,IBUFF(JJ+9,KI))
      IADDR = IGET(IKEY + IOFSET) + 14B 
      DO 950 JK=1,3 
950   LPROG(LKNT+1,JK)=IGET(IADDR+JK-1) 
      IND = 40B 
      IF(IBUFF(JJ+9,KI).LT.0)IND=55B
      LPROG(LKNT+1,3)=IOR(IND,IAND(177400B,LPROG(LKNT+1,3)))
      LKNT = LKNT+1 
      IF(LKNT.GE.2)LKNT1=2
      DO 960 JK=1,3 
960   LPROG(LKNT+1,JK)=2H 
970   CONTINUE
      IF(ENORPU.AND.IEXN.EQ.0)GO TO 1070
      IF(IEXN.EQ.-1) GO TO 990
C 
C  FILL THE TEMPORY BUFFER
C 
      DO 980 JK=1,9 
980   JBUFF(JK)=IBUFF(JK,KI)
      JBUF10=IP 
      GO TO 1170
990   IF(ITEMP.EQ.0)GO TO 1070
C 
C  PRINT THE FILES AND INFORMATION
C 
1000  IF(SUPFLG.GT.0)GO TO 1010 
      WRITE(LUOUT,IPNTX) JBUF1,JBUF2,JBUF3,JBUF4, 
     #JBUF7,ITEMP,JBUF8,JBUF9,JBUF10,JBUF5,JBUF6, 
     #((LPROG(JJ,JK),JK=1,3),JJ=1,LKNT1)
      TBLKAD = JBUF7*(ITEMP+1)
      ASSIGN 1010 TO IRTN 
      GO TO 1080
1010  ASSIGN 1110 TO IRTN 
      TBLK=TBLK+TBLKAD
      IF(IPURG.NE.99)GO TO 1050 
      IF(IVETO .EQ. 0)GO TO 1040
      ASSIGN 1050 TO NOPRGE 
      ASSIGN 1040  TO IPGAD 
1020  WRITE(LUIN,1030 ) 
1030  FORMAT(" PURGE ? (YES, NO, ABORT) _") 
      NHUH = 0
      CALL REIO(1,LUINE,NHUH,-1)
      IF(NHUH .EQ. 1HY)GO TO IPGAD
      IF(NHUH .EQ. 1HA)GO TO 1270 
C 
C  SUBTRACT BLOCKS AND FILE COUNT IF NOT PURGED 
C 
      TBLK = TBLK - TBLKAD
      KFILE = KFILE + ITEMP + 1 
      GO TO NOPRGE
1040  CALL PURGE(IDCB,IERR,JBUFF,JBUF9,ICR) 
      CALL IFMGR(IERR,10,LUIN,JBUFF)
1050  ITEMP = 0 
      JBUF1=0 
      IF(K.EQ.IFILE.AND.ENORPU.AND.IEXCK.NE.0)GO TO 890 
      IF((K.GE.IFILE).AND.(IEXCK.NE.0))GO TO 1180 
      IF(IEXCK)910,910,890
1060  FORMAT(2X,3A2,2X,I3,4X,I5," +",I3,2X,I5,3X,I6,"=",A2,3X,I4,4X,I3, 
     #4X,3A2,1X,3A2)
1061  FORMAT(2X,3A2,2X,I3,4X,I5," +",I3,2X,I5,2A2,I4,4X,I3, 
     #4X,3A2,1X,3A2)
1070  IF(IBUFF(4,KI).EQ.0 .AND. JCRIF .NE. 2HDI)GO TO 1150
      IF(SUPFLG.GT.0)GO TO 1130 
      WRITE(LUOUT,IPNT) IBUFF(1,KI),IBUFF(2,KI),IBUFF(3,KI),
     #IBUFF(4,KI),IBUFF(7,KI),IBUFF(8,KI),IBUFF(9,KI),IP, 
     #IBUFF(5,KI),IBUFF(6,KI),((LPROG(JJ,JK),JK=1,3),JJ=1,LKNT1)
      TBLKAD = IBUFF(7,KI)
1080  DO 1090 M=1,3 
      N=M*2 
      IF(LKNT.GT.N)WRITE(LUOUT,IOPNT)((LPROG(JJ,JK),JK=1,3),JJ=N+1,N+2) 
1090  CONTINUE
      LKNT = 0
      LKNT1 = 0 
      GO TO IRTN
1100  FORMAT(64X,3A2,1X,3A2)
1101  FORMAT(52X,3A2,1X,3A2)
1110  TBLK = TBLK + TBLKAD
      IF(IPURG.NE.99)GO TO 1130 
      IF(IVETO .EQ. 0)GO TO 1120
      ASSIGN 1130 TO NOPRGE 
      ASSIGN 1120 TO IPGAD
      GO TO 1020
1120  CALL PURGE(IDCB,IERR,IBUFF(1,KI),IBUFF(9,KI),ICR) 
      CALL IFMGR(IERR,10,LUIN,IBUFF(1,KI))
1130  IF(IBUFF(4,KI) .EQ. 0)GO TO 1170
1140  FORMAT(2X,3A2,2X,I3,4X,I5,7X,I5,3X,I6,"=",A2,3X,I4,4X,I3,4X 
     #3A2,1X,3A2) 
1141  FORMAT(2X,3A2,2X,I3,4X,I5,7X,I5,2A2,I4,4X,I3,4X   
     #3A2,1X,3A2) 
      GO TO 1170
C 
C  PRINT TYPE ZERO FILE 
C 
1150  IF(SUPFLG.GT.0)GO TO 1170 
      IFUNC = (IAND(IBUFF(5,KI),7700B))/64
      I0LU  = IAND(IBUFF(5,KI),77B) 
      WRITE(LUOUT,IPNT0) IBUFF(1,KI),IBUFF(2,KI),IBUFF(3,KI)  
     #,IBUFF(4,KI),IFUNC,I0LU,IBUFF(9,KI),IP
1160  FORMAT(2X,3A2,2X,I3,4X,O3,I2,15X,I6,"=",A2) 
1161  FORMAT(2X,3A2,2X,I3,4X,O3,I2,2A2) 
1170  IF((K.GE.IFILE).AND.(ITEMP.NE.0))GO TO 1000 
C 
C  GO GET THE NEXT FILE NAME
C 
      IF(IFBRK(IDUMY))1250,1180 
1180  CONTINUE
      IFILE = IFILE - KFILE 
      BLKPT = ISPT/2
      ITRK= TBLK/BLKPT
      ISC=AMOD(TBLK,BLKPT)
      ISC=ISC*2 
      TBLK = 0
      IF(JCRIF.EQ.2HDI)GO TO 1230 
      CALL ASCII(IPFIL,IP)
      IF(IPL.GT.1.AND.SUPFLG.GT.0)WRITE(LUOUT,1190)IPFIL,IP 
1190  FORMAT(" SECURITY CODE ",I6,"=",A2," HAS A")
      IF(JCRIF.EQ.2HHE.OR.JCRIF.EQ.0.OR.JFILT.EQ.2HEN)GO TO 1230
      WRITE(LUOUT,1200)IFILE,ITRK,ISC 
1200  FORMAT(/" TOTAL OF ",I4," FILES USING",I4," TRACKS AND ", 
     1I3," SECTORS (64 WORD SECTORS)"//)
      GO TO 1230
1210  WRITE(LUIN,1220)IDIM2 
1220  FORMAT(" DIRECTORY TOO LARGE MORE THAN",I5," ENTRIES")
C 
C  GO GET THE NEXT CARTRIDGE
C 
1230  IF(IPL.GT.1.AND.SUPFLG.EQ.0)CALL EXEC(3,LUPAG,-1) 
1240  CONTINUE
      IF(SLSW) CALL IFGLU(LU,MINUS,0,IDCB)
      IF(SFFLG)GO TO 1250 
      WRITE(LUOUT,1260) 
1250  CALL EXEC(3,LUPAG,-1) 
1260  FORMAT(17(" *"),"END DL",16("* "))
1270  RETURN
1280  WRITE(LUIN,1290)
1290  FORMAT(" /DL : PARTITION TO SMALL INCREASE SIZE OF DL !") 
      RETURN
C 
C  CHECK FOR IO12 ERROR FROM DISK READ
C 
1300  CALL ABREG(IA,IB) 
      IF(IA .NE. 2HIO)GO TO 1320
      IF(IB .NE. 2H12)GO TO 1320
      IERR = IFGLU(LU,LU,0,IDCB)
      SLSW = .TRUE. 
      IF(IERR .EQ. 0)GO TO 370
      WRITE(LUIN,1310)IERR,LU 
1310  FORMAT(" /DL :"I5" ERROR TRYING TO MAP LU"I3" INTO SST")
      GO TO 1240
1320  WRITE(LUIN,1330)IA,IB 
1330  FORMAT(2A2,2X," DL ABORTED")
      RETURN
      END 
      SUBROUTINE ASCII(BINARY,IA),CHECK FOR LEGAL ASCII 790720
      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 
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 
ASMB,R,L,C
      NAM ALPHA,7             REV.2020 750120 
* DOES AN ALPHABETIC SORT ON 3-WORD FIELD IN (NAMES) IFILE FIELDS LONG. 
* IT ALSO SETS BIT 8 OF THE TRACK SECTOR WORD IF IT IS AN EXTENT. 
* CALLED FROM FTN BY:  CALL ALPHA(NAMES,IFILE)
* 
*  MODIFIED TO COUNT NUMBER OF EXTENTS ENCOUNTERED 4/14/80 DHP
* 
      ENT ALPHA 
      EXT .ENTR 
NAMES BSS 1 
IFILE BSS 1 
XCNT  BSS 1         EXTENT COUNT
ALPHA NOP 
      JSB .ENTR 
      DEF NAMES 
      CLA 
      STA RPEAT 
      STA EXCNT     SET EXTENT COUNT TO ZERO
      LDA IFILE,I 
      CMA,INA 
      STA CNTR1 
LOOP1 EQU * 
      LDA CNTR1 
      ADA IFILE,I 
      ALS,ALS 
      ADA NAMES 
      STA ADDR1 
      STA PNTR1 
      LDA CNTR1 
      CPA RPEAT 
      JMP OUT 
      INA 
      SZA,RSS 
      JMP OUT 
      STA CNTR2 
LOOP2 EQU * 
      LDA CNTR2 
      ADA IFILE,I 
      ALS,ALS 
      ADA NAMES 
      STA ADDR2 
      STA PNTR2 
      LDA DM3 
      STA CNTR3 
      LDA ADDR1 
LOOP3 EQU * 
      LDB ADDR2,I 
      CMB,INB 
      ADB A,I 
      INA 
      ISZ ADDR2 
      SSB 
      JMP END2
      SZB 
      JMP SWTCH 
      ISZ CNTR3 
      JMP LOOP3 
      STA B 
      LDA A,I 
      IOR IFLAG     SET A FLAG
      STA B,I         IF A FILE 
      LDA ADDR2,I       EXTENT
      AND IFLAG 
      SZA,RSS 
      ISZ EXCNT 
      LDA ADDR2,I 
      IOR IFLAG 
      STA ADDR2,I 
      JMP END2
SWTCH EQU * 
      LDA DM4 
      STA CNTR4 
      LDA ADDR1 
      STA PNTR1 
LOOP4 EQU * 
      LDA PNTR1,I 
      LDB PNTR2,I 
      SWP 
      STA PNTR1,I 
      STB PNTR2,I 
      ISZ PNTR1 
      ISZ PNTR2 
      ISZ CNTR4 
      JMP LOOP4 
END2 EQU *
      ISZ CNTR2 
      JMP LOOP2 
      ISZ CNTR1 
      JMP LOOP1 
OUT   EQU * 
      LDA EXCNT 
      STA XCNT,I    SAVE EXTENT COUNT 
      JMP ALPHA,I 
CNTR1 BSS 1 
CNTR2 BSS 1 
CNTR3 BSS 1 
CNTR4 BSS 1 
PNTR1 BSS 1 
PNTR2 BSS 1 
RPEAT BSS 1 
ADDR1 BSS 1 
ADDR2 BSS 1 
IFLAG OCT 200 
EXCNT NOP 
DM4   DEC -4
DM3   DEC -3
A     EQU 0 
B     EQU 1 
      END 
ASMB,R,L,B,C
      HED ** FILE MANAGER ERROR PROCESSOR **
      NAM IFMGR,7 
      ENT IFMGR 
      EXT EXEC,.ENTR
* 
* THIS FUNCTION CHECKS FOR FILE MANAGER ERRORS.  IF THE ERROR 
* CODE IS < 0, THE ERROR MESSAGE IS PRINTED ON THE SPECIFIED TTY. 
* 
* IF ID IS >= 0, THE ERROR CODE IS RETURNED AS THE FUNCTION VALUE.
* 
* IF ID IS < 0 AND THE ERROR CODE IS < 0, THEN THE PROGRAM IS 
* ABORTED.
* 
* FORTRAN USEAGE EXAMPLE: 
*     IF (IFMGR (IERR,ID,LTTY,NAME)) 100,200
* 
* ASSEMBLY CALLING SEQUENCE 
*     JSB IFMGR 
*     DEF *+4 
*     DEF IERR
*     DEF ID
*     DEF LTTY
*     DEF NAME
*                   ON RETURN A = IERR
* 
* WHERE THE USER SUPPLIED VARIABLES ARE:
* 
* IERR = ERROR PARAMETER RETURNED FROM FILE MANAGER CALL. 
* ID   = CALL IDENTITY CODE (NEGATIVE TO ABORT IF ERROR EXISTS) 
*        1 = APOSN
*        2 = CLOSE
*        3 = CREAT
*        4 = FCONT
*        5 = FSTAT
*        6 = LOCF 
*        7 = NAMF 
*        8 = OPEN 
*        9 = POSNT
*       10 = PURGE
*       11 = READF
*       12 = RWNDF
*       13 = WRITF
* LTTY = LOGICAL UNIT NUMBER OF DEVICE TO LIST ERROR
* NAME = NAME OF FILE THAT HAD ERROR
* 
* PARAMETER ADDRESSES 
* 
IERR  NOP           ERROR CODE
ID    NOP           FILE MANAGER CALL ID
LTTY  NOP           LOGICAL UNIT TO OUTPUT ERROR MESSAGES.
NAME  NOP           NAME OF FILE THAT HAD ERROR 
IFMGR NOP 
      JSB .ENTR     USE .ENTR TO GET
      DEF IERR       ADDRESSES OF PARAMETERS
      LDA IERR,I    GET ERROR CODE
      SSA,RSS       FILE MANAGER ERROR? 
      JMP IFMGR,I   NO,RETURN TO USER 
* 
* ERROR - CONVERT ERROR TO ASCII AND PUT IT INTO OUTPUT BUFFER
* 
      MPY M1        MULTIPLY ERROR BY -1 & THEN 
      DIV .10       DIVIDE BY TEN TO GET TENS DIGIT.
      STA ERROR     SAVE TEMPORARILY
      MPY .10       MULTIPLY BY 10 AND DIVIDE BY
      DIV .1        .1 TO GET TENS VALUE ONLY 
      ADA IERR,I    ADD ERROR CODE,RESULT = - UNITS 
      CMA,INA       MAKE UNITS POSITIVE 
      LDB ERROR     GET TENS DIGIT
      BLF,BLF       ROTATE IT TO HIGH BYTE OF WORD
      IOR B         OR IT WITH UNITS
      IOR ASC00     OR IN ASCII CONSTANT
      STA ERROR     PUT ASCII ERROR CODE IN MSG BUFFER
* 
* ADD CALL ID AND FILE NAME TO BUFFER 
* 
      LDA ID,I      GET ID CODE 
      SSA           IS IT NEGATIVE? 
      CMA,INA       YES - MAKE POSITIVE 
      STA B          IS CODE
      ADB M14         GREATER 
      SSB,RSS         THAN 13?
      CLA           YES - OUTPUT $$$$$ FOR ID 
      STA B         SAVE ERROR CODE 
      ALS           MULTIPLY BY 2 AND 
      ADA B         ADD IT TO ITSELF (X3) 
      ADA CALL      ADD BUFR STARTING ADRS TO OFFSET
      LDB EMES      SET POINTER TO
      STB PNTR      ID NAME 
      CLB           SET FLAG TO INDICATE NAME 
      STB FLAG      BUFFER HAS TO BE TRANSFERRED. 
NFILE LDB M3        SET COUNTER TO
      STB CNTR      TRANSFER 3 WORDS
LOOP  LDB A,I       GET ID WORD & PUT IT
      STB PNTR,I    IN ERROR MESSAGE BUFFER 
      INA           ILNDEX ID AND 
      ISZ PNTR      ERROR MESSAGE POINTERS
      ISZ CNTR      TRANSFER COMPLETE?
      JMP LOOP      NO - TRANSFER NEXT WORD 
      LDB FLAG
      SZB           NAME ARRAY TRANSFERRED? 
      JMP LP1       YES - OUTPUT MESSAGE
      ISZ FLAG      NO - SET FLAG TO SAY YES
      LDA NAME      GET ADDRESS OF ARRAY IN A 
      LDB NAMEB     PUT OUTPUT BUFFER 
      STB PNTR      ADDRESS IN B
      JMP NFILE     TRANSFER FILE NAME
* 
*     PUT IN PROGRAM NAME 
* 
LP1   LDB 1717B 
      ADB .12 
      LDA B,I 
      STA PRGNM 
      INB 
      LDA B,I 
      STA PRGNM+1 
      INB 
      LDA B,I 
      AND M1774 
      IOR COLON 
      STA PRGNM+2 
* 
* OUTPUT ERROR MESSAGE
* 
OUT   JSB EXEC      OUTPUT THE ERROR MESSAGE
      DEF *+5 
      DEF WRITE 
      DEF LTTY,I
      DEF PRGNM 
      DEF M40 
* 
* CHECK FOR ABORT PROGRAM 
* 
      LDA IERR,I    PUT ERROR CODE IN CASE WE RETURN
      LDB ID,I      GET ID CODE 
      SSB,RSS       DO WE ABORT?
      JMP IFMGR,I   NO - RETURN 
* 
* ABORT PROGRAM 
* 
      JSB EXEC      WRITE 
      DEF *+5       "PROGRAM ABORTED!"
      DEF WRITE     ON THE
      DEF LTTY,I    LOCAL TTY 
      DEF ABORT 
      DEF M16 
      JSB EXEC      ASK RTE 
      DEF *+2       TO TERMINATE THE PROGRAM
      DEF .6
* 
* CONSTATNTS, STORAGE ALLOCATION, AND MESSAGES
* 
A     EQU 0         A REGISTER
B     EQU 1         B REGISTER
* 
* CONSTANTS 
* 
COLON OCT 72
.1    DEC 1 
.6    DEC 6 
.10   DEC 10
.12   DEC 12
M1    DEC -1
M3    DEC -3
M14   DEC -14 
M16   DEC -16 
M40   DEC -40 
M1774 OCT 177400
* 
* MISC. CONSTANTS 
* 
ASC00 ASC 1,00
WRITE DEC 2 
* 
* 
CNTR  NOP           UTILITY COUNTER 
FLAG  NOP           ID/NAME TRANSFER FLAG 
PNTR  NOP           TRANSFER POINTER TO MESSAGE BUFFER
* 
* FILE MANAGER CALLS
* 
CALL  DEF *+1 
      SUP PRESS THE GARBAGE 
      ASC 3,$$$$$ 
ID1   ASC 3,APOSN 
ID2   ASC 3,CLOSE 
ID3   ASC 3,CREAT 
ID4   ASC 3,FCONT 
ID5   ASC 3,FSTAT 
ID6   ASC 3,LOCF
ID7   ASC 3,NAMF
ID8   ASC 3,OPEN
ID9   ASC 3,POSNT 
ID10  ASC 3,PURGE 
ID11  ASC 3,READF 
ID12  ASC 3,RWNDF 
ID13  ASC 3,WRITF 
* 
* ERROR MESSAGE 
* 
PRGNM BSS 3 
      ASC 1,
ERMES BSS 3 
      ASC 4,ERROR - 
ERROR NOP 
      ASC 5, IN FILE
NAM.  BSS 3 
NAMEB DEF NAM.
EMES  DEF ERMES 
* 
* ABORT ERROR MESSAGE 
ABORT ASC 8,PROGRAM ABORTED!
* 
* 
* 
      END 
ASMB,R,B,L
      NAM ISOL8,7 ISOLATE,RIGHT JUSTIFY BITS. 18 JAN 77.
      ENT ISOL8 
      EXT .ENTR 
* 
* I=ISOL8(J,11,8) ISOLATES BITS 11,10,9,8 FROM J AND RETURNS THEM 
*                 IN THE LEAST SIGNIFICANT BITS OF I. HIGH BITS OF
*                 I ARE ZEROED OUT. 
* I=ISOL8(J,8,11) DOES THE SAME THING.
* 
* I=ISOL8(J,15,0) RETURNS I=J 
* I=ISOL8(J,16,1) RETURNS I = J ROTATED 1 BIT RIGHT 
* 
J     NOP 
I1    NOP 
I2    NOP 
ISOL8 NOP 
      JSB .ENTR 
      DEF J 
      LDA I1,I
      CMA,INA      (A)= -I1 
      ADA I2,I     (A)= I2-I1 
      SSA          (A)>0 ?  I2>I1 ? 
      JMP RVERS    NO. I1>I2. 
      LDB I1,I     YES. I2>I1. GET I1.
      JMP CONT
RVERS LDB I2,I     I2 IS THE LEAST OF I1,I2.
      CMA,INA      (A)>=0.
CONT  CMB,INB      LEAST OF I1,I2 COUNTS ROTATIONS. 
      STA MASK#    MASK NUMBER >= 0.
      LDA J,I      GET THE WORD TO BE OPERATED ON.
* 
RLOOP SZB,RSS      DONE?  ROTATION COUNTER ROSE TO ZERO ? 
      JMP ISOL     YES. 
      RAR          NO. MOVE BITS-OF-INTEREST ONE PLACE RIGHT. 
      INB          BUMP ROTATION COUNTER. 
      JMP RLOOP 
* 
ISOL  LDB .MASK 
      ADB MASK#    (B) POINTS TO DESIRED MASK.
      AND B,I      ZERO OUT UNWANTED BITS.
      JMP ISOL8,I  RETURN WITH (A)=RIGHT JUSTIFIED ISOLATED BITS. 
* 
MASK# NOP 
.MASK DEF *+1 
      OCT 000001
      OCT 000003
      OCT 000007
      OCT 000017
      OCT 000037
      OCT 000077
      OCT 000177
      OCT 000377
      OCT 000777
      OCT 001777
      OCT 003777
      OCT 007777
      OCT 017777
      OCT 037777
      OCT 077777
      OCT 177777
* 
A     EQU 0 
B     EQU 1 
S     EQU 1 
      END 
ASMB,R,B,L
*   1730 HRS   THU  14 JUN 79 
      NAM STGFD,7 IDENTIFY CHARACTER STRINGS IN A BUFFER  790614
      ENT STGFD 
      EXT .ENTR,.CBT
* 
*     THIS PROGRAM IS USED TO FIND AN EMBEDED ASCII STRING
*  IN A GIVEN BUFFER. 
* 
*     MODIFIED =STGCK TO RETURN CHARACTER POSITION OF THE 
*  EMBEDDED STRING WITHIN THE GIVEN BUFFER.  BY DAN ANTZOULATOS.
* 
*     CALLING SEQUENCE: 
* 
*              CALL STGFD(IBUF,ICHAR,JBUF,JCHAR,IMANY,IWHER)
* 
*     WHERE:
*           IBUF = THE LARGER BUFFER TO BE CHECKED
*           ICHAR= NO. OF CHARACTERS IN IBUF
*           JBUF = SMALLER BUFFER CONTAINING SEARCH STRING
*           JCHAR= NO. OF CHARCTERS IN JBUF (<=TO ICHAR)
*           IMANY= A) THE SIZE OF IWHER WHEN ITS PASSED TO
*                     THIS ROUTINE. 
*                  B) AS A RETURN VALUE IT IS SET TO THE NUMBER 
*                     OF TIMES IT HAS FOUND THE STRING. 
*           IWHER= AN ARRAY WHOSE ELEMENTS CONTAIN THE POSITION 
*                  OF THE FIRST CHARACTER OF JBUF EACH TIME JBUF IS 
*                  FOUND. EXAMPLE:   IF IMANY(RETURNED VALUE)=3 THEN
*                          IWHER(3)=POSITION OF THE THIRD JBUF IN IBUF. 
* 
* 
IBUF  NOP           TOTAL INPUT BUFFER
ICHAR NOP           NO. OF CHAR. IN IBUF
JBUF  NOP           BUFFER CONTAINING STRING TO CHECKED 
JCHAR NOP           NO. OF CHAR. IN JBUF
IMANY NOP          INO. OF TIMES STRING WAS FOUND.
IWHER NOP          POSITION OF STRING IN THE BUFFER.
STGFD NOP           ENTRY POINT 
      JSB .ENTR 
      DEF IBUF
      LDA IMANY,I   GET THE NUMBER OF TIMES JBUF MIGHT BE FOUND.
      SZA,RSS       CHECK FOR ZERO CHECK
      JMP STGFD,I    AND RETURN 
      STA MANY
      CLA           CLEAR 
      STA IMANY,I 
      STA NANY
      LDA ICHAR,I 
      CMA           SET UP LOOP 
      ADA JCHAR,I 
      SSA,RSS       CHECK FOR ENOUGH
      JMP STGFD,I     CHARACTERS
      STA CCNT      OK, SAVE LOOP COUNTER 
      STA INCNT 
      LDA IBUF      GET TOTAL RECORD ADDRESS
      RAL            FORM BYTE ADDRESS
      STA CBUF       SAVE FOR LATER 
CHECK LDB JBUF      GET STRING BUFFER ADDRESS 
      RBL            FORM BYTE ADDRESS
      JSB .CBT
      DEF JCHAR,I 
      NOP 
      JSB FOUND 
      NOP 
      NOP 
      ISZ CCNT
      RSS 
      JMP STGFD,I 
      ISZ CBUF
      LDA CBUF
      JMP CHECK 
* 
FOUND NOP 
      LDA NANY     ADVANCE THE NUMBER OF TIMES JBUF 
      INA          HAS BEEN FOUND.
      STA NANY
      STA IMANY,I  SAVE THE NEW COUNT 
      CCB         GET THE RIGHT ELEMENT 
      ADB IWHER   OF IWHER. 
      ADB NANY
      STB ITOTL 
      LDB CCNT        COMPLIMENT CCNT AND 
      CMB 
      ADB INCNT       ADD INCNT IN ORDER TO 
      CMB,INB         GET THE POISITION OF JBUF 
      STB ITOTL,I 
      CPA MANY        HAVE WE FOUND JBUF 'MANY' TIMES YET ? 
      JMP STGFD,I     WE'VE FOUND IT & RETURN 
      JMP FOUND,I     GO BACK AND LOOK FOR ANOTHER ONE. 
* 
* CONSTANTS AND STORGE
CCNT  NOP 
INCNT NOP 
CBUF  NOP 
MANY  NOP 
NANY  NOP 
ITOTL NOP 
      END 
      END$
          