C C LBN CALCULATION C PROGRAM LBN C C REVISED - C 02/05/79 - ADDED PROMPT FOR DEVICE, RATHER THAN RESTRICTING C TO DB1:. C 04/09/79 - REMOVED DBKXX STUFF AND REPLACED WITH OPEN AND WVB. C IMPLICIT INTEGER*4 (K) DIMENSION IBUF(40), IBAD(256), IK(2), ISPEC(11) BYTE BUF(79), BBAD(512), BK(2) C EQUIVALENCE (IBUF, BUF) EQUIVALENCE (KLBN,IK,BK), (IBAD,BBAD) C DATA IBUF/40*' '/, IBAD/O1401, O146000, 254*0/ DATA ISPEC/' ',' ','[0',',0',']B','AD','BL','K.','SY','S ', 0/ C C ACCEPT PACK INDENTIFICATION INFO FROM TI: OR FILE C TYPE *,'MANUFACTURER, SERIAL NUMBER, ETC.., OR @FILE' 10 READ (5, 500) BUF 500 FORMAT (79A1) CALL INDOP (5, BUF, 34, IRCOD) IF (IRCOD .NE. 0) GO TO 10 CALL CLRTAB (IBUF, .FALSE.) CALL SFCHR (BUF, 56, 81-56, ' ') CALL DATE (BUF(56)) CALL TIME (BUF(66)) WRITE (6, 520) BUF 520 FORMAT (' ',79A1// 1 ' CYLINDER TRACK SECTOR NO.-1 = LBN - LBN'/) C C READ IN BAD BLOCK DATA IN THE FOLLOWING FORMAT C C CYL TRK SEC NBLKSBAD C JBAD = 3 DO 100 I=1, 102 NO = 1 READ (5,*,END=110,ERR=200) KCYL, KTRK, KSEC, NO KLBN = (KCYL*19+KTRK)*22 + KSEC NO = NO - 1 IF (NO.GE.0 .AND. NO.LE.255) GO TO 50 TYPE *,' COUNT OUT OF RANGE, NO.=', NO CALL EXIT C 50 CONTINUE KLMX = KLBN + NO WRITE (6, 530) KCYL, KTRK, KSEC, NO, KLBN, KLMX 530 FORMAT (' ', 4I8, 3X, 2I8) C C PLUG IN BAD BLOCK DATA C IBAD(JBAD) = IK(2) IBAD(JBAD+1) = IK(1) BK(1) = NO JBAD = JBAD + 2 100 CONTINUE C CALL CLOSE (5) CALL ASSIGN (5, 'TI:') TYPE *, '>ERROR< TOO MANY BAD BLOCKS!!' GO TO 200 C 110 CONTINUE CALL CLOSE (5) CALL ASSIGN (5, 'TI:') C C INSERT NO OF MAP WORDS USED C BBAD(3) = JBAD - 3 C C COMPUTE WORD 256 CHECKSUM C DO 120 I=1, 255 120 IBAD(256) = IBAD(256) + IBAD(I) C C WRITE AUTO BAD BLOCK DATA TO DBN:[0,0]BADBLK.SYS C WRITE (5, 540) 540 FORMAT (' COPY OUT BAD BLOCK FILE? ',$) READ (5, 545) BAD 545 FORMAT (A4) IF (BAD .NE. 'YES ') GO TO 200 C C GET REQUESTED DEVICE TO COPY TO C WRITE (5, 546) 546 FORMAT (' DEVICE TO COPY TO ? ',$) READ (5, 547) ISPEC(1),ISPEC(2) 547 FORMAT (2A2) C OPEN (UNIT=1, TYPE='OLD', NAME=ISPEC, BUFFERCOUNT=-1, ERR=125) GO TO 130 C 125 TYPE 548, (ISPEC(I),I=1,10) 548 FORMAT (' OPEN FAILURE ON ', 10A2) GO TO 200 C 130 CONTINUE NR = 1 CALL WVB (1, IBAD, 1, NR, NERR) IF (NERR .NE. +1) STOP '**ERROR** WRITING TO BADBLK.SYS' CLOSE (UNIT=1) WRITE (6, 550) 550 FORMAT (/' BADBLOCK FILE UPDATED') C 200 CONTINUE CALL EXIT END