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$