FTN4,L C C VERSION 4 / 21 / 76 JRT C MODIFIED 6 / 08 / 7 MCC C MODIFIED 9 / 13 / 79 DHP C PROGRAM JSAVE(3,60),24999-16048 REV 1932 790913 C LOGICAL RWIND,VERIFY C DIMENSION IREG(2),MBUF(50),IPBUF(33),ISTNG(40) DIMENSION IBUF(8321),JBUF(20000B),ICLST(4,32) INTEGER FIRST,LAST,SFLAG,FILEN C DIMENSION MESS1(12),MESS2(29),MESS3(13),MESS4(15) DIMENSION MESS5(13),MESS6(14),MESS7(23),MES71(13) DIMENSION MESS8(8),MESS9(12),MES10(13),MES11(9) DIMENSION IREV(25),JVMESS(9) DIMENSION MES12(11),MES13(9),MES14(15),MES15(19) C EQUIVALENCE (IA,IREG),(IB,IREG(2)),(X,IREG) EQUIVALENCE (IBUF,ITRAK),(JBUF,IBUF(2)),(IBUF,ICLST) EQUIVALENCE (IPBUF(4),IWD4),(IPBUF(5),IWD5) EQUIVALENCE (IPBUF(2),IWD2),(IPBUF(6),IWD6) C EQUIVALENCE (JBUF(4),JBUF4),(JBUF(5),JBUF5),(JBUF(7),JBUF7), + (JBUF(8),JBUF8),(JBUF(10),JBUF10) EQUIVALENCE (MBUF(2),MBUF2),(MBUF(11),MBUF11),(MBUF(26),MBUF26), + (MBUF(27),MBUF27),(MBUF(4),MBUF4) C EQUIVALENCE (MES15(10),MS150),(MES15(11),MS151),(MES15(12),MS152) C DATA SFLAG,JLNTH,MLNTH/0,128,29/ C DATA MESS1/6412B,2H/J,2HSA,2HVE,2H: ,2HMA,2HG ,2HTA,2HPE, & 2H L,2HU:,2H _/ DATA MESS2/6412B,2H/J,2HSA,2HVE,2H: ,2HDI,2HSC,2H C,2HRN,2H[-, & 2HLU,2H]:,2H (, & 2H[,,2HLA,2HST,2H T,2HRA,2HCK,2H] ,2H , & 2HLU,2H= ,2H0 ,2H=>,2H E,2HND,2H) ,2H _/ DATA MESS3/2H/J,2HSA,2HVE,2H: ,2HTH,2HAT,2H'S,2H N,2HOT, & 2H A,2H D,2HIS,2HC!/ DATA MESS4/2H/J,2HSA,2HVE,2H: ,2HTH,2HAT,2H'S, & 2H N,2HOT,2H A,2H M,2HAG,2H T, & 2HAP,2HE!/ DATA MESS5/2H/J,2HSA,2HVE,2H: ,2HCA,2HN',2HT , & 2HDO,2H T,2HHA,2HT ,2HLU,2H! / DATA MESS6/2H/J,2HSA,2HVE,2H: ,2HMA,2HX ,2H= , & 2H50,2H, ,2HMI,2HN ,2H= ,2H0!/ DATA MESS7/2H/J,2HSA,2HVE,2H: ,2HEN,2HTE,2HR ,2HAN,2HY ,2HAD, & 2HDI,2HTI,2HON,2HAL,2H C,2HOM,2HME,2HNT,2HS ,2HOR, & 2H ",2H ",2HCR/ DATA MES71/2H/J,2HSA,2HVE,2H: ,2HDE,2HFA,2HUL,2HT ,2HHE,2HAD, & 2HER,2H I,2HS:/ DATA MESS8/6412B,2H/J,2HSA,2HVE,2H: ,2HEN,2HD?,2H _/ DATA MESS9/6412B,2H/J,2HSA,2HVE,2H: ,2HDO,2HNE,2H! ,6412B/ DATA MES10/6412B,2H/J,2HSA,2HVE,2H: ,2HMA,2HG , & 2HTA,2HPE,2H F,2HIL,2HE:,2H _/ DATA MES11/2H/J,2HSA,2HVE,2H: ,2HEO,2HF ,2HFO,2HUN,2HD!/ DATA MES12/2H/J,2HSA,2HVE,2H: ,2HNO,2HT ,2HJS,2HAV,2HE ,2HFI, & 2HLE/ DATA MES13/2H/J,2HSA,2HVE,2H: ,2H V,2HER,2HIF,2HYI,2HNG/ DATA MES14/2H/J,2HSA,2HVE,2H: ,2HWA,2HIT,2HIN,2HG ,2HFO, & 2HR ,2HLU,2H# ,3*2H / DATA MES15/2H/J,2HSA,2HVE,2H: ,2HCA,2HRT,2HRI,2HDG,2HE ,3*2H , & 2H N,2HOT,2H M,2HOU,2HNT,2HED,2H. / DATA IREV /2H24,2H99,2H9-,2H16,2H04,2H8 ,2H19,2H32,2H S,2HOF, & 2HTW,2HAR,2HE ,2HSE,2HRV,2HIC,2HE ,2HKI,2HT ,2HSY, & 2HST,2HEM,2H 1,2H00,2H0 / DATA JVMESS/2H/J,2HSA,2HVE,2H: ,2HVE,2HRI,2HFY,2H ?,2H _/ C C SET DEFAULTS AND CHECK TURN ON STRING C DATA MBUF/2HCR,24*20040B,6412B,24*20040B/ DATA ISTNG/40*0/,LEN,IDISC,NFILE/0,0,0/ DATA IRCNT,ISTRC/1,1/,MTLU/8/,IMESS/0/ DATA RWIND/.TRUE./,VERIFY/.FALSE./,LASTTR/0/ DATA ICL /3/,IDELT/0/ C C GET SESION TERMINAL C LU = LOGLU(ISES) ILU=LU+400B C C GET TURN ON STRING C CALL GETST(JBUF,-70,ILOG) IF(ILOG .EQ. 0)GO TO 3 C C SAVE ORIGINAL STRING IN CASE OF " . . . "'S C IOFF = IAND(ILOG,1) IWDL = ILOG/2 + IOFF DO 700 I=1,IWDL ISTNG(I) = JBUF(I) 700 CONTINUE C C CHANGE "=" 'S TO ":" 'S C CALL EQCOL(JBUF,ILOG) C C SCAN STRING FOR WHAT TO DO. ORDER DOESN'T MATTER C 710 IF(NAMR(IPBUF,JBUF,ILOG,ISTRC))3,720 C 720 NTYPE = IAND(IWD4,3) IF(NTYPE .LE. 1)GO TO 710 IPBUF = IOR(IAND(IPBUF,77400B),40B) IF(IPBUF .EQ. 1HD)IDISC = IWD5 IF(IPBUF .EQ. 1HF)NFILE = IWD5 IF(IPBUF .EQ. 1HI)RWIND = .FALSE. IF(IPBUF .EQ. 1HL)LASTTR= IWD5 IF(IPBUF .EQ. 1HM)MTLU = IWD5 IF(IPBUF .EQ. 1HR)IRCNT = IWD5 IF(IPBUF .EQ. 1HV)VERIFY= .TRUE. IF(IPBUF .EQ. 1H")CALL QUOTE(ISTNG,MBUF27,LEN) GO TO 710 C 3 CALL EXEC(2,ILU,IREV,25) IF(ILOG .EQ. 0)NFILE = 1 FILEN = NFILE C C GET DISC AND MAG TAPE LU'S C IF(ILOG .GT. 0)GO TO 11 10 CALL EXEC(2,ILU,MESS1,12) X=REIO(1,ILU,JBUF,-10) CALL PARSE(JBUF,IB,IPBUF) MTLU=IWD2 C 11 CALL EXEC(13,MTLU,ISTAT) IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 14 IF(IAND(ISTAT,37400B)*2.EQ.24000B)GO TO 14 C C NOT A MAG TAPE IF NOT DVR23 OR DVR24 C CALL EXEC(2,ILU,MESS4,15) GO TO 10 C 14 IREG=LURQ(100001B,MTLU,1) IF(IREG.EQ.0)GO TO 142 C C LOCK UNSUCCESSFUL, SO REPORT C CALL CNUMD(MTLU,MES14(13)) IF (IMESS .EQ. 0)CALL EXEC(2,LU,MES14,15) C IMESS = 1 CALL EXEC(12,0,2,0,-3) IF(IFBRK(IDMMY))99,14 142 IF(NFILE .GE. 1)REWIND MTLU C IF(ILOG .GT. 0 .AND. IDISC .NE. 0)GO TO 152 C 15 IF(SFLAG.EQ.0)GO TO 151 MESS2(13)=020137B MLNTH=13 C C GET DISK LU (LAST TRK) ETC. C 151 CALL EXEC(2,ILU,MESS2,MLNTH) X=REIO(1,ILU,JBUF,-12) CALL PARSE(JBUF,IB,IPBUF) IDISC=IWD2 IF(IWD5 .GT. 0)LASTTR=IWD6 ICL = 3 C C QUIT IF DISK LU GIVEN AS 0. C IF(IDISC.EQ.0)GO TO 90 152 IF(IDISC .GT. 0)GO TO 153 IDISC = IABS(IDISC) ICL = 1 153 CALL FSTAT(ICLST) DO 154 J=1,31 IF(ICLST(ICL,J) .NE. IDISC)GO TO 154 IDISC = ICLST(1,J) IF(LASTTR .EQ. 0)LASTTR = ICLST(2,J) GO TO 158 154 CONTINUE C C IF THIS IS AN LU# LET HIM SAVE IT C IF(ICL .EQ. 1)GO TO 158 C C TELL HIM THE CRN IS NOT MOUNTED C MS150 = 20040B MS151 = 20040B MS152 = -1 CALL ASCII(IDISC,MS152) IF(MS152 .EQ. 2H )CALL CNUMD(IDISC,MS150) CALL EXEC(2,ILU,MES15,19) GO TO 15 C C DISK LU < 7 NOT ALLOWED C 158 IF(IDISC .GT. 6)GO TO 16 CALL EXEC(2,ILU,MESS5,13) GO TO 15 C 16 CALL EXEC(13,IDISC,ISTAT) ITYPE=IAND(ISTAT,37000B)/256 C C NOT A DISK IF DVR NOT 30 OR 32 C IF((ITYPE.EQ.30B).OR.(ITYPE.EQ.32B))GO TO 20 CALL EXEC(2,ILU,MESS3,13) GO TO 15 C C GET MAG TAPE FILE NUMBER AND IDENT C 20 IF(SFLAG.NE.0)GO TO 30 IF(ILOG .GT. 0)GO TO 205 C C GET FILE # IF FIRST TIME. C 21 CALL EXEC(2,ILU,MES10,13) X=REIO(1,ILU,JBUF,-10) CALL PARSE(JBUF,IB,IPBUF) NFILE=IWD2 FILEN=NFILE C C QUIT IF FILE # < 0 . C 205 IF(NFILE.LT.0)GO TO 90 C C GO POSITION THE TAPE IF FILE # <= 50. IF(NFILE.LE.50)GO TO 22 CALL EXEC(2,ILU,MESS6,14) GO TO 21 C C POSITION THE TAPE C 22 IF(NFILE.LE.1)GO TO 30 C C READ ONE LONG (6145) RECORD FORM TAPE. C 23 X=EXEC(1,MTLU,IBUF,JLNTH+1) IF(IB.GT.0)GO TO 211 CALL EXEC(2,ILU,MES11,9) GO TO 30 211 IF(IB.LE.100)GO TO 212 C C NOT A HEADER IF LENGTH > 100 WORDS. C CALL EXEC(2,ILU,MES12,11) GO TO 213 C C DISPLAY THE HEADER FOR THIS FILE THEN FF ONE FILE . C (TO THE END OF THIS DISK COPY) C 212 CALL EXEC(2,ILU,IBUF,IB) 213 CALL EXEC(3,MTLU+1300B) NFILE=NFILE-1 IF(NFILE .EQ. 1)30,23 C C GET HEADER AND WRITE TO TAPE C C C GET THE # OF TRKS BY FORCING A SEEK BEYOND THE POSIBLE END. C 30 X=EXEC(1,IDISC,JBUF,128,10000,0) ITRAK=IB-1 IF(LASTTR.NE.0 .AND. LASTTR .LE. ITRAK)ITRAK=LASTTR CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) C C CALCULATE BUFFER LENGTH FROM NUMBER OF SECTORS/TRACK C JLNTH = JBUF7 * 64 C C PUT CR# LABEL INTO OUTPUT BUFFER & BLANK FILL THE CRN C DO 305 I=1,3 MBUF(I+5) = JBUF(I) MBUF(I+1) = 20040B 305 CONTINUE C C CHECK FOR POSSIBLE ASCII CR# C MBUF4 = -1 CALL ASCII(JBUF4,MBUF4) IF(MBUF4 .EQ. 2H )CALL CNUMD(JBUF4,MBUF2) C C CALL FTIME ROUTINE TO GET THE CURRENT DATE & TIME C CALL FTIME(MBUF11) C MBUF26 = 6412B IF(ILOG .GT. 0)GO TO 33 DO 31 I=27,50 MBUF(I)=2H 31 CONTINUE C C DISPLAY DEFAULT HEADER AND C PROMPT FOR HEADER. C CALL EXEC(2,ILU,MES71,13) CALL EXEC(2,ILU,MBUF,25) CALL EXEC(2,ILU,MESS7,23) C C READ THE HEADER. C X = REIO(1,ILU,MBUF27,-48) LEN = IB C C AND WRITE IT TO TAPE. C 33 IF(LEN .GT. 48)LEN = 48 CALL EXEC(2,ILU,MBUF,-(LEN+52)) CALL EXEC(2,MTLU,MBUF,50) C C C HAVE ALL LU'S, NOW GO COPY THE DISC... C COPY ALL DIRECTORY TRACKS FIRST, FOLLOWED BY C ALL TRACKS USED BY FMP (UN-USED TRACKS WON'T BE COPIED) C FIRST=JBUF5 LAST=JBUF10 IF(LAST.EQ.LASTTR)LAST=LAST-1 LOWDIR=JBUF8 C 40 CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) 41 CALL EXEC(2,MTLU,IBUF,JLNTH+1) IF(IFBRK(IDUM))99,42 C C GO COPY DATA TRKS IF DONE WITH DIRECTORY TRACKS. C 42 IF(ITRAK.EQ.LOWDIR)GO TO 45 C C ELSE - DECREMENT TRK # TO NEXT DIRECTORY TRK. C ITRAK=ITRAK-1 GO TO 40 C 45 DO 49 ITRAK=FIRST,LAST CALL EXEC(1,IDISC,JBUF,JLNTH,ITRAK,0) CALL EXEC(2,MTLU,IBUF,JLNTH+1) IF(IFBRK(IDUM))99,49 49 CONTINUE C C PUT 2 EOF AT THE END. C ENDFILE MTLU ENDFILE MTLU C C NOW SPACE BACK OVER ONE EOF. C CALL EXEC(3,MTLU+1400B) C C INCREMENT THE REPEAT COUNTER C IRCNT = IRCNT - 1 C IF(ILOG .EQ. 0)GO TO 1000 IF(VERIFY)1005,50 1000 CALL EXEC(2,ILU,JVMESS,9) CALL REIO(1,ILU,IANS,1) IF(IANS .NE. 2HYE) GO TO 50 VERIFY = .TRUE. C C 2-MORE BF & 1-FF REQUIRED IF NOT FIRST FILE C 1005 IF(FILEN .EQ. 1) GO TO 1010 CALL EXEC(3,MTLU+1400B) CALL EXEC(3,MTLU+1400B) C C CHECK IF AT SOT. YES ? DON'T DO FF. C X = EXEC(3,MTLU+600B) IA = IAND(IA,100B) IF(IA .EQ. 0)CALL EXEC(3,MTLU+1300B) GO TO 1020 C 1010 REWIND MTLU C C READ THE HEADER AGAIN & DISPLAY IT C 1020 CALL EXEC(2,ILU,MES13,9) X = EXEC(1,MTLU,IBUF,100) CALL EXEC(2,ILU,IBUF,IB) C C VERIFY THE FILE C CALL JVRFY(IBUF,LU,IDISC,MTLU,IDELT) C C NO ERROR ? CONTINUE C IF(IBUF .EQ. 0)GO TO 50 C C IF INTERACTIVE CONTINUE C IF(ILOG .EQ. 0)GO TO 50 C C IF INHIBIT REWIND SPICIFIED ASSUME POSSIBLE BATCH MODE C AND DO A FORWARD FILE FOR NEXT JSAVE. C IF(RWIND)GO TO 50 CALL EXEC(3,MTLU+1300B) C 50 SFLAG=1 IF(FILEN .EQ. 0)FILEN = FILEN + 1 FILEN = FILEN + 1 51 IF(IRCNT .GT. 0)GO TO 30 IF(ILOG .GT. 0)GO TO 90 GO TO 15 C C END: REWIND TAPE OFF LINE C 90 IF(RWIND)CALL EXEC(3,MTLU+500B) CALL EXEC(2,ILU,MESS9,12) C 99 END SUBROUTINE ASCII(BINARY,IA),CHECK FOR LEGAL ASCII 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 SUBROUTINE JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) +,24999-16163 REV.1932 790810 C C THIS SUBROUTINE IS DESIGNED TO COMPARE THE CONTENTS OF C A MAG TAPE FILE AGAINST THE CONTENTS OF A DISK TRACK. C THE MAG TAPE FORMAT SHOULD BE: C 6145 OR 8193 WORDS LONG C WHERE WORD #1 IS THE TRACK #. C TERMINATION WILL OCCUR UPON READING EOF. C THE MAG TAPE MUST BE POSITIONED TO THE FIRST DISC IMAGE RECORD C BEFORE SCHEDULING THIS SUBROUTINE. C C FORM OF CALL: C CALL JVRFY(IBUFF,LUCRT,LUDISK,LUMT,IDELT) C C WHERE: C LUCRT - LU WHERE MESSAGES WILL BE SENT C C LUDISK - LU # OF THE DISK SUBCHANNEL C TO BE VERIFIED. C C LUMT - LU # OF THE MAG TAPE. C C IDELT = OFFSET BETWEEN THE OLD DIRECTORY AND A C THE NEW DIRECTORY IF IT HAS BEEN MOVED C C IPBUF(1) = 0 - COMPARE GOOD. C IPBUF(2) = # OF MAG TAPE RECORDS TESTED. C C IPBUF(1) = -1 MAG TAPE COMPARE ERROR C IPBUF(2) = MAG TAPE RECORD NUMBER C IPBUF(3) = TRACK # C IPBUF(4) = SECTR # C IPBUF(5) = WORD OFFSET C C IPBUF(1) = -2 - MAG TAPE STATUS ERROR C IPBUF(2) = MAG TAPE RECORD NUMBER C IPBUF(3) = EQT #5 STATUS INFO C C IPBUF(1) = -3 - MAG TAPE RECORD LENGTH ERROR C IPBUF(2) = MAG TAPE RECORD NUMBER C IPBUF(3) = LENGTH OF MAG TAPE RECORD. C C IPBUF(1) = -4 - DISK READ ERROR. C IPBUF(2) = MAG TAPE RECORD NUMBER C IPBUF(3) = EQT #5 STATUS INFO. C DIMENSION IBUFF(1),IPBUF(5),LENB(7),ISCTRS(7),IREG(2) DIMENSION LENC(7) C DIMENSION JVM10(28),JVM20(31),JVM30(28),JVM40(46),JVM50(18) C EQUIVALENCE (REG,IREG),(IREG(2),IBREG) C EQUIVALENCE (IPBUF(1),IPBUF1),(IPBUF(2),IPBUF2),(IPBUF(3),IPBUF3), + (IPBUF(4),IPBUF4),(IPBUF(5),IPBUF5) C EQUIVALENCE (JVM10(18),JVM118),(JVM10(26),JVM126) EQUIVALENCE (JVM20(21),JVM221),(JVM20(29),JVM229) EQUIVALENCE (JVM30(18),JVM318),(JVM30(26),JVM326) EQUIVALENCE (JVM40(17),JVM417),(JVM40(29),JVM429), + (JVM40(37),JVM437),(JVM40(44),JVM444) EQUIVALENCE (JVM50(12),JVM512) C DATA JVM10/2H /,2HJS,2HAV,2HE:,2H D,2HIS,2HK ,2HRE,2HAD,2H E,2HRR, & 2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H ,2H R,2HEC,2HOR, & 2HD ,2H# ,3*2H / C DATA JVM20/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HRE,2HCO,2HRD,2H L,2HEN, & 2HGT,2HH ,2HER,2HRO,2HR ,2H- ,2HLE,2HNG,2HTH,3*2H , & 2H R,2HEC,2HOR,2HD ,2H# ,3*2H / C DATA JVM30/2H /,2HJS,2HAV,2HE:,2H M,2HT ,2HST,2HAT,2HUS,2H E,2HRR, & 2HOR,2H -,2H S,2HTA,2HTU,2HS ,3*2H ,2H R,2HEC,2HOR, & 2HD ,2H# ,3*2H / C DATA JVM40/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H E,2HRR,2HOR, & 2H R,2HEC,2HOR,2HD ,2H# ,3*2H ,6412B, & 2H /,2HJS,2HAV,2HE:,2H T,2HRA,2HCK,2H #,3*2H ,2H S, & 2HEC,2HTO,2HR ,2H# ,3*2H ,2H O,2HFF,2HSE,2HT ,3*2H / C DATA JVM50/2H /,2HJS,2HAV,2HE:,2H C,2HOM,2HPA,2HRE,2H G,2HOO,2HD., & 3*2H ,2H R,2HEC,2HOR,2HDS/ C DATA LENB/128,256,512,1024,2048,2176,2048/ DATA LENC/129,257,513,1025,2049,4097,6273/ DATA ISCTRS/0,2,6,14,30,62,96/ C C ICOUNT = 0 C C GET A MAG TAPE RECORD AND TEST FOR EOF C 10 IF(IFBRK(IDMY) .LT. 0) GO TO 100 REG=EXEC(1,LUMT,IBUFF(128),8193) C C IF FIRST TIME THROGH SET VALUES C (IBUFF(136) == WORD 7 OF DIRECTORY [LOWEST DIRECTORY TRACK]) C (IBUFF(138) == WORD 9 OF DIRECTORY [NEXT AVAILABLE TRACK]) C IF(ICOUNT .GT. 0)GO TO 15 LODIR = IBUFF(136) IBUFF(136) = IBUFF(136) + IDELT IF(IBUFF(138) .GT. IBUFF(136))IBUFF(138) = IBUFF(136) C C FINISHED IF EOF FOUND C 15 IF(IAND(IREG,200B) .NE. 0) GO TO 100 C C ANY OTHER STATUS EXCEPT NO WRITE RING IS AN ABORT CONDITION. C IF(IAND(IREG,373B) .NE. 0) GO TO 200 C C RECORD LENGTH MUST BE 6145 OR 8193 C IF(IBREG .NE. 6145) GO TO 20 ITMS = 6 GO TO 40 20 IF(IBREG .NE. 8193) GO TO 300 ITMS = 7 C C TRACK # IS IN FIRST WORD. C 40 ITRK = IBUFF(128) IF(ITRK .GE. LODIR)ITRK = ITRK + IDELT ICOUNT = ICOUNT + 1 IF(ITRK .LT. LODIR .AND. ITRAK .GE. (LODIR+IDELT))GO TO 10 C C NOW GET AND TEST THE CONTENTS OF ONE TRACK (6 READS) C DO 50 I=1,ITMS LENGTH = LENB(I) INDEX = LENC(I) C REG = EXEC(1,LUDISK,IBUFF,LENGTH,ITRK,ISCTRS(I)) C IF(IAND(IREG,1) .NE. 0) GO TO 400 C CALL CMPWD(IBUFF,IBUFF(INDEX),LENGTH,IERR) IF(IERR .NE. 0) GO TO 500 C 50 CONTINUE GO TO 10 C C GOOD COMPLETION C 100 IPBUF1 = 0 GO TO 1000 C C MAG TAPE STATUS ERROR. C 200 IPBUF1 = -2 IPBUF3 = IREG GO TO 1000 C C MAG TAPE RECORD LENGTH ERROR. C 300 IPBUF1 = -3 IPBUF3 = IBREG GO TO 1000 C C DISK READ ERROR. C 400 IPBUF1 = -4 IPBUF3 = IREG GO TO 1000 C C COMPARE ERROR. C 500 IPBUF1 = -1 IPBUF3 = ITRK IPBUF4 = ISCTRS(I) + IERR/64 IPBUF5 = MOD(IERR,64) C C FINISHED. C C WRITE A MESG IF LUCRT IS GIVEN C 1000 IPBUF2 = ICOUNT C IGO = IPBUF1 + 5 GO TO (1010,1020,1030,1040,1050),IGO C 1010 CALL CNUMO(IPBUF3,JVM118) CALL CNUMD(IPBUF2,JVM126) CALL EXEC(2,LUCRT,JVM10,28) C011 FORMAT(" /JVRFY: DISK READ ERROR - STATUS ",K6," RECORD #",I4) GO TO 2000 C 1020 CALL CNUMD(IPBUF3,JVM221) CALL CNUMD(IPBUF2,JVM229) CALL EXEC(2,LUCRT,JVM20,31) C021 FORMAT(" /JVRFY: MT RECORD LENGTH ERROR - LENGTH ", C + I5," RECORD #",I4) GO TO 2000 C 1030 CALL CNUMO(IPBUF3,JVM318) CALL CNUMD(IPBUF2,JVM326) CALL EXEC(2,LUCRT,JVM30,28) C031 FORMAT(" /JVRFY: MT STATUS ERROR - STATUS ",K6," RECORD #",I4) GO TO 2000 C C 1040 CALL CNUMD(IPBUF2,JVM417) CALL CNUMD(IPBUF3,JVM429) CALL CNUMD(IPBUF4,JVM437) CALL CNUMD(IPBUF5,JVM444) CALL EXEC(2,LUCRT,JVM40,46) C041 FORMAT(" /JVRFY: COMPARE ERROR RECORD #",I4/, C + " /JVRFY: TRACK #",I4," SECTOR #",I4," OFFSET",I4) GO TO 2000 C 1050 CALL CNUMD(IPBUF2,JVM512) CALL EXEC(2,LUCRT,JVM50,18) C051 FORMAT(" /JVRFY: COMPARE GOOD. ",I4," RECORDS") C 2000 IBUFF = IPBUF1 RETURN END END$ ASMB,R,L,C,Z IFN HED WORD COMPARE FOR 2100 & EARLIER CPU NAM CMPWD,7 WORD COMPARE FOR 2100 & EARLIER CPU 6/10/77 XIF IFZ HED WORD COMPARE FOR 21MX & LATER CPU NAM CMPWD,7 WORD COMPARE FOR 21MX & LATER CPU 6/10/77 XIF ENT CMPWD EXT .ENTR SKP * THIS PROGRAM WILL COMPARE THE CONTENTS OF TWO BUFFERS * AND RETURN: * IERR = 0 - GOOD COMPARE * IERR = +N - ERROR DETECTED. * WHERE N = BUFFER INDEX OF FAILED COMPARISON. * * THIS PROGRAM WILL RETURN AFTER ENCOUNTERING THE FIRST * COMPARE FAILURE. * * THIS PROGRAM IS FORTRAN CALLABLE AS FOLLOWS: * CALL CMPWD(BUF1,BUF2,LENGTH,IERR) * - OR - * REG = CMPWD(BUF1,BUF2,LENGTH,IERR) * WHERE IERR IS RETURNED IN THE 'A' REGISTER. * * CONDITIONAL ASSEMBLY REQUIRED FOR COMPUTER TYPE: * N FOR 2100 OR EARLIER MODELS * Z FOR 21MX OR LATER MODELS * * MCC 6/10/77 * SKP BUFF1 NOP BUFF2 NOP LENTH NOP IERR NOP CMPWD NOP SPC 1 JSB .ENTR DEF BUFF1 SPC 1 IFN LDA LENTH,I GET THE BUFFER LENGTH CMA,INA COMPLEMENT AND SAVE IT STA COUNT SPC 1 LOOP LDA BUFF1,I GET FIRST WORD XOR BUFF2,I XOR WITH SECOND SZA OK IF ZERO RESULTS. JMP ERROR NO - ERROR. SPC 1 ISZ COUNT YES - FINISHED IF COUNT = 0 JMP INCR SPC 1 JMP OUT FINISHED SPC 1 INCR ISZ BUFF1 INCREMENT BOTH BUFFER ADDRESSES ISZ BUFF2 JMP LOOP GO TEST THE NEXT TWO. SPC 1 ERROR ISZ COUNT SET UP THE LDA LENTH,I ERROR COUNT ADA COUNT FOR RETURN JMP BAD THEN RETURN SKP XIF IFZ LDA BUFF1 GET THE TWO ADDRESSES IN 'A' & 'B' LDB BUFF2 CMW LENTH,I GO TEST THESE ARRAYS JMP OUT GOOD RETURN HERE. SPC 1 NOP ERROR RETURN HERE LDB BUFF1 GET THE START ADDRESS CMB,INB AND SUBTRACT FROM ADA B PRESENT ADDRESS FOUND IN 'B' INA JMP BAD RETURN THE ERROR INDEX XIF SKP OUT CLA GOOD RETURN HERE. SPC 1 BAD STA IERR,I JMP CMPWD,I SKP COUNT NOP A EQU 0 B EQU 1 END * 1430 HRS THU 24 MAY 79 NAM QUOTE,7 QUOTE STRING SUBROUTINE FOR JSAVE 790524 ENT QUOTE,EQCOL EXT .ENTR,.SFB,.MBT * * CALLING SEQUENCE: * * CALL QUOTE(IBUF,QBUF,QLEN) * * WHERE : * IBUF = ASCII BUFFER TO CHECK FOR " . . . " * QBUF = BUFFER TO CONTAIN " . . . " * QLEN = LENGTH OF " . . . " BUFFER * ( 0 IF NOT FOUND) * * NOTE: IBUF SHOULD CONTAIN TWO(2) QUOTE MARKS(") IN THE BUFFER * OR SHOULD BE INITIALIZED WITH NULLS(OCT 0). THIS IS * TO PREVENT POSSIBLE ERRORS DUE TO MEMORY SCAN RUNAWAY. * (THE 'SFB' INSTRUCTION STOPS ONLY ON THE TEST BYTE OR * A TERMINATE BYTE.(WHICH IS NULL(0) IN THIS SUBROUTINE) * * QUOTE USES TWO(2) MX INSTRUCTIONS WHICH ARE: * 1) SFB SCAN FOR BYTE * 2) MBT MOVE BYTE * IBUF NOP STRING BUFFER QBUF NOP QUOTE BUFFER(" . . " RETURNED HERE) QLEN NOP QUOTE BUFFER LENGTH QUOTE NOP ENTRY POINT JSB .ENTR DEF IBUF CLA SET ERROR RETURN FLAG STA QLEN,I LDA ." GET TERMINATOR/TEST BYTE LDB IBUF AND ADDRESS OF SOURCE BUFFER RBL FORM BYTE ADDRESS JSB .SFB START LOOKING FOR ' " ' RSS FOUND IT !!! JMP QUOTE,I WE HAVE AN ERROR, GET OUT INB BUMP BUF. ADD. PAST THE " STB FBAD SAVE BUF. ADD. LOCALLY JSB .SFB START SCAN FOR 2ND. BYTE RSS FOUND JMP QUOTE,I NOT FOUND, GET OUT !!! ELB,CLE,ERB KILL HIGH BIT FOR ADDITION LDA FBAD START TO CALCULATE ELA,CLE,ERA DO SAME FOR LOW ADDRESS CMA,INA THE LENGTH ADB A OF THE QUOTE STB QLEN,I TELL USER TOO LDA FBAD NOW SET UP FOR MOVE BYTE LDB QBUF GET DESTINATION ADDRESS RBL SET TO BYTE ADDRESS JSB .MBT MOVE THE QUOTE TO USER DEF QLEN,I NOP JMP QUOTE,I AND RETURN * A EQU 0 * ." OCT 42 FBAD NOP ADDRESS OF 1ST BYTE IN QUOTE SPC 3 * * THIS SUBROUTINE, GIVEN AN ADDRESS AND LENGTH OF A BUFFER, * WILL CHECK FOR IMBEDDED EQUALS(=) AND REPLACE THEM WITH COLONS(:) * FOR THE NAMR LIBRARY ROUTINE. * * THE BUFFER CAN BE ANY LENGTH AND SHOULD SPECIFY * THE NUMBER OF CHARACTERS IN THE BUFFER. * BUFAD NOP BUFFER ADDRESS BUFLA NOP BUFFER LENGTH EQCOL 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 EQCOL,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 LO= AN ='S ? JMP LFIX YES, GO MAKE IT A COLON PAR1 LDA TEMP NO, PREPARE TO CONTINUE AND M774 THIS TIME LOOK AT THE HI BYTE CPA HI= AN ='S ? JMP HFIX YES, GO MAKE IT A COLON JMP TERM1 NO, LETS SAVE WHAT WE HAVE AND GO ON LFIX LDA TEMP GET ORIGINAL WORD ADA M3 MAKE THAT = A COLON STA TEMP AND SAVE JMP PAR1+1 GO CHECK HI BYTE HFIX LDA TEMP GET PRESENT VALUE ADA M1400 MAKE THE HI BYTE = A COLON 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 EQCOL,I NOPE, LETS GET OUT!! SPC 1 * CONSTANTS AND STORAGE * BUFL NOP TEMP NOP M177 OCT 177 M774 OCT 77400 LO= OCT 75 HI= OCT 36400 M3 OCT -3 M1400 OCT -1400 END ASMB,R,L,Q NAM MXLIB,0 ("MX" INSTRUCTION SET--SIMULATED) 6/78 DGA ENT .MBT,.CBT,.SFB,.SBL,.SBT,.LBT,IDRCT SPC 3 * NAME SIZE(10) ENTRIES EXTERNALS * * !1MBT 25 .MBT IDRCT,.LBT,.SBT * * !1CBT 41 .CBT IDRCT,.LBT * * !1SFB 25 .SFB .LBT * * !1SBL 14 .SBL .LBT * * !1SBT 23 .SBT * * !1LBT 11 .LBT * * !1DRK 17 IDRCT * * * FROM NOP LCNT NOP * AREG EQU 0 BREG EQU 1 * HED SIMULATION OF "MOVE BYTES" 21MX INSTRUCTION SPC 2 * CALL SEQUENCE: * A-REG. TO CONTAIN SOURCE ADDRESS * B-REG. TO CONTAIN SOURCE ADDRESS * JSB .MBT CALL SUB. OR OCT 105765 * DEF CNT(,I) ADDRESS OF # OF BYTES TO MOVE * NOP RESERVED FOR MICROCODE * BOTH A & B INCREMENTED BY CNT * * .MBT NOP STA FROM SOURCE BYTE ADDRESS STB TO DESTINATION BYTE ADDRESS * LDA .MBT,I JSB IDRCT TRACK DOWN INDIRECTS LDA AREG,I PICK UP ACTUAL BYTE COUNT CMA,INA STA BCNT USE AS LOOP COUNTER * SZA,RSS COUNT = 0? JMP EXIT2 YES, DO NOTHING * LOOP2 LDB FROM JSB .LBT TAKE A BYTE STB FROM BYTE ADDRESS INCREMENTED BY LBT * LDB TO JSB .SBT PUT IT HERE STB TO PREPARE FOR NEXT BYTE, IF ANY. * ISZ BCNT MOVE ENOUGH? JMP LOOP2 NOPE * LDA FROM NEXT BYTE IN SOURCE ARRAY EXIT2 ISZ .MBT ISZ .MBT SET UP RETURN ADDRESS JMP .MBT,I B-REG. ALREADY CORRECT. * TO NOP BCNT NOP * SPC 2 * CALLING SEQUENCE: * A-REG. TO CONTAIN STRING 1 ADDRESS * B-REG. TO CONTAIN STRING 2 ADDRESS * JSB .CBT SUB. CALL OR OCT 105766 * DEF CNT(,I) ADDRESS OF BYTE COUNT * NOP RESERVED FOR MICROCODE * JMP EQUAL THE BYTE STRINGS WERE EQUAL * JMP LESS STRING 1 LESS THAN STRING 2 * JMP MORE STRING 1 MORE THAN STRING 2 * * RESULTS: * ON ALL RETURNS B-REG. CONTAINS ORIGINAL VALUE * INCREMENTED BY "CNT". * ON EQUAL RETURN A-REG. HAS ALSO BEEN INCREMENTED * BY "CNT". * ON UNEQUAL RETURNS A-REG. CONTAINS STRING 1 * ADDRESS WHERE INEQUALITY FOUND. * .CBT NOP STA ARAY1 STB ARAY2 * LDA .CBT,I JSB IDRCT LDA AREG,I GET ACTUAL BYTE COUNT * ADB AREG STB BSAVE B-REG.'S RETURN VALUE * CMA,INA STA BCNT SET UP LOOP COUNTER SZA,RSS COUNT = 0? JMP NEQL1+1 YES, TAKE EQUAL EXIT! * ISZ .CBT ISZ .CBT SET UP FOR EQUAL RETURN * LOOP3 LDB ARAY1 JSB .LBT TAKE A BYTE FROM STRING 1 STB ARAY1 SAVE INCREMENTED BYTE ADDRESS STA BYTE1 * LDB ARAY2 JSB .LBT STB ARAY2 CMA,INA ADA BYTE1 STRING 1 MINUS STRING 2 * SZA EQUAL? JMP NEQL1 NO ! ISZ BCNT EXAMINED ALL BYTES? JMP LOOP3 NO * LDA ARAY1 "A" SET TO ORIGINAL + CNT JMP .CBT,I "B" ALREADY CORRECT, EQUAL * RETURN ! * NEQL1 SSA,RSS STRING 1 LARGEST? ISZ .CBT YES, SKIP TWO WORDS ISZ .CBT ELSE SKIP ONE * CCA ADA ARAY1 STRING 1 ADDRESS AT NON-MATCH LDB BSAVE STRING 2 ADDRESS + CNT JMP .CBT,I * ARAY1 NOP ARAY2 NOP BYTE1 NOP ATEMP NOP BTEMP NOP AWORK NOP BSAVE NOP * HED SIMULATION OF "SCAN FOR BYTE" 21MX INSTRUCTION * * CALLING SEQUENCE: * A-REG. TO CONTAIN TERMINATION BYTE AND TEST BYTE * B-REG. TO CONTAIN ADDRESS OF FIRST BYTE * JSB .SFB CALL SUB. OR OCT 105767 * EXIT IF BYTE FOUND TO MATCH TEST BYTE * EXIT IF BYTE FOUND TO MATCH TERMINATION BYTE * .SFB NOP STA ATEMP AND BMASK ISOLATE TEST BYTE STA TEST * LDA ATEMP ALF,ALF AND BMASK ISOLATE TERMINATION BYTE STA TERM * LOOP4 JSB .LBT FETCH A BYTE CPA TEST EQUAL TEST BYTE? JMP T.OUT YES * CPA TERM EQUALS TERMINATION BYTE? JMP DONE YES JMP LOOP4 NOPE, LOOK SOME MORE * DONE ISZ .SFB RETURN TO P + 2 LDA ATEMP RESTORE A-REG. JMP .SFB,I * T.OUT ADB M.1 DECREMENT B LDA ATEMP JMP .SFB,I RETURN TO P + 1 * TEST NOP TERM NOP BMASK OCT 377 M.1 DEC -1 * HED "SCAN BYTES LEFT" SUBROUTINE * * CALLING SEQUENCE: * * LDA FILL CHARACTER TO REMOVE * LDB BYTAD BYTE ADDRESS TO START * JSB .SBL * B-REG. CONTAINS ADDRESS * OF FIRST OPEN BYTE * * PURPOSE: * USED TO REMOVE TRAILING BLANKS. * * .SBL NOP AND M377 ISOLATE BYTE TO REMOVE STA SAVE ADB M1 DECREMENT BYTE ADDRESS * SLOOP JSB .LBT FETCH IT CPA SAVE REMOVE THIS ONE? RSS YES JMP .SBL,I NO, DONE! * ADB M2 LBT INCREMENTS B, JMP SLOOP THEREFORE, GO BACK 2 * SAVE NOP M1 DEC -1 M2 DEC -2 M377 OCT 377 * HED SIMULATION OF "STORE BYTE" 21MX INSTRUCTION SPC 2 * CALLING SEQUENCE: * A-REG. TO CONTAIN BYTE TO BE STORED * B-REG. TO CONTAIN BYTE ADDRESS * JSB .SBT CALL SUB. OR OCT 105764 * B-REG INCREMENTED BY ONE * .SBT NOP STA ATEMP AND MASK ISOLATE BYTE OF INTEREST ALF,ALF STA AWORK SAVE IT IN LEFT BYTE * STB BTEMP CLE,ERB CONVERT TO WORD ADDRESS, LDA BREG,I "E" = B SEZ 0 = STORE IN LEFT BYTE, THEREFORE SAVE RIGHT BYTE ALF,ALF SWAP BYTES AND MASK ISOLATE BYTE TO SAVE IOR AWORK MERGE BYTES SEZ WORD IN PROPER POSITION? ALF,ALF NO, SWAP IT BACK STA BREG,I REPLACE IN MEMORY * LDA ATEMP RESTORE A-REG. LDB BTEMP RESTORE B-REG. INB POINT TO NEXT BYTE JMP .SBT,I * MASK OCT 377 * HED SIMULATION OF "LOAD BYTE" 21MX INSTRUCTION SPC 2 * CALLING SEQUENCE: * B-REG. TO CONTAIN BYTE ADDRESS C JSB .LBT CALL SUB. OR OCT 105763 * BYTE REQUESTED IN RIGHT HALF OF A-REG. * B-REG. INCREMENTED BY ONE * .LBT NOP CLE,ERB PRODUCE WORD ADDRESS, BYTE FLAG IN "E" LDA BREG,I GET WORD SEZ,RSS 0 INDICATES LEFT BYTE ALF,ALF SWAP BYTES AND MASK ISOLATE BYTE OF INTEREST * ELB RESTORE "B" INB POINT TO NEXT BYTE JMP .LBT,I * * SPC 2 * HED INDIRECT TRACKING SUBROUTINE SPC 2 * CALLING SEQUENCE: * LOC. CONTAINING AN ADDRESS * JSB IDRCT * A-REG. HAS DIRECT ADDRESS * * RESULTS: * "B","E", AND "O" UNAFFECTED. * IDRCT NOP STA ATEMP CLA ELA STA AWORK SAVE "E" * LDA ATEMP PICK UP START OF CHAIN RSS LDA AREG,I GO ONE MORE LEVEL RAL,CLE,SLA,ERA TEST AND TURN OFF BIT 15 JMP *-2 PLAY IT AGAIN SAM! * STA ATEMP NOW HAVE DIRECT ADDRESS LDA AWORK ERA RESTORE "E" LDA ATEMP JMP IDRCT,I * * END END$